diff --git a/EEG/praat_EEG.cpp b/EEG/praat_EEG.cpp index 0c168f18..2437a8f9 100644 --- a/EEG/praat_EEG.cpp +++ b/EEG/praat_EEG.cpp @@ -475,19 +475,15 @@ FORM (REAL_ERP_getMinimum, U"ERP: Get minimum", U"Sound: Get minimum...") { SENTENCE (channelName, U"Channel name", U"Cz") REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (ERP) integer channelNumber = ERP_getChannelNumber (me, channelName); if (channelNumber == 0) Melder_throw (me, U": no channel named \"", channelName, U"\"."); double result; - Vector_getMinimumAndX (me, fromTime, toTime, channelNumber, interpolation, & result, nullptr); + Vector_getMinimumAndX (me, fromTime, toTime, channelNumber, peakInterpolationType, & result, nullptr); NUMBER_ONE_END (U" Volt") } @@ -495,19 +491,15 @@ FORM (REAL_ERP_getTimeOfMinimum, U"ERP: Get time of minimum", U"Sound: Get time SENTENCE (channelName, U"Channel name", U"Cz") REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (ERP) integer channelNumber = ERP_getChannelNumber (me, channelName); if (channelNumber == 0) Melder_throw (me, U": no channel named \"", channelName, U"\"."); double result; - Vector_getMinimumAndX (me, fromTime, toTime, channelNumber, interpolation, nullptr, & result); + Vector_getMinimumAndX (me, fromTime, toTime, channelNumber, peakInterpolationType, nullptr, & result); NUMBER_ONE_END (U" seconds") } @@ -515,19 +507,15 @@ FORM (REAL_ERP_getMaximum, U"ERP: Get maximum", U"Sound: Get maximum...") { SENTENCE (channelName, U"Channel name", U"Cz") REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (ERP) integer channelNumber = ERP_getChannelNumber (me, channelName); if (channelNumber == 0) Melder_throw (me, U": no channel named \"", channelName, U"\"."); double result; - Vector_getMaximumAndX (me, fromTime, toTime, channelNumber, interpolation, & result, nullptr); + Vector_getMaximumAndX (me, fromTime, toTime, channelNumber, peakInterpolationType, & result, nullptr); NUMBER_ONE_END (U" Volt") } @@ -535,19 +523,15 @@ FORM (REAL_ERP_getTimeOfMaximum, U"ERP: Get time of maximum", U"Sound: Get time SENTENCE (channelName, U"Channel name", U"Cz") REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (ERP) integer channelNumber = ERP_getChannelNumber (me, channelName); if (channelNumber == 0) Melder_throw (me, U": no channel named \"", channelName, U"\"."); double result; - Vector_getMaximumAndX (me, fromTime, toTime, channelNumber, interpolation, nullptr, & result); + Vector_getMaximumAndX (me, fromTime, toTime, channelNumber, peakInterpolationType, nullptr, & result); NUMBER_ONE_END (U" seconds") } diff --git a/FFNet/praat_FFNet_init.cpp b/FFNet/praat_FFNet_init.cpp index 1348585c..4c338906 100644 --- a/FFNet/praat_FFNet_init.cpp +++ b/FFNet/praat_FFNet_init.cpp @@ -341,8 +341,8 @@ END } FORM (NEW1_FFNet_ActivationList_to_Categories, U"FFNet & ActivationList: To Categories", 0) { RADIO (categorizationgMethod, U"Categorization method", 1) - RADIOBUTTON (U"Winner-takes-all") - RADIOBUTTON (U"Stochastic") + RADIOBUTTON (U"winner-takes-all") + RADIOBUTTON (U"stochastic") OK DO CONVERT_TWO (FFNet, ActivationList) @@ -398,8 +398,8 @@ DO FORM (NEW1_FFNet_PatternList_to_Categories, U"FFNet & PatternList: To Categories", U"FFNet & PatternList: To Categories...") { RADIO (categorizationgMethod, U"Categorization method", 1) - RADIOBUTTON (U"Winner-takes-all") - RADIOBUTTON (U"Stochastic") + RADIOBUTTON (U"winner-takes-all") + RADIOBUTTON (U"stochastic") OK DO GRAPHICS_TWO (FFNet, PatternList) @@ -420,8 +420,8 @@ DO FORM (REAL_FFNet_PatternList_ActivationList_getTotalCosts, U"FFNet & PatternList & ActivationList: Get total costs", U"FFNet & PatternList & ActivationList: Get total costs...") { RADIO (costFunctionType, U"Cost function", 1) - RADIOBUTTON (U"Minimum-squared-error") - RADIOBUTTON (U"Minimum-cross-entropy") + RADIOBUTTON (U"minimum-squared-error") + RADIOBUTTON (U"minimum-cross-entropy") OK DO NUMBER_THREE (FFNet, PatternList, ActivationList) @@ -431,8 +431,8 @@ DO FORM (REAL_FFNet_PatternList_ActivationList_getAverageCosts, U"FFNet & PatternList & ActivationList: Get average costs", U"FFNet & PatternList & ActivationList: Get average costs...") { RADIO (costFunctionType, U"Cost function", 1) - RADIOBUTTON (U"Minimum-squared-error") - RADIOBUTTON (U"Minimum-cross-entropy") + RADIOBUTTON (U"minimum-squared-error") + RADIOBUTTON (U"minimum-cross-entropy") OK DO NUMBER_THREE (FFNet, PatternList, ActivationList) @@ -445,8 +445,8 @@ FORM (MODIFY_FFNet_PatternList_ActivationList_learn, U"FFNet & PatternList & Act NATURAL (maximumNumberOfEpochs, U"Maximum number of epochs", U"100") POSITIVE (tolerance, U"Tolerance of minimizer", U"1e-7") RADIO (costFunctionType, U"Cost function", 1) - RADIOBUTTON (U"Minimum-squared-error") - RADIOBUTTON (U"Minimum-cross-entropy") + RADIOBUTTON (U"minimum-squared-error") + RADIOBUTTON (U"minimum-cross-entropy") OK DO MODIFY_FIRST_OF_THREE (FFNet, PatternList, ActivationList) @@ -463,8 +463,8 @@ FORM (MODIFY_FFNet_PatternList_ActivationList_learnSlow, U"FFNet & PatternList & POSITIVE (learningRate, U"Learning rate", U"0.1") REAL (momentum, U"Momentum", U"0.9") RADIO (costFunctionType, U"Cost function", 1) - RADIOBUTTON (U"Minimum-squared-error") - RADIOBUTTON (U"Minimum-cross-entropy") + RADIOBUTTON (U"minimum-squared-error") + RADIOBUTTON (U"minimum-cross-entropy") OK DO MODIFY_FIRST_OF_THREE (FFNet, PatternList, ActivationList) @@ -476,8 +476,8 @@ DO FORM (REAL_FFNet_PatternList_Categories_getTotalCosts, U"FFNet & PatternList & Categories: Get total costs", U"FFNet & PatternList & Categories: Get total costs...") { RADIO (costFunctionType, U"Cost function", 1) - RADIOBUTTON (U"Minimum-squared-error") - RADIOBUTTON (U"Minimum-cross-entropy") + RADIOBUTTON (U"minimum-squared-error") + RADIOBUTTON (U"minimum-cross-entropy") OK DO NUMBER_THREE (FFNet, PatternList, Categories) @@ -487,8 +487,8 @@ DO FORM (REAL_FFNet_PatternList_Categories_getAverageCosts, U"FFNet & PatternList & Categories: Get average costs", U"FFNet & PatternList & Categories: Get average costs...") { RADIO (costFunctionType, U"Cost function", 1) - RADIOBUTTON (U"Minimum-squared-error") - RADIOBUTTON (U"Minimum-cross-entropy") + RADIOBUTTON (U"minimum-squared-error") + RADIOBUTTON (U"minimum-cross-entropy") OK DO NUMBER_THREE (FFNet, PatternList, Categories) @@ -500,8 +500,8 @@ FORM (MODIFY_FFNet_PatternList_Categories_learn, U"FFNet & PatternList & Categor NATURAL (maximumNumberOfEpochs, U"Maximum number of epochs", U"100") POSITIVE (tolerance, U"Tolerance of minimizer", U"1e-7") RADIO (costFunctionType, U"Cost function", 1) - RADIOBUTTON (U"Minimum-squared-error") - RADIOBUTTON (U"Minimum-cross-entropy") + RADIOBUTTON (U"minimum-squared-error") + RADIOBUTTON (U"minimum-cross-entropy") OK DO MODIFY_FIRST_OF_THREE (FFNet, PatternList, Categories) @@ -516,8 +516,8 @@ FORM (MODIFY_FFNet_PatternList_Categories_learnSlow, U"FFNet & PatternList & Cat POSITIVE (learningRate, U"Learning rate", U"0.1") REAL (momentum, U"Momentum", U"0.9") RADIO (costFunctionType, U"Cost function", 1) - RADIOBUTTON (U"Minimum-squared-error") - RADIOBUTTON (U"Minimum-cross-entropy") + RADIOBUTTON (U"minimum-squared-error") + RADIOBUTTON (U"minimum-cross-entropy") OK DO MODIFY_FIRST_OF_THREE (FFNet, PatternList, Categories) diff --git a/dwtools/FormantModeler.cpp b/LPC/FormantModeler.cpp similarity index 66% rename from dwtools/FormantModeler.cpp rename to LPC/FormantModeler.cpp index 0f2af772..fa6f7c8e 100644 --- a/dwtools/FormantModeler.cpp +++ b/LPC/FormantModeler.cpp @@ -66,103 +66,114 @@ void structFormantModeler :: v_info () { } } -double FormantModeler_getStandardDeviation (FormantModeler me, integer iformant) { +static void checkTrackAutoRange (FormantModeler me, integer *fromTrack, integer *toTrack) { + if (*fromTrack == 0 && *toTrack == 0) { // auto + *fromTrack = 1; + *toTrack = my trackmodelers.size; + return; + } + if (*toTrack == 0) + *toTrack = my trackmodelers.size; // auto + Melder_require (*fromTrack <= *toTrack, + U"\"FromTrack\" should not exceed \"toTrack\"."); + if (*toTrack > my trackmodelers.size) // questionable because 0 is an alternative + *toTrack = my trackmodelers.size; + Melder_require (*fromTrack >= 1 && *toTrack <= my trackmodelers.size, + U"1 \\=< \"fromTrack\" \\=< \"toTrack\" \\=< ", my trackmodelers.size, U"."); +} + +static autoINTVEC newINTVECasNumbers (integer size, integer number) { + autoINTVEC target = newINTVECraw (size); + for (integer i = 1; i <= size; i++) + target [i] = number; + return target; +} + +double FormantModeler_getStandardDeviation (FormantModeler me, integer itrack) { double sigma = undefined; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; sigma = DataModeler_getDataStandardDeviation (ff); } return sigma; } -double FormantModeler_getDataPointValue (FormantModeler me, integer iformant, integer index) { +double FormantModeler_getDataPointValue (FormantModeler me, integer itrack, integer index) { double value = undefined; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; value = DataModeler_getDataPointYValue (ff, index); } return value; } -void FormantModeler_setDataPointValue (FormantModeler me, integer iformant, integer index, double value) { - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; +void FormantModeler_setDataPointValue (FormantModeler me, integer itrack, integer index, double value) { + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; DataModeler_setDataPointYValue (ff, index, value); } } -double FormantModeler_getDataPointSigma (FormantModeler me, integer iformant, integer index) { +double FormantModeler_getDataPointSigma (FormantModeler me, integer itrack, integer index) { double sigma = undefined; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = (DataModeler) my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = (DataModeler) my trackmodelers.at [itrack]; sigma = DataModeler_getDataPointYSigma (ff, index); } return sigma; } -void FormantModeler_setDataPointSigma (FormantModeler me, integer iformant, integer index, double sigma) { - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; +void FormantModeler_setDataPointSigma (FormantModeler me, integer itrack, integer index, double sigma) { + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; DataModeler_setDataPointYSigma (ff, index, sigma); } } -kDataModelerData FormantModeler_getDataPointStatus (FormantModeler me, integer iformant, integer index) { +kDataModelerData FormantModeler_getDataPointStatus (FormantModeler me, integer itrack, integer index) { kDataModelerData value =kDataModelerData::INVALID; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; value = DataModeler_getDataPointStatus (ff, index); } return value; } -void FormantModeler_setDataPointStatus (FormantModeler me, integer iformant, integer index, kDataModelerData status) { - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; +void FormantModeler_setDataPointStatus (FormantModeler me, integer itrack, integer index, kDataModelerData status) { + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; DataModeler_setDataPointStatus (ff, index, status); } } -static void FormantModeler_setDataPointValueAndStatus (FormantModeler me, integer iformant, integer index, double value, kDataModelerData dataStatus) { - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; +static void FormantModeler_setDataPointValueAndStatus (FormantModeler me, integer itrack, integer index, double value, kDataModelerData dataStatus) { + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; DataModeler_setDataPointValueAndStatus (ff, index, value, dataStatus); } } -void FormantModeler_setParameterValueFixed (FormantModeler me, integer iformant, integer index, double value) { - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ffi = my trackmodelers.at [iformant]; +void FormantModeler_setParameterValueFixed (FormantModeler me, integer itrack, integer index, double value) { + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ffi = my trackmodelers.at [itrack]; DataModeler_setParameterValueFixed (ffi, index, value); } } -void FormantModeler_setParametersFree (FormantModeler me, integer fromFormant, integer toFormant, integer fromIndex, integer toIndex) { - const integer numberOfFormants = my trackmodelers.size; - if (toFormant < fromFormant || (fromFormant == toFormant && fromFormant == 0)) { - fromFormant = 1; - toFormant = numberOfFormants; - } - Melder_require (toFormant > 0 && toFormant <= numberOfFormants && fromFormant > 0 && fromFormant <= numberOfFormants && fromFormant <= toFormant, - U"Formant number(s) should be in the interval [1, ", numberOfFormants, U"]."); +void FormantModeler_setParametersFree (FormantModeler me, integer fromTrack, integer toTrack, integer fromIndex, integer toIndex) { + checkTrackAutoRange (me, & fromTrack, & toTrack); - for (integer iformant = fromFormant; iformant <= toFormant; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; + for (integer itrack = fromTrack; itrack <= toTrack; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; DataModeler_setParametersFree (ffi, fromIndex, toIndex); } } -void FormantModeler_setDataWeighing (FormantModeler me, integer fromFormant, integer toFormant, kFormantModelerWeights weighFormants) { - integer numberOfFormants = my trackmodelers.size; - if (toFormant < fromFormant || (fromFormant == toFormant && fromFormant == 0)) { - fromFormant = 1; - toFormant= numberOfFormants; - } - Melder_require (toFormant > 0 && toFormant <= numberOfFormants && fromFormant > 0 && fromFormant <= numberOfFormants && fromFormant <= toFormant, - U"Formant number(s) should be in the interval [1, ", numberOfFormants, U"]."); +void FormantModeler_setDataWeighing (FormantModeler me, integer fromTrack, integer toTrack, kFormantModelerWeights weighFormants) { + checkTrackAutoRange (me, & fromTrack, & toTrack); - for (integer iformant = fromFormant; iformant <= toFormant; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; + for (integer itrack = fromTrack; itrack <= toTrack; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; kDataModelerWeights dataWeights = kDataModelerWeights::EQUAL_WEIGHTS; if (weighFormants == kFormantModelerWeights::ONE_OVER_BANDWIDTH) dataWeights = kDataModelerWeights::ONE_OVER_SIGMA; @@ -175,20 +186,20 @@ void FormantModeler_setDataWeighing (FormantModeler me, integer fromFormant, int } void FormantModeler_fit (FormantModeler me) { - for (integer iformant = 1; iformant <= my trackmodelers.size; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; + for (integer itrack = 1; itrack <= my trackmodelers.size; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; DataModeler_fit (ffi); } } void FormantModeler_drawBasisFunction (FormantModeler me, Graphics g, double tmin, double tmax, double fmin, double fmax, - integer iformant, integer iterm, bool scaled, integer numberOfPoints, bool garnish) + integer itrack, integer iterm, bool scaled, integer numberOfPoints, bool garnish) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - if (iformant < 1 || iformant > my trackmodelers.size) + if (itrack < 1 || itrack > my trackmodelers.size) return; Graphics_setInner (g); - const DataModeler ffi = my trackmodelers.at [iformant]; + const DataModeler ffi = my trackmodelers.at [itrack]; DataModeler_drawBasisFunction_inside (ffi, g, tmin, tmax, fmin, fmax, iterm, scaled, numberOfPoints); Graphics_unsetInner (g); if (garnish) { @@ -211,35 +222,35 @@ static integer FormantModeler_drawingSpecifiers_x (FormantModeler me, double *xm static void FormantModeler_getCumulativeChiScores (FormantModeler me, VEC chisq) { try { const integer numberOfDataPoints = FormantModeler_getNumberOfDataPoints (me); - const integer numberOfFormants = my trackmodelers.size; - for (integer iformant = 1; iformant <= numberOfFormants; iformant ++) { - const DataModeler fm = my trackmodelers.at [iformant]; + const integer numberOfTracks = my trackmodelers.size; + for (integer itrack = 1; itrack <= numberOfTracks; itrack ++) { + const DataModeler fm = my trackmodelers.at [itrack]; autoVEC zscores = DataModeler_getZScores (fm); autoVEC chisqif = DataModeler_getChisqScoresFromZScores (fm, zscores.get(), true); // undefined -> average - for (integer i = 1; i <= numberOfDataPoints; i ++) - chisq [i] += chisqif [i]; + for (integer ipoint = 1; ipoint <= numberOfDataPoints; ipoint ++) + chisq [ipoint] += chisqif [ipoint]; } } catch (MelderError) { Melder_throw (me, U"cannot determine cumulative chi squares."); } } -static autoVEC FormantModeler_getVariancesBetweenTrackAndEstimatedTrack (FormantModeler me, integer iformant, integer estimatedFormant) { +static autoVEC FormantModeler_getVariancesBetweenTrackAndEstimatedTrack (FormantModeler me, integer itrack, integer estimatedTrack) { try { const integer numberOfDataPoints = FormantModeler_getNumberOfDataPoints (me); - const integer numberOfFormants = my trackmodelers.size; + const integer numberOfTracks = my trackmodelers.size; autoVEC var; - if (iformant < 1 || iformant > numberOfFormants || estimatedFormant < 1 || estimatedFormant > numberOfFormants) + if (itrack < 1 || itrack > numberOfTracks || estimatedTrack < 1 || estimatedTrack > numberOfTracks) return var; var. resize (numberOfDataPoints); - const DataModeler fi = my trackmodelers.at [iformant]; - const DataModeler fe = my trackmodelers.at [estimatedFormant]; - for (integer i = 1; i <= numberOfDataPoints; i ++) { - var [i] = undefined; - if (fi -> data [i] .status != kDataModelerData::INVALID) { - const double ye = fe -> f_evaluate (fe, fe -> data [i] .x, fe -> parameters.get()); - const double diff = ye - fi -> data [i] .y; - var [i] = diff * diff; + const DataModeler fi = my trackmodelers.at [itrack]; + const DataModeler fe = my trackmodelers.at [estimatedTrack]; + for (integer ipoint = 1; ipoint <= numberOfDataPoints; ipoint ++) { + var [ipoint] = undefined; + if (fi -> data [ipoint] .status != kDataModelerData::INVALID) { + const double ye = fe -> f_evaluate (fe, fe -> data [ipoint] .x, fe -> parameters.get()); + const double diff = ye - fi -> data [ipoint] .y; + var [ipoint] = diff * diff; } } return var; @@ -249,34 +260,34 @@ static autoVEC FormantModeler_getVariancesBetweenTrackAndEstimatedTrack (Formant } static autoVEC FormantModeler_getSumOfVariancesBetweenShiftedAndEstimatedTracks (FormantModeler me, - kFormantModelerTrackShift shiftDirection, integer *fromFormant, integer *toFormant) + kFormantModelerTrackShift shiftDirection, integer *fromTrack, integer *toTrack) { try { - const integer numberOfFormants = my trackmodelers.size; - if (*fromFormant < 1 || *fromFormant > numberOfFormants || *toFormant < 1 || *toFormant > numberOfFormants || *toFormant < *fromFormant) { - *toFormant = 1; - *fromFormant = numberOfFormants; + const integer numberOfTracks = my trackmodelers.size; + if (*fromTrack < 1 || *fromTrack > numberOfTracks || *toTrack < 1 || *toTrack > numberOfTracks || *toTrack < *fromTrack) { + *toTrack = 1; + *fromTrack = numberOfTracks; } - integer formantTrack = *fromFormant, estimatedFormantTrack = *fromFormant; // FormantModeler_NOSHIFT_TRACKS + integer formantTrack = *fromTrack, estimatedTrack = *fromTrack; // FormantModeler_NOSHIFT_TRACKS if (shiftDirection == kFormantModelerTrackShift::DOWN) { - estimatedFormantTrack = *fromFormant; - formantTrack = *fromFormant + 1; - *fromFormant = ( *fromFormant == 1 ? 2 : *fromFormant ); + estimatedTrack = *fromTrack; + formantTrack = *fromTrack + 1; + *fromTrack = ( *fromTrack == 1 ? 2 : *fromTrack ); } else if (shiftDirection == kFormantModelerTrackShift::UP) { - formantTrack = *fromFormant; - estimatedFormantTrack = *fromFormant + 1; - *toFormant = ( *toFormant == numberOfFormants ? numberOfFormants - 1 : *toFormant ); + formantTrack = *fromTrack; + estimatedTrack = *fromTrack + 1; + *toTrack = ( *toTrack == numberOfTracks ? numberOfTracks - 1 : *toTrack ); } const integer numberOfDataPoints = FormantModeler_getNumberOfDataPoints (me); autoVEC sumOfVariances = newVECzero (numberOfDataPoints); - for (integer iformant = *fromFormant; iformant <= *toFormant; iformant ++) { - autoVEC vari = FormantModeler_getVariancesBetweenTrackAndEstimatedTrack (me, formantTrack, estimatedFormantTrack); - for (integer i = 1; i <= numberOfDataPoints; i ++) { - if (isdefined (vari [i])) - sumOfVariances [i] += vari [i]; + for (integer itrack = *fromTrack; itrack <= *toTrack; itrack ++) { + autoVEC vari = FormantModeler_getVariancesBetweenTrackAndEstimatedTrack (me, formantTrack, estimatedTrack); + for (integer ipoint = 1; ipoint <= numberOfDataPoints; ipoint ++) { + if (isdefined (vari [ipoint])) + sumOfVariances [ipoint] += vari [ipoint]; } formantTrack ++; - estimatedFormantTrack ++; + estimatedTrack ++; } return sumOfVariances; } catch (MelderError) { @@ -285,33 +296,37 @@ static autoVEC FormantModeler_getSumOfVariancesBetweenShiftedAndEstimatedTracks } void FormantModeler_drawVariancesOfShiftedTracks (FormantModeler me, Graphics g, double xmin, double xmax, - double ymin, double ymax, kFormantModelerTrackShift shiftDirection, integer fromFormant, integer toFormant, bool garnish) + double ymin, double ymax, kFormantModelerTrackShift shiftDirection, integer fromTrack, integer toTrack, bool garnish) { try { integer ixmin, ixmax; + checkTrackAutoRange (me, & fromTrack, & toTrack); Melder_require (FormantModeler_drawingSpecifiers_x (me, & xmin, & xmax, & ixmin, & ixmax) > 0, U"The are not enough data points in the drawing range."); - const integer numberOfDataPoints = FormantModeler_getNumberOfDataPoints (me); - autoVEC varShifted = FormantModeler_getSumOfVariancesBetweenShiftedAndEstimatedTracks (me, shiftDirection, & fromFormant, & toFormant); - autoVEC var = FormantModeler_getSumOfVariancesBetweenShiftedAndEstimatedTracks (me, kFormantModelerTrackShift::NO_, & fromFormant, & toFormant); - for (integer i = ixmin + 1; i <= ixmax; i ++) { - if (isdefined (varShifted [i]) && isdefined (var [i])) - var [i] -= varShifted [i]; + autoVEC varShifted = FormantModeler_getSumOfVariancesBetweenShiftedAndEstimatedTracks (me, shiftDirection, & fromTrack, & toTrack); + autoVEC var = FormantModeler_getSumOfVariancesBetweenShiftedAndEstimatedTracks (me, kFormantModelerTrackShift::NO_, & fromTrack, & toTrack); + for (integer ipoint = ixmin + 1; ipoint <= ixmax; ipoint ++) { + if (isdefined (varShifted [ipoint]) && isdefined (var [ipoint])) + var [ipoint] -= varShifted [ipoint]; } if (ymax <= ymin) NUMextrema (var.part (ixmin, ixmax), & ymin, & ymax); + if (ymin == ymax) { + ymin -= 0.5; + ymax += 0.5; + } Graphics_setInner (g); Graphics_setWindow (g, xmin, xmax, ymin, ymax); const DataModeler thee = my trackmodelers.at [1]; while (isundef (var [ixmin]) && ixmin <= ixmax) ixmin ++; double xp = thy data [ixmin] .x, yp = var [ixmin]; - for (integer i = ixmin + 1; i <= ixmax; i ++) { - if (isdefined (var [i])) { - Graphics_line (g, xp, yp, thy data [i] .x, var [i]); - xp = thy data [i] .x; - yp = var [i]; + for (integer ipoint = ixmin + 1; ipoint <= ixmax; ipoint ++) { + if (isdefined (var [ipoint])) { + Graphics_line (g, xp, yp, thy data [ipoint] .x, var [ipoint]); + xp = thy data [ipoint] .x; + yp = var [ipoint]; } } Graphics_unsetInner (g); @@ -339,8 +354,8 @@ void FormantModeler_drawCumulativeChiScores (FormantModeler me, Graphics g, doub Graphics_setInner (g); Graphics_setWindow (g, xmin, xmax, ymin, ymax); DataModeler thee = my trackmodelers.at [1]; - for (integer i = ixmin + 1; i <= ixmax; i ++) - Graphics_line (g, thy data [i - 1] .x, chisq [i - 1], thy data [i] .x, chisq [i]); + for (integer ipoint = ixmin + 1; ipoint <= ixmax; ipoint ++) + Graphics_line (g, thy data [ipoint - 1] .x, chisq [ipoint - 1], thy data [ipoint] .x, chisq [ipoint]); Graphics_unsetInner (g); if (garnish) { Graphics_drawInnerBox (g); @@ -353,24 +368,16 @@ void FormantModeler_drawCumulativeChiScores (FormantModeler me, Graphics g, doub } void FormantModeler_drawOutliersMarked (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, integer fromTrack, integer toTrack, - double numberOfSigmas, conststring32 mark, double marksFontSize, double horizontalOffset_mm, bool garnish) + double numberOfSigmas, conststring32 mark, double marksFontSize, MelderColour oddTracks, MelderColour evenTracks, bool garnish) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - const integer maxTrack = my trackmodelers.size; - if (toTrack == 0 && fromTrack == 0) { - fromTrack = 1; - toTrack = maxTrack; - } - if (fromTrack > maxTrack) - return; - if (toTrack > maxTrack) - toTrack = maxTrack; + checkTrackAutoRange (me, & fromTrack, & toTrack); Graphics_setInner (g); double currectFontSize = Graphics_inqFontSize (g); - for (integer iformant = fromTrack; iformant <= toTrack; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; - const double xOffset_mm = ( iformant % 2 == 1 ? horizontalOffset_mm : -horizontalOffset_mm ); - DataModeler_drawOutliersMarked_inside (ffi, g, tmin, tmax, 0.0, fmax, numberOfSigmas, mark, marksFontSize, xOffset_mm); + for (integer itrack = fromTrack; itrack <= toTrack; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; + Graphics_setColour (g, itrack %2 == 1 ? oddTracks : evenTracks ); + DataModeler_drawOutliersMarked_inside (ffi, g, tmin, tmax, 0.0, fmax, numberOfSigmas, mark, marksFontSize); } Graphics_setFontSize (g, currectFontSize); Graphics_unsetInner (g); @@ -383,38 +390,40 @@ void FormantModeler_drawOutliersMarked (FormantModeler me, Graphics g, double tm } } -void FormantModeler_normalProbabilityPlot (FormantModeler me, Graphics g, integer iformant, +void FormantModeler_normalProbabilityPlot (FormantModeler me, Graphics g, integer itrack, integer numberOfQuantiles, double numberOfSigmas, double labelSize, conststring32 label, bool garnish) { - if (iformant > 0 || iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 || itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; DataModeler_normalProbabilityPlot (ff, g, numberOfQuantiles, numberOfSigmas, labelSize, label, garnish); } } -static void FormantModeler_drawTracks_inside (FormantModeler me, Graphics g, double xmin, double xmax, double fmax, - integer fromTrack, integer toTrack, bool estimated, integer numberOfParameters, double horizontalOffset_mm) { - for (integer iformant = fromTrack; iformant <= toTrack; iformant ++) { - DataModeler ffi = my trackmodelers.at [iformant]; - double xOffset_mm = ( iformant % 2 == 1 ? horizontalOffset_mm : -horizontalOffset_mm ); - DataModeler_drawTrack_inside (ffi, g, xmin, xmax, 0, fmax, estimated, numberOfParameters, xOffset_mm); +void FormantModeler_drawModel_inside (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, + integer fromTrack, integer toTrack, MelderColour oddTracks, MelderColour evenTracks, integer numberOfPoints) { + checkTrackAutoRange (me, & fromTrack, & toTrack); + for (integer itrack = fromTrack; itrack <= toTrack; itrack ++) { + DataModeler ffi = my trackmodelers.at [itrack]; + Graphics_setColour (g, itrack % 2 == 1 ? oddTracks : evenTracks ); + DataModeler_drawModel_inside (ffi, g, tmin, tmax, 0.0, fmax, numberOfPoints); + } +} + +void FormantModeler_drawTracks_inside (FormantModeler me, Graphics g, double xmin, double xmax, double fmax, integer fromTrack, integer toTrack, bool useEstimatedTrack, integer numberOfParameters, MelderColour oddTracks, MelderColour evenTracks) { + checkTrackAutoRange (me, & fromTrack, & toTrack); + for (integer itrack = fromTrack; itrack <= toTrack; itrack ++) { + DataModeler ffi = my trackmodelers.at [itrack]; + Graphics_setColour (g, itrack % 2 == 1 ? oddTracks : evenTracks ); + DataModeler_drawTrack_inside (ffi, g, xmin, xmax, 0.0, fmax, useEstimatedTrack, numberOfParameters); } } void FormantModeler_drawTracks (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, - integer fromTrack, integer toTrack, bool estimated, integer numberOfParameters, double horizontalOffset_mm, bool garnish) + integer fromTrack, integer toTrack, bool useEstimatedTrack, integer numberOfParameters, MelderColour oddTracks, MelderColour evenTracks, bool garnish) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - const integer maxTrack = my trackmodelers.size; - if (toTrack == 0 && fromTrack == 0) { - fromTrack = 1; - toTrack = maxTrack; - } - if (fromTrack > maxTrack) - return; - if (toTrack > maxTrack) - toTrack = maxTrack; + checkTrackAutoRange (me, & fromTrack, & toTrack); Graphics_setInner (g); - FormantModeler_drawTracks_inside (me, g, tmin, tmax, fmax, fromTrack, toTrack, estimated, numberOfParameters, horizontalOffset_mm); + FormantModeler_drawTracks_inside (me, g, tmin, tmax, fmax, fromTrack, toTrack, useEstimatedTrack, numberOfParameters, oddTracks, evenTracks); Graphics_unsetInner (g); if (garnish) { Graphics_drawInnerBox (g); @@ -425,31 +434,24 @@ void FormantModeler_drawTracks (FormantModeler me, Graphics g, double tmin, doub } } -static void FormantModeler_speckle_inside (FormantModeler me, Graphics g, double xmin, double xmax, double fmax, - integer fromTrack, integer toTrack, int estimated, integer numberOfParameters, int errorBars, double barWidth_mm, double horizontalOffset_mm) { - for (integer iformant = fromTrack; iformant <= toTrack; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; - const double xOffset_mm = ( iformant % 2 == 1 ? horizontalOffset_mm : -horizontalOffset_mm ); - DataModeler_speckle_inside (ffi, g, xmin, xmax, 0, fmax, estimated, numberOfParameters, errorBars, barWidth_mm, xOffset_mm); +void FormantModeler_speckle_inside (FormantModeler me, Graphics g, double xmin, double xmax, double fmax, + integer fromTrack, integer toTrack, bool useEstimatedTrack, integer numberOfParameters, bool errorBars, MelderColour oddTracks, MelderColour evenTracks) { + checkTrackAutoRange (me, & fromTrack, & toTrack); + for (integer itrack = fromTrack; itrack <= toTrack; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; + Graphics_setColour (g, itrack % 2 == 1 ? oddTracks : evenTracks); + DataModeler_speckle_inside (ffi, g, xmin, xmax, 0, fmax, useEstimatedTrack, numberOfParameters, errorBars, 0.0); } } void FormantModeler_speckle (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, - integer fromTrack, integer toTrack, bool estimated, integer numberOfParameters, - bool errorBars, double barWidth_mm, double horizontalOffset_mm, bool garnish) + integer fromTrack, integer toTrack, bool useEstimatedTrack, integer numberOfParameters, + bool errorBars, MelderColour oddTracks, MelderColour evenTracks, bool garnish) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - const integer maxTrack = my trackmodelers.size; - if (toTrack == 0 && fromTrack == 0) { - fromTrack = 1; - toTrack = maxTrack; - } - if (fromTrack > maxTrack) - return; - if (toTrack > maxTrack) - toTrack = maxTrack; + checkTrackAutoRange (me, & fromTrack, & toTrack); Graphics_setInner (g); - FormantModeler_speckle_inside (me, g, tmin, tmax, fmax, fromTrack, toTrack, estimated, numberOfParameters, errorBars, barWidth_mm, horizontalOffset_mm); + FormantModeler_speckle_inside (me, g, tmin, tmax, fmax, fromTrack, toTrack, useEstimatedTrack, numberOfParameters, errorBars, oddTracks, evenTracks); Graphics_unsetInner (g); if (garnish) { Graphics_drawInnerBox (g); @@ -460,13 +462,18 @@ void FormantModeler_speckle (FormantModeler me, Graphics g, double tmin, double } } -autoFormantModeler FormantModeler_create (double tmin, double tmax, integer numberOfFormants, integer numberOfDataPoints, integer numberOfParameters) { +autoFormantModeler FormantModeler_create (double tmin, double tmax, integer numberOfDataPoints, integer numberOfTracks, integer numberOfParameters) { + autoINTVEC npar = newINTVECasNumbers (numberOfTracks, numberOfParameters); + return FormantModeler_create (tmin, tmax, numberOfDataPoints, npar.get()); +} + +autoFormantModeler FormantModeler_create (double tmin, double tmax, integer numberOfDataPoints, constINTVEC const& numberOfParameters) { try { autoFormantModeler me = Thing_new (FormantModeler); my xmin = tmin; my xmax = tmax; - for (integer itrack = 1; itrack <= numberOfFormants; itrack ++) { - autoDataModeler ff = DataModeler_create (tmin, tmax, numberOfDataPoints, numberOfParameters, kDataModelerFunction::LEGENDRE); + for (integer itrack = 1; itrack <= numberOfParameters.size; itrack ++) { + autoDataModeler ff = DataModeler_create (tmin, tmax, numberOfDataPoints, numberOfParameters [itrack], kDataModelerFunction::LEGENDRE); my trackmodelers. addItem_move (ff.move()); } return me; @@ -475,28 +482,28 @@ autoFormantModeler FormantModeler_create (double tmin, double tmax, integer numb } } -double FormantModeler_getModelValueAtTime (FormantModeler me, integer iformant, double time) { +double FormantModeler_getModelValueAtTime (FormantModeler me, integer itrack, double time) { double f = undefined; - if (iformant >= 1 && iformant <= my trackmodelers.size) { - const DataModeler thee = my trackmodelers.at [iformant]; + if (itrack >= 1 && itrack <= my trackmodelers.size) { + const DataModeler thee = my trackmodelers.at [itrack]; f = DataModeler_getModelValueAtX (thee, time); } return f; } -double FormantModeler_getModelValueAtIndex (FormantModeler me, integer iformant, integer index) { +double FormantModeler_getModelValueAtIndex (FormantModeler me, integer itrack, integer index) { double f = undefined; - if (iformant >= 1 && iformant <= my trackmodelers.size) { - const DataModeler thee = my trackmodelers.at [iformant]; + if (itrack >= 1 && itrack <= my trackmodelers.size) { + const DataModeler thee = my trackmodelers.at [itrack]; f = DataModeler_getModelValueAtIndex (thee, index); } return f; } -double FormantModeler_getWeightedMean (FormantModeler me, integer iformant) { +double FormantModeler_getWeightedMean (FormantModeler me, integer itrack) { double f = undefined; - if (iformant >= 1 && iformant <= my trackmodelers.size) { - const DataModeler thee = my trackmodelers.at [iformant]; + if (itrack >= 1 && itrack <= my trackmodelers.size) { + const DataModeler thee = my trackmodelers.at [itrack]; f = DataModeler_getWeightedMean (thee); } return f; @@ -506,19 +513,19 @@ integer FormantModeler_getNumberOfTracks (FormantModeler me) { return my trackmodelers.size; } -integer FormantModeler_getNumberOfParameters (FormantModeler me, integer iformant) { +integer FormantModeler_getNumberOfParameters (FormantModeler me, integer itrack) { integer numberOfParameters = 0; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; numberOfParameters = ff -> numberOfParameters; } return numberOfParameters; } -integer FormantModeler_getNumberOfFixedParameters (FormantModeler me, integer iformant) { +integer FormantModeler_getNumberOfFixedParameters (FormantModeler me, integer itrack) { integer numberOfParameters = 0; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; numberOfParameters = ff -> numberOfParameters; numberOfParameters -= DataModeler_getNumberOfFreeParameters (ff); } @@ -526,68 +533,64 @@ integer FormantModeler_getNumberOfFixedParameters (FormantModeler me, integer if } -integer FormantModeler_getNumberOfInvalidDataPoints (FormantModeler me, integer iformant) { +integer FormantModeler_getNumberOfInvalidDataPoints (FormantModeler me, integer itrack) { integer numberOfInvalidDataPoints = 0; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; numberOfInvalidDataPoints = DataModeler_getNumberOfInvalidDataPoints (ff); } return numberOfInvalidDataPoints; } -double FormantModeler_getParameterValue (FormantModeler me, integer iformant, integer iparameter) { +double FormantModeler_getParameterValue (FormantModeler me, integer itrack, integer iparameter) { double value = undefined; - if (iformant > 0 && iformant <= my trackmodelers.size) { - DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + DataModeler ff = my trackmodelers.at [itrack]; value = DataModeler_getParameterValue (ff, iparameter); } return value; } -kDataModelerParameter FormantModeler_getParameterStatus (FormantModeler me, integer iformant, integer index) { +kDataModelerParameter FormantModeler_getParameterStatus (FormantModeler me, integer itrack, integer index) { kDataModelerParameter status = kDataModelerParameter::NOT_DEFINED; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; status = DataModeler_getParameterStatus (ff, index); } return status; } -double FormantModeler_getParameterStandardDeviation ( FormantModeler me, integer iformant, integer index) { +double FormantModeler_getParameterStandardDeviation ( FormantModeler me, integer itrack, integer index) { double stdev = undefined; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; stdev = DataModeler_getParameterStandardDeviation (ff, index); } return stdev; } -double FormantModeler_getDegreesOfFreedom (FormantModeler me, integer iformant) { +double FormantModeler_getDegreesOfFreedom (FormantModeler me, integer itrack) { double dof = 0.0; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; + if (itrack > 0 && itrack <= my trackmodelers.size) { + const DataModeler ff = my trackmodelers.at [itrack]; dof = DataModeler_getDegreesOfFreedom (ff); } return dof; } -double FormantModeler_getVarianceOfParameters (FormantModeler me, integer fromFormant, integer toFormant, integer fromIndex, integer toIndex, integer *out_numberOfFreeParameters) { - double variance = undefined; - integer numberOfFormants = my trackmodelers.size, numberOfParameters = 0, nofp; - if (toFormant < fromFormant || (toFormant == 0 && fromFormant == 0)) { - fromFormant = 1; - toFormant = numberOfFormants; - } - if (fromFormant <= toFormant && fromFormant > 0 && toFormant <= numberOfFormants) { - variance = 0.0; - for (integer iformant = fromFormant; iformant <= toFormant; iformant ++) { - const DataModeler ff = my trackmodelers.at [iformant]; - variance += DataModeler_getVarianceOfParameters (ff, fromIndex, toIndex, &nofp); - numberOfParameters += nofp; - } +double FormantModeler_getVarianceOfParameters (FormantModeler me, integer fromTrack, integer toTrack, integer fromIndex, integer toIndex, integer *out_numberOfFreeParameters) { + checkTrackAutoRange (me, & fromTrack, & toTrack); + double variance = 0.0; + integer numberOfFreeParameters = 0; + for (integer itrack = fromTrack; itrack <= toTrack; itrack ++) { + const DataModeler ff = my trackmodelers.at [itrack]; + integer free; + variance += DataModeler_getVarianceOfParameters (ff, fromIndex, toIndex, & free); + numberOfFreeParameters += free; } + if (out_numberOfFreeParameters) - *out_numberOfFreeParameters = numberOfParameters; + *out_numberOfFreeParameters = numberOfFreeParameters; return variance; } @@ -604,11 +607,11 @@ autoTable FormantModeler_to_Table_zscores (FormantModeler me) { const integer numberOfDataPoints = FormantModeler_getNumberOfDataPoints (me); autoTable ztable = Table_createWithoutColumnNames (numberOfDataPoints, numberOfFormants + 1); Table_setColumnLabel (ztable.get(), icolt, U"time"); - for (integer iformant = 1; iformant <= numberOfFormants; iformant ++) { - const integer icolz = iformant + 1; - Table_setColumnLabel (ztable.get(), icolz, Melder_cat (U"z", iformant)); - DataModeler ffi = my trackmodelers.at [iformant]; - if (iformant == 1) { + for (integer itrack = 1; itrack <= numberOfFormants; itrack ++) { + const integer icolz = itrack + 1; + Table_setColumnLabel (ztable.get(), icolz, Melder_cat (U"z", itrack)); + DataModeler ffi = my trackmodelers.at [itrack]; + if (itrack == 1) { for (integer i = 1; i <= numberOfDataPoints; i ++) // only once all tracks have same x-values Table_setNumericValue (ztable.get(), i, icolt, ffi -> data [i] .x); } @@ -622,11 +625,11 @@ autoTable FormantModeler_to_Table_zscores (FormantModeler me) { } } -autoDataModeler FormantModeler_extractDataModeler (FormantModeler me, integer iformant) { +autoDataModeler FormantModeler_extractDataModeler (FormantModeler me, integer itrack) { try { - Melder_require (iformant > 0 && iformant<= my trackmodelers.size, + Melder_require (itrack > 0 && itrack<= my trackmodelers.size, U"The formant should be greater than zero and smaller than or equal to ", my trackmodelers.size); - const DataModeler ff = my trackmodelers.at [iformant]; + const DataModeler ff = my trackmodelers.at [itrack]; autoDataModeler thee = Data_copy (ff); return thee; } catch (MelderError) { @@ -634,11 +637,11 @@ autoDataModeler FormantModeler_extractDataModeler (FormantModeler me, integer if } } -autoCovariance FormantModeler_to_Covariance_parameters (FormantModeler me, integer iformant) { +autoCovariance FormantModeler_to_Covariance_parameters (FormantModeler me, integer itrack) { try { - Melder_require (iformant > 0 && iformant<= my trackmodelers.size, + Melder_require (itrack > 0 && itrack <= my trackmodelers.size, U"The formant should be greater than zero and smaller than or equal to ", my trackmodelers.size); - const DataModeler dm = my trackmodelers.at [iformant]; + const DataModeler dm = my trackmodelers.at [itrack]; autoCovariance thee = Data_copy (dm -> parameterCovariances.get()); return thee; } catch (MelderError) { @@ -648,8 +651,8 @@ autoCovariance FormantModeler_to_Covariance_parameters (FormantModeler me, integ } void FormantModeler_setTolerance (FormantModeler me, double tolerance) { - for (integer iformant = 1; iformant <= my trackmodelers.size; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; + for (integer itrack = 1; itrack <= my trackmodelers.size; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; DataModeler_setTolerance (ffi, tolerance); } } @@ -661,17 +664,19 @@ double FormantModeler_indexToTime (FormantModeler me, integer index) { } autoFormantModeler Formant_to_FormantModeler (Formant me, double tmin, double tmax, - integer numberOfFormants, integer numberOfParametersPerTrack) -{ + integer numberOfFormants, integer numberOfParametersPerTrack) { + autoINTVEC npar = newINTVECasNumbers (numberOfFormants, numberOfParametersPerTrack); + return Formant_to_FormantModeler (me, tmin, tmax, npar.get()); +} + +autoFormantModeler Formant_to_FormantModeler (Formant me, double tmin, double tmax, constINTVEC const& numberOfParametersPerTrack) { try { integer ifmin, ifmax, posInCollection = 0; Function_unidirectionalAutowindow (me, & tmin, & tmax); const integer numberOfDataPoints = Sampled_getWindowSamples (me, tmin, tmax, & ifmin, & ifmax); - Melder_require (numberOfDataPoints >= numberOfParametersPerTrack, - U"There are not enough data points, please extend the selection."); - - autoFormantModeler thee = FormantModeler_create (tmin, tmax, numberOfFormants, numberOfDataPoints, numberOfParametersPerTrack); - for (integer iformant = 1; iformant <= numberOfFormants; iformant ++) { + autoFormantModeler thee = FormantModeler_create (tmin, tmax, numberOfDataPoints, numberOfParametersPerTrack); + Thing_setName (thee.get(), my name.get()); + for (integer iformant = 1; iformant <= numberOfParametersPerTrack.size; iformant ++) { posInCollection ++; const DataModeler ffi = thy trackmodelers.at [posInCollection]; integer idata = 0, validData = 0; @@ -692,13 +697,7 @@ autoFormantModeler Formant_to_FormantModeler (Formant me, double tmin, double tm } ffi -> weighData = kDataModelerWeights::ONE_OVER_SIGMA; ffi -> tolerance = 1e-5; - if (validData < numberOfParametersPerTrack) { // remove don't throw exception - thy trackmodelers. removeItem (posInCollection); - posInCollection --; - } } - Melder_require (posInCollection > 0, - U"Not enough data points in all the formants."); FormantModeler_fit (thee.get()); return thee; } catch (MelderError) { @@ -715,16 +714,16 @@ autoFormant FormantModeler_to_Formant (FormantModeler me, bool useEstimates, boo autoFormant thee = Formant_create (my xmin, my xmax, numberOfFrames, dt, t1, numberOfFormants); autoVEC sigma = newVECraw (numberOfFormants); if (useEstimates || estimateUndefineds) { - for (integer iformant = 1; iformant <= numberOfFormants; iformant ++) - sigma [iformant] = FormantModeler_getStandardDeviation (me, iformant); + for (integer itrack = 1; itrack <= numberOfFormants; itrack ++) + sigma [itrack] = FormantModeler_getStandardDeviation (me, itrack); } for (integer iframe = 1; iframe <= numberOfFrames; iframe ++) { const Formant_Frame thyFrame = & thy frames [iframe]; thyFrame -> intensity = 1.0; //??? thyFrame -> formant = newvectorzero (numberOfFormants); - for (integer iformant = 1; iformant <= numberOfFormants; iformant ++) { - DataModeler ffi = my trackmodelers.at [iformant]; + for (integer itrack = 1; itrack <= numberOfFormants; itrack ++) { + DataModeler ffi = my trackmodelers.at [itrack]; double f = undefined, b = f; if (ffi -> data [iframe] .status != kDataModelerData::INVALID) { f = ( useEstimates ? DataModeler_getModelValueAtX (ffi, ffi -> data [iframe] .x) : @@ -732,12 +731,12 @@ autoFormant FormantModeler_to_Formant (FormantModeler me, bool useEstimates, boo b = ff -> data [iframe] .sigmaY; // copy original value } else { if (estimateUndefineds) { - f = FormantModeler_getModelValueAtTime (me, iformant, ffi -> data [iframe] .x); - b = sigma [iformant]; + f = FormantModeler_getModelValueAtTime (me, itrack, ffi -> data [iframe] .x); + b = sigma [itrack]; } } - thyFrame -> formant [iformant]. frequency = f; - thyFrame -> formant [iformant]. bandwidth = b; + thyFrame -> formant [itrack]. frequency = f; + thyFrame -> formant [itrack]. bandwidth = b; } } return thee; @@ -746,78 +745,63 @@ autoFormant FormantModeler_to_Formant (FormantModeler me, bool useEstimates, boo } } -double FormantModeler_getChiSquaredQ (FormantModeler me, integer fromFormant, integer toFormant, double *out_probability, double *out_ndf) { +double FormantModeler_getChiSquaredQ (FormantModeler me, integer fromTrack, integer toTrack, double *out_probability, double *out_ndf) { double chisq = undefined, ndfTotal = 0.0; - if (toFormant < fromFormant || (fromFormant == 0 && toFormant == 0)) { - fromFormant = 1; - toFormant = my trackmodelers.size; - } - if (fromFormant >= 1 && toFormant <= my trackmodelers.size) { - chisq = 0.0; - integer numberOfDefined = 0; - for (integer iformant= fromFormant; iformant <= toFormant; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; - double p, df; - const double chisqi = DataModeler_getChiSquaredQ (ffi, & p, & df); - if (isdefined (chisqi)) { - chisq += df * chisqi; - ndfTotal += df; - numberOfDefined ++; - } - } - if (numberOfDefined == toFormant - fromFormant + 1) { // chisq of all tracks defined - chisq /= ndfTotal; - if (out_ndf) - *out_ndf = ndfTotal; - if (out_probability) - *out_probability = NUMchiSquareQ (chisq, ndfTotal); + checkTrackAutoRange (me, & fromTrack, & toTrack); + chisq = 0.0; + integer numberOfDefined = 0; + for (integer itrack = fromTrack; itrack <= toTrack; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; + double p, df; + const double chisqi = DataModeler_getChiSquaredQ (ffi, & p, & df); + if (isdefined (chisqi)) { + chisq += df * chisqi; + ndfTotal += df; + numberOfDefined ++; } } + if (numberOfDefined == toTrack - fromTrack + 1) { // chisq of all tracks defined + chisq /= ndfTotal; + if (out_ndf) + *out_ndf = ndfTotal; + if (out_probability) + *out_probability = NUMchiSquareQ (chisq, ndfTotal); + } return chisq; } -double FormantModeler_getCoefficientOfDetermination (FormantModeler me, integer fromFormant, integer toFormant) { +double FormantModeler_getCoefficientOfDetermination (FormantModeler me, integer fromTrack, integer toTrack) { double rSquared = undefined; - if (fromFormant == 0 && toFormant == 0) { - fromFormant = 1; - toFormant = my trackmodelers.size; - } - if (fromFormant >= 1 && toFormant <= my trackmodelers.size) { - double ssreg = 0.0, sstot = 0.0; - for (integer iformant= fromFormant; iformant <= toFormant; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; - double ssregi, sstoti; - DataModeler_getCoefficientOfDetermination (ffi, & ssregi, & sstoti); - sstot += sstoti; - ssreg += ssregi; - } - rSquared = ( sstot > 0.0 ? ssreg / sstot : 1.0 ); - } + checkTrackAutoRange (me, & fromTrack, & toTrack); + double ssreg = 0.0, sstot = 0.0; + for (integer itrack= fromTrack; itrack <= toTrack; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; + double ssregi, sstoti; + DataModeler_getCoefficientOfDetermination (ffi, & ssregi, & sstoti); + sstot += sstoti; + ssreg += ssregi; + } + rSquared = ( sstot > 0.0 ? ssreg / sstot : 1.0 ); return rSquared; } -double FormantModeler_getResidualSumOfSquares (FormantModeler me, integer iformant, integer *out_numberOfDataPoints) { +double FormantModeler_getResidualSumOfSquares (FormantModeler me, integer itrack, integer *out_numberOfDataPoints) { double rss = undefined; integer numberOfDataPoints = -1; - if (iformant > 0 && iformant <= my trackmodelers.size) { - const DataModeler ff = my trackmodelers.at [iformant]; - rss = DataModeler_getResidualSumOfSquares (ff, & numberOfDataPoints); - } + if (itrack < 1 || itrack > my trackmodelers.size) + return undefined; + const DataModeler ff = my trackmodelers.at [itrack]; + rss = DataModeler_getResidualSumOfSquares (ff, & numberOfDataPoints); if (out_numberOfDataPoints) *out_numberOfDataPoints = numberOfDataPoints; return rss; } -void FormantModeler_setParameterValuesToZero (FormantModeler me, integer fromFormant, integer toFormant, double numberOfSigmas) { - if (fromFormant == 0 && toFormant == 0) { - fromFormant = 1; - toFormant = my trackmodelers.size; - } - if (fromFormant >= 1 && toFormant <= my trackmodelers.size) { - for (integer iformant= fromFormant; iformant <= toFormant; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; - DataModeler_setParameterValuesToZero (ffi, numberOfSigmas); - } +void FormantModeler_setParameterValuesToZero (FormantModeler me, integer fromTrack, integer toTrack, double numberOfSigmas) { + checkTrackAutoRange (me, & fromTrack, & toTrack); + for (integer itrack= fromTrack; itrack <= toTrack; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; + DataModeler_setParameterValuesToZero (ffi, numberOfSigmas); } } @@ -835,27 +819,27 @@ autoFormantModeler FormantModeler_processOutliers (FormantModeler me, double num // 1. calculate z-scores for each formant and sort them in descending order DataModeler ff = my trackmodelers.at [1]; - for (integer idata = 1; idata <= numberOfDataPoints; idata ++) - x [idata] = ff -> data [idata] .x; - for (integer iformant = 1; iformant <= numberOfFormants; iformant ++) { - const DataModeler ffi = my trackmodelers.at [iformant]; + for (integer ipoint = 1; ipoint <= numberOfDataPoints; ipoint ++) + x [ipoint] = ff -> data [ipoint] .x; + for (integer itrack = 1; itrack <= numberOfFormants; itrack ++) { + const DataModeler ffi = my trackmodelers.at [itrack]; autoVEC zscores = DataModeler_getZScores (ffi); - z.row (iformant) <<= zscores.get (); + z.row (itrack) <<= zscores.get(); } // 2. Do the manipulation in a copy autoFormantModeler thee = Data_copy (me); - for (integer i = 1; i <= numberOfDataPoints; i ++) { + for (integer ipoint = 1; ipoint <= numberOfDataPoints; ipoint ++) { // First the easy one: first formant missing: F1' = F2; F2' = F3 - if (isdefined (z [1] [i]) && isdefined (z [1] [i]) && isdefined (z [3] [i])) { - if (z [1] [i] > numberOfSigmas && z [2] [i] > numberOfSigmas && z [3] [i] > numberOfSigmas) { + if (isdefined (z [1] [ipoint]) && isdefined (z [1] [ipoint]) && isdefined (z [3] [ipoint])) { + if (z [1] [ipoint] > numberOfSigmas && z [2] [ipoint] > numberOfSigmas && z [3] [ipoint] > numberOfSigmas) { // all deviations have the same sign: // probably F1 is missing // try if f2 <- F1 and f3 <- F2 reduces chisq - const double f2 = FormantModeler_getDataPointValue (me, 1, i); // F1 - const double f3 = FormantModeler_getDataPointValue (me, 2, i); // F2 - FormantModeler_setDataPointStatus (thee.get(), 1, i, kDataModelerData::INVALID); - FormantModeler_setDataPointValueAndStatus (thee.get(), 2, i, f2, kDataModelerData::VALID); - FormantModeler_setDataPointValueAndStatus (thee.get(), 3, i, f3, kDataModelerData::VALID); + const double f2 = FormantModeler_getDataPointValue (me, 1, ipoint); // F1 + const double f3 = FormantModeler_getDataPointValue (me, 2, ipoint); // F2 + FormantModeler_setDataPointStatus (thee.get(), 1, ipoint, kDataModelerData::INVALID); + FormantModeler_setDataPointValueAndStatus (thee.get(), 2, ipoint, f2, kDataModelerData::VALID); + FormantModeler_setDataPointValueAndStatus (thee.get(), 3, ipoint, f3, kDataModelerData::VALID); } } } @@ -866,22 +850,15 @@ autoFormantModeler FormantModeler_processOutliers (FormantModeler me, double num } } - -double FormantModeler_getSmoothnessValue (FormantModeler me, integer fromFormant, integer toFormant, integer numberOfParametersPerTrack, double power) { - double smoothness = undefined; - if (toFormant < fromFormant || (toFormant == 0 && fromFormant == 0)) { - fromFormant = 1; - toFormant = my trackmodelers.size; - } - if (fromFormant > 0 && fromFormant <= toFormant && toFormant <= my trackmodelers.size) { - integer nofp; - const double var = FormantModeler_getVarianceOfParameters (me, fromFormant, toFormant, 1, numberOfParametersPerTrack, & nofp); - double ndof; - const double chisq = FormantModeler_getChiSquaredQ (me, fromFormant, toFormant, nullptr, &ndof); - if (isdefined (var) && isdefined (chisq) && nofp > 0) - smoothness = log10 (pow (var / nofp, power) * (chisq / ndof)); - } - return smoothness; +double FormantModeler_getStress (FormantModeler me, integer fromTrack, integer toTrack, integer numberOfParametersPerTrack, double power) { + checkTrackAutoRange (me, & fromTrack, & toTrack); + integer numberOfFreeParameters; + const double var = FormantModeler_getVarianceOfParameters (me, fromTrack, toTrack, 1, numberOfParametersPerTrack, & numberOfFreeParameters); + double degreesOfFreedom; + const double chisq = FormantModeler_getChiSquaredQ (me, fromTrack, toTrack, nullptr, & degreesOfFreedom); + return ( isdefined (var) && isdefined (chisq) && numberOfFreeParameters > 0 ? + ( sqrt (pow (var / numberOfFreeParameters, power) * (chisq / degreesOfFreedom))) : + undefined ); } double FormantModeler_getAverageDistanceBetweenTracks (FormantModeler me, integer track1, integer track2, int type) { @@ -894,14 +871,14 @@ double FormantModeler_getAverageDistanceBetweenTracks (FormantModeler me, intege // fi and fj have equal number of data points integer numberOfDataPoints = 0; diff = 0.0; - for (integer i = 1; i <= fi -> numberOfDataPoints; i ++) { + for (integer ipoint = 1; ipoint <= fi -> numberOfDataPoints; ipoint ++) { if (type != 0) { - const double fie = fi -> f_evaluate (fi, fi -> data [i] .x, fi -> parameters.get()); - const double fje = fj -> f_evaluate (fj, fj -> data [i] .x, fj -> parameters.get()); + const double fie = fi -> f_evaluate (fi, fi -> data [ipoint] .x, fi -> parameters.get()); + const double fje = fj -> f_evaluate (fj, fj -> data [ipoint] .x, fj -> parameters.get()); diff += fabs (fie - fje); numberOfDataPoints ++; - } else if (fi -> data [i] .status != kDataModelerData::INVALID && fj -> data [i] .status != kDataModelerData::INVALID) { - diff += fabs (fi -> data [i] .y - fj -> data [i] .y); + } else if (fi -> data [ipoint] .status != kDataModelerData::INVALID && fj -> data [ipoint] .status != kDataModelerData::INVALID) { + diff += fabs (fi -> data [ipoint] .y - fj -> data [ipoint] .y); numberOfDataPoints ++; } } @@ -923,22 +900,22 @@ double FormantModeler_getFormantsConstraintsFactor (FormantModeler me, double mi } void FormantModeler_reportChiSquared (FormantModeler me) { - const integer numberOfFormants = my trackmodelers.size; + const integer numberOfTracks = my trackmodelers.size; double ndf = 0, probability; - MelderInfo_writeLine (U"Chi squared tests for individual models of each of ", numberOfFormants, U" formant track:"); + MelderInfo_writeLine (U"Chi squared tests for individual models of each of ", numberOfTracks, U" formant track:"); MelderInfo_writeLine (( my weighFormants == kFormantModelerWeights::EQUAL_WEIGHTS ? U"Standard deviation is estimated from the data." : ( my weighFormants == kFormantModelerWeights::ONE_OVER_BANDWIDTH ? U"\tBandwidths are used as estimate for local standard deviations." : ( my weighFormants == kFormantModelerWeights::Q_FACTOR ? U"\t1/Q's are used as estimate for local standard deviations." : U"\tSquare root of bandwidths are used as estimate for local standard deviations." ) ) )); - for (integer iformant = 1; iformant <= numberOfFormants; iformant ++) { - const double chisq_f = FormantModeler_getChiSquaredQ (me, iformant, iformant, & probability, & ndf); - MelderInfo_writeLine (U"Formant track ", iformant, U":"); - MelderInfo_writeLine (U"\tChi squared (F", iformant, U") = ", chisq_f); - MelderInfo_writeLine (U"\tProbability (F", iformant, U") = ", probability); - MelderInfo_writeLine (U"\tNumber of degrees of freedom (F", iformant, U") = ", ndf); - } - const double chisq = FormantModeler_getChiSquaredQ (me, 1, numberOfFormants, & probability, & ndf); - MelderInfo_writeLine (U"Chi squared test for the complete model with ", numberOfFormants, U" formants:"); + for (integer itrack = 1; itrack <= numberOfTracks; itrack ++) { + const double chisq_f = FormantModeler_getChiSquaredQ (me, itrack, itrack, & probability, & ndf); + MelderInfo_writeLine (U"Formant track ", itrack, U":"); + MelderInfo_writeLine (U"\tChi squared (F", itrack, U") = ", chisq_f); + MelderInfo_writeLine (U"\tProbability (F", itrack, U") = ", probability); + MelderInfo_writeLine (U"\tNumber of degrees of freedom (F", itrack, U") = ", ndf); + } + const double chisq = FormantModeler_getChiSquaredQ (me, 1, numberOfTracks, & probability, & ndf); + MelderInfo_writeLine (U"Chi squared test for the complete model with ", numberOfTracks, U" formants:"); MelderInfo_writeLine (U"\tChi squared = ", chisq); MelderInfo_writeLine (U"\tProbability = ", probability); MelderInfo_writeLine (U"\tNumber of degrees of freedom = ", ndf); @@ -1006,7 +983,7 @@ integer Formants_getSmoothestInInterval (CollectionOf* me, double autoFormantModeler fs = Formant_to_FormantModeler (fi, tmin, tmax, numberOfFormantTracks, numberOfParametersPerTrack); FormantModeler_setParameterValuesToZero (fs.get(), 1, numberOfFormantTracks, numberOfSigmas); const double cf = ( useConstraints ? FormantModeler_getFormantsConstraintsFactor (fs.get(), minF1, maxF1, minF2, maxF2, minF3) : 1.0 ); - const double chiVar = FormantModeler_getSmoothnessValue (fs.get(), 1, numberOfFormantTracks, numberOfParametersPerTrack, power); + const double chiVar = FormantModeler_getStress (fs.get(), 1, numberOfFormantTracks, numberOfParametersPerTrack, power); if (isdefined (chiVar) && cf * chiVar < minChiVar) { minChiVar = cf * chiVar; index = iobject; @@ -1088,7 +1065,7 @@ autoFormant Sound_to_Formant_interval (Sound me, double startTime, double endTim const double nyquistFrequency = 0.5 / my dx; Melder_require (maxFreq <= nyquistFrequency, U"The upper value of the maximum frequency range should not exceed the Nyquist frequency of the sound."); - + autoINTVEC noPararametersPerTrack = newINTVECasNumbers (numberOfFormantTracks, numberOfParametersPerTrack); double df = 0, mincriterium = 1e28; if (minFreq >= maxFreq) numberOfFrequencySteps = 1; @@ -1104,19 +1081,18 @@ autoFormant Sound_to_Formant_interval (Sound me, double startTime, double endTim autoSound part = Sound_extractPart (me, startTime - windowLength + timeStep / 2.0, endTime + windowLength + timeStep / 2.0, kSound_windowShape::RECTANGULAR, 1, 1); // Resample to 2*maxFreq to reduce resampling load in Sound_to_Formant - autoSound resampled = Sound_resample (part.get(), 2.0 * maxFreq, 50); OrderedOf formants; Melder_progressOff (); for (integer istep = 1; istep <= numberOfFrequencySteps; istep ++) { const double currentCeiling = minFreq + (istep - 1) * df; autoFormant formant = Sound_to_Formant_burg (resampled.get(), timeStep, 5.0, currentCeiling, windowLength, preemphasisFrequency); - autoFormantModeler fm = Formant_to_FormantModeler (formant.get(), startTime, endTime, numberOfFormantTracks, numberOfParametersPerTrack); + autoFormantModeler fm = Formant_to_FormantModeler (formant.get(), startTime, endTime, noPararametersPerTrack.get()); //TODO FormantModeler_setFormantWeighting (me, weighFormants); FormantModeler_setParameterValuesToZero (fm.get(), 1, numberOfFormantTracks, numberOfSigmas); formants. addItem_move (formant.move()); const double cf = ( useConstraints ? FormantModeler_getFormantsConstraintsFactor (fm.get(), minF1, maxF1, minF2, maxF2, minF3) : 1.0 ); - const double chiVar = FormantModeler_getSmoothnessValue (fm.get(), 1, numberOfFormantTracks, numberOfParametersPerTrack, power); + const double chiVar = FormantModeler_getStress (fm.get(), 1, numberOfFormantTracks, numberOfParametersPerTrack, power); const double criterium = chiVar * cf; if (isdefined (chiVar) && criterium < mincriterium) { mincriterium = criterium; @@ -1155,28 +1131,34 @@ autoFormant Sound_to_Formant_interval_robust (Sound me, double startTime, double numberOfFrequencySteps = 1; else df = (maxFreq - minFreq) / (numberOfFrequencySteps - 1); + + autoINTVEC noPararametersPerTrack = newINTVECasNumbers (numberOfFormantTracks, numberOfParametersPerTrack); integer istep_best = 0; double optimalCeiling = minFreq; // extract part +- windowLength because of Gaussian windowing in the formant analysis // +timeStep/2 to have the analysis points maximally spread in the new domain. - autoSound part = Sound_extractPart (me, startTime - windowLength + timeStep / 2, endTime + windowLength + timeStep / 2, kSound_windowShape::RECTANGULAR, 1, 1); + autoSound part = Sound_extractPart (me, startTime - windowLength + timeStep / 2.0, endTime + windowLength + timeStep / 2.0, + kSound_windowShape::RECTANGULAR, 1, true); - // Resample to 2*maxFreq to reduce resampling load in Sound_to_Formant - + /* + Resample to 2*maxFreq to reduce resampling load in Sound_to_Formant. + */ autoSound resampled = Sound_resample (part.get(), 2.0 * maxFreq, 50); + OrderedOf formants; Melder_progressOff (); for (integer istep = 1; istep <= numberOfFrequencySteps; istep ++) { const double currentCeiling = minFreq + (istep - 1) * df; - autoFormant formant = Sound_to_Formant_robust (resampled.get(), timeStep, 5.0, currentCeiling, windowLength, preemphasisFrequency, 50.0, 1.5, 3, 0.0000001, 1); - autoFormantModeler fm = Formant_to_FormantModeler (formant.get(), startTime, endTime, numberOfFormantTracks, numberOfParametersPerTrack); + autoFormant formant = Sound_to_Formant_robust (resampled.get(), timeStep, 5.0, + currentCeiling, windowLength, preemphasisFrequency, 50.0, 1.5, 3, 0.0000001, true); + autoFormantModeler fm = Formant_to_FormantModeler (formant.get(), startTime, endTime, noPararametersPerTrack.get()); // TODO set weighing FormantModeler_setParameterValuesToZero (fm.get(), 1, numberOfFormantTracks, numberOfSigmas); formants. addItem_move (formant.move()); const double cf = ( useConstraints ? FormantModeler_getFormantsConstraintsFactor (fm.get(), minF1, maxF1, minF2, maxF2, minF3) : 1.0 ); - const double chiVar = FormantModeler_getSmoothnessValue (fm.get(), 1, numberOfFormantTracks, numberOfParametersPerTrack, power); + const double chiVar = FormantModeler_getStress (fm.get(), 1, numberOfFormantTracks, numberOfParametersPerTrack, power); const double criterium = chiVar * cf; if (isdefined (chiVar) && criterium < mincriterium) { mincriterium = criterium; @@ -1221,11 +1203,11 @@ autoOptimalCeilingTier Sound_to_OptimalCeilingTier (Sound me, } integer numberOfFrames; double firstTime; - const double modelingTimeStep = timeStep; + const double modellingTimeStep = timeStep; autoOptimalCeilingTier octier = OptimalCeilingTier_create (my xmin, my xmax); - Sampled_shortTermAnalysis (me, smoothingWindow, modelingTimeStep, & numberOfFrames, & firstTime); + Sampled_shortTermAnalysis (me, smoothingWindow, modellingTimeStep, & numberOfFrames, & firstTime); for (integer iframe = 1; iframe <= numberOfFrames; iframe ++) { - const double time = firstTime + (iframe - 1) * modelingTimeStep; + const double time = firstTime + (iframe - 1) * modellingTimeStep; const double tmin = time - smoothingWindow / 2.0; const double tmax = tmin + smoothingWindow; const integer index = Formants_getSmoothestInInterval (& formants, tmin, tmax, numberOfFormantTracks, numberOfParametersPerTrack, weighFormants, @@ -1239,4 +1221,4 @@ autoOptimalCeilingTier Sound_to_OptimalCeilingTier (Sound me, } } -/* End of file DataModeler.cpp */ +/* End of file FormantModeler.cpp */ diff --git a/dwtools/FormantModeler.h b/LPC/FormantModeler.h similarity index 65% rename from dwtools/FormantModeler.h rename to LPC/FormantModeler.h index 41e82cec..8b4f46f0 100644 --- a/dwtools/FormantModeler.h +++ b/LPC/FormantModeler.h @@ -19,10 +19,12 @@ */ #include "Collection.h" -#include "Pitch.h" +#include "Covariance.h" +#include "DataModeler.h" +#include "Formant.h" #include "OptimalCeilingTier.h" +#include "Pitch.h" #include "Sound_to_Formant.h" -#include "SSCP.h" #include "Table.h" #include "FormantModeler_enums.h" @@ -31,101 +33,133 @@ autoFormant Formant_extractPart (Formant me, double tmin, double tmax); -autoFormantModeler FormantModeler_create (double tmin, double tmax, integer numberOfFormants, integer numberOfDataPoints, integer numberOfParameters); +autoFormantModeler FormantModeler_create (double tmin, double tmax, integer numberOfDataPoints, integer numberOfTracks, integer numberOfParameters); + +autoFormantModeler FormantModeler_create (double tmin, double tmax, integer numberOfDataPoints, constINTVEC const& numberOfParameters); double FormantModeler_indexToTime (FormantModeler me, integer index); void FormantModeler_fit (FormantModeler me); void FormantModeler_drawBasisFunction (FormantModeler me, Graphics g, double tmin, double tmax, double fmin, double fmax, - integer iformant, integer iterm, bool scaled, integer numberOfPoints, bool garnish); + integer itrack, integer iterm, bool scaled, integer numberOfPoints, bool garnish); -void FormantModeler_setDataWeighing (FormantModeler me, integer fromFormant, integer toFormant, kFormantModelerWeights weighFormants); +void FormantModeler_setDataWeighing (FormantModeler me, integer fromTrack, integer toTrack, kFormantModelerWeights weighFormants); -void FormantModeler_setParameterValueFixed (FormantModeler me, integer iformant, integer index, double value); +void FormantModeler_setParameterValueFixed (FormantModeler me, integer itrack, integer index, double value); -void FormantModeler_setParametersFree (FormantModeler me, integer fromFormant, integer toFormant, integer fromIndex, integer toIndex); +void FormantModeler_setParametersFree (FormantModeler me, integer fromTrack, integer toTrack, integer fromIndex, integer toIndex); -void FormantModeler_setParameterValuesToZero (FormantModeler me, integer fromFormant, integer toFormant, double numberOfSigmas); +void FormantModeler_setParameterValuesToZero (FormantModeler me, integer fromTrack, integer toTrack, double numberOfSigmas); void FormantModeler_setTolerance (FormantModeler me, double tolerance); +void FormantModeler_drawModel_inside (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, + integer fromTrack, integer toTrack, MelderColour oddTracks, MelderColour evenTracks, integer numberOfPoints); + void FormantModeler_speckle (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, - integer fromTrack, integer toTrack, bool estimated, integer numberOfParameters, - bool errorBars, double barWidth_mm, double horizontalOffset_mm, bool garnish); + integer fromTrack, integer toTrack, bool useEstimatedTrack, integer numberOfParameters, bool errorBars, + MelderColour oddTracks, MelderColour evenTracks, bool garnish); -void FormantModeler_drawTracks (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, integer fromTrack, integer toTrack, bool estimated, integer numberOfParameters, double horizontalOffset_mm, bool garnish); +void FormantModeler_speckle_inside (FormantModeler me, Graphics g, double xmin, double xmax, double fmax, + integer fromTrack, integer toTrack, bool useEstimatedTrack, integer numberOfParameters, bool errorBars, MelderColour oddTracks, MelderColour evenTracks); -void FormantModeler_drawOutliersMarked (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, integer fromTrack, integer toTrack, - double numberOfSigmas, conststring32 mark, double marksFontSize, double horizontalOffset_mm, bool garnish); +void FormantModeler_drawTracks (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, integer fromTrack, integer toTrack, bool useEstimatedTrack, integer numberOfParameters, MelderColour oddTracks, MelderColour evenTracks, bool garnish); + +void FormantModeler_drawTracks_inside (FormantModeler me, Graphics g, double xmin, double xmax, double fmax, integer fromTrack, integer toTrack, bool useEstimatedTrack, integer numberOfParameters, MelderColour oddTracks, MelderColour evenTracks, bool garnish); + +void FormantModeler_drawOutliersMarked (FormantModeler me, Graphics g, double tmin, double tmax, double fmax, integer fromTrack, integer toTrack, double numberOfSigmas, conststring32 mark, double marksFontSize, MelderColour oddTracks, MelderColour evenTracks, bool garnish); void FormantModeler_drawCumulativeChiScores (FormantModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool garnish); void FormantModeler_drawVariancesOfShiftedTracks (FormantModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - kFormantModelerTrackShift shiftDirection, integer fromFormant, integer toFormant, bool garnish); + kFormantModelerTrackShift shiftDirection, integer fromTrack, integer toTrack, bool garnish); -void FormantModeler_normalProbabilityPlot (FormantModeler me, Graphics g, integer iformant, integer numberOfQuantiles, double numberOfSigmas, double labelSize, conststring32 label, bool garnish); +void FormantModeler_normalProbabilityPlot (FormantModeler me, Graphics g, integer itrack, integer numberOfQuantiles, double numberOfSigmas, double labelSize, conststring32 label, bool garnish); autoTable FormantModeler_to_Table_zscores (FormantModeler me); -autoCovariance FormantModeler_to_Covariance_parameters (FormantModeler me, integer iformant); +autoCovariance FormantModeler_to_Covariance_parameters (FormantModeler me, integer itrack); -double FormantModeler_getChiSquaredQ (FormantModeler me, integer fromFormant, integer toFormant, double *probability, double *ndf); -double FormantModeler_getCoefficientOfDetermination (FormantModeler me, integer fromFormant, integer toFormant); +/* + Precondition: fromFormant >= 1 + toFormant == 0 signals 'all' data +*/ +double FormantModeler_getChiSquaredQ (FormantModeler me, integer fromTrack, integer toTrack, double *probability, double *ndf); -double FormantModeler_getStandardDeviation (FormantModeler me, integer iformant); +double FormantModeler_getCoefficientOfDetermination (FormantModeler me, integer fromTrack, integer toTrack); -double FormantModeler_getResidualSumOfSquares (FormantModeler me, integer iformant, integer *numberOfDataPoints); +double FormantModeler_getStandardDeviation (FormantModeler me, integer itrack); -double FormantModeler_getEstimatedValueAtTime (FormantModeler me, integer iformant, double time); +double FormantModeler_getResidualSumOfSquares (FormantModeler me, integer itrack, integer *numberOfDataPoints); -integer FormantModeler_getNumberOfParameters (FormantModeler me, integer iformant); +double FormantModeler_getEstimatedValueAtTime (FormantModeler me, integer itrack, double time); -integer FormantModeler_getNumberOfFixedParameters (FormantModeler me, integer iformant); +integer FormantModeler_getNumberOfParameters (FormantModeler me, integer itrack); -double FormantModeler_getParameterStandardDeviation ( FormantModeler me, integer iformant, integer index); +integer FormantModeler_getNumberOfFixedParameters (FormantModeler me, integer itrack); -double FormantModeler_getVarianceOfParameters (FormantModeler me, integer fromFormant, integer toFormant, integer fromIndex, integer toIndex, integer *numberOfFreeParameters); +double FormantModeler_getParameterStandardDeviation ( FormantModeler me, integer itrack, integer index); -kDataModelerParameter FormantModeler_getParameterStatus (FormantModeler me, integer iformant, integer index); +/* + Precondition: fromIndex >= 1 && fromFormant >= 1 + toFormant == 0 && toIndex == 0 signal 'all' data +*/ +double FormantModeler_getVarianceOfParameters (FormantModeler me, integer fromTrack, integer toTrack, integer fromIndex, integer toIndex, integer *numberOfFreeParameters); + +kDataModelerParameter FormantModeler_getParameterStatus (FormantModeler me, integer itrack, integer index); integer FormantModeler_getNumberOfDataPoints (FormantModeler me); -integer FormantModeler_getNumberOfInvalidDataPoints (FormantModeler me, integer iformant); +integer FormantModeler_getNumberOfInvalidDataPoints (FormantModeler me, integer itrack); -void FormantModeler_setDataPointStatus (FormantModeler me, integer iformant, integer index, kDataModelerData status); +void FormantModeler_setDataPointStatus (FormantModeler me, integer itrack, integer index, kDataModelerData status); -kDataModelerData FormantModeler_getDataPointStatus (FormantModeler me, integer iformant, integer index); +kDataModelerData FormantModeler_getDataPointStatus (FormantModeler me, integer itrack, integer index); -double FormantModeler_getDataPointValue (FormantModeler me, integer iformant, integer index); +double FormantModeler_getDataPointValue (FormantModeler me, integer itrack, integer index); -void FormantModeler_setDataPointValue (FormantModeler me, integer iformant, integer index, double value); +void FormantModeler_setDataPointValue (FormantModeler me, integer itrack, integer index, double value); -double FormantModeler_getDataPointSigma (FormantModeler me, integer iformant, integer index); +double FormantModeler_getDataPointSigma (FormantModeler me, integer itrack, integer index); -void FormantModeler_setDataPointSigma (FormantModeler me, integer iformant, integer index, double sigma); +void FormantModeler_setDataPointSigma (FormantModeler me, integer itrack, integer index, double sigma); -double FormantModeler_getDegreesOfFreedom (FormantModeler me, integer iformant); +double FormantModeler_getDegreesOfFreedom (FormantModeler me, integer itrack); integer FormantModeler_getNumberOfTracks (FormantModeler me); -double FormantModeler_getModelValueAtTime (FormantModeler me, integer iformant, double time); +double FormantModeler_getModelValueAtTime (FormantModeler me, integer itrack, double time); -double FormantModeler_getModelValueAtIndex (FormantModeler me, integer iformant, integer index); +double FormantModeler_getModelValueAtIndex (FormantModeler me, integer itrack, integer index); -double FormantModeler_getWeightedMean (FormantModeler me, integer iformant); +double FormantModeler_getWeightedMean (FormantModeler me, integer itrack); -double FormantModeler_getParameterValue (FormantModeler me, integer iformant, integer iparameter); +double FormantModeler_getParameterValue (FormantModeler me, integer itrack, integer iparameter); -autoFormantModeler Formant_to_FormantModeler (Formant me, double tmin, double tmax, integer numberOfFormants, +autoFormantModeler Formant_to_FormantModeler (Formant me, double tmin, double tmax, integer numberOfTracks, integer numberOfParametersPerTrack); +autoFormantModeler Formant_to_FormantModeler (Formant me, double tmin, double tmax, constINTVEC const& numberOfParametersPerTrack); + autoFormant FormantModeler_to_Formant (FormantModeler me, bool estimate, bool estimateUndefined); autoFormantModeler FormantModeler_processOutliers (FormantModeler me, double numberOfSigmas); -double FormantModeler_getSmoothnessValue (FormantModeler me, integer fromFormant, integer toFormant, +/* + Get roughness criterion value according to Weenink's (2015) measure + W = (var/k)^t * (chi^2/d), where + var is the sum of all variances of all parameters of all modelled formants, + k is the total number of parameters to mode all tracks, chi^2 is the combined chi-squared of all + the modelled tracks, d is the combined degrees of freedom, and t is a number that if chosen + larger than 1 guarantees that for tracks that only differ in bandwidth the one with the largest + bandwidth obtains a higher value for W. + A lower value for W means a smoother track. + + The routine returns log10 (W). +*/ +double FormantModeler_getStress (FormantModeler me, integer fromTrack, integer toTrack, integer numberOfParametersPerTrack, double power); double FormantModeler_getAverageDistanceBetweenTracks (FormantModeler me, integer track1, integer track2, int type); @@ -140,7 +174,7 @@ autoFormant Formants_extractSmoothestPart (CollectionOf* me, doub autoFormant Formants_extractSmoothestPart_withFormantsConstraints (CollectionOf* me, double tmin, double tmax, integer numberOfFormantTracks, integer numberOfParametersPerTrack, kFormantModelerWeights weighFormants, double numberOfSigmas, double power, double minF1, double maxF1, double minF2, double maxF2, double minF3); -autoDataModeler FormantModeler_extractDataModeler (FormantModeler me, integer iformant); +autoDataModeler FormantModeler_extractDataModeler (FormantModeler me, integer itrack); autoFormant Sound_to_Formant_interval (Sound me, double startTime, double endTime, double windowLength, double timeStep, double minFreq, double maxFreq, integer numberOfFrequencySteps, diff --git a/LPC/FormantModelerList.cpp b/LPC/FormantModelerList.cpp new file mode 100644 index 00000000..61b1e7fa --- /dev/null +++ b/LPC/FormantModelerList.cpp @@ -0,0 +1,333 @@ +/*FormantModelerList.cpp + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "FormantModelerList.h" + +#include "oo_DESTROY.h" +#include "FormantModelerList_def.h" +#include "oo_COPY.h" +#include "FormantModelerList_def.h" +#include "oo_EQUAL.h" +#include "FormantModelerList_def.h" +#include "oo_CAN_WRITE_AS_ENCODING.h" +#include "FormantModelerList_def.h" +#include "oo_WRITE_BINARY.h" +#include "FormantModelerList_def.h" +#include "oo_READ_BINARY.h" +#include "FormantModelerList_def.h" +#include "oo_WRITE_TEXT.h" +#include "FormantModelerList_def.h" +#include "oo_READ_TEXT.h" +#include "FormantModelerList_def.h" +#include "oo_DESCRIPTION.h" +#include "FormantModelerList_def.h" +/* +void structFormantModelerListDrawingSpecification :: v_writeBinary (FILE *_filePointer_) {} +void structFormantModelerList :: v_writeBinary (FILE *_filePointer_) {} +void structFormantModelerListDrawingSpecification :: v_readBinary (FILE *_filePointer_, int _formatVersion_) {} +void structFormantModelerList :: v_readBinary (FILE *_filePointer_, int _formatVersion_) {} + +*/ +void structFormantModelerList :: v_info () { + +}; + +Thing_implement (FormantModelerList, Function, 0); +Thing_implement (FormantModelerListDrawingSpecification, Daata, 0); + +autoFormantModelerList FormantPath_to_FormantModelerList (FormantPath me, double startTime, double endTime, conststring32 numberOfParametersPerTrack_string) { + try { + autoFormantModelerList thee = Thing_new (FormantModelerList); + thy xmin = startTime; + thy xmax = endTime; + autoINTVEC numberOfParametersPerTrack = newINTVECfromString (numberOfParametersPerTrack_string); + Melder_require (numberOfParametersPerTrack.size > 0, + U"The number of items in the parameter list should be larger than zero."); + thy numberOfTracksPerModel = numberOfParametersPerTrack.size; + integer numberOfZeros = 0; + for (integer ipar = 1; ipar <= numberOfParametersPerTrack.size; ipar ++) { + const integer value = numberOfParametersPerTrack [ipar]; + Melder_require (value >= 0, + U"Numbers in the 'Number of parameter list' should be positive."); + if (value == 0) + numberOfZeros += 1; + } + thy numberOfParametersPerTrack = numberOfParametersPerTrack.move(); + thy numberOfTracksPerModel = thy numberOfParametersPerTrack.size; + thy numberOfModelers = my formants . size; + for (integer imodel = 1; imodel <= thy numberOfModelers; imodel ++) { + Formant formanti = (Formant) my formants . at [imodel]; + autoFormantModeler fm = Formant_to_FormantModeler (formanti, startTime, endTime, thy numberOfParametersPerTrack.get()); + Thing_setName (fm.get(), Melder_fixed (my ceilings [imodel], 0)); + thy formantModelers. addItem_move (fm.move()); + } + thy drawingSpecification = FormantModelerList_to_FormantModelerListDrawingSpecification (thee.get(), 0); + return thee; + } catch (MelderError) { + Melder_throw (me, U": FormantModelerList not created."); + } +} + +void FormantModelerList_showBest3 (FormantModelerList me) { + autoINTVEC best3 = FormantModelerList_getBest3 (me); + INTVEC drawingOrder = my drawingSpecification -> drawingOrder.get(); + drawingOrder.part (1, 3) <<= best3.all(); + my drawingSpecification -> numberOfModelersToDraw = 3; +} + +void FormantModelerList_markBest3 (FormantModelerList me) { + /* + 3 The smoothest F1 score + 2 The smoothest F1 & F2 score + 1 the smoothest F1 & F2 & F3 score + */ + autoINTVEC best3 = FormantModelerList_getBest3 (me); + for (integer imodel = 1; imodel <= my numberOfModelers; imodel ++) { + autoMelderString best; + if (imodel == best3 [1]) { + MelderString_append (& best, U"F123"); + } + if (imodel == best3 [2]) { + MelderString_append (& best, ( best.string && best.string [0] ? U"&F12" : U"F12" )); + } + if (imodel == best3 [3]) { + MelderString_append (& best, ( best.string && best.string [0] ? U"&F1" : U"F1" )); + } + my drawingSpecification -> midTopText [imodel] = Melder_dup (best.string); + } +} + +integer FormantModelerList_getBestModelIndex (FormantModelerList me, integer fromTrack, integer toTrack) { + double wmin = std::numeric_limits::max(); + integer best = 0; + for (integer imodel = 1; imodel <= my numberOfModelers; imodel ++) { + FormantModeler fm = my formantModelers.at [imodel]; + double w = FormantModeler_getStress (fm, fromTrack, toTrack, 0, my varianceExponent); + if (w < wmin) { + wmin = w; + best = imodel; + } + } + return best; +} + +autoINTVEC FormantModelerList_getBest3 (FormantModelerList me) { + /* + 3 The least stress F1 score + 2 The least (summed) stress F1 & F2 score + 1 the least (summed) stress F1 & F2 & F3 score + */ + autoINTVEC best = newINTVECraw (3); + double stressF1, stressF1F2, stressF1F2F3; + stressF1 = stressF1F2 = stressF1F2F3 = std::numeric_limits::max(); + for (integer imodel = 1; imodel <= my numberOfModelers; imodel ++) { + FormantModeler fm = my formantModelers.at [imodel]; + double stress = FormantModeler_getStress (fm, 1, 1, 0, my varianceExponent); + if (stress < stressF1) { + stressF1 = stress; + best [3] = imodel; + } + stress = FormantModeler_getStress (fm, 1, 2, 0, my varianceExponent); + if (stress < stressF1F2) { + stressF1F2 = stress; + best [2] = imodel; + } + stress = FormantModeler_getStress (fm, 1, 3, 0, my varianceExponent); + if (stress < stressF1F2F3) { + stressF1F2F3 = stress; + best [1] = imodel; + } + } + return best; +} + +static void getMatrixGridLayout (integer numberOfModels, integer *out_numberOfRows, integer *out_numberOfColums) { + integer ncol = 1; + integer nrow = 3; + if (numberOfModels > 3) { + nrow = 1 + Melder_ifloor (sqrt (numberOfModels - 0.5)); + ncol = 1 + Melder_ifloor ((numberOfModels - 1) / nrow); + } + if (out_numberOfRows) + *out_numberOfRows = nrow; + if (out_numberOfColums) + *out_numberOfColums = ncol; +} + +void FormantModelerList_getMatrixGridLayout (FormantModelerList me, integer *out_numberOfRows, integer *out_numberOfColums) { + getMatrixGridLayout (my drawingSpecification -> numberOfModelersToDraw, out_numberOfRows, out_numberOfColums); +} + +void FormantModelerListDrawingSpecification_showAll (FormantModelerListDrawingSpecification me) { + my numberOfModelersToDraw = my numberOfModelers; + INTVEClinear (my drawingOrder.get(), 1, 1); +} + +integer FormantModelerListDrawingSpecification_getNumberOfShown (FormantModelerListDrawingSpecification me) { + return my numberOfModelersToDraw; +} + +void FormantModelerListDrawingSpecification_setModelerColours (FormantModelerListDrawingSpecification me, conststring32 oddFormantColour_string, conststring32 evenFormantColour_string, conststring32 selectedCandidateColour_string) { + my oddFormantColour = MelderColour_fromColourNameOrNumberStringOrRGBString (oddFormantColour_string); + my evenFormantColour = MelderColour_fromColourNameOrNumberStringOrRGBString (evenFormantColour_string); + my selectedCandidateColour = MelderColour_fromColourNameOrNumberStringOrRGBString (selectedCandidateColour_string); +} + +autoFormantModelerListDrawingSpecification FormantModelerList_to_FormantModelerListDrawingSpecification (FormantModelerList me, integer defaultModeler) { + try { + autoFormantModelerListDrawingSpecification thee = Thing_new (FormantModelerListDrawingSpecification); + thy numberOfModelers = my numberOfModelers; + thy drawingOrder = newINTVEClinear (my numberOfModelers, 1, 1); + thy numberOfModelersToDraw = my numberOfModelers; + thy boxLineWidth = 4.0; + thy oddFormantColour = Melder_RED; + thy evenFormantColour = Melder_MAROON; + thy selectedCandidateColour = Melder_RED; + thy midTopText_colour = Melder_PURPLE; + autoSTRVEC midTopText (my numberOfModelers); + for (integer imodel = 1; imodel <= my numberOfModelers; imodel ++) + midTopText [imodel] = Melder_dup (U""); + thy midTopText = newSTRVECcopy (midTopText.get()); + return thee; + } catch (MelderError) { + Melder_throw (U"No FormantModelerListDrawingSpecification created."); + } +} + +void FormantModelerList_drawInMatrixGrid (FormantModelerList me, Graphics g, integer nrow, integer ncol, kGraphicsMatrixOrigin origin, double spaceBetweenFraction_x, double spaceBetweenFraction_y, integer fromFormant, integer toFormant, double fmax, double yGridLineEvery_Hz, double xCursor, double yCursor, integer numberOfParameters, bool drawErrorBars, double barwidth_s, bool drawEstimated, bool garnish) { + if (nrow <= 0 || ncol <= 0) + FormantModelerList_getMatrixGridLayout (me, & nrow, & ncol); + const double fmin = 0.0; + double x1NDC, x2NDC, y1NDC, y2NDC; + Graphics_inqViewport (g, & x1NDC, & x2NDC, & y1NDC, & y2NDC); + const double fontSize_old = Graphics_inqFontSize (g), newFontSize = 8.0; + auto getXtick = [] (Graphics gg, double fontSize) { + const double margin = 2.8 * fontSize * gg -> resolution / 72.0; + const double wDC = (gg -> d_x2DC - gg -> d_x1DC) / (gg -> d_x2wNDC - gg -> d_x1wNDC) * (gg -> d_x2NDC - gg -> d_x1NDC); + double dx = 1.5 * margin / wDC; + double xTick = 0.06 * dx; + if (dx > 0.4) dx = 0.4; + return xTick /= 1.0 - 2.0 * dx; + }; + auto getYtick = [] (Graphics gg, double fontSize) { + double margin = 2.8 * fontSize * gg -> resolution / 72.0; + double hDC = integer_abs (gg->d_y2DC - gg->d_y1DC) / (gg->d_y2wNDC - gg->d_y1wNDC) * (gg->d_y2NDC - gg-> d_y1NDC); + double dy = margin / hDC; + double yTick = 0.09 * dy; + if (dy > 0.4) dy = 0.4; + yTick /= 1.0 - 2.0 * dy; + return yTick; + }; + const bool fillUp = ( origin == kGraphicsMatrixOrigin::BOTTOM_LEFT || origin == kGraphicsMatrixOrigin::BOTTOM_RIGHT ); + const bool rightToLeft = ( origin == kGraphicsMatrixOrigin::TOP_RIGHT || origin ==kGraphicsMatrixOrigin:: BOTTOM_RIGHT ); + const double vp_width = x2NDC - x1NDC, vp_height = y2NDC - y1NDC; + const double vpi_width = vp_width / (ncol + (ncol - 1) * spaceBetweenFraction_x); + const double vpi_height = vp_height / (nrow + (nrow - 1) * spaceBetweenFraction_y); + for (integer index = 1; index <= my drawingSpecification->numberOfModelersToDraw; index ++) { + const integer irow1 = 1 + (index - 1) / ncol; // left-to-right + top-to-bottom + const integer icol1 = 1 + (index - 1) % ncol; + const integer icol = ( rightToLeft ? ncol - icol1 + 1 : icol1 ); + const integer irow = ( fillUp ? nrow - irow1 + 1 : irow1 ); + double vpi_x1 = x1NDC + (icol - 1) * vpi_width * (1.0 + spaceBetweenFraction_x); + double vpi_x2 = vpi_x1 + vpi_width; + double vpi_y2 = y2NDC - (irow - 1) * vpi_height * (1.0 + spaceBetweenFraction_y); + double vpi_y1 = vpi_y2 - vpi_height; + integer imodel = my drawingSpecification -> drawingOrder [index]; + FormantModeler fm = my formantModelers.at [imodel]; + Graphics_setViewport (g, vpi_x1, vpi_x2, vpi_y1, vpi_y2); + Graphics_setWindow (g, fm -> xmin, fm -> xmax, 0.0, fmax); + FormantModeler_speckle_inside (fm, g, fm -> xmin, fm -> xmax, fmax, fromFormant, toFormant, + drawEstimated, 0.0, drawErrorBars, my drawingSpecification -> oddFormantColour, my drawingSpecification -> evenFormantColour); + + Graphics_setLineWidth (g, my drawingSpecification -> boxLineWidth); + Graphics_setColour (g, (imodel == my drawingSpecification -> selectedCandidate ? + my drawingSpecification -> selectedCandidateColour : Melder_BLACK )); + Graphics_rectangle (g, fm -> xmin, fm -> xmax, fmin, fmax); + Graphics_setLineType (g, Graphics_DRAWN); + Graphics_setColour (g, Melder_BLACK); + Graphics_setLineWidth (g, 1.0); + /* + Mark name & roughness + */ + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::RIGHT, Graphics_HALF); + Graphics_text (g, fm -> xmax - 0.05 * (fm -> xmax - fm -> xmin), + fmax - 0.05 * fmax, fm -> name.get()); + double w = FormantModeler_getStress (fm, fromFormant, toFormant, 0, my varianceExponent); + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::LEFT, Graphics_HALF); + Graphics_text (g, fm -> xmin + 0.05 * (fm -> xmax - fm -> xmin), + fmax - 0.05 * fmax, Melder_fixed (w, 2)); + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::CENTRE, Graphics_HALF); + conststring32 midTopText = my drawingSpecification -> midTopText [imodel].get(); + if (midTopText && midTopText [0]) { + Graphics_setColour (g,my drawingSpecification -> midTopText_colour); + Graphics_text (g, fm -> xmin + 0.5 * (fm -> xmax - fm -> xmin), + fmax - 0.05 * fmax, my drawingSpecification -> midTopText [imodel].get()); + Graphics_setColour (g, Melder_BLACK); + } + + if (garnish) { + double xTick = (double) getXtick (g, newFontSize) * (fm -> xmax - fm -> xmin); + double yTick = (double) getYtick (g, newFontSize) * (fmax - 0.0); + if (icol == 1 && irow % 2 == 1) { + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::RIGHT, Graphics_HALF); + Graphics_line (g, fm -> xmin - xTick, fmax, fm -> xmin, fmax); + Graphics_text (g, fm -> xmin - xTick, fmax, Melder_iround (fmax)); + Graphics_line (g, fm -> xmin - xTick, 0.0, fm -> xmin, 0.0); + Graphics_text (g, fm -> xmin - xTick, 0.0, U"0.0"); + } else if (icol == ncol && irow % 2 == 0) { + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::LEFT, Graphics_HALF); + Graphics_text (g, fm -> xmax, fmax, Melder_iround (fmax)); + Graphics_text (g, fm -> xmax, 0.0, U"0.0"); + } + if (irow == 1 && icol % 2 == 0) { + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::CENTRE, Graphics_BOTTOM); + Graphics_line (g, fm -> xmin, fmax, fm -> xmin, fmax + yTick); + Graphics_text (g, fm -> xmin, fmax + yTick, Melder_fixed (fm -> xmin, 3)); + Graphics_line (g, fm -> xmax, fmax, fm -> xmax, fmax + yTick); + Graphics_text (g, fm -> xmax, fmax + yTick, Melder_fixed (fm -> xmax, 3)); + } else if (irow == nrow && icol % 2 == 1) { + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::CENTRE, Graphics_TOP); + Graphics_line (g, fm -> xmin, 0.0, fm -> xmin, 0.0 - yTick); + Graphics_text (g, fm -> xmin, 0.0 - yTick, Melder_fixed (fm -> xmin, 3)); + Graphics_line (g, fm -> xmax, 0.0, fm -> xmax, 0.0 - yTick); + Graphics_text (g, fm -> xmax, 0.0 - yTick, Melder_fixed (fm -> xmax, 3)); + } + double yGridLine_Hz = yGridLineEvery_Hz; + Graphics_setLineType (g, Graphics_DOTTED); + while (yGridLine_Hz < 0.95 * fmax) { + Graphics_line (g, fm -> xmin, yGridLine_Hz, fm -> xmax, yGridLine_Hz); + yGridLine_Hz += yGridLineEvery_Hz; + } + /* + Cursors + */ + Graphics_setColour (g, Melder_RED); + Graphics_setLineType (g, Graphics_DASHED); + if (xCursor > fm -> xmin && xCursor <= fm -> xmax) + Graphics_line (g, xCursor, 0.0, xCursor, fmax); + if (yCursor > 0.0 && yCursor < fmax) + Graphics_line (g, fm -> xmin, yCursor, fm -> xmax, yCursor); + Graphics_setColour (g, Melder_BLACK); + Graphics_setLineType (g, Graphics_DRAWN); + } + } + Graphics_setFontSize (g, fontSize_old); + Graphics_setViewport (g, x1NDC, x2NDC, y1NDC, y2NDC); +} + +/* End of file FormantModelerList.cpp */ diff --git a/LPC/FormantModelerList.h b/LPC/FormantModelerList.h new file mode 100644 index 00000000..a1f6f3d4 --- /dev/null +++ b/LPC/FormantModelerList.h @@ -0,0 +1,56 @@ +#ifndef _FormantModelerList_h_ +#define _FormantModelerList_h_ +/*FormantModelerList.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "Collection.h" +#include "Function.h" +#include "FormantModeler.h" +#include "FormantPath.h" +#include "Graphics.h" +#include "melder.h" + +#include "FormantModelerList_def.h" + +autoFormantModelerList FormantPath_to_FormantModelerList (FormantPath me, double startTime, double endTime, conststring32 numberOfParametersPerTrack_string); + +/* + Find best model according to Weenink (2015), Improved formant frequency measurements of short segments. + in Proceedings of ICPhSc 2015. +*/ +integer FormantModelerList_getBestModelIndex (FormantModelerList me, integer fromTrack, integer toTrack); + +void FormantModelerList_markBest3 (FormantModelerList me); +void FormantModelerList_showBest3 (FormantModelerList me); +autoINTVEC FormantModelerList_getBest3 (FormantModelerList me); + +void FormantModelerList_getMatrixGridLayout (FormantModelerList me, integer *out_numberOfRows, integer *out_numberOfColums); + +void FormantModelerList_drawInMatrixGrid (FormantModelerList me, Graphics g, integer nrow, integer ncol, kGraphicsMatrixOrigin origin, double spaceBetweenFraction_x, double spaceBetweenFraction_y, integer fromFormant, integer toFormant, double fmax, double yGridLineEvery_Hz, double xCursor, double yCursor, integer numberOfParameters, bool drawErrorBars, double barwidth_s, bool drawEstimated, bool garnish); + +/* For special drawings, like in the FormantEditor */ + +autoFormantModelerListDrawingSpecification FormantModelerList_to_FormantModelerListDrawingSpecification (FormantModelerList me, integer special); + +integer FormantModelerListDrawingSpecification_getNumberOfShown (FormantModelerListDrawingSpecification me); + +void FormantModelerListDrawingSpecification_showAll (FormantModelerListDrawingSpecification me); + +void FormantModelerListDrawingSpecification_setModelerColours (FormantModelerListDrawingSpecification me, conststring32 oddFormantColour_string, conststring32 evenFormantColour_string, conststring32 selectedCandidateColour_string); + +#endif /* _FormantModelerList_h_ */ diff --git a/LPC/FormantModelerList_def.h b/LPC/FormantModelerList_def.h new file mode 100644 index 00000000..599be397 --- /dev/null +++ b/LPC/FormantModelerList_def.h @@ -0,0 +1,66 @@ +/*FormantModelerList_def.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#define ooSTRUCT FormantModelerListDrawingSpecification +oo_DEFINE_CLASS (FormantModelerListDrawingSpecification, Daata) + oo_INTEGER (numberOfModelers) + oo_INTEGER (numberOfModelersToDraw) + oo_INTVEC (drawingOrder, numberOfModelers) + oo_INTEGER (selectedCandidate) + oo_DOUBLE (boxLineWidth) // {3.0}; + oo_INTVEC (showOrder, numberOfModelers) + oo_STRING_VECTOR (midTopText, numberOfModelers) + + #if oo_DECLARING + MelderColour oddFormantColour; // {Melder_RED}; + MelderColour evenFormantColour; // {Melder_MAROON}; + MelderColour selectedCandidateColour; // {Melder_RED} + MelderColour midTopText_colour; // {Melder_BLUE}; + #endif + + #if oo_DECLARING + void v_info () override { } + #endif + +oo_END_CLASS (FormantModelerListDrawingSpecification) +#undef ooSTRUCT + +#define ooSTRUCT FormantModelerList +oo_DEFINE_CLASS (FormantModelerList, Function) + + oo_INTEGER (numberOfModelers) + oo_INTEGER (numberOfTracksPerModel) + oo_DOUBLE (varianceExponent) + oo_INTVEC (numberOfParametersPerTrack, numberOfTracksPerModel) + oo_COLLECTION_OF (OrderedOf, formantModelers, FormantModeler, 0) + + #if oo_DECLARING || oo_DESTROYING + + oo_OBJECT (FormantModelerListDrawingSpecification, 0, drawingSpecification) + + #endif + + #if oo_DECLARING + void v_info () + override; + #endif + +oo_END_CLASS (FormantModelerList) +#undef ooSTRUCT + +/* End of file FormantModelerList_def.h */ diff --git a/dwtools/FormantModeler_def.h b/LPC/FormantModeler_def.h similarity index 100% rename from dwtools/FormantModeler_def.h rename to LPC/FormantModeler_def.h diff --git a/dwtools/FormantModeler_enums.h b/LPC/FormantModeler_enums.h similarity index 100% rename from dwtools/FormantModeler_enums.h rename to LPC/FormantModeler_enums.h diff --git a/LPC/FormantPath.cpp b/LPC/FormantPath.cpp new file mode 100644 index 00000000..2238406c --- /dev/null +++ b/LPC/FormantPath.cpp @@ -0,0 +1,582 @@ +/* FormantPath.cpp + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "FormantPath.h" +#include "FormantModeler.h" +#include "Graphics_extensions.h" +#include "LPC_and_Formant.h" +#include "Matrix.h" +#include "Sound_to_Formant.h" +#include "Sound_and_LPC.h" +#include "Sound.h" +#include "Sound_and_LPC_robust.h" + +#include "oo_DESTROY.h" +#include "FormantPath_def.h" +#include "oo_COPY.h" +#include "FormantPath_def.h" +#include "oo_EQUAL.h" +#include "FormantPath_def.h" +#include "oo_CAN_WRITE_AS_ENCODING.h" +#include "FormantPath_def.h" +#include "oo_WRITE_TEXT.h" +#include "FormantPath_def.h" +#include "oo_WRITE_BINARY.h" +#include "FormantPath_def.h" +#include "oo_READ_TEXT.h" +#include "FormantPath_def.h" +#include "oo_READ_BINARY.h" +#include "FormantPath_def.h" +#include "oo_DESCRIPTION.h" +#include "FormantPath_def.h" + +void structFormantPath :: v_info () { + structDaata :: v_info (); + MelderInfo_writeLine (U"Number of Formant objects: ", formants . size); + for (integer ic = 1; ic <= ceilings.size; ic ++) + MelderInfo_writeLine (U"Ceiling ", ic, U": ", ceilings [ic], U" Hz"); +} + +double structFormantPath :: v_getValueAtSample (integer iframe, integer which, int units) { + const Formant formant = reinterpret_cast (our formants.at [our path [iframe]]); + return formant -> v_getValueAtSample (iframe, which, units); +} + +conststring32 structFormantPath :: v_getUnitText (integer /*level*/, int /*unit*/, uint32 /*flags*/) { + return U"Frequency (Hz)"; + +}; + +Thing_implement (FormantPath, Sampled, 0); + +autoFormantPath FormantPath_create (double xmin, double xmax, integer nx, double dx, double x1, integer numberOfCeilings) { + autoFormantPath me = Thing_new (FormantPath); + Sampled_init (me.get (), xmin, xmax, nx, dx, x1); + my ceilings = newVECzero (numberOfCeilings); + my path = newINTVECzero (nx); + return me; +} + +void FormantPath_pathFinder (FormantPath me, double qWeight, double frequencyChangeWeight, double stressWeight, double ceilingChangeWeight, double intensityModulationStepSize, double windowLength, constINTVEC const& parameters, double powerf) { + autoINTVEC path = FormantPath_getOptimumPath (me, qWeight, frequencyChangeWeight, stressWeight, ceilingChangeWeight, intensityModulationStepSize, windowLength,parameters, powerf, nullptr); + my path = path.move(); +} + +autoINTVEC FormantPath_getOptimumPath (FormantPath me, double qWeight, double frequencyChangeWeight, double stressWeight, double ceilingChangeWeight, double intensityModulationStepSize, double windowLength, constINTVEC const& parameters, double powerf, autoMatrix *out_delta) { + constexpr double qCutoff = 20.0; + constexpr double stressCutoff = 200.0; + constexpr double frequencyChangeCutoff = 100.0; + try { + autoMatrix stresses, qsums; + MelderExtremaWithInit intensities; + const double ceilingsRange = NUMmax (my ceilings.get()) - NUMmin (my ceilings.get()); + const integer midformant = (my formants.size + 1) / 2; + for (integer iframe = 1; iframe <= my nx; iframe ++) { + const Formant_Frame frame = & my formants.at [midformant] -> frames [iframe]; + intensities.update (frame -> intensity); + } + const bool hasIntensityDifference = ( intensities.max - intensities.min > 0.0 ); + const double dbMid = 0.5 * 10.0 * log10 (intensities.max * intensities.min); + const integer maxnFormants = my formants.at [1] -> maxnFormants; + const integer numberOfTracks = std::min (maxnFormants, parameters.size); + if (qWeight > 0.0) + qsums = FormantPath_to_Matrix_qSums (me, numberOfTracks); + if (stressWeight > 0.0) + stresses = FormantPath_to_Matrix_stress (me, windowLength, parameters, powerf); + + /* + Some options for assigning costs/benefits to states and state transitions: + We have states s[i], where i = 1.. S (= my formants.size) + Whithin each state i we can have j=1..F formant frequencies f[i][j] and bandwidths b[i][j]. + Benefits of a state could be expressed as: + 1. sum (j=1..F, 0.1*f[j]/b[j])/F, this has the advantage that states with large Q values (sharp peaks) have larger benefits + (2?). -|log(min(max(f1-f2, 100),300)|, keep sufficient distance between f1 and f2 + Costs between successive states: + 3. -sum(j=1..F, ( (2|f[i][j]-f[i+1][j]|/(f[i][j]+f[i+1][j])) + Global: + 4. -global measure like w ? + We try to find the path that maximizes the benefits + */ + autoINTMAT psi = newINTMATzero (my formants.size, my nx); + autoMatrix thee = Matrix_create (my xmin, my xmax, my nx, my dx, my x1, 1.0, my formants.size, my formants.size, 1.0, 1.0); + MAT deltas (& thy z [1] [1], thy ny, thy nx); + autoINTVEC path = newINTVECzero (my nx); + autoVEC intensity = newVECraw (my nx); + for (integer itime = 1; itime <= my nx; itime ++) { + for (integer iformant = 1; iformant <= my formants.size; iformant ++) { + const Formant_Frame frame = & my formants.at [iformant] -> frames [itime]; + double wIntensity = 1.0, delta = 0.0; + if (hasIntensityDifference) { + if (frame -> intensity > 0.0) { + const double dbi = 10.0 * log10 (frame -> intensity / 2e-5); + wIntensity = NUMsigmoid ((dbi - dbMid) / intensityModulationStepSize); + } else + wIntensity = 0.0; + } + if (qWeight > 0.0) + delta += qWeight * std::min (qsums -> z [iformant] [itime] / qCutoff, 1.0); + double stress = 1.0; + if (stressWeight > 0.0 && isdefined (stresses -> z [iformant] [itime])) + stress = std::min (stresses -> z [iformant] [itime] / stressCutoff, 1.0); + delta -= stressWeight * stress; + + deltas [iformant] [itime] += wIntensity * delta; + } + } + for (integer itime = 2; itime <= my nx; itime ++) { + for (integer iformant = 1; iformant <= my formants.size; iformant++) { + const Formant_Frame ffi = & my formants.at [iformant] -> frames [itime]; + double deltamax = -1e100; + integer maxPos = 0; + for (integer jformant = 1; jformant <= my formants.size; jformant++) { + const Formant_Frame ffj = & my formants.at [jformant] -> frames [itime - 1]; + double transitionCosts = 0.0; + if (frequencyChangeWeight > 0.0) { + const integer ntracks = std::min (numberOfTracks, ffi -> numberOfFormants); + double frequencyChangeCosts = 0.0; + for (integer itrack = 1; itrack <= std::min (ntracks, ffj -> numberOfFormants); itrack ++) { + const double dif = fabs (ffi -> formant [itrack] . frequency - ffj -> formant [itrack] . frequency); + const double sum = ffi -> formant [itrack] . frequency + ffj -> formant [itrack] . frequency; + const double bw = sqrt (ffi -> formant [itrack] . bandwidth * ffj -> formant [itrack] . bandwidth); + frequencyChangeCosts += bw * dif / sum; + } + frequencyChangeCosts = std::min (frequencyChangeCosts / frequencyChangeCutoff, 1.0); + transitionCosts += frequencyChangeWeight * frequencyChangeCosts; + } + if (ceilingChangeWeight > 0.0) { + const double ceilingChangeCosts = fabs (my ceilings [iformant] - my ceilings [jformant]) / ceilingsRange; + transitionCosts += ceilingChangeCosts * ceilingChangeWeight; + } + const double deltaj = deltas [jformant] [itime - 1] - transitionCosts; + if (deltaj > deltamax) { + deltamax = deltaj; + maxPos = jformant; + } + } + deltas [iformant] [itime] += deltamax; + psi [iformant] [itime] = maxPos; + } + } + path [my nx] = NUMmaxPos (deltas.column (my nx)); + /* + Backtrack + */ + for (integer itime = my nx; itime > 1; itime --) { + path [itime - 1] = psi [path [itime]] [itime]; + } + if (out_delta) + *out_delta = thee.move(); + return path; + } catch (MelderError) { + Melder_throw (me, U": cannot find path."); + } +} + +autoFormant FormantPath_extractFormant (FormantPath me) { + Formant formant = my formants. at [1]; + autoFormant thee = Formant_create (my xmin, my xmax, my nx, my dx, my x1, formant -> maxnFormants); + for (integer iframe = 1; iframe <= my path.size; iframe ++) { + Formant source = reinterpret_cast (my formants. at [my path [iframe]]); + Formant_Frame targetFrame = & thy frames [iframe]; + Formant_Frame sourceFrame = & source -> frames [iframe]; + sourceFrame -> copy (targetFrame); + } + return thee; +} + +autoFormantPath Sound_to_FormantPath_any (Sound me, kLPC_Analysis lpcType, double timeStep, double maximumNumberOfFormants, + double middleCeiling, double analysisWidth, double preemphasisFrequency, double ceilingStepSize, + integer numberOfStepsToACeiling, double marple_tol1, double marple_tol2, double huber_numberOfStdDev, double huber_tol, + integer huber_maximumNumberOfIterations, autoSound *out_sourcesMultiChannel) { + try { + Melder_require (timeStep > 0.0, + U"The timeStep needs to greater than zero seconds."); + Melder_require (ceilingStepSize > 0.0, + U"The ceiling step size should larger than 0.0."); + const double nyquistFrequency = 0.5 / my dx; + const integer numberOfCeilings = 2 * numberOfStepsToACeiling + 1; + const double maximumCeiling = middleCeiling * exp (ceilingStepSize * numberOfStepsToACeiling); + Melder_require (maximumCeiling <= nyquistFrequency, + U"The maximum ceiling should be smaller than ", nyquistFrequency, U" Hz. " + "Decrease the 'ceiling step size' or the 'number of steps' or both."); + volatile double windowDuration = 2.0 * analysisWidth; + if (windowDuration > my dx * my nx) + windowDuration = my dx * my nx; + /* + Get the data for the LPC from the resampled sound with 'middleCeiling' as maximum frequency + to make the sampling exactly equal as if performed with a standard LPC analysis. + */ + integer numberOfFrames; + double t1; + autoSound midCeiling = Sound_resample (me, 2.0 * middleCeiling, 50); + Sampled_shortTermAnalysis (midCeiling.get(), windowDuration, timeStep, & numberOfFrames, & t1); // Gaussian window + const integer predictionOrder = Melder_iround (2.0 * maximumNumberOfFormants); + autoFormantPath thee = FormantPath_create (my xmin, my xmax, numberOfFrames, timeStep, t1, numberOfCeilings); + autoSound multiChannelSound; + if (out_sourcesMultiChannel) + multiChannelSound = Sound_create (numberOfCeilings, midCeiling -> xmin, midCeiling -> xmax, midCeiling -> nx, midCeiling -> dx, midCeiling -> x1); + const double formantSafetyMargin = 50.0; + thy ceilings [numberOfStepsToACeiling + 1] = middleCeiling; + for (integer ic = 1; ic <= numberOfCeilings; ic ++) { + autoFormant formant; + if (ic <= numberOfStepsToACeiling) + thy ceilings [ic] = middleCeiling * exp (-ceilingStepSize * (numberOfStepsToACeiling - ic + 1)); + else if (ic > numberOfStepsToACeiling + 1) + thy ceilings [ic] = middleCeiling * exp ( ceilingStepSize * (ic - numberOfStepsToACeiling - 1)); + autoSound resampled; + if (ic != numberOfStepsToACeiling + 1) + resampled = Sound_resample (me, 2.0 * thy ceilings [ic], 50); + else + resampled = midCeiling.move(); + autoLPC lpc = LPC_create (my xmin, my xmax, numberOfFrames, timeStep, t1, predictionOrder, resampled -> dx); + if (lpcType != kLPC_Analysis::ROBUST) { + Sound_into_LPC (resampled.get(), lpc.get(), analysisWidth, preemphasisFrequency, lpcType, marple_tol1, marple_tol2); + } else { + Sound_into_LPC (resampled.get(), lpc.get(), analysisWidth, preemphasisFrequency, kLPC_Analysis::AUTOCORRELATION, marple_tol1, marple_tol2); + lpc = LPC_Sound_to_LPC_robust (lpc.get(), resampled.get(), analysisWidth, preemphasisFrequency, huber_numberOfStdDev, huber_maximumNumberOfIterations, huber_tol, true); + } + formant = LPC_to_Formant (lpc.get(), formantSafetyMargin); + thy formants . addItem_move (formant.move()); + if (out_sourcesMultiChannel) { + autoSound source = LPC_Sound_filterInverse (lpc.get(), resampled.get ()); + autoSound source_resampled = Sound_resample (source.get(), 2.0 * middleCeiling, 50); + const integer numberOfSamples = std::min (midCeiling -> nx, source_resampled -> nx); + multiChannelSound -> z.row (ic).part (1, numberOfSamples) <<= source_resampled -> z.row (1).part (1, numberOfSamples); + } + } + /* + Maintain invariants + */ + Melder_assert (thy formants . size == numberOfCeilings); + thy path = newINTVECraw (thy nx); + for (integer i = 1; i <= thy path.size; i++) + thy path [i] = numberOfStepsToACeiling + 1; + if (out_sourcesMultiChannel) + *out_sourcesMultiChannel = multiChannelSound.move(); + return thee; + } catch (MelderError) { + Melder_throw (me, U": FormantPath not created."); + } +} + +autoMatrix FormantPath_to_Matrix_qSums (FormantPath me, integer numberOfTracks) { + try { + autoMatrix thee = Matrix_create (my xmin, my xmax, my nx, my dx, my x1, 0.5, my formants.size + 0.5, my formants.size, 1.0, 1.0); + const integer maxnFormants = my formants.at [1] -> maxnFormants; + if (numberOfTracks == 0) + numberOfTracks = maxnFormants; + for (integer itime = 1; itime <= my nx; itime ++) { + for (integer iformant = 1; iformant <= my formants.size; iformant ++) { + const Formant_Frame frame = & my formants.at [iformant] -> frames [itime]; + double qsum = 0.0; + for (integer itrack = 1; itrack <= std::min (numberOfTracks, frame -> numberOfFormants); itrack ++) + qsum += frame -> formant [itrack] . frequency / frame-> formant [itrack]. bandwidth; + qsum /= frame -> numberOfFormants; + thy z [iformant] [itime] = qsum; + } + } + return thee; + } catch (MelderError) { + Melder_throw (me, U": cannot calculate qsum."); + } +} + +autoMatrix FormantPath_to_Matrix_transition (FormantPath me, bool maximumCosts) { + try { + autoMatrix thee = Matrix_create (my xmin, my xmax, my nx, my dx, my x1, 0.5, my formants.size + 0.5, my formants.size, 1.0, 1.0); + for (integer itime = 2; itime <= my nx; itime ++) { + for (integer iformant = 1; iformant <= my formants.size; iformant++) { + const Formant_Frame ffi = & my formants.at [iformant] -> frames [itime]; + MelderExtremaWithInit costs; + for (integer jformant = 1; jformant <= my formants.size; jformant++) { + const Formant_Frame ffj = & my formants.at [jformant] -> frames [itime - 1]; + long double transitionCosts = 0.0; + const integer ntracks = std::min (ffj -> numberOfFormants, ffi -> numberOfFormants); + for (integer itrack = 1; itrack <= ntracks; itrack ++) { + const double dif = fabs (ffi -> formant [itrack] . frequency - ffj -> formant [itrack] . frequency); + const double sum = ffi -> formant [itrack] . frequency + ffj -> formant [itrack] . frequency; + const double bw = sqrt (ffi -> formant [itrack] . bandwidth * ffj -> formant [itrack] . bandwidth); + transitionCosts += bw * dif / sum; + } + costs.update ((double) transitionCosts); + } + thy z [iformant] [itime] = ( maximumCosts ? costs.max : costs.min ); + } + } + return thee; + } catch (MelderError) { + Melder_throw (me, U": cannot calculate transition costs."); + } +} + +autoMatrix FormantPath_to_Matrix_stress (FormantPath me, double windowLength, constINTVEC const& parameters, double powerf) { + try { + const integer numberOfFormants = my formants.size; + Melder_require (parameters.size > 0 && parameters.size <= numberOfFormants, + U"The number of parameters should be between 1 and ", numberOfFormants, U"."); + integer fromFormant = 1; + const integer maximum = NUMmax (parameters); + const integer numberOfDataPoints = (windowLength + 0.5 * my dx) / my dx; + Melder_require (numberOfDataPoints >= maximum, + U"The window length is too short for the number of coefficients you use in the stress determination (", + maximum, U"). Either increase your window length or decrease the number of coefficents per track."); + while (fromFormant <= parameters.size && parameters [fromFormant] <= 0) + fromFormant ++; + integer toFormant = std::min (numberOfFormants, parameters.size); + while (toFormant > 0 && parameters [toFormant] <= 0) + toFormant --; + Melder_require (fromFormant <= toFormant, + U"Not all the parameter values should equal zero."); + autoMatrix thee = Matrix_create (my xmin, my xmax, my nx, my dx, my x1, 0.5, numberOfFormants + 0.5, numberOfFormants, 1.0, 1.0); + for (integer iformant = 1; iformant <= numberOfFormants; iformant ++) { + const Formant formanti = (Formant) my formants . at [iformant]; + for (integer iframe = 1; iframe <= my nx; iframe ++) { + const double time = my x1 + (iframe - 1) * my dx; + const double startTime = time - 0.5 * windowLength; + const double endTime = time + 0.5 * windowLength; + autoFormantModeler fm = Formant_to_FormantModeler (formanti, startTime, endTime, parameters); + thy z [iformant] [iframe] = FormantModeler_getStress (fm.get(), fromFormant, toFormant, 0, powerf); + } + } + return thee; + } catch (MelderError) { + Melder_throw (me, U": cannot create stress Matrix"); + } +} + +autoVEC FormantPath_getSmootness (FormantPath me, double tmin, double tmax, integer fromFormant, integer toFormant, constINTVEC const& parameters, double powerf) { + autoVEC stress = newVECraw (my formants.size); + for (integer iformant = 1; iformant <= my formants.size; iformant ++) { + const Formant formanti = (Formant) my formants . at [iformant]; + autoFormantModeler fm = Formant_to_FormantModeler (formanti, tmin, tmax, parameters); + stress [iformant] = FormantModeler_getStress (fm.get(), fromFormant, toFormant, 0, powerf); + } + return stress; +} + +static void Formant_speckles_inside (Formant me, Graphics g, double tmin, double tmax, double fmin, double fmax, integer fromFormant, integer toFormant, double suppress_dB, bool drawBandWidths, MelderColour odd, MelderColour even) +{ + double maximumIntensity = 0.0, minimumIntensity; + Function_unidirectionalAutowindow (me, & tmin, & tmax); + integer itmin, itmax; + if (! Sampled_getWindowSamples (me, tmin, tmax, & itmin, & itmax)) + return; + if (fromFormant == 0 && toFormant == 0) { + fromFormant = 1; + toFormant = my maxnFormants; + } + Graphics_setWindow (g, tmin, tmax, fmin, fmax); + + for (integer iframe = itmin; iframe <= itmax; iframe ++) { + const Formant_Frame frame = & my frames [iframe]; + if (frame -> intensity > maximumIntensity) + maximumIntensity = frame -> intensity; + } + if (maximumIntensity == 0.0 || suppress_dB <= 0.0) + minimumIntensity = 0.0; // ignore + else + minimumIntensity = maximumIntensity / pow (10.0, suppress_dB / 10.0); + + for (integer iframe = itmin; iframe <= itmax; iframe ++) { + const Formant_Frame frame = & my frames [iframe]; + const double x = Sampled_indexToX (me, iframe); + if (frame -> intensity < minimumIntensity) + continue; + /* + Higher formants in general have larger bandwidths. Draw them first to show lower formants clearer. + */ + for (integer iformant = std::min (frame -> numberOfFormants, toFormant); iformant >= fromFormant; iformant --) { + const double frequency = frame -> formant [iformant]. frequency; + Graphics_setColour (g, iformant % 2 == 1 ? odd : even ); + if (frequency >= fmin && frequency <= fmax) { + Graphics_speckle (g, x, frequency); + if (drawBandWidths) { + const double bandwidth = frame -> formant [iformant]. bandwidth; + const double upper = std::min (frequency + 0.5 * bandwidth, fmax); + const double lower = std::max (frequency - 0.5 * bandwidth, fmin); + Graphics_line (g, x, upper, x, lower); + } + } + } + } +} + +void FormantPath_drawAsGrid_inside (FormantPath me, Graphics g, double tmin, double tmax, double fmax, + integer fromFormant, integer toFormant, bool showBandwidths, MelderColour odd, MelderColour even, + integer nrow, integer ncol, double spaceBetweenFraction_x, double spaceBetweenFraction_y, double yGridLineEvery_Hz, + double xCursor, double yCursor, integer iselected, MelderColour selected, constINTVEC const & parameters, + bool markWithinPath, bool showStress, double powerf, bool showEstimatedModels, bool garnish) +{ + MelderColour singleSelectionColour = MelderColour (0.984,0.984, 0.7); + MelderColour multipleSelectionsColour = MelderColour (0.984,0.984, 0.9); + constexpr double fmin = 0.0; + if (nrow <= 0 || ncol <= 0) + NUMgetGridDimensions (my formants.size, & nrow, & ncol); + double x1NDC, x2NDC, y1NDC, y2NDC; + Graphics_inqViewport (g, & x1NDC, & x2NDC, & y1NDC, & y2NDC); + const double fontSize_old = Graphics_inqFontSize (g), newFontSize = 8.0; + const double vp_width = x2NDC - x1NDC, vp_height = y2NDC - y1NDC; + const double vpi_width = vp_width / (ncol + (ncol - 1) * spaceBetweenFraction_x); + const double vpi_height = vp_height / (nrow + (nrow - 1) * spaceBetweenFraction_y); + integer numberOfCeilingInInterval = 1; + integer itmin, itmax; + autoBOOLVEC ceilingInInterval = newBOOLVECzero (my formants.size); + if (markWithinPath && Sampled_getWindowSamples (me, tmin, tmax, & itmin, & itmax)) { + /* + If the path in the interval (tmin, tmax) is constant, then we have only one of + the candidates chosen in the whole interval. + */ + numberOfCeilingInInterval = 0; + for (integer iformant = 1; iformant <= my formants.size; iformant ++) + for (integer i = itmin; i <= itmax; i ++) + if (my path [i] == iformant) { + ceilingInInterval [iformant] = true; + numberOfCeilingInInterval ++; + break; + } + } + + for (integer iformant = 1; iformant <= my formants.size; iformant ++) { + const integer irow = 1 + (iformant - 1) / ncol; // left-to-right + top-to-bottom + const integer icol = 1 + (iformant - 1) % ncol; + const double vpi_x1 = x1NDC + (icol - 1) * vpi_width * (1.0 + spaceBetweenFraction_x); + const double vpi_x2 = vpi_x1 + vpi_width; + const double vpi_y2 = y2NDC - (irow - 1) * vpi_height * (1.0 + spaceBetweenFraction_y); + const double vpi_y1 = vpi_y2 - vpi_height; + const Formant formant = my formants.at [iformant]; + autoFormantModeler fm = Formant_to_FormantModeler (formant, tmin, tmax, parameters); + Graphics_setViewport (g, vpi_x1, vpi_x2, vpi_y1, vpi_y2); + Graphics_setWindow (g, tmin, tmax, fmin, fmax); + if (garnish && markWithinPath) { + if (ceilingInInterval [iformant]) { + MelderColour colour = Graphics_inqColour (g); + MelderColour fillColour = (numberOfCeilingInInterval == 1 ? singleSelectionColour : multipleSelectionsColour); + Graphics_setColour (g, fillColour); + Graphics_fillRectangle (g, tmin, tmax, 0.0, fmax); + Graphics_setColour (g, colour); + } + } + Formant_speckles_inside (formant, g, tmin, tmax, fmin, fmax, fromFormant, toFormant, 100.0, showBandwidths, odd, even); + if (showEstimatedModels) + FormantModeler_drawModel_inside (fm.get(), g, tmin, tmax, fmax, fromFormant, toFormant, odd, even, 100_integer); + Graphics_setColour (g, Melder_BLACK); + if (garnish) + Graphics_rectangle (g, tmin, tmax, fmin, fmax); + + Graphics_setLineType (g, Graphics_DRAWN); + Graphics_setLineWidth (g, 1.0); + /* + Mark ceiling & stress + */ + autoMelderString info; + const double tLeftPos = tmin - 0.01 * (tmax - tmin), tRightPos = tmax + 0.01 * (tmax - tmin); + if (garnish) { + if (showStress) { + const double stress = FormantModeler_getStress (fm.get(), fromFormant, toFormant, 0, powerf); + MelderString_append (& info, U"Fit=", Melder_fixed (stress, 2)); + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::LEFT, Graphics_BOTTOM); + Graphics_text (g, tLeftPos, fmax, info.string); + } + MelderString_empty (& info); + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::RIGHT, Graphics_BOTTOM); + MelderString_append (& info, U"Ceiling=", Melder_fixed (my ceilings [iformant], 0), U" Hz"); + Graphics_text (g, tRightPos, fmax, info.string); + } + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::CENTRE, Graphics_HALF); + if (garnish) { + auto getXtick = [] (Graphics gg, double fontSize) { + const double margin = 2.8 * fontSize * gg -> resolution / 72.0; + const double wDC = (gg -> d_x2DC - gg -> d_x1DC) / (gg -> d_x2wNDC - gg -> d_x1wNDC) * (gg -> d_x2NDC - gg -> d_x1NDC); + double dx = 1.5 * margin / wDC; + double xTick = 0.06 * dx; + if (dx > 0.4) dx = 0.4; + return xTick /= 1.0 - 2.0 * dx; + }; + auto getYtick = [] (Graphics gg, double fontSize) { + const double margin = 2.8 * fontSize * gg -> resolution / 72.0; + const double hDC = integer_abs (gg->d_y2DC - gg->d_y1DC) / (gg->d_y2wNDC - gg->d_y1wNDC) * (gg->d_y2NDC - gg-> d_y1NDC); + double dy = margin / hDC; + double yTick = 0.09 * dy; + if (dy > 0.4) dy = 0.4; + yTick /= 1.0 - 2.0 * dy; + return yTick; + }; + const double xTick = (double) getXtick (g, newFontSize) * (tmax - tmin); + const double yTick = (double) getYtick (g, newFontSize) * (fmax - fmin); + if (irow == nrow) { + MelderString_empty (& info); + MelderString_append (& info, Melder_fixed (tmin, 3), U" s"); + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::LEFT, Graphics_TOP); + Graphics_line (g, tmin, fmin, tmin, fmin - yTick); + Graphics_text (g, tmin , fmin - yTick, info.string); + MelderString_empty (& info); + MelderString_append (& info, Melder_fixed (tmax, 3), U" s"); + Graphics_line (g, tmax, fmin, tmax, fmin - yTick); + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::RIGHT, Graphics_TOP); + Graphics_text (g, tmax, fmin - yTick, info.string); + } + if (icol == 1) { + MelderString_empty (& info); + MelderString_append (& info, Melder_iround (fmin), U" Hz"); + Graphics_line (g, tmin - xTick, fmin, tmin, fmin); + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::RIGHT, Graphics_HALF); + Graphics_text (g, tmin - xTick, fmin, info.string); + MelderString_empty (& info); + MelderString_append (& info, Melder_iround (fmax), U" Hz"); + Graphics_text (g, tmin - xTick, fmax, info.string); + + } + double yGridLine_Hz = yGridLineEvery_Hz; + Graphics_setLineType (g, Graphics_DOTTED); + while (yGridLine_Hz < 0.95 * fmax) { + Graphics_line (g, tmin, yGridLine_Hz, tmax, yGridLine_Hz); + yGridLine_Hz += yGridLineEvery_Hz; + } + /* + Cursors + */ + Graphics_setColour (g, Melder_RED); + Graphics_setLineType (g, Graphics_DASHED); + if (xCursor > tmin && xCursor <= tmax) + Graphics_line (g, xCursor, 0.0, xCursor, fmax); + if (yCursor > 0.0 && yCursor < fmax) + Graphics_line (g, tmin, yCursor, tmax, yCursor); + Graphics_setColour (g, Melder_BLACK); + Graphics_setLineType (g, Graphics_DRAWN); + } + } + Graphics_setFontSize (g, fontSize_old); + Graphics_setViewport (g, x1NDC, x2NDC, y1NDC, y2NDC); + +} + +void FormantPath_drawAsGrid (FormantPath me, Graphics g, double tmin, double tmax, double fmax, + integer fromFormant, integer toFormant, bool showBandwidths, MelderColour odd, MelderColour even, + integer nrow, integer ncol, double spaceBetweenFraction_x, double spaceBetweenFraction_y, double yGridLineEvery_Hz, + double xCursor, double yCursor, integer iselected, MelderColour selected, constINTVEC const & parameters, + bool markWithinPath, bool showStress, double powerf, bool showEstimatedModels, bool garnish) +{ + Function_bidirectionalAutowindow (me, & tmin, & tmax); + Graphics_setInner (g); + FormantPath_drawAsGrid_inside (me, g, tmin, tmax, fmax, fromFormant, toFormant, showBandwidths, odd, even, nrow, ncol, spaceBetweenFraction_x, spaceBetweenFraction_y, yGridLineEvery_Hz, xCursor, yCursor, iselected, selected, parameters, markWithinPath, showStress, powerf, showEstimatedModels, garnish); + Graphics_unsetInner (g); +} + + + +/* End of file FormantPath.cpp */ diff --git a/LPC/FormantPath.h b/LPC/FormantPath.h new file mode 100644 index 00000000..78debe3c --- /dev/null +++ b/LPC/FormantPath.h @@ -0,0 +1,72 @@ +#ifndef _FormantPath_h_ +#define _FormantPath_h_ +/* FormantPath.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "Collection.h" +#include "Formant.h" +#include "Function.h" +#include "LPC.h" +#include "Sound.h" + +#include "FormantPath_def.h" + +/* + A FormantPath has an ordered collection of Formants and an IntervalTier. + All Formants and the IntervalTier have the same domain. + All Formant have the same sampling. +*/ + +autoFormantPath FormantPath_create (double xmin, double xmax, integer nx, double dx, double x1, integer numberOfCeilings); + +void FormantPath_replaceFrames (FormantPath me, integer beginFrame, integer endFrame, integer formantIndex); + +autoFormant FormantPath_extractFormant (FormantPath me); + +autoMatrix FormantPath_to_Matrix_qSums (FormantPath me, integer numberOfTracks); +autoMatrix FormantPath_to_Matrix_transition (FormantPath me, bool maximumCosts); +autoMatrix FormantPath_to_Matrix_stress (FormantPath me, double windowLength, constINTVEC const& parameters, double powerf); + +autoVEC FormantPath_getSmootness (FormantPath me, double tmin, double tmax, integer fromFormant, integer toFormant, constINTVEC const& parameters, double powerf); + +autoINTVEC FormantPath_getOptimumPath (FormantPath me, double qWeight, double frequencyChangeWeight, double stressWeight, double ceilingChangeWeight, double intensityModulationStepSize, double windowLength, constINTVEC const& parameters, double powerf, autoMatrix *out_delta); + +void FormantPath_pathFinder (FormantPath me, double qWeight, double frequencyChangeWeight, double stressWeight, double ceilingChangeWeight, double intensityModulationStepSize, double windowLength, constINTVEC const& parameters, double powerf); + +autoFormantPath Sound_to_FormantPath_any (Sound me, kLPC_Analysis lpcType, double timeStep, double maximumNumberOfFormants, + double formantCeiling, double analysisWidth, double preemphasisFrequency, double ceilingExtensionFraction, + integer numberOfStepsToACeiling, double marple_tol1, double marple_tol2, double huber_numberOfStdDev, + double huber_tol, integer huber_maximumNumberOfIterations, autoSound *out_sourcesMultiChannel); + +static inline autoFormantPath Sound_to_FormantPath_burg (Sound me, double timeStep, double maximumNumberOfFormants, double formantCeiling, double analysisWidth, double preemphasisFrequency, double ceilingExtensionFraction, integer numberOfStepsToACeiling) { + return Sound_to_FormantPath_any (me, kLPC_Analysis::BURG, timeStep, maximumNumberOfFormants, formantCeiling, analysisWidth, preemphasisFrequency, ceilingExtensionFraction, numberOfStepsToACeiling, 1e-6, 1e-6, 1.5, 1e-6, 5, nullptr); +} + +void FormantPath_drawAsGrid (FormantPath me, Graphics g, double tmin, double tmax, double fmax, + integer fromFormant, integer toFormant, bool showBandwidths, MelderColour odd, MelderColour even, + integer nrow, integer ncol, double spaceBetweenFraction_x, double spaceBetweenFraction_y, double yGridLineEvery_Hz, + double xCursor, double yCursor, integer iselected, MelderColour selected, constINTVEC const & parameters, + bool markWithinPath, bool showStress, double powerf, bool showEstimatedModels, bool garnish); + +void FormantPath_drawAsGrid_inside (FormantPath me, Graphics g, double tmin, double tmax, double fmax, + integer fromFormant, integer toFormant, bool showBandwidths, MelderColour odd, MelderColour even, + integer nrow, integer ncol, double spaceBetweenFraction_x, double spaceBetweenFraction_y, double yGridLineEvery_Hz, + double xCursor, double yCursor, integer iselected, MelderColour selected, constINTVEC const & parameters, + bool markWithinPath, bool showStress, double powerf, bool showEstimatedModels, bool garnish); + +#endif /* _FormantPath_h_ */ diff --git a/LPC/FormantPathEditor.cpp b/LPC/FormantPathEditor.cpp new file mode 100644 index 00000000..3efb3deb --- /dev/null +++ b/LPC/FormantPathEditor.cpp @@ -0,0 +1,941 @@ +/* FormantPathEditor.cpp + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +/* + TODO: 28/5/20 + 1. claim somewhat more space for the selection viewer + 2. the scroll bar should be shorter, only go to the end the sound view. + 3. navigation aid buttons? next and previous buttons at the side of the navigation tier? + 4. Adapt Select menu and File menu, the navigation aid should have accelerators. + 5. The formant menu can use some logging + 6. .. +*/ +#include "FormantPathEditor.h" +#include "EditorM.h" +#include "praat.h" +#include "melder_kar.h" +#include "Sampled.h" +#include "SoundEditor.h" +#include "Sound_and_MixingMatrix.h" +#include "Sound_and_Spectrogram.h" +#include "TextGrid_Sound.h" +#include "TextGrid_extensions.h" + +Thing_implement (FormantPathEditor, TimeSoundAnalysisEditor, 0); + +#include "prefs_define.h" +#include "FormantPathEditor_prefs.h" +#include "prefs_install.h" +#include "FormantPathEditor_prefs.h" +#include "prefs_copyToInstance.h" +#include "FormantPathEditor_prefs.h" + +void structFormantPathEditor :: v_info () { + FormantPathEditor_Parent :: v_info (); +} + +void structFormantPathEditor :: v_updateMenuItems_navigation () { + /*FormantPath formantPath = (FormantPath) our data; + IntervalTierNavigator navigator = formantPath -> intervalTierNavigator.get(); + bool navigationPossible = ( navigator && IntervalTierNavigator_isNavigationPossible (navigator) && + our pathGridView && TextGridView_hasTierInView (our pathGridView.get(), formantPath -> navigationTierNumber) ); + bool nextSensitive = false; + bool previousSensitive = false; + if (navigationPossible) { + if (IntervalTierNavigator_getPreviousMatchingIntervalNumberFromTime (navigator, our startSelection) > 0) + previousSensitive = true; + if (IntervalTierNavigator_getNextMatchingIntervalNumberFromTime (navigator, our endSelection) > 0) + nextSensitive = true; + } + GuiThing_setSensitive (our navigateSettingsButton, navigationPossible); + GuiThing_setSensitive (our navigateNextButton, nextSensitive); + GuiThing_setSensitive (our navigatePreviousButton, previousSensitive);*/ +} +void operator<<= (BOOLVECVU const& target, bool value) { + for (integer i = 1; i <= target.size; i ++) + target [i] = value; +} + +void operator<<= (INTVECVU const& target, integer value) { + for (integer i = 1; i <= target.size; i ++) + target [i] = value; +} + +void FormantPathEditor_deselect (FormantPathEditor me) { +} + +/********** UTILITIES **********/ + +static double _FormantPathEditor_computeSoundY (FormantPathEditor me) { + /* + We want half of the screen for the spectrogram. 3/8 for the sound and 1/8 for the textgrid + */ + return (my d_longSound.data || my d_sound.data) ? 0.7 : 1.0; +} + +static void FormantPathEditor_getDrawingData (FormantPathEditor me, double *startTime, double *endTime, double *xCursor, double *yCursor) { + *startTime = my startWindow; + *endTime = my endWindow; + if (my startSelection == my endSelection) { + *startTime = my startWindow; + *endTime = my endWindow; + *xCursor = my startSelection; + } else { + *startTime = my startSelection; + *endTime = my endSelection; + *xCursor = my tmin - 1.0; // don't show + } + *yCursor = ( my d_spectrogram_cursor > my p_spectrogram_viewFrom && + my d_spectrogram_cursor < my p_spectrogram_viewTo ? my d_spectrogram_cursor : -1000.0 ); +} + +static void checkTierSelection (FormantPathEditor me, conststring32 verbPhrase) { + if (my selectedTier < 1 || my selectedTier > my pathGridView -> tiers -> size) + Melder_throw (U"To ", verbPhrase, U", first select a tier by clicking anywhere inside it."); +} + +static void scrollToView (FormantPathEditor me, double t) { + if (t <= my startWindow) { + FunctionEditor_shift (me, t - my startWindow - 0.618 * (my endWindow - my startWindow), true); + } else if (t >= my endWindow) { + FunctionEditor_shift (me, t - my endWindow + 0.618 * (my endWindow - my startWindow), true); + } else { + FunctionEditor_marksChanged (me, true); + } +} + +/********** METHODS **********/ + +/* + * The main invariant of the FormantPathEditor is that the selected interval + * always has the cursor in it, and that the cursor always selects an interval + * if the selected tier is an interval tier. + */ + +/***** FILE MENU *****/ + +static void menu_cb_ExtractSelectedTextGrid_preserveTimes (FormantPathEditor me, EDITOR_ARGS_DIRECT) { + if (my endSelection <= my startSelection) + Melder_throw (U"No selection."); + autoTextGrid grid = TextGridView_to_TextGrid (my pathGridView.get()); + autoTextGrid extract = TextGrid_extractPart (grid.get(), my startSelection, my endSelection, true); + Editor_broadcastPublication (me, extract.move()); +} + +static void menu_cb_ExtractSelectedTextGrid_timeFromZero (FormantPathEditor me, EDITOR_ARGS_DIRECT) { + if (my endSelection <= my startSelection) + Melder_throw (U"No selection."); + autoTextGrid grid = TextGridView_to_TextGrid (my pathGridView.get()); + autoTextGrid extract = TextGrid_extractPart (grid.get(), my startSelection, my endSelection, false); + Editor_broadcastPublication (me, extract.move()); +} + +void structFormantPathEditor :: v_createMenuItems_file_extract (EditorMenu menu) { + FormantPathEditor_Parent :: v_createMenuItems_file_extract (menu); + extractSelectedTextGridPreserveTimesButton = + EditorMenu_addCommand (menu, U"Extract selected TextGrid (preserve times)", 0, menu_cb_ExtractSelectedTextGrid_preserveTimes); + extractSelectedTextGridTimeFromZeroButton = + EditorMenu_addCommand (menu, U"Extract selected TextGrid (time from 0)", 0, menu_cb_ExtractSelectedTextGrid_timeFromZero); +} + +static void menu_cb_WriteToTextFile (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM_SAVE (U"Save as TextGrid text file", nullptr) + Melder_sprint (defaultName,300, my pathGridView -> name.get(), U".TextGrid"); + EDITOR_DO_SAVE + autoTextGrid grid = TextGridView_to_TextGrid (my pathGridView.get()); + Data_writeToTextFile (grid.get(), file); + EDITOR_END +} + +void structFormantPathEditor :: v_createMenuItems_file_write (EditorMenu menu) { + FormantPathEditor_Parent :: v_createMenuItems_file_write (menu); + EditorMenu_addCommand (menu, U"Save TextGrid as text file...", 'S', menu_cb_WriteToTextFile); +} + +static void menu_cb_DrawVisibleTextGrid (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Draw visible TextGrid", nullptr) + my v_form_pictureWindow (cmd); + my v_form_pictureMargins (cmd); + my v_form_pictureSelection (cmd); + BOOLEAN (garnish, U"Garnish", my default_picture_garnish ()) + EDITOR_OK + my v_ok_pictureWindow (cmd); + my v_ok_pictureMargins (cmd); + my v_ok_pictureSelection (cmd); + SET_BOOLEAN (garnish, my pref_picture_garnish ()) + EDITOR_DO + my v_do_pictureWindow (cmd); + my v_do_pictureMargins (cmd); + my v_do_pictureSelection (cmd); + my pref_picture_garnish () = garnish; + Editor_openPraatPicture (me); + TextGrid_Sound_draw (my pathGridView.get(), nullptr, my pictureGraphics, my startWindow, my endWindow, true, my p_useTextStyles, + my pref_picture_garnish ()); + FunctionEditor_garnish (me); + Editor_closePraatPicture (me); + EDITOR_END +} + +static void menu_cb_DrawVisibleSoundAndTextGrid (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Draw visible sound and TextGrid", nullptr) + my v_form_pictureWindow (cmd); + my v_form_pictureMargins (cmd); + my v_form_pictureSelection (cmd); + BOOLEAN (garnish, U"Garnish", my default_picture_garnish ()) + EDITOR_OK + my v_ok_pictureWindow (cmd); + my v_ok_pictureMargins (cmd); + my v_ok_pictureSelection (cmd); + SET_BOOLEAN (garnish, my pref_picture_garnish ()) + EDITOR_DO + my v_do_pictureWindow (cmd); + my v_do_pictureMargins (cmd); + my v_do_pictureSelection (cmd); + my pref_picture_garnish () = garnish; + Editor_openPraatPicture (me); + {// scope + autoSound sound = my d_longSound.data ? + LongSound_extractPart (my d_longSound.data, my startWindow, my endWindow, true) : + Sound_extractPart (my d_sound.data, my startWindow, my endWindow, + kSound_windowShape::RECTANGULAR, 1.0, true); + TextGrid_Sound_draw (my pathGridView.get(), sound.get(), my pictureGraphics, + my startWindow, my endWindow, true, my p_useTextStyles, my pref_picture_garnish ()); + } + FunctionEditor_garnish (me); + Editor_closePraatPicture (me); + EDITOR_END +} + +void structFormantPathEditor :: v_createMenuItems_file_draw (EditorMenu menu) { + FormantPathEditor_Parent :: v_createMenuItems_file_draw (menu); + EditorMenu_addCommand (menu, U"Draw visible TextGrid...", 0, menu_cb_DrawVisibleTextGrid); + if (d_sound.data || d_longSound.data) + EditorMenu_addCommand (menu, U"Draw visible sound and TextGrid...", 0, menu_cb_DrawVisibleSoundAndTextGrid); +} + +/***** QUERY MENU *****/ +#if 0 +static void menu_cb_GetStartingPointOfInterval (FormantPathEditor me, EDITOR_ARGS_DIRECT) { + const TextGrid grid = my pathGridView.get(); + checkTierSelection (me, U"query the starting point of an interval"); + const Function anyTier = grid -> tiers->at [my selectedTier]; + if (anyTier -> classInfo == classIntervalTier) { + const IntervalTier tier = (IntervalTier) anyTier; + const integer iinterval = IntervalTier_timeToIndex (tier, my startSelection); + const double time = ( iinterval < 1 || iinterval > tier -> intervals.size ? undefined : + tier -> intervals.at [iinterval] -> xmin ); + Melder_informationReal (time, U"seconds"); + } else { + Melder_throw (U"The selected tier is not an interval tier."); + } +} + +static void menu_cb_GetEndPointOfInterval (FormantPathEditor me, EDITOR_ARGS_DIRECT) { + const TextGrid grid = my pathGridView.get(); + checkTierSelection (me, U"query the end point of an interval"); + const Function anyTier = grid -> tiers->at [my selectedTier]; + if (anyTier -> classInfo == classIntervalTier) { + const IntervalTier tier = (IntervalTier) anyTier; + const integer iinterval = IntervalTier_timeToIndex (tier, my startSelection); + const double time = ( iinterval < 1 || iinterval > tier -> intervals.size ? undefined : + tier -> intervals.at [iinterval] -> xmax ); + Melder_informationReal (time, U"seconds"); + } else { + Melder_throw (U"The selected tier is not an interval tier."); + } +} + +static void menu_cb_GetLabelOfInterval (FormantPathEditor me, EDITOR_ARGS_DIRECT) { + const TextGrid grid = my pathGridView.get(); + checkTierSelection (me, U"query the label of an interval"); + const Function anyTier = grid -> tiers->at [my selectedTier]; + if (anyTier -> classInfo == classIntervalTier) { + const IntervalTier tier = (IntervalTier) anyTier; + const integer iinterval = IntervalTier_timeToIndex (tier, my startSelection); + const conststring32 label = ( iinterval < 1 || iinterval > tier -> intervals.size ? U"" : + tier -> intervals.at [iinterval] -> text.get() ); + Melder_information (label); + } else { + Melder_throw (U"The selected tier is not an interval tier."); + } +} +#endif +/***** PITCH MENU *****/ + +static void menu_cb_DrawTextGridAndPitch (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Draw TextGrid and Pitch separately", nullptr) + my v_form_pictureWindow (cmd); + LABEL (U"TextGrid:") + BOOLEAN (showBoundariesAndPoints, U"Show boundaries and points", my default_picture_showBoundaries ()); + LABEL (U"Pitch:") + BOOLEAN (speckle, U"Speckle", my default_picture_pitch_speckle ()); + my v_form_pictureMargins (cmd); + my v_form_pictureSelection (cmd); + BOOLEAN (garnish, U"Garnish", my default_picture_garnish ()); + EDITOR_OK + my v_ok_pictureWindow (cmd); + SET_BOOLEAN (showBoundariesAndPoints, my pref_picture_showBoundaries ()) + SET_BOOLEAN (speckle, my pref_picture_pitch_speckle ()) + my v_ok_pictureMargins (cmd); + my v_ok_pictureSelection (cmd); + SET_BOOLEAN (garnish, my pref_picture_garnish ()) + EDITOR_DO + my v_do_pictureWindow (cmd); + my pref_picture_showBoundaries () = showBoundariesAndPoints; + my pref_picture_pitch_speckle () = speckle; + my v_do_pictureMargins (cmd); + my v_do_pictureSelection (cmd); + my pref_picture_garnish () = garnish; + if (! my p_pitch_show) + Melder_throw (U"No pitch contour is visible.\nFirst choose \"Show pitch\" from the Pitch menu."); + if (! my d_pitch) { + TimeSoundAnalysisEditor_computePitch (me); + Melder_require (my d_pitch, + U"Cannot compute pitch."); + } + Editor_openPraatPicture (me); + double pitchFloor_hidden = Function_convertStandardToSpecialUnit (my d_pitch.get(), my p_pitch_floor, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + double pitchCeiling_hidden = Function_convertStandardToSpecialUnit (my d_pitch.get(), my p_pitch_ceiling, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + double pitchFloor_overt = Function_convertToNonlogarithmic (my d_pitch.get(), pitchFloor_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + double pitchCeiling_overt = Function_convertToNonlogarithmic (my d_pitch.get(), pitchCeiling_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + double pitchViewFrom_overt = ( my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewFrom : pitchFloor_overt ); + double pitchViewTo_overt = ( my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewTo : pitchCeiling_overt ); + TextGrid_Pitch_drawSeparately (my pathGridView.get(), my d_pitch.get(), my pictureGraphics, my startWindow, my endWindow, + pitchViewFrom_overt, pitchViewTo_overt, showBoundariesAndPoints, my p_useTextStyles, garnish, + speckle, my p_pitch_unit + ); + FunctionEditor_garnish (me); + Editor_closePraatPicture (me); + EDITOR_END +} + +/***** SEARCH MENU *****/ + +static void findInTier (FormantPathEditor me) { + const TextGrid grid = my pathGridView.get(); + checkTierSelection (me, U"find a text"); + Function anyTier = grid -> tiers->at [my selectedTier]; + if (anyTier -> classInfo == classIntervalTier) { + const IntervalTier tier = (IntervalTier) anyTier; + integer iinterval = IntervalTier_timeToIndex (tier, my startSelection) + 1; + while (iinterval <= tier -> intervals.size) { + TextInterval interval = tier -> intervals.at [iinterval]; + conststring32 text = interval -> text.get(); + if (text) { + const char32 *position = str32str (text, my findString.get()); + if (position) { + my startSelection = interval -> xmin; + my endSelection = interval -> xmax; + scrollToView (me, my startSelection); + GuiText_setSelection (my text, position - text, position - text + str32len (my findString.get())); + return; + } + } + iinterval ++; + } + if (iinterval > tier -> intervals.size) + Melder_beep (); + } else { + TextTier tier = (TextTier) anyTier; + integer ipoint = AnyTier_timeToLowIndex (tier->asAnyTier(), my startSelection) + 1; + while (ipoint <= tier -> points.size) { + const TextPoint point = tier->points.at [ipoint]; + conststring32 text = point -> mark.get(); + if (text) { + const char32 * const position = str32str (text, my findString.get()); + if (position) { + my startSelection = my endSelection = point -> number; + scrollToView (me, point -> number); + GuiText_setSelection (my text, position - text, position - text + str32len (my findString.get())); + return; + } + } + ipoint ++; + } + if (ipoint > tier -> points.size) + Melder_beep (); + } +} + +static void do_find (FormantPathEditor me) { + if (my findString) { + integer left, right; + autostring32 label = GuiText_getStringAndSelectionPosition (my text, & left, & right); + const char32 * const position = str32str (& label [right], my findString.get()); // CRLF BUG? + if (position) { + GuiText_setSelection (my text, position - label.get(), position - label.get() + str32len (my findString.get())); + } else { + findInTier (me); + } + } +} + +static void menu_cb_Find (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Find text", nullptr) + TEXTFIELD (findString, U"Text:", U"") + EDITOR_OK + EDITOR_DO + my findString = Melder_dup (findString); + do_find (me); + EDITOR_END +} + +static void menu_cb_FindAgain (FormantPathEditor me, EDITOR_ARGS_DIRECT) { + do_find (me); +} + +/***** TIER MENU *****/ + + +static void menu_cb_candidate_modellingSettings (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Candidate modelling settings", U"Candidate modelling settings...") + SENTENCE (parameters_string, U"Coefficients by track", my default_modeler_numberOfParametersPerTrack ()) + POSITIVE (varianceExponent, U"Variance exponent", U"1.25") + EDITOR_OK + SET_STRING (parameters_string, my p_modeler_numberOfParametersPerTrack) + EDITOR_DO + pref_str32cpy2 (my pref_modeler_numberOfParametersPerTrack (), my p_modeler_numberOfParametersPerTrack, parameters_string); + my pref_modeler_varianceExponent () = my p_modeler_varianceExponent = varianceExponent; + FunctionEditor_redraw (me); + EDITOR_END +} + +static void menu_cb_AdvancedCandidateDrawingSettings (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Formant modeler advanced drawing settings", nullptr) + BOOLEAN (drawEstimatedModels, U"Draw estimated models", my default_modeler_draw_estimatedModels ()) + POSITIVE (yGridLineEvery_Hz, U"Hor. grid lines every (Hz)", my default_modeler_draw_yGridLineEvery_Hz ()) + POSITIVE (maximumFrequency, U"Maximum frequency (Hz)", my default_modeler_draw_maximumFrequency ()) + BOOLEAN (drawErrorBars, U"Draw error bars", my default_modeler_draw_showErrorBars ()) + EDITOR_OK + SET_BOOLEAN (drawEstimatedModels, my p_modeler_draw_estimatedModels) + SET_REAL (yGridLineEvery_Hz, my p_modeler_draw_yGridLineEvery_Hz) + SET_REAL (maximumFrequency, my p_modeler_draw_maximumFrequency) + SET_BOOLEAN (drawErrorBars, my p_modeler_draw_showErrorBars) + EDITOR_DO + my pref_modeler_draw_estimatedModels () = my p_modeler_draw_estimatedModels = drawEstimatedModels; + my pref_modeler_draw_maximumFrequency () = my p_modeler_draw_maximumFrequency = maximumFrequency; + my pref_modeler_draw_yGridLineEvery_Hz () = my p_modeler_draw_yGridLineEvery_Hz = yGridLineEvery_Hz; + my pref_modeler_draw_showErrorBars () = my p_modeler_draw_showErrorBars = drawErrorBars; + FunctionEditor_redraw (me); + EDITOR_END +} + +static void menu_cb_candidates_FindPath (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Find path", nullptr) + LABEL (U"Within frame:") + REAL (qWeight, U"F/B weight (0-1)", U"1.0") + LABEL (U"Between frames:") + REAL (frequencyChangeWeight, U"Frequency change weight (0-1)", U"1.0") + REAL (stressWeight, U"Stress weight (0-1)", U"1.0") + REAL (ceilingChangeWeight, U"Ceiling change weight (0-1)", U"1.0") + POSITIVE (intensityModulationStepSize, U"Intensity modulation step size (dB)", U"5.0") + LABEL (U"Global stress parameters:") + POSITIVE (windowLength, U"Window length", U"0.035") + SENTENCE (parameters_string, U"Coefficients by track", U"3 3 3 3") + POSITIVE (powerf, U"Power", U"1.25") + EDITOR_OK + EDITOR_DO + FormantPath formantPath = (FormantPath) my data; + autoINTVEC parameters = newINTVECfromString (parameters_string); + FormantPath_pathFinder (formantPath, qWeight, frequencyChangeWeight, stressWeight, ceilingChangeWeight, intensityModulationStepSize, windowLength, parameters.get(), powerf); + my d_formant = FormantPath_extractFormant (formantPath); + FunctionEditor_redraw (me); + Editor_broadcastDataChanged (me); + EDITOR_END +} + +static void menu_cb_DrawVisibleCandidates (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Draw visible candidates", nullptr) + my v_form_pictureWindow (cmd); + my v_form_pictureMargins (cmd); + BOOLEAN (crossHairs, U"Draw cross hairs", 0) + BOOLEAN (garnish, U"Garnish", my default_picture_garnish ()); + EDITOR_OK + my v_ok_pictureWindow (cmd); + my v_ok_pictureMargins (cmd); + SET_BOOLEAN (garnish, my pref_picture_garnish ()) + EDITOR_DO + my v_do_pictureWindow (cmd); + my v_do_pictureMargins (cmd); + my pref_picture_garnish () = garnish; + Editor_openPraatPicture (me); + FormantPath formantPath = (FormantPath) my data; + Graphics_setInner (my pictureGraphics); + double startTime, endTime, xCursor, yCursor; + FormantPathEditor_getDrawingData (me, & startTime, & endTime, & xCursor, & yCursor); + + + autoINTVEC parameters = newINTVECfromString (my p_modeler_numberOfParametersPerTrack); + constexpr double xSpace_fraction = 0.1, ySpace_fraction = 0.1; + FormantPath_drawAsGrid_inside (formantPath, my pictureGraphics, startTime, endTime, my p_modeler_draw_maximumFrequency, 1, 5, my p_modeler_draw_showErrorBars, Melder_RED, Melder_PURPLE, 0, 0, xSpace_fraction, ySpace_fraction, my p_modeler_draw_yGridLineEvery_Hz, xCursor, yCursor, my selectedCandidate, Melder_RED, parameters.get(), true, true, my p_modeler_varianceExponent, my p_modeler_draw_estimatedModels, true); + Graphics_unsetInner (my pictureGraphics); + Editor_closePraatPicture (me); + EDITOR_END +} + +static void menu_cb_FormantColourSettings (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Formant colour settings", nullptr) + WORD (oddPathColour_string, U"Dots in F1, F3, F5", my default_formant_path_oddColour ()) + WORD (evenPathColour_string, U"Dots in F2, F4", my default_formant_path_evenColour ()) + EDITOR_OK + SET_STRING (oddPathColour_string, my p_formant_path_oddColour) + SET_STRING (evenPathColour_string, my p_formant_path_evenColour) + EDITOR_DO + pref_str32cpy2 (my pref_formant_path_oddColour (), my p_formant_path_oddColour, oddPathColour_string); + pref_str32cpy2 (my pref_formant_path_evenColour (), my p_formant_path_evenColour, evenPathColour_string); + FunctionEditor_redraw (me); + Editor_broadcastDataChanged (me); + EDITOR_END +} + +static void menu_cb_DrawVisibleFormantContour (FormantPathEditor me, EDITOR_ARGS_FORM) { + EDITOR_FORM (U"Draw visible formant contour", nullptr) + my v_form_pictureWindow (cmd); + my v_form_pictureMargins (cmd); + my v_form_pictureSelection (cmd); + BOOLEAN (garnish, U"Garnish", true) + EDITOR_OK + my v_ok_pictureWindow (cmd); + my v_ok_pictureMargins (cmd); + my v_ok_pictureSelection (cmd); + SET_BOOLEAN (garnish, my p_formant_picture_garnish) + EDITOR_DO + my v_do_pictureWindow (cmd); + my v_do_pictureMargins (cmd); + my v_do_pictureSelection (cmd); + my pref_formant_picture_garnish () = my p_formant_picture_garnish = garnish; + if (! my p_formant_show) + Melder_throw (U"No formant contour is visible.\nFirst choose \"Show formant\" from the Formant menu."); + Editor_openPraatPicture (me); + //FormantPath formantPath = (FormantPath) my data; + //const Formant formant = formantPath -> formant.get(); + //const Formant defaultFormant = formantPath -> formants.at [formantPath -> defaultFormant]; + Formant_drawSpeckles (my d_formant.get(), my pictureGraphics, my startWindow, my endWindow, + my p_spectrogram_viewTo, my p_formant_dynamicRange, + my p_formant_picture_garnish); + FunctionEditor_garnish (me); + Editor_closePraatPicture (me); + EDITOR_END +} + + +static void menu_cb_showFormants (FormantPathEditor me, EDITOR_ARGS_DIRECT) { + my pref_formant_show () = my p_formant_show = ! my p_formant_show; + GuiMenuItem_check (my formantToggle, my p_formant_show); // in case we're called from a script + FunctionEditor_redraw (me); +} + +void structFormantPathEditor :: v_createMenuItems_formant (EditorMenu menu) { + formantToggle = EditorMenu_addCommand (menu, U"Show formants", + GuiMenu_CHECKBUTTON | (pref_formant_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showFormants); + EditorMenu_addCommand (menu, U"Formant colour settings...", 0, menu_cb_FormantColourSettings); + EditorMenu_addCommand (menu, U"Draw visible formant contour...", 0, menu_cb_DrawVisibleFormantContour); +} + +/***** HELP MENU *****/ + +static void menu_cb_FormantPathEditorHelp (FormantPathEditor, EDITOR_ARGS_DIRECT) { Melder_help (U"FormantPathEditor"); } +static void menu_cb_AboutSpecialSymbols (FormantPathEditor, EDITOR_ARGS_DIRECT) { Melder_help (U"Special symbols"); } +static void menu_cb_PhoneticSymbols (FormantPathEditor, EDITOR_ARGS_DIRECT) { Melder_help (U"Phonetic symbols"); } +static void menu_cb_AboutTextStyles (FormantPathEditor, EDITOR_ARGS_DIRECT) { Melder_help (U"Text styles"); } + +void structFormantPathEditor :: v_createMenus () { + FormantPathEditor_Parent :: v_createMenus (); + EditorMenu menu; + Editor_addCommand (this, U"Edit", U"-- search --", 0, nullptr); + Editor_addCommand (this, U"Edit", U"Find...", 'F', menu_cb_Find); + Editor_addCommand (this, U"Edit", U"Find again", 'G', menu_cb_FindAgain); + +// Editor_addCommand (this, U"Query", U"-- query interval --", 0, nullptr); +// Editor_addCommand (this, U"Query", U"Get starting point of interval", 0, menu_cb_GetStartingPointOfInterval); +// Editor_addCommand (this, U"Query", U"Get end point of interval", 0, menu_cb_GetEndPointOfInterval); +// Editor_addCommand (this, U"Query", U"Get label of interval", 0, menu_cb_GetLabelOfInterval); + +// menu = Editor_addMenu (this, U"Interval", 0); +// EditorMenu_addCommand (menu, U"-- green stuff --", 0, nullptr); + +// our navigateSettingsButton = EditorMenu_addCommand (menu, U"Navigation settings...", 0, menu_cb_NavigationSettings); +// our navigateNextButton = EditorMenu_addCommand (menu, U"Next green interval", 0, menu_cb_NextGreenInterval); +// our navigatePreviousButton = EditorMenu_addCommand (menu, U"Previous green interval", 0, menu_cb_PreviousGreenInterval); + +// menu = Editor_addMenu (this, U"Tier", 0); +// EditorMenu_addCommand (menu, U"-- remove tier --", 0, nullptr); +// EditorMenu_addCommand (menu, U"-- extract tier --", 0, nullptr); + + if (our d_sound.data || our d_longSound.data) { + if (our v_hasAnalysis ()) + our v_createMenus_analysis (); // insert some of the ancestor's menus *after* the TextGrid menus + } + menu = Editor_addMenu (this, U"Candidates", 0); + EditorMenu_addCommand (menu, U"Candidate modelling settings...", 0, menu_cb_candidate_modellingSettings); + EditorMenu_addCommand (menu, U"Advanced candidate drawing settings...", 0, menu_cb_AdvancedCandidateDrawingSettings); + EditorMenu_addCommand (menu, U" -- drawing -- ", 0, 0); + EditorMenu_addCommand (menu, U"Find path...", 0, menu_cb_candidates_FindPath); + EditorMenu_addCommand (menu, U"Draw visible candidates...", 0, menu_cb_DrawVisibleCandidates); +} + +void structFormantPathEditor :: v_createHelpMenuItems (EditorMenu menu) { + FormantPathEditor_Parent :: v_createHelpMenuItems (menu); + EditorMenu_addCommand (menu, U"FormantPathEditor help", '?', menu_cb_FormantPathEditorHelp); + EditorMenu_addCommand (menu, U"About special symbols", 0, menu_cb_AboutSpecialSymbols); + EditorMenu_addCommand (menu, U"Phonetic symbols", 0, menu_cb_PhoneticSymbols); + EditorMenu_addCommand (menu, U"About text styles", 0, menu_cb_AboutTextStyles); +} + +/***** CHILDREN *****/ + +void structFormantPathEditor :: v_createChildren () { + FormantPathEditor_Parent :: v_createChildren (); + /*if (our text) + GuiText_setChangedCallback (our text, gui_text_cb_changed, this);*/ +} + +void structFormantPathEditor :: v_dataChanged () { + const TextGrid grid = our pathGridView.get(); + /* + Perform a minimal selection change. + Most changes will involve intervals and boundaries; however, there may also be tier removals. + Do a simple guess. + */ + if (our selectedTier > grid -> tiers->size) + our selectedTier = grid -> tiers->size; + our v_updateMenuItems_navigation (); + FormantPathEditor_Parent :: v_dataChanged (); // does all the updating +} + +/********** DRAWING AREA **********/ + +void structFormantPathEditor :: v_prepareDraw () { + if (our d_longSound.data) { + try { + LongSound_haveWindow (our d_longSound.data, our startWindow, our endWindow); + } catch (MelderError) { + Melder_clearError (); + } + } +} + +void structFormantPathEditor :: v_draw () { + Graphics_Viewport vp1; + const bool showAnalysis = v_hasAnalysis () && + (p_spectrogram_show || p_pitch_show || p_intensity_show || p_formant_show) && + (d_longSound.data || d_sound.data); + double soundY = _FormantPathEditor_computeSoundY (this); + + /* + Draw the sound. + */ + if (d_longSound.data || d_sound.data) { + vp1 = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, soundY, 1.0); + Graphics_setColour (our graphics.get(), Melder_WHITE); + Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); + Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); + TimeSoundEditor_drawSound (this, -1.0, 1.0); + Graphics_resetViewport (our graphics.get(), vp1); + } + + /* + Draw tiers. + */ + if (our textgrid) {} + if (showAnalysis) { + vp1 = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, (our textgrid ? 0.3 : 0.0), soundY); + v_draw_analysis (); + Graphics_resetViewport (our graphics.get(), vp1); + /* Draw pulses. */ + if (p_pulses_show) { + vp1 = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, soundY, 1.0); + v_draw_analysis_pulses (); + TimeSoundEditor_drawSound (this, -1.0, 1.0); // second time, partially across the pulses + Graphics_resetViewport (our graphics.get(), vp1); + } + } + Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, 1.0); + /*if (our d_longSound.data || our d_sound.data) { + Graphics_line (our graphics.get(), our startWindow, soundY, our endWindow, soundY); + if (showAnalysis) { + Graphics_line (our graphics.get(), our startWindow, soundY2, our endWindow, soundY2); + Graphics_line (our graphics.get(), our startWindow, soundY, our startWindow, soundY2); + Graphics_line (our graphics.get(), our endWindow, soundY, our endWindow, soundY2); + } + }*/ + + /* + Finally, us usual, update the menus. + */ + v_updateMenuItems_file (); + v_updateMenuItems_navigation (); +} + +void structFormantPathEditor :: v_drawSelectionViewer () { + static double previousStartTime, previousEndTime; + double original_fontSize = Graphics_inqFontSize (our graphics.get()); + constexpr double xSpace_fraction = 0.1, ySpace_fraction = 0.1; + Graphics_setColour (our graphics.get(), Melder_WHITE); + Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); + Graphics_setColour (our graphics.get(), Melder_BLACK); + Graphics_setFontSize (our graphics.get(), 10.0); + Graphics_setTextAlignment (our graphics.get(), Graphics_CENTRE, Graphics_HALF); + double startTime, endTime = endWindow, xCursor, yCursor; + FormantPathEditor_getDrawingData (this, & startTime, & endTime, & xCursor, & yCursor); + Graphics_setInner (our graphics.get()); + FormantPath formantPath = (FormantPath) our data; + const integer nrow = 0, ncol = 0; + if (startTime != previousStartTime || endTime != previousEndTime) + our selectedCandidate = 0; + autoINTVEC parameters = newINTVECfromString (our p_modeler_numberOfParametersPerTrack); + MelderColour oddColour = MelderColour_fromColourName (our p_formant_path_oddColour); + MelderColour evenColour = MelderColour_fromColourName (our p_formant_path_evenColour); + FormantPath_drawAsGrid_inside (formantPath, our graphics.get(), startTime, endTime, + our p_modeler_draw_maximumFrequency, 1, 5, our p_modeler_draw_showErrorBars, oddColour, evenColour, nrow, ncol, xSpace_fraction, ySpace_fraction, our p_modeler_draw_yGridLineEvery_Hz, xCursor, yCursor, our selectedCandidate, Melder_RED, parameters.get(), true, true, our p_modeler_varianceExponent, our p_modeler_draw_estimatedModels, true); + Graphics_unsetInner (our graphics.get()); + Graphics_setFontSize (our graphics.get(), original_fontSize); + previousStartTime = startTime; + previousEndTime = endTime; +} + +void FormantPathEditor_drawCeilings (FormantPathEditor me, Graphics g, double tmin, double tmax, double fmin, double fmax) { + FormantPath formantPath = (FormantPath) my data; + integer itmin, itmax; + if (! Sampled_getWindowSamples (formantPath, tmin, tmax, & itmin, & itmax)) + return; + Graphics_setWindow (g, tmin, tmax, fmin, fmax); + Graphics_setColour (g, Melder_RED); + Graphics_setLineWidth (g, 3.0); + const double dx2 = 0.5 * formantPath -> dx; + integer iframe = itmin, iframe2 = itmin + 1; + double ceiling = formantPath -> ceilings [formantPath -> path [itmin]]; + while (iframe2 <= itmax) { + double ceiling2; + while (iframe2 <= itmax) { + ceiling2 = formantPath -> ceilings [formantPath -> path [iframe2]]; + if (ceiling2 != ceiling) + break; + iframe2 ++; + } + const double tmid = Sampled_indexToX (formantPath, iframe); + const double tmid2 = Sampled_indexToX (formantPath, iframe2 - 1); + Graphics_line (g, tmid - dx2, ceiling, tmid2 + dx2, ceiling); + Graphics_setTextAlignment (g, kGraphics_horizontalAlignment::CENTRE, Graphics_BASELINE); + Graphics_text (g, 0.5 * (tmid + tmid2), ceiling + 50.0, ((integer) ceiling)); + ceiling = ceiling2; + iframe = iframe2; + } + if (iframe == itmax) { + const double tmid = Sampled_indexToX (formantPath, iframe); + Graphics_line (g, tmid - dx2, ceiling, tmid + dx2, ceiling); + } + Graphics_setLineWidth (g, 1.0); +} + +void structFormantPathEditor :: v_draw_analysis_formants () { + if (our p_formant_show) { + Graphics_setColour (our graphics.get(), Melder_RED); + Graphics_setSpeckleSize (our graphics.get(), our p_formant_dotSize); + MelderColour oddColour = MelderColour_fromColourName (our p_formant_path_oddColour); + MelderColour evenColour = MelderColour_fromColourName (our p_formant_path_evenColour); + + Formant_drawSpeckles_inside (d_formant.get(), our graphics.get(), our startWindow, our endWindow, our p_spectrogram_viewFrom, our p_spectrogram_viewTo, our p_formant_dynamicRange, oddColour, evenColour, true); + Graphics_setColour (our graphics.get(), Melder_PINK); + FormantPathEditor_drawCeilings (this, our graphics.get(), our startWindow, our endWindow, + our p_spectrogram_viewFrom, our p_spectrogram_viewTo); + Graphics_setColour (our graphics.get(), Melder_BLACK); + } +} + +static void Formant_replaceFrames (Formant target, integer beginFrame, integer endFrame, Formant source) { + // Precondition target and source have exactly the same Sampled xmin, xmax, x1, nx, dx + if (beginFrame == endFrame && beginFrame == 0) { + beginFrame = 1; + endFrame = target->nx; + } + Melder_require (beginFrame <= endFrame, + U"The start frame should not be after the end frame."); + Melder_require (beginFrame > 0, + U"The begin frame should be larger than zero."); + Melder_require (endFrame <= target->nx, + U"The end frame sould not be larger than ", target->nx); + for (integer iframe = beginFrame ; iframe <= endFrame; iframe ++) { + Formant_Frame targetFrame = & target -> frames [iframe]; + Formant_Frame sourceFrame = & source -> frames [iframe]; + sourceFrame -> copy (targetFrame); + } +} + +void structFormantPathEditor :: v_clickSelectionViewer (double xWC, double yWC) { + /* + On which of the modelers was the click? + */ + FormantPath formantPath = (FormantPath) our data; + integer numberOfRows, numberOfColums; + NUMgetGridDimensions (formantPath -> formants.size, & numberOfRows, & numberOfColums); + const integer icol = 1 + (int) (xWC * numberOfColums); + if (icol < 1 || icol > numberOfColums) + return; + const integer irow = 1 + (int) ((1.0 - yWC) * numberOfRows); + if (irow < 1 || irow > numberOfRows) + return; + integer index = (irow - 1) * numberOfColums + icol; // left-to-right, top-to-bottom + if (index > 0 && index <= formantPath -> formants.size) { + double tmin_ = our startWindow, tmax_ = our endWindow; + if (our startSelection < our endSelection) { + tmin_ = our startSelection; + tmax_ = our endSelection; + } + our selectedCandidate = index; + Editor_save (this, U"insert interval by selection viewer"); + integer itmin, itmax; + Sampled_getWindowSamples (formantPath, tmin_, tmax_, & itmin, & itmax); + for (integer iframe = itmin; iframe <= itmax; iframe ++) + formantPath -> path [iframe] = our selectedCandidate; + Formant source = reinterpret_cast (formantPath -> formants.at [our selectedCandidate]); + Formant_replaceFrames (d_formant.get(), itmin, itmax, source); + } +} + +void structFormantPathEditor :: v_play (double tmin_, double tmax_) { + if (! d_sound.data && ! d_longSound.data) + return; + integer numberOfChannels = ( d_longSound.data ? d_longSound.data -> numberOfChannels : d_sound.data -> ny ); + integer numberOfMuteChannels = 0; + Melder_assert (our d_sound.muteChannels.size == numberOfChannels); + for (integer ichan = 1; ichan <= numberOfChannels; ichan ++) + if (our d_sound.muteChannels [ichan]) + numberOfMuteChannels ++; + integer numberOfChannelsToPlay = numberOfChannels - numberOfMuteChannels; + Melder_require (numberOfChannelsToPlay > 0, + U"Please select at least one channel to play."); + if (our d_longSound.data) { + if (numberOfMuteChannels > 0) { + autoSound part = LongSound_extractPart (our d_longSound.data, tmin_, tmax_, true); + autoMixingMatrix thee = MixingMatrix_create (numberOfChannelsToPlay, numberOfChannels); + MixingMatrix_muteAndActivateChannels (thee.get(), our d_sound.muteChannels.get()); + Sound_MixingMatrix_playPart (part.get(), thee.get(), tmin_, tmax_, theFunctionEditor_playCallback, this); + } else { + LongSound_playPart (our d_longSound.data, tmin_, tmax_, theFunctionEditor_playCallback, this); + } + } else { + if (numberOfMuteChannels > 0) { + autoMixingMatrix thee = MixingMatrix_create (numberOfChannelsToPlay, numberOfChannels); + MixingMatrix_muteAndActivateChannels (thee.get(), our d_sound.muteChannels.get()); + Sound_MixingMatrix_playPart (our d_sound.data, thee.get(), tmin_, tmax_, theFunctionEditor_playCallback, this); + } else { + Sound_playPart (our d_sound.data, tmin_, tmax_, theFunctionEditor_playCallback, this); + } + } +} + +POSITIVE_VARIABLE (v_prefs_addFields_fontSize) +OPTIONMENU_ENUM_VARIABLE (kGraphics_horizontalAlignment, v_prefs_addFields_textAlignmentInIntervals) +OPTIONMENU_VARIABLE (v_prefs_addFields_useTextStyles) +OPTIONMENU_ENUM_VARIABLE (kTextGridEditor_showNumberOf, v_prefs_addFields_showNumberOf) +void structFormantPathEditor :: v_prefs_addFields (EditorCommand cmd) { + UiField _radio_; + POSITIVE_FIELD (v_prefs_addFields_fontSize, U"Font size (points)", our default_fontSize ()) + OPTIONMENU_ENUM_FIELD (kGraphics_horizontalAlignment, v_prefs_addFields_textAlignmentInIntervals, + U"Text alignment in intervals", kGraphics_horizontalAlignment::DEFAULT) + OPTIONMENU_FIELD (v_prefs_addFields_useTextStyles, U"The symbols %#_^ in labels", our default_useTextStyles () + 1) + OPTION (U"are shown as typed") + OPTION (U"mean italic/bold/sub/super") + OPTIONMENU_ENUM_FIELD (kTextGridEditor_showNumberOf, v_prefs_addFields_showNumberOf, + U"Show number of", kTextGridEditor_showNumberOf::DEFAULT) +} +void structFormantPathEditor :: v_prefs_setValues (EditorCommand cmd) { + SET_OPTION (v_prefs_addFields_useTextStyles, our p_useTextStyles + 1) + SET_REAL (v_prefs_addFields_fontSize, our p_fontSize) + SET_ENUM (v_prefs_addFields_textAlignmentInIntervals, kGraphics_horizontalAlignment, our p_alignment) + SET_ENUM (v_prefs_addFields_showNumberOf, kTextGridEditor_showNumberOf, our p_showNumberOf) +} + +void structFormantPathEditor :: v_prefs_getValues (EditorCommand /* cmd */) { + our pref_useTextStyles () = our p_useTextStyles = v_prefs_addFields_useTextStyles - 1; + our pref_fontSize () = our p_fontSize = v_prefs_addFields_fontSize; + our pref_alignment () = our p_alignment = v_prefs_addFields_textAlignmentInIntervals; + our pref_shiftDragMultiple () = our p_shiftDragMultiple = false; + our pref_showNumberOf () = our p_showNumberOf = v_prefs_addFields_showNumberOf; + FunctionEditor_redraw (this); +} + +void structFormantPathEditor :: v_createMenuItems_view_timeDomain (EditorMenu menu) { + FormantPathEditor_Parent :: v_createMenuItems_view_timeDomain (menu); +} + +void structFormantPathEditor :: v_highlightSelection (double left, double right, double bottom, double top) { + if (our v_hasAnalysis () && our p_spectrogram_show && (our d_longSound.data || our d_sound.data)) { + const double soundY = _FormantPathEditor_computeSoundY (this); + Graphics_highlight (our graphics.get(), left, right, bottom+(top-bottom)*soundY, top); + } else { + Graphics_highlight (our graphics.get(), left, right, bottom, top); + } +} + +double structFormantPathEditor :: v_getBottomOfSoundArea () { + return _FormantPathEditor_computeSoundY (this); +} + +double structFormantPathEditor :: v_getBottomOfSoundAndAnalysisArea () { + return (our textgrid ? 0.3 : 0.0); +} + +void structFormantPathEditor :: v_createMenuItems_pitch_picture (EditorMenu menu) { + FormantPathEditor_Parent :: v_createMenuItems_pitch_picture (menu); + EditorMenu_addCommand (menu, U"Draw visible pitch contour and TextGrid...", 0, menu_cb_DrawTextGridAndPitch); +} + +void structFormantPathEditor :: v_updateMenuItems_file () { + FormantPathEditor_Parent :: v_updateMenuItems_file (); + GuiThing_setSensitive (extractSelectedTextGridPreserveTimesButton, our endSelection > our startSelection); + GuiThing_setSensitive (extractSelectedTextGridTimeFromZeroButton, our endSelection > our startSelection); +} + +/********** EXPORTED **********/ + +autoFormantPathEditor FormantPathEditor_create (conststring32 title, FormantPath formantPath, Sound sound, TextGrid textgrid) { + try { + autoFormantPathEditor me = Thing_new (FormantPathEditor); + + TimeSoundAnalysisEditor_init (me.get(), title, formantPath, sound, false); + my d_formant = FormantPath_extractFormant (formantPath); + if (textgrid) { + my textgrid = Data_copy (textgrid); + my pathGridView = TextGridView_create (my textgrid.get()); + } + if (my p_modeler_numberOfParametersPerTrack [0] == U'\0') + pref_str32cpy2(my p_modeler_numberOfParametersPerTrack, my pref_modeler_numberOfParametersPerTrack (), my default_modeler_numberOfParametersPerTrack ()); + if (my p_formant_default_colour [0] == U'\0') + pref_str32cpy2 (my p_formant_default_colour, my pref_formant_default_colour (), my default_formant_default_colour ()); + if (my p_formant_path_oddColour [0] == U'\0') + pref_str32cpy2 (my p_formant_path_oddColour, my pref_formant_path_oddColour (), my default_formant_path_oddColour ()); + if (my p_formant_path_evenColour [0] == U'\0') + pref_str32cpy2 (my p_formant_path_evenColour, my pref_formant_path_evenColour (), my default_formant_path_evenColour ()); + if (my p_formant_selected_colour [0] == U'\0') + pref_str32cpy2 (my p_formant_selected_colour, my pref_formant_selected_colour (), my default_formant_selected_colour ()); + my selectedTier = 1; + if (my endWindow - my startWindow > 5.0) { + my endWindow = my startWindow + 5.0; + if (my startWindow == my tmin) + my startSelection = my endSelection = 0.5 * (my startWindow + my endWindow); + FunctionEditor_marksChanged (me.get(), false); + } + return me; + } catch (MelderError) { + Melder_throw (U"FormantPathEditor window not created."); + } +} + +/* End of file FormantPathEditor.cpp */ diff --git a/LPC/FormantPathEditor.h b/LPC/FormantPathEditor.h new file mode 100644 index 00000000..bd38f4f5 --- /dev/null +++ b/LPC/FormantPathEditor.h @@ -0,0 +1,124 @@ +#ifndef _FormantPathEditor_h_ +#define _FormantPathEditor_h_ +/* FormantPathEditor.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "Collection.h" +#include "FormantModelerList.h" +#include "Formant.h" +#include "FormantPath.h" +#include "melder.h" +#include "Preferences.h" +#include "Sound.h" +#include "LPC.h" +#include "TextGrid.h" +#include "TextGridView.h" +#include "TimeSoundAnalysisEditor.h" + +#include "TextGridEditor_enums.h" +/* + We might add one tier named formant-log if the input textgrid does not have our specific log tier. + + The explanation following is for analyses with different maximum formant frequencies (i.e. different ceilings). + The -log tier can have multiple intervals. Each interval shows a particular analysis prefered by the user. It shows first the that was selected by the user, then a ';' separator and finally the number of parameters per track of the formant modeler. + Its content could be, for example '5000; 5 5 5', which means that the analysis with a ceiling of 5000 Hz was chosen and the Formant modeler used F1, F2, and F3 in the modelling and reserved 5 coefficients to model F1, 5 coefficients to model F2 and 5 coefficients to model F3. The number must match one of the possible ceilings (rounded to integer Hz values) + An empty interval always implies the default analysis. Therefore only intervals where you want a non-default have to be specified. + + There is no need to permanently store the FormantModelers because they can easily + be calculated whenever they are needed from the information in the tiers. + + Multichannel sounds don't make sense with respect to the analysis part. If both channels are the same sound, one is resundant. + If two different sounds?. May be only copy channel 1? +*/ + +Thing_define (FormantPathEditor, TimeSoundAnalysisEditor) { + autoTextGrid textgrid; + autoTextGridView pathGridView; + Graphics_Viewport selectionViewer_viewport; + integer selectedTier, selectedCandidate; + bool suppressRedraw; + autostring32 findString; + GuiMenuItem navigateSettingsButton, navigateNextButton, navigatePreviousButton; + GuiMenuItem extractSelectedTextGridPreserveTimesButton, extractSelectedTextGridTimeFromZeroButton; + void v_info () + override; + void v_createChildren () + override; + void v_createMenus () + override; + void v_createHelpMenuItems (EditorMenu menu) + override; + void v_dataChanged () + override; + void v_createMenuItems_file_extract (EditorMenu menu) + override; + void v_createMenuItems_file_write (EditorMenu menu) + override; + void v_createMenuItems_file_draw (EditorMenu menu) + override; + void v_prepareDraw () + override; + void v_draw () + override; + void v_drawSelectionViewer () + override; + bool v_hasText () + override { return false; } + //bool v_click (double xWC, double yWC, bool shiftKeyPressed) + // override; + void v_clickSelectionViewer (double xWC, double yWC) + override; + void v_draw_analysis_formants () + override; + void v_play (double startTime, double endTime) + override; + void v_updateText () + override {}; + void v_prefs_addFields (EditorCommand cmd) + override; + void v_prefs_setValues (EditorCommand cmd) + override; + void v_prefs_getValues (EditorCommand cmd) + override; + conststring32 v_selectionViewerName () + override { return U"Formant candidates"; } + void v_createMenuItems_view_timeDomain (EditorMenu menu) + override; + void v_highlightSelection (double left, double right, double bottom, double top) + override; + void v_unhighlightSelection (double left, double right, double bottom, double top) + /*override*/; + double v_getBottomOfSoundArea () + override; + double v_getBottomOfSoundAndAnalysisArea () + override; + void v_updateMenuItems_file () + override; + void v_createMenuItems_pitch_picture (EditorMenu menu) + override; + void v_createMenuItems_formant (EditorMenu menu) + override; + virtual void v_updateMenuItems_navigation (); + + #include "FormantPathEditor_prefs.h" +}; + +autoFormantPathEditor FormantPathEditor_create (conststring32 title, FormantPath formantPath, Sound sound, TextGrid textgrid); + +/* End of file FormantPathEditor.h */ +#endif diff --git a/LPC/FormantPathEditor_prefs.h b/LPC/FormantPathEditor_prefs.h new file mode 100644 index 00000000..89752d9c --- /dev/null +++ b/LPC/FormantPathEditor_prefs.h @@ -0,0 +1,61 @@ +/* FormantPathEditor_prefs.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +prefs_begin (FormantPathEditor) + + prefs_override_int (FormantPathEditor, shellWidth, 1, U"800") + prefs_override_int (FormantPathEditor, shellHeight, 1, U"600") + prefs_override_bool (FormantPathEditor, picture_garnish, 1, true) + prefs_override_bool (FormantPathEditor, showSelectionViewer, 1, true) + prefs_override_bool (FormantPathEditor, spectrogram_show, 1, true) + prefs_override_bool (FormantPathEditor, formant_show, 1, true) + +// from TextGridEditor + prefs_add_bool_with_data (FormantPathEditor, useTextStyles, 1, false) + prefs_add_double_with_data (FormantPathEditor, fontSize, 1, U"18") + prefs_add_enum_with_data (FormantPathEditor, alignment, 1, kGraphics_horizontalAlignment, DEFAULT) + prefs_add_bool_with_data (FormantPathEditor, shiftDragMultiple, 1, false) + prefs_add_enum_with_data (FormantPathEditor, showNumberOf, 1, kTextGridEditor_showNumberOf, DEFAULT) + prefs_add_enum_with_data (FormantPathEditor, greenMethod, 1, kMelder_string, DEFAULT) + prefs_add_string_with_data (FormantPathEditor, greenString, 1, U"some text here for green paint") + prefs_add_bool_with_data (FormantPathEditor, picture_showBoundaries, 1, true) + prefs_add_bool_with_data (FormantPathEditor, picture_pitch_speckle, 1, false) + prefs_add_string_with_data (FormantPathEditor, align_language, 1, U"English") + prefs_add_bool_with_data (FormantPathEditor, align_includeWords, 1, true) + prefs_add_bool_with_data (FormantPathEditor, align_includePhonemes, 1, false) + prefs_add_bool_with_data (FormantPathEditor, align_allowSilences, 1, false) +//end from TextGridEditor + + prefs_add_string_with_data (FormantPathEditor, formant_path_evenColour, 1, U"pink") + prefs_add_string_with_data (FormantPathEditor, formant_path_oddColour, 1, U"red") + prefs_add_string_with_data (FormantPathEditor, formant_default_colour, 1, U"blue") + prefs_add_string_with_data (FormantPathEditor, formant_selected_colour, 1, U"pink") + prefs_add_bool_with_data (FormantPathEditor, formant_draw_showBandWidths, 1, false) + + prefs_add_integer_with_data(FormantPathEditor, modeler_numberOfTracks, 1, U"3") + prefs_add_string_with_data (FormantPathEditor, modeler_numberOfParametersPerTrack, 1, U"7 7 7") + prefs_add_double_with_data (FormantPathEditor, modeler_varianceExponent, 1, U"1.25") + prefs_add_bool_with_data (FormantPathEditor, modeler_draw_showAllModels, 1, true) + prefs_add_double_with_data (FormantPathEditor, modeler_draw_maximumFrequency, 1, U"5000.0") + prefs_add_bool_with_data (FormantPathEditor, modeler_draw_estimatedModels, 1, false) + prefs_add_bool_with_data (FormantPathEditor, modeler_draw_showErrorBars, 1, true) + prefs_add_double_with_data (FormantPathEditor, modeler_draw_yGridLineEvery_Hz, 1, U"1000.0") // Hz + +prefs_end (FormantPathEditor) + +/* End of file FormantPathEditor_prefs.h */ diff --git a/LPC/FormantPath_def.h b/LPC/FormantPath_def.h new file mode 100644 index 00000000..1dea9510 --- /dev/null +++ b/LPC/FormantPath_def.h @@ -0,0 +1,44 @@ +/* FormantPath_def.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#define ooSTRUCT FormantPath +oo_DEFINE_CLASS (FormantPath, Sampled) + + oo_COLLECTION_OF (OrderedOf, formants, Formant, 2) + oo_VEC (ceilings, formants. size) + oo_INTVEC (path, nx) + + #if oo_DECLARING + void v_info () + override; + int v_domainQuantity () + override { return MelderQuantity_TIME_SECONDS; } + conststring32 v_getUnitText (integer level, int unit, uint32 flags) + override; + double v_getValueAtSample (integer sampleNumber, integer level, int unit) + override; + conststring32 v_getIndexText () const + override { return U"frame number"; } + conststring32 v_getNxText () const + override { return U"the number of frames"; } + #endif + +oo_END_CLASS (FormantPath) +#undef ooSTRUCT + +/* End of FormantPath_def.h */ diff --git a/LPC/LPC_enums.h b/LPC/LPC_enums.h index 473908c7..e64a45de 100644 --- a/LPC/LPC_enums.h +++ b/LPC/LPC_enums.h @@ -25,6 +25,6 @@ enums_begin (kLPC_Analysis, 1) enums_add (kLPC_Analysis, 3, BURG, U"Burg") enums_add (kLPC_Analysis, 4, MARPLE, U"Marple") enums_add (kLPC_Analysis, 5, ROBUST, U"Robust") -enums_end (kLPC_Analysis, 5, ROBUST) +enums_end (kLPC_Analysis, 5, BURG) #endif /* _LPC_enums_h_ */ diff --git a/LPC/Makefile b/LPC/Makefile index f990f5c5..7a6a49a8 100644 --- a/LPC/Makefile +++ b/LPC/Makefile @@ -1,14 +1,17 @@ # Makefile of the library "LPC" # David Weenink and Paul Boersma -# 20200407 - +# 20200521 +# -save-temps=cwd include ../makefile.defs -CPPFLAGS = -I ../kar -I ../melder -I ../dwtools -I ../fon -I ../sys -I ../dwsys -I ../stat +CPPFLAGS = -I . -I ../kar -I ../melder -I ../fon -I ../dwtools -I ../sys -I ../dwsys -I ../stat OBJECTS = Cepstrum.o Cepstrumc.o Cepstrum_and_Spectrum.o \ Cepstrogram.o \ - Formant_extensions.o LineSpectralFrequencies.o \ + Formant_extensions.o \ + FormantModeler.o FormantModelerList.o \ + FormantPath.o FormantPathEditor.o \ + LineSpectralFrequencies.o \ LPC.o LPC_and_Cepstrumc.o LPC_and_Formant.o LPC_and_LFCC.o \ LPC_and_LineSpectralFrequencies.o LPC_and_Polynomial.o \ LPC_to_Spectrum.o LPC_to_Spectrogram.o \ diff --git a/LPC/PowerCepstrogram.cpp b/LPC/PowerCepstrogram.cpp index e664ee58..279a2e7a 100644 --- a/LPC/PowerCepstrogram.cpp +++ b/LPC/PowerCepstrogram.cpp @@ -134,13 +134,13 @@ autoTable PowerCepstrogram_to_Table_hillenbrand (PowerCepstrogram me, double pit } } -autoTable PowerCepstrogram_to_Table_cpp (PowerCepstrogram me, double pitchFloor, double pitchCeiling, double deltaF0, int interpolation, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod) { +autoTable PowerCepstrogram_to_Table_cpp (PowerCepstrogram me, double pitchFloor, double pitchCeiling, double deltaF0, kVector_peakInterpolation peakInterpolationType, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod) { try { autoTable thee = Table_createWithColumnNames (my nx, U"time quefrency cpp f0 rnr"); autoPowerCepstrum him = PowerCepstrum_create (my ymax, my ny); for (integer icol = 1; icol <= my nx; icol ++) { his z.row (1) <<= my z.column (icol); - double qpeak, cpp = PowerCepstrum_getPeakProminence (him.get(), pitchFloor, pitchCeiling, interpolation, + double qpeak, cpp = PowerCepstrum_getPeakProminence (him.get(), pitchFloor, pitchCeiling, peakInterpolationType, qstartFit, qendFit, lineType, fitMethod, & qpeak); double rnr = PowerCepstrum_getRNR (him.get(), pitchFloor, pitchCeiling, deltaF0); double time = Sampled_indexToX (me, icol); @@ -369,14 +369,14 @@ autoPowerCepstrogram Sound_to_PowerCepstrogram_hillenbrand (Sound me, double pit } } -double PowerCepstrogram_getCPPS (PowerCepstrogram me, bool subtractTiltBeforeSmoothing, double timeAveragingWindow, double quefrencyAveragingWindow, double pitchFloor, double pitchCeiling, double deltaF0, int interpolation, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod) { +double PowerCepstrogram_getCPPS (PowerCepstrogram me, bool subtractTiltBeforeSmoothing, double timeAveragingWindow, double quefrencyAveragingWindow, double pitchFloor, double pitchCeiling, double deltaF0, kVector_peakInterpolation peakInterpolationType, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod) { try { autoPowerCepstrogram flattened; if (subtractTiltBeforeSmoothing) flattened = PowerCepstrogram_subtractTrend (me, qstartFit, qendFit, lineType, fitMethod); autoPowerCepstrogram smooth = PowerCepstrogram_smooth (flattened ? flattened.get() : me, timeAveragingWindow, quefrencyAveragingWindow); - autoTable table = PowerCepstrogram_to_Table_cpp (smooth.get(), pitchFloor, pitchCeiling, deltaF0, interpolation, qstartFit, qendFit, lineType, fitMethod); + autoTable table = PowerCepstrogram_to_Table_cpp (smooth.get(), pitchFloor, pitchCeiling, deltaF0, peakInterpolationType, qstartFit, qendFit, lineType, fitMethod); const double cpps = Table_getMean (table.get(), 3); return cpps; } catch (MelderError) { diff --git a/LPC/PowerCepstrogram.h b/LPC/PowerCepstrogram.h index 53615c3e..03f39bc0 100644 --- a/LPC/PowerCepstrogram.h +++ b/LPC/PowerCepstrogram.h @@ -54,7 +54,7 @@ autoPowerCepstrogram Sound_to_PowerCepstrogram_hillenbrand (Sound me, double ana autoTable PowerCepstrogram_to_Table_hillenbrand (PowerCepstrogram me, double pitchFloor, double pitchCeiling); -autoTable PowerCepstrogram_to_Table_cpp (PowerCepstrogram me, double pitchFloor, double pitchCeiling, double deltaF0, int interpolation, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit method); +autoTable PowerCepstrogram_to_Table_cpp (PowerCepstrogram me, double pitchFloor, double pitchCeiling, double deltaF0, kVector_peakInterpolation peakInterpolationType, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit method); autoPowerCepstrum PowerCepstrogram_to_PowerCepstrum_slice (PowerCepstrogram me, double time); @@ -64,7 +64,7 @@ void PowerCepstrogram_subtractTrend_inplace (PowerCepstrogram me, double qstartF double PowerCepstrogram_getCPPS_hillenbrand (PowerCepstrogram me, bool subtractTiltBeforeSmoothing, double timeAveragingWindow, double quefrencyAveragingWindow, double pitchFloor, double pitchCeiling); -double PowerCepstrogram_getCPPS (PowerCepstrogram me, bool subtractTiltBeforeSmoothing, double timeAveragingWindow, double quefrencyAveragingWindow, double pitchFloor, double pitchCeiling, double deltaF0, int interpolation, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod); +double PowerCepstrogram_getCPPS (PowerCepstrogram me, bool subtractTiltBeforeSmoothing, double timeAveragingWindow, double quefrencyAveragingWindow, double pitchFloor, double pitchCeiling, double deltaF0, kVector_peakInterpolation peakInterpolationType, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod); autoMatrix PowerCepstrogram_to_Matrix (PowerCepstrogram me); diff --git a/LPC/PowerCepstrum.cpp b/LPC/PowerCepstrum.cpp index 6885d378..c869bd66 100644 --- a/LPC/PowerCepstrum.cpp +++ b/LPC/PowerCepstrum.cpp @@ -250,14 +250,14 @@ autoPowerCepstrum PowerCepstrum_smooth (PowerCepstrum me, double quefrencyAverag return thee; } -void PowerCepstrum_getMaximumAndQuefrency (PowerCepstrum me, double pitchFloor, double pitchCeiling, int interpolation, double *out_peakdB, double *out_quefrency) { +void PowerCepstrum_getMaximumAndQuefrency (PowerCepstrum me, double pitchFloor, double pitchCeiling, kVector_peakInterpolation peakInterpolationType, double *out_peakdB, double *out_quefrency) { autoPowerCepstrum thee = Data_copy (me); double lowestQuefrency = 1.0 / pitchCeiling, highestQuefrency = 1.0 / pitchFloor; for (integer i = 1; i <= my nx; i ++) { thy z [1] [i] = my v_getValueAtSample (i, 1, 0); // 10 log val^2 } double peakdB, quefrency; - Vector_getMaximumAndX ((Vector) thee.get(), lowestQuefrency, highestQuefrency, 1, interpolation, & peakdB, & quefrency); // FIXME cast + Vector_getMaximumAndX ((Vector) thee.get(), lowestQuefrency, highestQuefrency, 1, peakInterpolationType, & peakdB, & quefrency); // FIXME cast if (out_peakdB) *out_peakdB = peakdB; if (out_quefrency) @@ -267,7 +267,7 @@ void PowerCepstrum_getMaximumAndQuefrency (PowerCepstrum me, double pitchFloor, double PowerCepstrum_getRNR (PowerCepstrum me, double pitchFloor, double pitchCeiling, double f0fractionalWidth) { double rnr = undefined; double qmin = 1.0 / pitchCeiling, qmax = 1.0 / pitchFloor, peakdB, qpeak; - PowerCepstrum_getMaximumAndQuefrency (me, pitchFloor, pitchCeiling, 2, & peakdB, & qpeak); + PowerCepstrum_getMaximumAndQuefrency (me, pitchFloor, pitchCeiling, kVector_peakInterpolation :: CUBIC, & peakdB, & qpeak); integer imin, imax; if (Matrix_getWindowSamplesX (me, qmin, qmax, & imin, & imax) == 0) return rnr; @@ -308,16 +308,16 @@ double PowerCepstrum_getPeakProminence_hillenbrand (PowerCepstrum me, double pit PowerCepstrum_fitTrendLine (me, 0.001, 0, & slope, & intercept, kCepstrumTrendType::LINEAR, kCepstrumTrendFit::LEAST_SQUARES); autoPowerCepstrum thee = Data_copy (me); PowerCepstrum_subtractTrendLine_inplace (thee.get(), slope, intercept, kCepstrumTrendType::LINEAR); - PowerCepstrum_getMaximumAndQuefrency (thee.get(), pitchFloor, pitchCeiling, 0, & peakdB, & quefrency); + PowerCepstrum_getMaximumAndQuefrency (thee.get(), pitchFloor, pitchCeiling, kVector_peakInterpolation :: NONE, & peakdB, & quefrency); if (out_qpeak) *out_qpeak = quefrency; return peakdB; } -double PowerCepstrum_getPeakProminence (PowerCepstrum me, double pitchFloor, double pitchCeiling, int interpolation, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod, double *out_qpeak) { +double PowerCepstrum_getPeakProminence (PowerCepstrum me, double pitchFloor, double pitchCeiling, kVector_peakInterpolation peakInterpolationType, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod, double *out_qpeak) { double slope, intercept, qpeak, peakdB; PowerCepstrum_fitTrendLine (me, qstartFit, qendFit, & slope, & intercept, lineType, fitMethod); - PowerCepstrum_getMaximumAndQuefrency (me, pitchFloor, pitchCeiling, interpolation, & peakdB, & qpeak); + PowerCepstrum_getMaximumAndQuefrency (me, pitchFloor, pitchCeiling, peakInterpolationType, & peakdB, & qpeak); double xq = lineType == kCepstrumTrendType::EXPONENTIAL_DECAY ? log(qpeak) : qpeak; double db_background = slope * xq + intercept; double cpp = peakdB - db_background; diff --git a/LPC/PowerCepstrum.h b/LPC/PowerCepstrum.h index 976b856e..00b9828d 100644 --- a/LPC/PowerCepstrum.h +++ b/LPC/PowerCepstrum.h @@ -19,6 +19,7 @@ */ #include "Cepstrum.h" +#include "Vector.h" /* The PowerCepstrum is a sequence of real numbers. @@ -66,14 +67,14 @@ void PowerCepstrum_drawTrendLine (PowerCepstrum me, Graphics g, double qmin, dou [minimum, maximum]: amplitude; y range of drawing. */ -void PowerCepstrum_getMaximumAndQuefrency (PowerCepstrum me, double pitchFloor, double pitchCeiling, int interpolation, double *maximum, double *quefrency); +void PowerCepstrum_getMaximumAndQuefrency (PowerCepstrum me, double pitchFloor, double pitchCeiling, kVector_peakInterpolation peakInterpolationType, double *maximum, double *quefrency); // The standard of Hillenbrand with fitting options double PowerCepstrum_getPeakProminence_hillenbrand (PowerCepstrum me, double pitchFloor, double pitchCeiling, double *qpeak); double PowerCepstrum_getRNR (PowerCepstrum me, double pitchFloor, double pitchCeiling, double f0fractionalWidth); -double PowerCepstrum_getPeakProminence (PowerCepstrum me, double pitchFloor, double pitchCeiling, int interpolation, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod, double *qpeak); +double PowerCepstrum_getPeakProminence (PowerCepstrum me, double pitchFloor, double pitchCeiling, kVector_peakInterpolation peakInterpolationType, double qstartFit, double qendFit, kCepstrumTrendType lineType, kCepstrumTrendFit fitMethod, double *qpeak); void PowerCepstrum_fitTrendLine (PowerCepstrum me, double qmin, double qmax, double *out_slope, double *out_intercept, kCepstrumTrendType lineType, kCepstrumTrendFit method); diff --git a/LPC/Sound_and_LPC.cpp b/LPC/Sound_and_LPC.cpp index 7ea002e0..29727463 100644 --- a/LPC/Sound_and_LPC.cpp +++ b/LPC/Sound_and_LPC.cpp @@ -113,7 +113,7 @@ static int Sound_into_LPC_Frame_auto (Sound me, LPC_Frame thee, VEC const& works goto end; } end: - i--; + i --; for (integer j = 1; j <= i; j ++) thy a [j] = a [j + 1]; if (i == numberOfCoefficients) @@ -142,7 +142,7 @@ static int Sound_into_LPC_Frame_covar (Sound me, LPC_Frame thee, VEC const& work start = end + 1; end += m + 1; VEC a = workspace. part (start, end); // autoVEC a = newVECzero (m + 1); start = end + 1; end += m + 1; - VEC cc = workspace. part (start, end); // autoVEC cc = newVECzero (m + 1); + VEC cc = workspace. part (start, end); // autoVEC cc = newVECzero (m + 1); thy gain = 0.0; integer i; @@ -207,7 +207,7 @@ static int Sound_into_LPC_Frame_covar (Sound me, LPC_Frame thee, VEC const& work goto end; } end: - i--; + i --; for (integer j = 1; j <= i; j ++) thy a [j] = a [j + 1]; if (i == m) @@ -234,7 +234,7 @@ static double VECburg_buffered (VEC const& a, constVEC const& x, VEC const& work longdouble xms = p / n; if (xms <= 0.0) { - return xms; // warning empty + return double (xms); // warning empty } // (9) @@ -255,7 +255,7 @@ static double VECburg_buffered (VEC const& a, constVEC const& x, VEC const& work if (denum <= 0.0) return 0.0; // warning ill-conditioned - a [i] = 2.0 * num / denum; + a [i] = 2.0 * double (num / denum); // (10) @@ -278,7 +278,7 @@ static double VECburg_buffered (VEC const& a, constVEC const& x, VEC const& work } } } - return xms; + return double (xms); } static int Sound_into_LPC_Frame_burg (Sound me, LPC_Frame thee, VEC const& workspace) { @@ -428,30 +428,31 @@ static int Sound_into_LPC_Frame_marple (Sound me, LPC_Frame thee, double tol1, d } } end: - thy gain *= 0.5; // because e0 is twice the energy + thy gain *= 0.5; // because e0 is twice the energy thy a.resize (m); - thy nCoefficients = thy a.size; // maintain invariant + thy nCoefficients = thy a.size; // maintain invariant return status == 1 || status == 4 || status == 5; } -static autoLPC Sound_to_LPC_noThreads (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency, kLPC_Analysis method, double tol1, double tol2) { +static void Sound_into_LPC_noThreads (Sound me, LPC thee, double analysisWidth, double preEmphasisFrequency, kLPC_Analysis method, double tol1, double tol2) { + Melder_require (my xmin == thy xmin && my xmax == thy xmax, + U"The Sound and the LPC should have the same domain."); const double samplingFrequency = 1.0 / my dx; double windowDuration = 2.0 * analysisWidth; // Gaussian window + const integer predictionOrder = thy maxnCoefficients; Melder_require (Melder_roundDown (windowDuration / my dx) > predictionOrder, U"Analysis window duration too short.\n For a prediction order of ", predictionOrder, - U" the analysis window duration should be greater than ", my dx * (predictionOrder + 1), U"Please increase the analysis window duration or lower the prediction order."); - - // Convenience: analyse the whole sound into one LPC_frame - if (windowDuration > my dx * my nx) { + U" the analysis window duration should be greater than ", my dx * (predictionOrder + 1), + U" s. Please increase the analysis window duration."); + /* + Convenience: analyse the whole sound into one LPC_frame. + */ + if (windowDuration > my dx * my nx) windowDuration = my dx * my nx; - } - double t1; - integer numberOfFrames; - Sampled_shortTermAnalysis (me, windowDuration, dt, & numberOfFrames, & t1); + integer numberOfFrames = thy nx; autoSound sound = Data_copy (me); autoSound sframe = Sound_createSimple (1, windowDuration, samplingFrequency); autoSound window = Sound_createGaussian (windowDuration, samplingFrequency); - autoLPC thee = LPC_create (my xmin, my xmax, numberOfFrames, dt, t1, predictionOrder, my dx); for (integer iframe = 1; iframe <= numberOfFrames; iframe ++) { const LPC_Frame lpcFrame = & thy d_frames [iframe]; LPC_Frame_init (lpcFrame, predictionOrder); @@ -465,8 +466,8 @@ static autoLPC Sound_to_LPC_noThreads (Sound me, int predictionOrder, double ana integer frameErrorCount = 0; for (integer iframe = 1; iframe <= numberOfFrames; iframe ++) { const LPC_Frame lpcframe = & thy d_frames [iframe]; - const double t = Sampled_indexToX (thee.get(), iframe); - Sound_into_Sound (sound.get(), sframe.get(), t - windowDuration / 2.0); + const double t = Sampled_indexToX (thee, iframe); + Sound_into_Sound (sound.get(), sframe.get(), t - 0.5 * windowDuration); Vector_subtractMean (sframe.get()); Sounds_multiply (sframe.get(), window.get()); integer status = 1; @@ -480,36 +481,45 @@ static autoLPC Sound_to_LPC_noThreads (Sound me, int predictionOrder, double ana status = Sound_into_LPC_Frame_marple (sframe.get(), lpcframe, tol1, tol2, workspace.get()); if (status != 0) frameErrorCount ++; - if (iframe % 10 == 1) - Melder_progress ( (double) iframe / numberOfFrames, U"LPC analysis of frame ", iframe, U" out of ", numberOfFrames, U"."); + Melder_progress (double (iframe) / numberOfFrames, U"LPC analysis of frame ", iframe, U" out of ", numberOfFrames, U"."); } +} + +static autoLPC Sound_to_LPC_noThreads (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency, kLPC_Analysis method, double tol1, double tol2) { + double t1; + integer numberOfFrames; + Sampled_shortTermAnalysis (me, 2.0 * analysisWidth, dt, & numberOfFrames, & t1); // Gaussian window + autoLPC thee = LPC_create (my xmin, my xmax, numberOfFrames, dt, t1, predictionOrder, my dx); + Sound_into_LPC_noThreads (me, thee.get(), analysisWidth, preEmphasisFrequency, method, tol1, tol2); return thee; } -static autoLPC Sound_to_LPC (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency, kLPC_Analysis method, double tol1, double tol2) { +void Sound_into_LPC (Sound me, LPC thee, double analysisWidth, double preEmphasisFrequency, kLPC_Analysis method, double tol1, double tol2) { const integer numberOfProcessors = std::thread::hardware_concurrency (); if (numberOfProcessors <= 1) { /* We cannot use multithreading. */ - return Sound_to_LPC_noThreads (me, predictionOrder, analysisWidth, dt, preEmphasisFrequency, method, tol1, tol2); + Sound_into_LPC_noThreads (me, thee, analysisWidth, preEmphasisFrequency, method, tol1, tol2); } const double samplingFrequency = 1.0 / my dx; + Melder_require (my xmin == thy xmin && my xmax == thy xmax, + U"The Sound and the LPC should have the same domain."); + const integer predictionOrder = thy maxnCoefficients; double windowDuration = 2.0 * analysisWidth; // Gaussian window Melder_require (Melder_roundDown (windowDuration / my dx) > predictionOrder, U"Analysis window duration too short.\n For a prediction order of ", predictionOrder, - U" the analysis window duration should be greater than ", my dx * (predictionOrder + 1), U"Please increase the analysis window duration or lower the prediction order."); - - if (windowDuration > my dx * my nx) { + U" the analysis window duration should be greater than ", my dx * (predictionOrder + 1), + U" s. Please increase the analysis window duration."); + /* + Convenience: analyse the whole sound into one LPC_frame. + */ + if (windowDuration > my dx * my nx) windowDuration = my dx * my nx; - } - double t1; - integer numberOfFrames; - Sampled_shortTermAnalysis (me, windowDuration, dt, & numberOfFrames, & t1); + integer numberOfFrames = thy nx; autoSound sound = Data_copy (me); autoSound window = Sound_createGaussian (windowDuration, samplingFrequency); - autoLPC thee = LPC_create (my xmin, my xmax, numberOfFrames, dt, t1, predictionOrder, my dx); /* Because of threading we initialise the frames beforehand. We initialize the coefficient vector with a size equal to the prediction order. @@ -531,10 +541,10 @@ static autoLPC Sound_to_LPC (Sound me, int predictionOrder, double analysisWidth for (integer ithread = 1; ithread <= numberOfThreads; ithread ++) sframe [ithread] = Sound_createSimple (1, windowDuration, samplingFrequency); - const integer worspaceSize = getLPCAnalysisWorkspaceSize (sframe [1] -> nx, predictionOrder, method); - Melder_require (worspaceSize > 0, + const integer workspaceSize = getLPCAnalysisWorkspaceSize (sframe [1] -> nx, predictionOrder, method); + Melder_require (workspaceSize > 0, U"The workspace size is not properly defined."); - autoMAT workspace = newMATraw (numberOfThreads, worspaceSize); + autoMAT workspace = newMATraw (numberOfThreads, workspaceSize); std::vector thread (numberOfThreads); std::atomic frameErrorCount (0); @@ -543,15 +553,14 @@ static autoLPC Sound_to_LPC (Sound me, int predictionOrder, double analysisWidth for (integer ithread = 1; ithread <= numberOfThreads; ithread ++) { Sound soundFrame = sframe [ithread]. get(), fullsound = sound.get(), windowFrame = window.get(); VEC threadWorkspace = workspace. row (ithread); - LPC lpc = thee.get(); const integer firstFrame = 1 + (ithread - 1) * numberOfFramesPerThread; const integer lastFrame = ( ithread == numberOfThreads ? numberOfFrames : firstFrame + numberOfFramesPerThread - 1 ); thread [ithread - 1] = std::thread ([=, & frameErrorCount]() { for (integer iframe = firstFrame; iframe <= lastFrame; iframe ++) { - const LPC_Frame lpcframe = & lpc -> d_frames [iframe]; - const double t = Sampled_indexToX (lpc, iframe); - Sound_into_Sound (fullsound, soundFrame, t - windowDuration / 2.0); + const LPC_Frame lpcframe = & thy d_frames [iframe]; + const double t = Sampled_indexToX (thee, iframe); + Sound_into_Sound (fullsound, soundFrame, t - 0.5 * windowDuration); Vector_subtractMean (soundFrame); Sounds_multiply (soundFrame, windowFrame); integer status = 1; @@ -577,11 +586,28 @@ static autoLPC Sound_to_LPC (Sound me, int predictionOrder, double analysisWidth } for (integer ithread = 1; ithread <= numberOfThreads; ithread ++) thread [ithread - 1]. join (); + +} + +static autoLPC Sound_to_LPC (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency, kLPC_Analysis method, double tol1, double tol2) { + double windowDuration = 2.0 * analysisWidth; // Gaussian window + Melder_require (Melder_roundDown (windowDuration / my dx) > predictionOrder, + U"Analysis window duration too short.\n For a prediction order of ", predictionOrder, + U" the analysis window duration should be greater than ", my dx * (predictionOrder + 1), + U"Please increase the analysis window duration or lower the prediction order." + ); + if (windowDuration > my dx * my nx) + windowDuration = my dx * my nx; + double t1; + integer numberOfFrames; + Sampled_shortTermAnalysis (me, windowDuration, dt, & numberOfFrames, & t1); + autoLPC thee = LPC_create (my xmin, my xmax, numberOfFrames, dt, t1, predictionOrder, my dx); + Sound_into_LPC (me, thee.get(), analysisWidth, preEmphasisFrequency, method, tol1, tol2); return thee; } -autoLPC Sound_to_LPC_auto (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency) { +autoLPC Sound_to_LPC_autocorrelation (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency) { try { autoLPC thee = Sound_to_LPC (me, predictionOrder, analysisWidth, dt, preEmphasisFrequency, kLPC_Analysis :: AUTOCORRELATION, 0.0, 0.0); return thee; @@ -590,7 +616,7 @@ autoLPC Sound_to_LPC_auto (Sound me, int predictionOrder, double analysisWidth, } } -autoLPC Sound_to_LPC_covar (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency) { +autoLPC Sound_to_LPC_covariance (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency) { try { autoLPC thee = Sound_to_LPC (me, predictionOrder, analysisWidth, dt, preEmphasisFrequency, kLPC_Analysis :: COVARIANCE, 0.0, 0.0); return thee; @@ -625,12 +651,13 @@ autoSound LPC_Sound_filterInverse (LPC me, Sound thee) { U"The domains of LPC and Sound should be equal."); autoSound him = Data_copy (thee); - + VEC source = his z.row (1); + VEC sound = thy z.row (1); for (integer isamp = 1; isamp <= his nx; isamp ++) { const double sampleTime = Sampled_indexToX (him.get(), isamp); const integer frameNumber = Sampled_xToNearestIndex (me, sampleTime); if (frameNumber < 1 || frameNumber > my nx) { - his z [1] [isamp] = 0.0; + source [isamp] = 0.0; continue; } const LPC_Frame frame = & my d_frames [frameNumber]; @@ -638,7 +665,7 @@ autoSound LPC_Sound_filterInverse (LPC me, Sound thee) { const integer maximumSoundDepth = isamp - 1; const integer usableDepth = std::min (maximumFilterDepth, maximumSoundDepth); for (integer icoef = 1; icoef <= usableDepth; icoef ++) - his z [1] [isamp] += frame -> a [icoef] * thy z [1] [isamp - icoef]; + source [isamp] += frame -> a [icoef] * sound [isamp - icoef]; } return him; } catch (MelderError) { @@ -647,7 +674,7 @@ autoSound LPC_Sound_filterInverse (LPC me, Sound thee) { } /* - gain used as a constant amplitude multiplier within a frame of duration my dx. + Gain used as a constant amplitude multiplier within a frame of duration my dx. future alternative: convolve gain with a smoother. */ autoSound LPC_Sound_filter (LPC me, Sound thee, bool useGain) { @@ -664,7 +691,7 @@ autoSound LPC_Sound_filter (LPC me, Sound thee, bool useGain) { autoSound source; if (my samplingPeriod != thy dx) { source = Sound_resample (thee, 1.0 / my samplingPeriod, 50); - thee = source.get(); // Reference copy; remove at end + thee = source.get(); // reference copy; remove at end } autoSound him = Data_copy (thee); diff --git a/LPC/Sound_and_LPC.h b/LPC/Sound_and_LPC.h index c130790b..ae327ccc 100644 --- a/LPC/Sound_and_LPC.h +++ b/LPC/Sound_and_LPC.h @@ -28,14 +28,15 @@ #include "LPC.h" #include "Sound.h" -autoLPC Sound_to_LPC_auto (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency); +autoLPC Sound_to_LPC_autocorrelation (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency); -autoLPC Sound_to_LPC_covar (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency); +autoLPC Sound_to_LPC_covariance (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency); autoLPC Sound_to_LPC_burg (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency); autoLPC Sound_to_LPC_marple (Sound me, int predictionOrder, double analysisWidth, double dt, double preEmphasisFrequency, double tol1, double tol2); +void Sound_into_LPC (Sound me, LPC thee, double analysisWidth, double preEmphasisFrequency, kLPC_Analysis method, double tol1, double tol2); /* * Function: * Calculate linear prediction coefficients according to following model: diff --git a/LPC/Sound_and_LPC_robust.cpp b/LPC/Sound_and_LPC_robust.cpp index 9e32bcda..ecc28c19 100644 --- a/LPC/Sound_and_LPC_robust.cpp +++ b/LPC/Sound_and_LPC_robust.cpp @@ -225,7 +225,7 @@ autoFormant Sound_to_Formant_robust (Sound me, double dt_in, double numberOfForm else sound = Sound_resample (me, maximumFrequency * 2.0, 50); - autoLPC lpc = Sound_to_LPC_auto (sound.get(), predictionOrder, halfdt_window, dt, preEmphasisFrequency); + autoLPC lpc = Sound_to_LPC_autocorrelation (sound.get(), predictionOrder, halfdt_window, dt, preEmphasisFrequency); autoLPC lpcRobust = LPC_Sound_to_LPC_robust (lpc.get(), sound.get(), halfdt_window, preEmphasisFrequency, k, itermax, tol, wantlocation); autoFormant thee = LPC_to_Formant (lpcRobust.get(), safetyMargin); return thee; diff --git a/LPC/manual_LPC.cpp b/LPC/manual_LPC.cpp index 63afbf35..33fbe034 100644 --- a/LPC/manual_LPC.cpp +++ b/LPC/manual_LPC.cpp @@ -28,6 +28,29 @@ void manual_LPC (ManPages me); void manual_LPC (ManPages me) { +MAN_BEGIN (U"Candidate modelling settings...", U"djmw", 20201011) +INTRO (U"A command in the #Candidates menu of the @FormantPathEditor window.") +TAG (U"##Coefficients by track#") +DEFINITION (U"determines how many coefficients will be used in the modelling of a formant track. " + "The first number determines the number of coefficients that will be used in modeling formant 1 with a polynomial function." + "The second number determines the number of coefficients in the modelling of formant 2, and so on. " + "For example, if you specify \"4 3 3\", the first three formants will be modelled. Formant 1 will be modelled with 4 " + "coefficients which means that a third order polynomial is modelled. Formant 2 and formant 3 are modelled with " + "3 coefficients polynomials (parabolas).") +TAG (U"##Variance exponent#") +DEFINITION (U"determines the power of the first term in the overall stress criterion #S. " + "The best model is the one with the lowest value for the stress %S.") +NORMAL (U"The stress criterion #S is defined in @@Weenink (2015)@ as") +FORMULA (U"%S = (%s^2 / %k)^^%varianceExponent^ (%\\ci^^2^ / %d),") +NORMAL (U"where %s^^2^ is the sum of the squares of the standard errors of all the coefficients of the modelled formant " + "tracks within one Formant object, %k is the total number of coefficients of these tracks, in the example given above " + "%k is 10 (= 4 + 3 + 3), \\ci^^2^ is the sum of the chi squares of each track, %d is the sum of the " + "degrees of freedom of each track. " + "Because the standard error %s is proportional to bandwidth and \\ci^^2^ is inversely proportional to bandwidth, " + "the expression for %S grows approximately as 2\\.c%varianceExponent-2 with bandwidth. Setting the %varianceExponent " + "somewhat larger than one guarantees that for two tracks that only differ in their bandwidths, the track with the " + "larger bandwidths obtains a larger value for the stress value %S.") +MAN_END MAN_BEGIN (U"CC: Paint...", U"djmw", 20040407) INTRO (U"A command to paint the cepstral coefficients in shades of grey.") @@ -65,8 +88,88 @@ NORMAL (U"where %z__%ji_ is the matrix element in row %j and column %i and " "%c__%ij_ is the %j-th cepstral coefficient in frame %i.") MAN_END +MAN_BEGIN (U"FormantPath", U"djmw", 20201013) +INTRO (U"One of the @@types of objects@ in Praat. It maintains a path through a collection of Formant objects, " + "each the result of a formant frequency analysis of the same sound but with a different setting of the analysis parameters.") +NORMAL (U"A FormantPath combines a collection of @@Formant@s with an index that indicates which of these formants is preferred " + "at each moment in its time domain. " + "For example, consider a collection with nine Formant objects. " + "These formant objects could be the result of multiple @@Sound: To Formant (burg)...@ analyses on the same sound, " + "with a difference only in the \"Formant ceiling (Hz)\" parameter setting. " + "Suppose that the formant ceilings were chosen as 4093.7, 4303.5, 4524.2, 4756.1, 5000.0, 5256.4, 5525.9, 5809.2, and 6107.0 Hz, respectively. " + "In this way, the collection functions as a set of alternative analyses. " + "The middle one in this set with a ceiling of 5000 Hz corresponds to the result of a \"standard\" analysis for a male voice. ") +NORMAL (U"You can create a FormantPath with @@Sound: To FormantPath (burg)...@. The FormantPath example above could have been created from a Sound by:") +CODE (U"To FormantPath (burg): 0.005, 5.0, 5000.0, 0.025, 50.0, 0.05, 4") +NORMAL (U"To choose your own path through the alternatives you can use Praat's @@FormantPathEditor@.") +MAN_END + +MAN_BEGIN (U"Sound: To FormantPath (burg)...", U"djmw", 20201026) +INTRO (U"A command that creates a @@FormantPath@ object from each selected @@Sound@ . ") +ENTRY (U"##Settings") +NORMAL (U"The settings for ##Time step (s)#, ##Maximum number of formants#, ##Window length (s)# and ##Pre-emphasis from (Hz)# " + "are as you would set them with the @@Sound: To Formant (burg)...@ method. " + "The defaults are 0.005 seconds, 5.0 formants, 0.025 seconds, and 50.0 Hz, respectively.") +TAG (U"##Middle formant ceiling (Hz)") +DEFINITION (U"determines the middle formant ceiling frequency in Hz. You normaly would use 5500.0 Hz for an average female voice " + "and 5000.0 Hz for an average male voice as you would do for the ##Formant ceiling (Hz)# setting in ##To Formant (burg)...#. " + "However, instead of performing only one analysis with a fixed ceiling, we perform in a number of steps " + "multiple analyses, each with a different ceiling frequency. The number of analyses with a %lower formant ceiling than the " + "%%middle formant ceiling% is equal to the number of analyses with a %higher formant ceiling than the %%middle formant ceiling%. ") +TAG (U"##Ceiling step size#") +DEFINITION (U"defines the increase or decrease in the formant ceiling between two successive analyses as exp(%ceilingStepSize) " + "when we step up or as exp(-%ceilingStepSize) when we step down.") +TAG (U"##Number of steps up / down") +DEFINITION (U"determines the number steps we go up as well as the number of steps we go down with respect to the %middle formant ceiling%. " + "The ceiling frequency for the %i^^th^ step down is %middleFormantCeiling\\.cexp (-%i\\.c%ceilingStepSize) and for the %i^^th^ step up " + "is %middleFormantCeiling\\.cexp (+%i\\.c%ceilingStepSize). The total number of analyses is always 2\\.c%numberOfStepsUpOrDown+1.") +ENTRY (U"Algorithm") +NORMAL (U"The following algorithm describes what is going on. ") +CODE (U"ceiling [numberOfStepsUpOrDown + 1] = middleCeiling") +CODE (U"for istep from 1 to 2 * numberOfStepsUpOrDown + 1") +CODE (U" if istep <= numberOfStepsUpOrDown") +CODE (U" ceiling [istep] = middleFormantCeiling * exp (-(numberOfStepsUpOrDown - istep + 1) * ceilingStepSize)") +CODE (U" elsif istep > numberOfStepsUpOrDown + 1") +CODE (U" ceiling [istep] = middleFormantCeiling * exp ((istep - numberOfStepsUpOrDown - 1) * ceilingStepSize)") +CODE (U" selectObject: sound") +CODE (U" formant [istep] = To Formant (burg): timeStep, maxNumberOfFormants, ceiling [istep], windowLength, preEmphasis") +CODE (U"endfor") +NORMAL (U"This description is approximate because in the \"To Formant\" step we have to guarantee that all the Formant objects get the same time sampling.") +MAN_END + +MAN_BEGIN (U"FormantPathEditor", U"djmw", 20201004) +INTRO (U"One of the @@Editors@ in Praat, for editing a @@FormantPath@ object.") +NORMAL (U"You can optionally include a @Sound and a @TextGrid in this editor, by selecting both the Sound and the FormantPath together, or the Sound and the TextGrid and the FormantPath together before clicking ##View & Edit#.") +NORMAL (U"With the FormantPathEditor you can, for each interval that you select, " + "replace its formant frequencies and bandwidths by the corresponding values " + "from one of the alternative Formant objects in the FormantPath's collection.") +ENTRY (U"Editor layout") +NORMAL (U"The left part of the editor is similar to the layout of the @@SoundEditor@.") +NORMAL (U"The right part is called the %%selection viewer%. " + "Here you see alternative formant frequency analyses of the selected part of the sound laid out in a grid " + "(or of the whole visible sound window if there is no selection).") +NORMAL (U"The selection viewer shows not only a formant's frequency but also its bandwidth as a vertical line. " + "This will give you a better impression of the analysis results because well defined formants have small bandwidths " + "and, therefore, show short vertical lines.") +ENTRY (U"How to operate") +NORMAL (U"When you start to edit a new FormantPath object, the formants in the path are set equal to the formants of the default " + "analysis. This guarantees that there always is a path at the start. The path is indicated by the fat read line in the " + "upper part of the spectrogram. " + "If you click in one of the rectangles in the selection viewer the values of the formant frequencies (and bandwidths) " + "in the selected part on the left are replaced by the values present in the rectangle and the fat red line will indicate " + "the new ceiling. The colour of the clicked rectangle on the right will also change.") +ENTRY (U"Details") +NORMAL (U"The meaning of the numbers in the upper left corner of the rectangles in the selection viewer " + "are explained in @@Weenink (2015)@. Basically this number is a combined stress score of the individual formant tracks " + "within the rectangle. Each track's stress score quantifies how well a track has been modelled. " + "The lower this number is, the better the track is modelled by a smooth curve, a polynomial of a certain order. " + "The higher the order, the more flexible the curve is and the better it can adapt to the data. " + "The higher the order of the polynomial, the more parameters are needed in the model. " + "You can change the number of paramaters that model the tracks.") +MAN_END + MAN_BEGIN (U"Formants: Extract smoothest part...", U"djmw", 20140313) -INTRO (U"Extracts the part from one of the selected formants which shows the smoothest formant tracks in a given interval.") +INTRO (U"Extracts the part from one of the selected formants which shows the smoothest formant tracks in a given interval. ") ENTRY (U"Settings") SCRIPT (5, Manual_SETTINGS_WINDOW_HEIGHT (5), U"" Manual_DRAW_SETTINGS_WINDOW (U"Formants: Extract smoothest part", 5) @@ -74,24 +177,34 @@ SCRIPT (5, Manual_SETTINGS_WINDOW_HEIGHT (5), U"" Manual_DRAW_SETTINGS_WINDOW_RANGE (U"Fitter formant range", U"1", U"3") Manual_DRAW_SETTINGS_WINDOW_FIELD (U"Order of polynomials", U"3") Manual_DRAW_SETTINGS_WINDOW_BOOLEAN (U"Use bandwidths to model formant tracks", 1) - Manual_DRAW_SETTINGS_WINDOW_BOOLEAN (U"Bandwidths for smoothing test", 0) + Manual_DRAW_SETTINGS_WINDOW_BOOLEAN (U"Bandwidths for stress test", 0) ) TAG (U"##Time range (s)#") DEFINITION (U"determines the position of the intervals that have to be compared.") TAG (U"##Fitter formant range") -DEFINITION (U"determines which formant tracks will be modelled with a polynomial function. The goodness of fit of these models will be used in the comparison.") +DEFINITION (U"determines which formant tracks will be modelled with a polynomial function. The goodness of fit of these models " + "will be used in the comparison.") TAG (U"##Order of polynomials") -DEFINITION (U"determines the maximum order of the polynomials that are used in modeling each formant track. Order 0 means a model which is a constant function; this model needs only one parameter. Order 1 means a model that is a straight line function; this order needs two parameters. Order 2 means that an additional parabolic function is used in the modeling; order 2 needs therefore 3 parameters. In general an order %p model needs %p+1 parameters.") +DEFINITION (U"determines the maximum order of the polynomials that are used in modelling each formant track. Order 0 means a " + "model which is a constant function; this model needs only one parameter. Order 1 means a model that is a straight line " + "function; this order needs two parameters. Order 2 means that an additional parabolic function is used in the modelling; " + "order 2 needs therefore 3 parameters. In general an order %p model needs %p+1 parameters.") TAG (U"##Use bandwidths to model formant tracks") -DEFINITION (U"Bandwidths give an indication about the sharpness of a spectral peak. Sharp peaks have small bandwidths and, vice versa, broad peaks have large bandwidths. The width of a peak can also be interpreted as a measure of certainty for its formant frequency value. Setting this option %%on%, the default setting, means that you force the modeling function to be closer to frequencies that are well defined, i.e. that have sharp peaks, than to the frequencies of broad peaks, if choices have to be made. The consequence is that in the model sharp peaks will be better represented than broad peaks.") -TAG (U"##Bandwidths for smoothing test") -DEFINITION (U"determines whether for the smoothnes determination the formant frequencies are still needed. Not using them anymore probably gives a better indication of the smoothness of a track.") +DEFINITION (U"Bandwidths give an indication about the sharpness of a spectral peak. Sharp peaks have small bandwidths and, " + "vice versa, broad peaks have large bandwidths. The width of a peak can also be interpreted as a measure of certainty " + "for its formant frequency value. Setting this option %%on%, the default setting, means that you force the modelling " + "function to be closer to frequencies that are well defined, i.e. that have sharp peaks, than to the frequencies of " + "broad peaks, if choices have to be made. The consequence is that in the model sharp peaks will be better represented than broad peaks.") +TAG (U"##Bandwidths for stress test") +DEFINITION (U"determines whether for the stress determination the formant frequencies are still needed. Not using them anymore " + "probably gives a better indication of the stress of a track.") MAN_END #define PowerCepstrum_manual_pitchRange \ U"determine the limits of the quefrency range where a peak is searched for. The lower quefrency is determined as " \ "1 / %%pitchCeiling% and this value is in general more critical than " \ - "the value of the upper quefrency which equals 1 / %%pitchFloor%. A %%pitchCeiling% of 300 Hz will correspond to a lower quefrency of 1/300\\~~0.0033 seconds." + "the value of the upper quefrency which equals 1 / %%pitchFloor%. A %%pitchCeiling% of 300 Hz will correspond to a " \ + "lower quefrency of 1/300\\~~0.0033 seconds." #define PowerCepstrum_manual_trendRange \ U"the quefrency range for which the amplitudes (in dB) will be modelled by a straight line. " \ @@ -108,7 +221,8 @@ MAN_END #define PowerCepstrum_manual_fitMethod \ U"defines how the line that models the cepstrum backgroud is calculated. The default method is " \ - "@@theil regression|Theil's robust line fit@. However, to be compatible with the past, a standard least squares line fit can also be chosen." + "@@theil regression|Theil's robust line fit@. However, to be compatible with the past, a standard least squares " \ + "line fit can also be chosen." #define PowerCepstrum_manual_quefrencyAveragingWindow \ U"determines how many quefrency bins will be used for the averaging across quefrency step. The number of " \ @@ -129,13 +243,14 @@ MAN_END "The %numberOfFramesToAverage has to be uneven to allow for this symmetric behaviour. " MAN_BEGIN (U"PowerCepstrogram", U"djmw", 20190909) -INTRO (U"One of the @@types of objects@ in P\\s{RAAT}. A cepstrogram represents a time-quefrency representation of a sound. Horizontally it shows time, vertically it shows quefrency while the quefrency power density is shown as shades of grey.") +INTRO (U"One of the @@types of objects@ in P\\s{RAAT}. A cepstrogram represents a time-quefrency representation of a sound. " + "Horizontally it shows time, vertically it shows quefrency while the quefrency power density is shown as shades of grey.") MAN_END MAN_BEGIN (U"PowerCepstrogram: Get CPPS...", U"djmw", 20190910) ENTRY (U"Settings") TAG (U"##Subtract trend before smoothing#") -DEFINITION (U"defines whether the smoothing should be performed om the Cepstrogram after all trend of each PowerCepstrum has been removed. ") +DEFINITION (U"defines whether the smoothing should be performed on the Cepstrogram after all trend of each PowerCepstrum has been removed. ") TAG (U"##Time averaging window (s)#") DEFINITION (PowerCepstrogram_manual_timeAveraging) TAG (U"##Quefrency averaging window (s)#") @@ -161,9 +276,10 @@ SCRIPT (5, Manual_SETTINGS_WINDOW_HEIGHT (7), U"" Manual_DRAW_SETTINGS_WINDOW ("PowerCepstrogram: To Table (peak prominence)", 7) Manual_DRAW_SETTINGS_WINDOW_RANGE("Peak search pitch range (Hz)", U"60.0", U"300.0") Manual_DRAW_SETTINGS_WINDOW_RADIO (U"Interpolation", U"None", 0) - Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"Parabolic", 1) - Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"Cubic", 0) - Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"Sinc70", 0) + Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"parabolic", 1) + Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"cubic", 0) + Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"sinc70", 0) + Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"sinc700", 0) Manual_DRAW_SETTINGS_WINDOW_RANGE("Trend line quefrency range (s)", U"0.001", U"0.05") Manual_DRAW_SETTINGS_WINDOW_OPTIONMENU(U"Trend type", U"Exponential decay") Manual_DRAW_SETTINGS_WINDOW_OPTIONMENU(U"Fit method", U"Robust") @@ -216,8 +332,8 @@ DEFINITION (PowerCepstrogram_manual_timeAveraging) TAG (U"##Quefrency averaging window (s)") DEFINITION (PowerCepstrum_manual_quefrencyAveragingWindow) ENTRY (U"Note") -NORMAL (U"The following commands should reproduce the smoothing described in the @@Hillenbrand & Houde (1996)@ article, where they use a 20 ms " - "(10 frame) time smoothing and a 1 ms (10 bin) quefrency smoothing. ") +NORMAL (U"The following commands should reproduce the smoothing described in the @@Hillenbrand & Houde (1996)@ article, " + "where they use a 20 ms (10 frame) time smoothing and a 1 ms (10 bin) quefrency smoothing. ") CODE (U"selectObject (\"Sound xxx\")") CODE (U"To PowerCepstrogram: 60.0, 0.041, 0.002, 5000.0") CODE (U"Smooth: 0.02, 0.001") @@ -230,10 +346,11 @@ NORMAL (U"A Cepstrum is the log spectrum of the log power spectrum.") MAN_END MAN_BEGIN (U"PowerCepstrum", U"djmw", 20200403) -INTRO (U"One of the @@types of objects@ in P\\s{RAAT}.") +INTRO (U"One of the @@types of objects@ in Praat.") ENTRY (U"Description") NORMAL (U"A PowerCepstrum is the power spectrum of the log power spectrum. When drawn the vertical scale " - "will show the amplitude expressed in dB. The horizontal scale shows %%quefrency% in units of seconds. It is calculated from the ##Spectrum# by a method described at @@Spectrum: To PowerCepstrum@.") + "will show the amplitude expressed in dB. The horizontal scale shows %%quefrency% in units of seconds. " + "It is calculated from the ##Spectrum# by a method described at @@Spectrum: To PowerCepstrum@.") MAN_END MAN_BEGIN (U"PowerCepstrum: Get peak prominence...", U"djmw", 20190912) @@ -246,9 +363,10 @@ SCRIPT (7, Manual_SETTINGS_WINDOW_HEIGHT (7), U"" Manual_DRAW_SETTINGS_WINDOW (U"PowerCepstrum: Get peak prominence", 7) Manual_DRAW_SETTINGS_WINDOW_RANGE("Search peak in pitch range (s)", U"60.0", U"333.3") Manual_DRAW_SETTINGS_WINDOW_RADIO (U"Interpolation", U"None", 0) - Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"Parabolic", 0) - Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"Cubic", 1) - Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"Sinc70", 0) + Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"parabolic", 0) + Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"cubic", 1) + Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"sinc70", 0) + Manual_DRAW_SETTINGS_WINDOW_RADIO (U"", U"sinc700", 0) Manual_DRAW_SETTINGS_WINDOW_RANGE (U"Trend line quefrency range (s)", U"0.001", U"0.0 (= end)") Manual_DRAW_SETTINGS_WINDOW_OPTIONMENU (U"Fit method", U"Robust") ) @@ -270,23 +388,23 @@ CODE (U"Create KlattGrid from vowel: \"a\", 0.3, 125, 800, 80, 1200, 80, 2300, 1 CODE (U"To Sound") CODE (U"To PowerCepstrogram: 60, 0.002, 5000, 50") CODE (U"To PowerCepstrum (slice): 0.1") -CODE (U"prominence = Get peak prominence: 60, 333.3, \"Parabolic\", 0.001, 0.05, \"Straight\", \"Robust slow\"") +CODE (U"prominence = Get peak prominence: 60, 333.3, \"parabolic\", 0.001, 0.05, \"straight\", \"robust slow\"") CODE (U"Text top: \"no\", \"Peak prominence = \" + fixed$ (prominence, 2) + \" dB\"") CODE (U"Draw: 0, 0, 0, 110, \"yes\"") -CODE (U"Colour: \"Blue\"") -CODE (U"Draw trend line: 0, 0, 0, 110, 0.001, 0.05, \"Straight\", \"Robust slow\"") -CODE (U"Colour: \"Black\"") +CODE (U"Colour: \"blue\"") +CODE (U"Draw trend line: 0, 0, 0, 110, 0.001, 0.05, \"straight\", \"robust slow\"") +CODE (U"Colour: \"black\"") CODE (U"Text top: \"no\", \"Peak prominence = \" + fixed$ (prominence, 2) + \" dB\"") SCRIPT (5, 3, U"" "kg = Create KlattGrid from vowel: \"a\", 0.3, 125, 800, 80, 1200, 80, 2300, 100, 2800, 0.1, 1000\n" "vowel = To Sound\n" "cepstrogram = To PowerCepstrogram: 60, 0.002, 5000, 50\n" "cepstrum = To PowerCepstrum (slice): 0.1\n" - "prominence = Get peak prominence: 60, 333.3, \"Parabolic\", 0.001, 0.05, \"Straight\", \"Robust slow\"\n" + "prominence = Get peak prominence: 60, 333.3, \"parabolic\", 0.001, 0.05, \"straight\", \"robust slow\"\n" "Text top: \"no\", \"Peak prominence = \" + fixed$ (prominence, 2) + \" dB\"\n" "Draw: 0, 0, 0, 110, \"yes\"\n" "Colour: \"Blue\"\n" - "Draw trend line: 0, 0, 0, 110, 0.001, 0.05, \"Straight\", \"Robust slow\"\n" + "Draw trend line: 0, 0, 0, 110, 0.001, 0.05, \"straight\", \"robust slow\"\n" "Colour: \"Black\"\n" "Text top: \"no\", \"Peak prominence = \" + fixed$ (prominence, 2) + \" dB\"\n" "removeObject: kg, vowel, cepstrogram, cepstrum\n") @@ -297,11 +415,11 @@ SCRIPT (5, 3, U"" "vowel = To Sound\n" "cepstrogram = To PowerCepstrogram: 60, 0.002, 5000, 50\n" "cepstrum = To PowerCepstrum (slice): 0.1\n" - "prominence = Get peak prominence: 60, 333.3, \"Parabolic\", 0.001, 0.05, \"Exponential decay\", \"Robust slow\"\n" + "prominence = Get peak prominence: 60, 333.3, \"parabolic\", 0.001, 0.05, \"exponential decay\", \"robust slow\"\n" "Text top: \"no\", \"Peak prominence = \" + fixed$ (prominence, 2) + \" dB\"\n" "Draw: 0, 0, 0, 110, \"yes\"\n" "Colour: \"Blue\"\n" - "Draw trend line: 0, 0, 0, 110, 0.001, 0.05, \"Exponential decay\", \"Robust slow\"\n" + "Draw trend line: 0, 0, 0, 110, 0.001, 0.05, \"exponential decay\", \"robust slow\"\n" "Colour: \"Black\"\n" "Text top: \"no\", \"Peak prominence = \" + fixed$ (prominence, 2) + \" dB\"\n" "removeObject: kg, vowel, cepstrogram, cepstrum\n") @@ -470,7 +588,7 @@ NORMAL (U"The intensities at the frequencies of the selected formant are copied MAN_END MAN_BEGIN (U"LFCC", U"djmw", 20040421) -INTRO (U"One of the @@types of objects@ in P\\s{RAAT}.") +INTRO (U"One of the @@types of objects@ in Praat.") NORMAL (U"An object of type LFCC represents cepstral " "coefficients on a linear frequency scale as a function of time. " "The coefficients are represented in frames with constant sampling " @@ -748,11 +866,14 @@ ENTRY (U"Settings") TAG (U"##From coefficient#, ##To coefficient#") DEFINITION (U"the range of coefficients that will be used in the reconstruction.") TAG (U"##Include constant term") -DEFINITION (U"selects whether or not to include the %c__0_ coefficient in the reconstruction. As can be seen from the formula below, the contribution of the %c__0_ term is equal for each filter.") +DEFINITION (U"selects whether or not to include the %c__0_ coefficient in the reconstruction. " + "As can be seen from the formula below, the contribution of the %c__0_ term is equal for each filter.") ENTRY (U"Details") -NORMAL (U"The values %P__%j_ in each frame of the MelSpectrogram will be constructed by applying the inverse Discrete Cosine Transform to the corresponding frame of the MFCC object:") +NORMAL (U"The values %P__%j_ in each frame of the MelSpectrogram will be constructed by " + "applying the inverse Discrete Cosine Transform to the corresponding frame of the MFCC object:") FORMULA (U"%P__%j_ = 2/N (%c__0_/2 + \\Si__%k=1_^^%N-1^ %c__%k_ cos (\\pi%k(%j-0.5)/%N))),") -NORMAL (U"where %N represents the number of filters that were used to get the MFCC object, %j runs from 1 to %N, and coefficients %c__%k_ with %k less than " +NORMAL (U"where %N represents the number of filters that were used to get the MFCC object, %j runs from 1 to %N, " + "and coefficients %c__%k_ with %k less than " "%%fromCoefficient% and %k larger than %%toCoefficient% take zero values in the evaluation.") MAN_END @@ -760,9 +881,11 @@ MAN_BEGIN (U"Sound: To PowerCepstrogram...", U"djmw", 20200403) INTRO (U"A command that creates a @@PowerCepstrogram@ from every selected @@Sound@.") ENTRY (U"Settings") TAG (U"##Pitch floor (Hz)") -DEFINITION (U"determines the effective length of the analysis window as three periods of this pitch, i.e. if the pitch floor is 60 Hz, the analysis window will be 3/60 = 0.05 seconds long.") +DEFINITION (U"determines the effective length of the analysis window as three periods of this pitch, " + "e.g. if the pitch floor is 60 Hz, the analysis window will be 3/60 = 0.05 seconds long.") TAG (U"##Time step (s)") -DEFINITION (U"defines the distance between the centres of subsequent frames. This determines the number of frames in the resulting PowerCepstrogram.") +DEFINITION (U"defines the distance between the centres of subsequent frames. This determines the number of frames " + "in the resulting PowerCepstrogram.") TAG (U"##Maximum frequency (Hz)") DEFINITION (U"the maximum frequency subject to analysis.") TAG (U"##Pre-emphasis from (Hz)") @@ -770,14 +893,15 @@ ENTRY (U"Algorithm") NORMAL (U"The sound will first be resampled to twice the value of the %%Maximum frequency%, with " "the algorithm described at @@Sound: Resample...@. After this, pre-emphasis is applied with the " "algorithm described at @@Sound: Pre-emphasize (in-place)...@. For each analysis window a Gaussian " - "window is applied and the ##Spectrum# is calculated. The Spectrum is then transformed to a ##PowerCepstrum# with the procedure described at @@Spectrum: To PowerCepstrum@. Finally the values from the PowerCepstrum are stored in the vertical slice of the PowerCepstrogram.") - + "window is applied and the ##Spectrum# is calculated. " + "The Spectrum is then transformed to a ##PowerCepstrum# with the procedure described at @@Spectrum: To PowerCepstrum@. " + "Finally, the values from the PowerCepstrum are stored in the vertical slice of the PowerCepstrogram.") MAN_END MAN_BEGIN (U"Sound: To Formant (robust)...", U"djmw", 20111027) INTRO (U"A command that creates a @@Formant@ object from every selected @@Sound@. ") ENTRY (U"Settings") -NORMAL (U"The settings for ##Time step (s)#, ##Maximum number of formants#, ##Maximum formant (Hz), " +NORMAL (U"The settings for ##Time step (s)#, ##Maximum number of formants#, ##Formant ceiling (Hz), " "##Window length (s)# and ##Pre emphasis from (Hz)# are as in @@Sound: To Formant (burg)...@. " " The following settings determine aspects of the iterative formant frequency refinement.") TAG (U"%%Number of std. dev.%,") @@ -789,7 +913,10 @@ DEFINITION (U"detemines another stop ctriterion for the refinement step. If the "between successive iterations is less then this value, iteration stops. Iteration stops whenever " "one of the two defined stop criteria is reached.") ENTRY (U"Algorithm") -NORMAL (U"First the sound is downsampled to twice the maximum formant frequency. Next the LPC coefficients are determined by the autocorrelation method. Finally, in an iterative procedure as described by @@Lee (1988)@ the formant frequencies and bandwidths are refined by selectively weighting of samples values.") +NORMAL (U"First the sound is downsampled to twice the maximum formant frequency. " + "Next, the LPC coefficients are determined by the autocorrelation method. " + "Finally, in an iterative procedure as described by @@Lee (1988)@, " + "the formant frequencies and bandwidths are refined by selective weighting of samples values.") MAN_END MAN_BEGIN (U"Sound: LPC analysis", U"djmw", 19970126) @@ -888,22 +1015,26 @@ NORMAL (U"The new spectrum %X\\'p(%f) is then transformed to a Sound %x(%t) by m MAN_END MAN_BEGIN (U"VocalTractTier", U"djmw", 20120423) -INTRO (U"One of the @@types of objects@ in Praat. A VocalTractTier objects contains a number of (%%time%, %%VocalTract%) points, where a @@VocalTract@ represents the area function of the vocal tract expressed as m^^2^, running from the glottis to the lips.") +INTRO (U"One of the @@types of objects@ in Praat. A VocalTractTier objects contains a number of (%%time%, %%VocalTract%) " + "points, where a @@VocalTract@ represents the area function of the vocal tract expressed as m^^2^, running from the glottis to the lips.") MAN_END MAN_BEGIN (U"theil regression", U"djmw", 20190909) NORMAL (U"a robust linear regression method, first proposed by @@Theil (1950)@. The slope of the regression line is estimated as " "the median of all pairwise slopes between each pair of points in the data set. Because this number of pairs increases quadratically " - "with the number of data points, we have implemented a somewhat less computationally intensive procedure, the %%incomplete% theil regression. In the incomplete method we first split the data set of %N data points (%x__%i_, %y__%i_), %i = 1..%N, in two equal sets " - "of size %N/2 and then calculate %N/2 slopes as ") + "with the number of data points, we have implemented a somewhat less computationally intensive procedure, the %%incomplete% " + "theil regression. In the incomplete method we first split the data set of %N data points (%x__%i_, %y__%i_), %i = 1..%N, " + "in two equal sets of size %N/2 and then calculate %N/2 slopes as ") FORMULA (U"%m__%i_ = (%y__%N/2+%i_ - %y__%i_) / (%x__%N/2+%i_ - %x__%i_), for %i = 1..%N/2.") NORMAL (U"The regression slope %m is calculated as the median of these %N/2 values %m__%i_.") NORMAL (U"Given the slope %m, the offset %b is calculated as the median of the %N values %b__%i_= %y__%i_ - %m\\.c%x__%i_.") -NORMAL (U"The theil regression has a breakdown point of 29.3\\% , which means that it can tolerate arbitrary corruption of up to 29.3\\% of the input data-points without degradation of its accuracy") +NORMAL (U"The theil regression has a breakdown point of 29.3\\% , which means that it can tolerate arbitrary corruption of up to " + "29.3\\% of the input data-points without degradation of its accuracy") MAN_END MAN_BEGIN (U"Ammar et al. (2001)", U"djmw", 20200416) -NORMAL (U"G.S. Ammar, D. Calvetti, W.B. Gragg, L. Reichel (2001): \"Polynomial zero finders based on Szegö polynomials\", %%Journal of Computational and Applied Mathematics% #127: 1\\-–16.") +NORMAL (U"G.S. Ammar, D. Calvetti, W.B. Gragg, L. Reichel (2001): \"Polynomial zero finders based on Szegö polynomials\", " + "%%Journal of Computational and Applied Mathematics% #127: 1\\-–16.") MAN_END MAN_BEGIN (U"Anderson (1978)", U"djmw", 20030701) @@ -913,7 +1044,8 @@ NORMAL (U"N. Anderson (1978): \"On the calculation of filter coefficients for " MAN_END MAN_BEGIN (U"Fleisher et al. (2015)", U"djmw", 20191008) -NORMAL (U"M. Fleisher, S. Pinkert, W. Mattheus, A. Mainka & D. Mürbe (2015): \"Formant frequencies and bandwidths of the vocal transfer function are affected by the mechanical impedance of the vocal tract wall.\", %%Biomech Model Mechanobiol% #14: 719\\--733.") +NORMAL (U"M. Fleisher, S. Pinkert, W. Mattheus, A. Mainka & D. Mürbe (2015): \"Formant frequencies and bandwidths of the vocal " + "transfer function are affected by the mechanical impedance of the vocal tract wall.\", %%Biomech Model Mechanobiol% #14: 719\\--733.") MAN_END MAN_BEGIN (U"Hawks & Miller (1995)", U"djmw", 20191008) @@ -922,11 +1054,13 @@ NORMAL (U"J. Hawks & J. Miller (1995): \"A formant bandwidth estimation procedu MAN_END MAN_BEGIN (U"Hillenbrand et al. (1994)", U"djmw", 20121017) -NORMAL (U"J. Hillenbrand, R.A. Cleveland & R.L. Erickson (1994): \"Acoustic correlates of breathy vocal quality\", %%Journal of speech and hearing research% #37: 769\\--778.") +NORMAL (U"J. Hillenbrand, R.A. Cleveland & R.L. Erickson (1994): \"Acoustic correlates of breathy vocal quality\", " + "%%Journal of speech and hearing research% #37: 769\\--778.") MAN_END MAN_BEGIN (U"Hillenbrand & Houde (1996)", U"djmw", 20121203) -NORMAL (U"J. Hillenbrand & R.A. Houde (1996): \"Acoustic correlates of breathy vocal quality: Dysphonic voices and continuous speech\", %%Journal of speech and hearing research% #39: 311\\--321.") +NORMAL (U"J. Hillenbrand & R.A. Houde (1996): \"Acoustic correlates of breathy vocal quality: Dysphonic voices and continuous " + "speech\", %%Journal of speech and hearing research% #39: 311\\--321.") MAN_END @@ -960,6 +1094,11 @@ NORMAL (U"H. Wakita (1977): \"Normalization of vowels by vocal-tract " "#25: 183\\--192.") MAN_END +MAN_BEGIN (U"Weenink (2015)", U"djmw", 20200514) +NORMAL (U"D. Weenink (2015): \"Improved formant frequency measurements of short segments\", " + "%%Proceedings of the 18th International Congress of Phonetic Sciences%, Brighton. ") +MAN_END + } /* End of file manual_LPC.cpp */ diff --git a/LPC/praat_LPC_init.cpp b/LPC/praat_LPC_init.cpp index 9d6f7809..8bc9558f 100644 --- a/LPC/praat_LPC_init.cpp +++ b/LPC/praat_LPC_init.cpp @@ -33,6 +33,9 @@ #include "DTW.h" #include "FilterBank.h" #include "Formant_extensions.h" +#include "FormantPath.h" +#include "FormantPathEditor.h" +#include "IntervalTierNavigator.h" #include "LPC.h" #include "MFCC.h" #include "LFCC.h" @@ -67,6 +70,174 @@ static const conststring32 MODIFY_BUTTON = U"Modify -"; void praat_CC_init (ClassInfo klas); void praat_TimeFrameSampled_query_init (ClassInfo klas); +static void cb_FormantPathEditor_publication (Editor /* editor */, autoDaata publication) { + /* + * Keep the gate for error handling. + */ + try { + praat_new (publication.move()); + praat_updateSelection (); + } catch (MelderError) { + Melder_flushError (); + } +} + +DIRECT (WINDOW_FormantPath_viewAndEditAlone) { + if (theCurrentPraatApplication -> batch) + Melder_throw (U"Cannot view or edit a Formant from batch."); + FIND_ONE_WITH_IOBJECT (FormantPath) + autoFormantPathEditor editor = FormantPathEditor_create (ID_AND_FULL_NAME, me, nullptr, nullptr); + Editor_setPublicationCallback (editor.get(), cb_FormantPathEditor_publication); + praat_installEditor (editor.get(), IOBJECT); + editor.releaseToUser(); + END +} + +DIRECT (HINT_FormantPath_Sound_viewAndEdit) { + INFO_NONE + Melder_information (U"To include a Sound in your FormantPath window:\n" + "select a FormantPath and a Sound, and click \"View & Edit\"."); + INFO_NONE_END +} + +FORM (GRAPHICS_FormantPath_drawAsGrid, U"FormantPath: Draw as grid", nullptr) { + REAL (tmin, U"left Time range (s)", U"0.0") + REAL (tmax, U"right Time range (s)", U"0.1") + POSITIVE (fmax, U"Maximum frequency", U"6200.0") + NATURAL (fromFormant, U"left Formant range", U"1") + NATURAL (toFormant, U"right Formant range", U"5") + BOOLEAN (showBandwidths, U"Show bandwidths", true) + COLOUR (odd, U"Colour of F1, F3, F5", U"red") + COLOUR (even, U"Colour of F2, F4", U"purple") + INTEGER (numberOfRows, U"Number of rows", U"0") + INTEGER (numberOfColumns, U"Number of columns", U"0") + POSITIVE (xSpaceFraction, U"X space fraction", U"0.1") + POSITIVE (ySpaceFraction, U"Y space fraction", U"0.1") + POSITIVE (lineEvery_Hz, U"Horizontal line every (Hz)", U"1000.0") + REAL (xCursor, U"X cursor line at (s)", U"-0.1 (=no line)") + REAL (yCursor, U"Y cursor at (Hz)", U"-100.0 (=no line)") + INTEGER (special, U"Index of special", U"0 (=no)") + COLOUR (specialColour, U"Colour for special", U"pink") + SENTENCE (parameters_string, U"Coefficients by track", U"7 7 7 7") + BOOLEAN (markWithinPath, U"Mark within path", false) + BOOLEAN (showStress, U"Show stress", true) + POSITIVE (powerf, U"Power", U"1.25") + BOOLEAN (showEstimatedModels, U"Show estimated models", true) + BOOLEAN (garnish, U"Garnish", true) + OK +DO + GRAPHICS_EACH (FormantPath) + autoINTVEC parameters = newINTVECfromString (parameters_string); + FormantPath_drawAsGrid (me, GRAPHICS, tmin, tmax, fmax, fromFormant, toFormant, showBandwidths, odd, even, numberOfRows, numberOfColumns, xSpaceFraction, ySpaceFraction, lineEvery_Hz, xCursor, yCursor, special, specialColour, parameters.get(), markWithinPath, showStress, powerf, showEstimatedModels, garnish); + GRAPHICS_EACH_END +} + +FORM (NEW_FormantPath_to_Matrix_stress, U"FormantPath: To Matrix (stress)", nullptr) { + POSITIVE (windowLength, U"Window length", U"0.025") + SENTENCE (parameters_string, U"Coefficients by track", U"3 3 3 3") + POSITIVE (powerf, U"Power", U"1.25") + OK +DO + CONVERT_EACH (FormantPath) + autoINTVEC parameters = newINTVECfromString (parameters_string); + autoMatrix result = FormantPath_to_Matrix_stress (me, windowLength, parameters.get (), powerf); + CONVERT_EACH_END (my name.get()) +} + +DIRECT (NEW_FormantPath_to_Matrix_qsum) { + CONVERT_EACH (FormantPath) + autoMatrix result = FormantPath_to_Matrix_qSums (me, 0.0); + CONVERT_EACH_END (my name.get()) +} + +FORM (NEW_FormantPath_to_Matrix_transition, U"FormantPath: To Matrix (transition)", nullptr) { + BOOLEAN (maximumCosts, U"Maximum costs", false) + OK +DO + CONVERT_EACH (FormantPath) + autoMatrix result = FormantPath_to_Matrix_transition (me, maximumCosts); + CONVERT_EACH_END (my name.get()) +} + +FORM (NEW_FormantPath_to_Matrix_deltas, U"FormantPath: To Matrix (deltas)", nullptr) { + LABEL (U"Within frame:") + REAL (qWeight, U"F/B weight (0-1)", U"1.0") + LABEL (U"Between frames:") + REAL (frequencyChangeWeight, U"Frequency change weight (0-1)", U"1.0") + REAL (stressWeight, U"Stress weight (0-1)", U"1.0") + REAL (ceilingChangeWeight, U"Ceiling change weight (0-1)", U"1.0") + POSITIVE (intensityModulationStepSize, U"Intensity modulation step size (dB)", U"5.0") + LABEL (U"Global stress parameters:") + POSITIVE (windowLength, U"Window length", U"0.035") + SENTENCE (parameters_string, U"Coefficients by track", U"3 3 3 3") + POSITIVE (powerf, U"Power", U"1.25") + OK +DO + CONVERT_EACH (FormantPath) + autoMatrix result; + Melder_require (qWeight >= 0 && qWeight <= 1.0 && + frequencyChangeWeight >= 0 && frequencyChangeWeight <= 1.0 && + stressWeight >= 0 && stressWeight <= 1.0 && + ceilingChangeWeight >= 0 && ceilingChangeWeight <= 1.0, + U"A weight should greater or equal 0.0 and smaller or equal 1.0."); + autoINTVEC parameters = newINTVECfromString (parameters_string); + autoINTVEC path = FormantPath_getOptimumPath (me, qWeight, frequencyChangeWeight, stressWeight, ceilingChangeWeight, windowLength, intensityModulationStepSize, parameters.get(), powerf, & result); + CONVERT_EACH_END (my name.get()) +} + +FORM (MODIFY_FormantPath_pathFinder, U"FormantPath: Path finder", nullptr) { + LABEL (U"Within frame:") + REAL (qWeight, U"F/B weight (0-1)", U"1.0") + LABEL (U"Between frames:") + REAL (frequencyChangeWeight, U"Frequency change weight (0-1)", U"1.0") + REAL (stressWeight, U"Stress weight (0-1)", U"1.0") + REAL (ceilingChangeWeight, U"Ceiling change weight (0-1)", U"1.0") + POSITIVE (intensityModulationStepSize, U"Intensity modulation step size (dB)", U"5.0") + LABEL (U"Global stress parameters:") + POSITIVE (windowLength, U"Window length", U"0.035") + SENTENCE (parameters_string, U"Coefficients by track", U"3 3 3 3") + POSITIVE (powerf, U"Power", U"1.25") + OK +DO + MODIFY_EACH (FormantPath) + Melder_require (qWeight >= 0 && qWeight <= 1.0 && + frequencyChangeWeight >= 0 && frequencyChangeWeight <= 1.0 && + stressWeight >= 0 && stressWeight <= 1.0 && + ceilingChangeWeight >= 0 && ceilingChangeWeight <= 1.0, + U"A weight should be greater than or equal to 0.0 and smaller than or equal to 1.0."); + autoINTVEC parameters = newINTVECfromString (parameters_string); + FormantPath_pathFinder (me, qWeight, frequencyChangeWeight, stressWeight, ceilingChangeWeight, intensityModulationStepSize, windowLength, parameters.get(), powerf); + MODIFY_EACH_END +} + +DIRECT (NEW_FormantPath_extractFormant) { + CONVERT_EACH (FormantPath) + autoFormant result = FormantPath_extractFormant (me); + CONVERT_EACH_END (my name.get()) +} + +DIRECT (WINDOW_Sound_TextGrid_FormantPath_createFormantPathEditor) { + if (theCurrentPraatApplication -> batch) + Melder_throw (U"Cannot view or edit a Formant from batch."); + FIND_THREE_WITH_IOBJECT (FormantPath, Sound, TextGrid) + autoFormantPathEditor editor = FormantPathEditor_create (ID_AND_FULL_NAME, me, you, him); + Editor_setPublicationCallback (editor.get(), cb_FormantPathEditor_publication); + praat_installEditor (editor.get(), IOBJECT); + editor.releaseToUser(); + END +} + +DIRECT (WINDOW_Sound_FormantPath_createFormantPathEditor) { + if (theCurrentPraatApplication -> batch) + Melder_throw (U"Cannot view or edit a Formant from batch."); + FIND_TWO_WITH_IOBJECT (FormantPath, Sound) + autoFormantPathEditor editor = FormantPathEditor_create (ID_AND_FULL_NAME, me, you, nullptr); + Editor_setPublicationCallback (editor.get(), cb_FormantPathEditor_publication); + praat_installEditor (editor.get(), IOBJECT); + editor.releaseToUser(); + END +} + /********************** Cepstrum ****************************************/ DIRECT (NEW_Cepstrum_downto_PowerCepstrum) { @@ -133,32 +304,26 @@ DO FORM (REAL_PowerCepstrum_getPeak, U"PowerCepstrum: Get peak", U"PowerCepstrum: Get peak...") { REAL (fromPitch, U"left Search peak in pitch range (Hz)", U"60.0") REAL (toPitch, U"right Search peak in pitch range (Hz)", U"333.3") - RADIO (interpolationMethod, U"Interpolation", 2) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation :: PARABOLIC) OK DO NUMBER_ONE (PowerCepstrum) double result; - PowerCepstrum_getMaximumAndQuefrency (me, fromPitch, toPitch, interpolationMethod - 1, & result, nullptr); + PowerCepstrum_getMaximumAndQuefrency (me, fromPitch, toPitch, peakInterpolationType, & result, nullptr); NUMBER_ONE_END (U" dB") } FORM (REAL_PowerCepstrum_getQuefrencyOfPeak, U"PowerCepstrum: Get quefrency of peak", U"PowerCepstrum: Get quefrency of peak...") { REAL (fromPitch, U"left Search peak in pitch range (Hz)", U"60.0") REAL (toPitch, U"right Search peak in pitch range (Hz)", U"333.3") - RADIO (interpolationMethod, U"Interpolation", 2) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation :: PARABOLIC) OK DO NUMBER_ONE (PowerCepstrum) double result; - PowerCepstrum_getMaximumAndQuefrency (me, fromPitch, toPitch, interpolationMethod - 1, nullptr, & result); + PowerCepstrum_getMaximumAndQuefrency (me, fromPitch, toPitch, peakInterpolationType, nullptr, & result); double f = 1.0 / result; NUMBER_ONE_END (U" s (f =", f, U" Hz)") } @@ -214,11 +379,8 @@ DO FORM (REAL_PowerCepstrum_getPeakProminence, U"PowerCepstrum: Get peak prominence", U"PowerCepstrum: Get peak prominence...") { REAL (fromPitch, U"left Search peak in pitch range (Hz)", U"60.0") REAL (toPitch, U"right Search peak in pitch range (Hz)", U"333.3") - RADIO (interpolationMethod, U"Interpolation", 2) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation :: PARABOLIC) REAL (fromQuefrency_trendLine, U"left Trend line quefrency range (s)", U"0.001") REAL (toQuefrency_trendLine, U"right Trend line quefrency range (s)", U"0.05") OPTIONMENU_ENUM (kCepstrumTrendType, lineType, U"Trend type", kCepstrumTrendType::DEFAULT) @@ -227,7 +389,7 @@ FORM (REAL_PowerCepstrum_getPeakProminence, U"PowerCepstrum: Get peak prominence DO NUMBER_ONE (PowerCepstrum) double qpeak; - const double result = PowerCepstrum_getPeakProminence (me, fromPitch, toPitch, interpolationMethod - 1, fromQuefrency_trendLine, toQuefrency_trendLine, lineType, fitMethod, & qpeak); + const double result = PowerCepstrum_getPeakProminence (me, fromPitch, toPitch, peakInterpolationType, fromQuefrency_trendLine, toQuefrency_trendLine, lineType, fitMethod, & qpeak); NUMBER_ONE_END (U" dB; quefrency=", qpeak, U" s (f=", 1.0 / qpeak, U" Hz)."); } @@ -403,11 +565,8 @@ FORM (REAL_PowerCepstrogram_getCPPS, U"PowerCepstrogram: Get CPPS", U"PowerCepst REAL (fromPitch, U"left Peak search pitch range (Hz)", U"60.0") REAL (toPitch, U"right Peak search pitch range (Hz)", U"330.0") POSITIVE (tolerance, U"Tolerance (0-1)", U"0.05") - RADIO (interpolationMethod, U"Interpolation", 2) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation :: PARABOLIC) LABEL (U"Trend line:") REAL (fromQuefrency_trendLine, U"left Trend line quefrency range (s)", U"0.001") REAL (toQuefrency_trendLine, U"right Trend line quefrency range (s)", U"0.05") @@ -416,7 +575,7 @@ FORM (REAL_PowerCepstrogram_getCPPS, U"PowerCepstrogram: Get CPPS", U"PowerCepst OK DO NUMBER_ONE (PowerCepstrogram) - const double result = PowerCepstrogram_getCPPS (me, subtractTrendBeforeSmoothing, smoothingWindowDuration, quefrencySmoothingWindowDuration, fromPitch, toPitch, tolerance, interpolationMethod - 1, fromQuefrency_trendLine, toQuefrency_trendLine, lineType, fitMethod); + const double result = PowerCepstrogram_getCPPS (me, subtractTrendBeforeSmoothing, smoothingWindowDuration, quefrencySmoothingWindowDuration, fromPitch, toPitch, tolerance, peakInterpolationType, fromQuefrency_trendLine, toQuefrency_trendLine, lineType, fitMethod); NUMBER_ONE_END (U" dB"); } @@ -446,11 +605,8 @@ FORM (NEW_PowerCepstrogram_to_Table_cpp, U"PowerCepstrogram: To Table (peak prom REAL (fromPitch, U"left Peak search pitch range (Hz)", U"60.0") REAL (toPitch, U"right Peak search pitch range (Hz)", U"330.0") POSITIVE (tolerance, U"Tolerance (0-1)", U"0.05") - RADIO (interpolationMethod, U"Interpolation", 2) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation :: PARABOLIC) REAL (fromQuefrency_trendLine, U"left Trend line quefrency range (s)", U"0.001") REAL (toQuefrency_trendLine, U"right Trend line quefrency range (s)", U"0.05)") OPTIONMENU_ENUM (kCepstrumTrendType, lineType, U"Trend type", kCepstrumTrendType::DEFAULT) @@ -458,7 +614,7 @@ FORM (NEW_PowerCepstrogram_to_Table_cpp, U"PowerCepstrogram: To Table (peak prom OK DO CONVERT_EACH (PowerCepstrogram) - autoTable result = PowerCepstrogram_to_Table_cpp (me, fromPitch, toPitch, tolerance, interpolationMethod - 1, fromQuefrency_trendLine, toQuefrency_trendLine, lineType, fitMethod); + autoTable result = PowerCepstrogram_to_Table_cpp (me, fromPitch, toPitch, tolerance, peakInterpolationType, fromQuefrency_trendLine, toQuefrency_trendLine, lineType, fitMethod); CONVERT_EACH_END (my name.get(), U"_cpp"); } @@ -822,7 +978,7 @@ DO FORM (NEW_Sound_to_Formant_robust, U"Sound: To Formant (robust)", U"Sound: To Formant (robust)...") { REAL (timeStep, U"Time step (s)", U"0.0 (= auto)") POSITIVE (maximumNumberOfFormants, U"Max. number of formants", U"5.0") - REAL (maximumFormantFrequency, U"Maximum formant (Hz)", U"5500.0 (= adult female)") + REAL (middleCeiling, U"Formant ceiling (Hz)", U"5500.0 (= adult female)") POSITIVE (windowLength, U"Window length (s)", U"0.025") POSITIVE (preEmphasisFrequency, U"Pre-emphasis from (Hz)", U"50.0") POSITIVE (numberOfStandardDeviations, U"Number of std. dev.", U"1.5") @@ -831,10 +987,57 @@ FORM (NEW_Sound_to_Formant_robust, U"Sound: To Formant (robust)", U"Sound: To Fo OK DO CONVERT_EACH (Sound) - autoFormant result = Sound_to_Formant_robust (me, timeStep, maximumNumberOfFormants, maximumFormantFrequency, windowLength, preEmphasisFrequency, 50.0, numberOfStandardDeviations, maximumNumberOfIterations, tolerance, 1); + autoFormant result = Sound_to_Formant_robust (me, timeStep, maximumNumberOfFormants, middleCeiling, windowLength, preEmphasisFrequency, 50.0, numberOfStandardDeviations, maximumNumberOfIterations, tolerance, 1); CONVERT_EACH_END (my name.get()) } +FORM (NEW_Sound_to_FormantPath, U"Sound: To FormantPath", nullptr) { + REAL (timeStep, U"Time step (s)", U"0.005") + POSITIVE (maximumNumberOfFormants, U"Max. number of formants", U"5.0") + REAL (middleFormantCeiling, U"Middle formant ceiling (Hz)", U"5500.0 (= adult female)") + POSITIVE (windowLength, U"Window length (s)", U"0.025") + POSITIVE (preEmphasisFrequency, U"Pre-emphasis from (Hz)", U"50.0") + OPTIONMENU_ENUM (kLPC_Analysis, lpcModel, U"LPC model", kLPC_Analysis::DEFAULT) + LABEL (U"The maximum and minimum ceilings are determined as:") + LABEL (U" middleFormantCeiling * exp(+/- ceilingStepSize * numberOfStepsToACeiling).") + POSITIVE (ceilingStepSize, U"Ceiling step size", U"0.05") + NATURAL (numberOfStepsToACeiling, U"Number of steps up / down", U"4") + LABEL (U"For Marple analysis:") + POSITIVE (marple_tol1, U"Tolerance 1", U"1e-6") + POSITIVE (marple_tol2, U"Tolerance 2", U"1e-6") + LABEL (U"For Robust analysis:") + POSITIVE (huber_numberOfStdDev, U"Number of std. dev.", U"1.5") + NATURAL (huber_maximumNumberOfIterations, U"Maximum number of iterations", U"5") + REAL (huber_tolerance, U"Tolerance", U"0.000001") + BOOLEAN (sourcesAsMultichannel, U"Get sources as multi channel sound", false) + OK +DO + CONVERT_EACH (Sound) + autoSound multichannel; + autoFormantPath result = Sound_to_FormantPath_any (me, lpcModel, timeStep, maximumNumberOfFormants, middleFormantCeiling, windowLength, preEmphasisFrequency, ceilingStepSize, numberOfStepsToACeiling, marple_tol1, marple_tol2, huber_numberOfStdDev, huber_tolerance, huber_maximumNumberOfIterations, + ( sourcesAsMultichannel ? & multichannel : nullptr )); + if (sourcesAsMultichannel) + praat_new (multichannel.move(), my name.get(), U"_sources"); + CONVERT_EACH_END (my name.get()) +} + +FORM (NEW_Sound_to_FormantPath_burg, U"Sound: To FormantPath (Burg method)", U"Sound: To FormantPath (burg)...") { + REAL (timeStep, U"Time step (s)", U"0.005") + POSITIVE (maximumNumberOfFormants, U"Max. number of formants", U"5.0") + REAL (middleFormantCeiling, U"Middle formant ceiling (Hz)", U"5500.0 (= adult female)") + POSITIVE (windowLength, U"Window length (s)", U"0.025") + POSITIVE (preEmphasisFrequency, U"Pre-emphasis from (Hz)", U"50.0") + LABEL (U"The maximum and minimum ceilings are determined as:") + LABEL (U" middleCeiling * exp(+/- ceilingStepSize * numberOfStepsToACeiling).") + POSITIVE (ceilingStepSize, U"Ceiling step size", U"0.05") + NATURAL (numberOfStepsToACeiling, U"Number of steps up / down", U"4") + OK +DO + CONVERT_EACH (Sound) + autoFormantPath result = Sound_to_FormantPath_burg (me, timeStep, maximumNumberOfFormants, middleFormantCeiling, windowLength, preEmphasisFrequency, ceilingStepSize, numberOfStepsToACeiling); + CONVERT_EACH_END (my name.get()) +} + #define Sound_to_LPC_addWarning \ LABEL (U"Warning 1: for formant analysis, use \"To Formant\" instead.") \ LABEL (U"Warning 2: if you do use \"To LPC\", you may want to resample first.") \ @@ -851,7 +1054,7 @@ FORM (NEW_Sound_to_LPC_autocorrelation, U"Sound: To LPC (autocorrelation)", U"So DO preEmphasisFrequency = preEmphasisFrequency < 0.0 ? 0.0 : preEmphasisFrequency; CONVERT_EACH (Sound) - autoLPC result = Sound_to_LPC_auto (me, predictionOrder, windowLength, timeStep, preEmphasisFrequency); + autoLPC result = Sound_to_LPC_autocorrelation (me, predictionOrder, windowLength, timeStep, preEmphasisFrequency); CONVERT_EACH_END (my name.get()) } @@ -865,7 +1068,7 @@ FORM (NEW_Sound_to_LPC_covariance, U"Sound: To LPC (covariance)", U"Sound: To LP DO preEmphasisFrequency = preEmphasisFrequency < 0.0 ? 0.0 : preEmphasisFrequency; CONVERT_EACH (Sound) - autoLPC result = Sound_to_LPC_covar (me, predictionOrder, windowLength, timeStep, preEmphasisFrequency); + autoLPC result = Sound_to_LPC_covariance (me, predictionOrder, windowLength, timeStep, preEmphasisFrequency); CONVERT_EACH_END (my name.get()) } @@ -1047,8 +1250,10 @@ extern void praat_TimeTier_query_init (ClassInfo klas); extern void praat_TimeTier_modify_init (ClassInfo klas); void praat_uvafon_LPC_init (); void praat_uvafon_LPC_init () { - Thing_recognizeClassesByName (classCepstrumc, classPowerCepstrum, classCepstrogram, classPowerCepstrogram, classLPC, classLFCC, classLineSpectralFrequencies, classMFCC, classVocalTractTier, nullptr); - + Thing_recognizeClassesByName (classCepstrumc, classPowerCepstrum, classCepstrogram, classFormantPath, classFormantPathEditor, classPowerCepstrogram, classLPC, classLFCC, classLineSpectralFrequencies, classMFCC, classVocalTractTier, nullptr); + + structFormantPathEditor :: f_preferences (); + praat_addAction1 (classPowerCepstrum, 0, U"PowerCepstrum help", 0, 0, HELP_PowerCepstrum_help); praat_addAction1 (classPowerCepstrum, 0, U"Draw...", 0, 0, GRAPHICS_PowerCepstrum_draw); praat_addAction1 (classPowerCepstrum, 0, U"Draw trend line...", 0, 0, GRAPHICS_PowerCepstrum_drawTrendLine); @@ -1115,9 +1320,18 @@ void praat_uvafon_LPC_init () { praat_addAction1 (classFormant, 0, U"To LPC...", 0, 0, NEW_Formant_to_LPC); praat_addAction1 (classFormant, 0, U"Formula...", U"Formula (bandwidths)...", 1, MODIFY_Formant_formula); praat_addAction2 (classFormant, 1, classSpectrogram, 1, U"To IntensityTier...", 0, 0, NEW1_Formant_Spectrogram_to_IntensityTier); - - + praat_addAction1 (classFormantPath, 1, U"View & Edit alone", 0, 0, WINDOW_FormantPath_viewAndEditAlone); + praat_addAction1 (classFormantPath, 1, U"View & Edit with Sound?", 0, 0, HINT_FormantPath_Sound_viewAndEdit); + praat_addAction1 (classFormantPath, 1, U"Draw as grid...", 0, 0, GRAPHICS_FormantPath_drawAsGrid); + praat_addAction1 (classFormantPath, 0, U"Query -", nullptr, 0, nullptr); + praat_addAction1 (classFormantPath, 0, U"Extract Formant", 0, 0, NEW_FormantPath_extractFormant); + praat_addAction1 (classFormantPath, 0, U"To Matrix (stress)...", 0, 0, NEW_FormantPath_to_Matrix_stress); + praat_addAction1 (classFormantPath, 0, U"To Matrix (qsum)...", 0, 0, NEW_FormantPath_to_Matrix_qsum); + praat_addAction1 (classFormantPath, 0, U"To Matrix (transition)...", 0, 0, NEW_FormantPath_to_Matrix_transition); + praat_addAction1 (classFormantPath, 0, U"To Matrix (deltas)...", 0, 0, NEW_FormantPath_to_Matrix_deltas); + praat_addAction1 (classFormantPath, 0, U"Path finder...", 0, 0, MODIFY_FormantPath_pathFinder); + praat_addAction1 (classLFCC, 0, U"LFCC help", 0, 0, HELP_LFCC_help); praat_CC_init (classLFCC); praat_addAction1 (classLFCC, 0, U"To LPC...", 0, 0, NEW_LFCC_to_LPC); @@ -1163,7 +1377,7 @@ void praat_uvafon_LPC_init () { praat_addAction1 (classLPC, 0, U"To LFCC...", 0, 0, NEW_LPC_to_LFCC); praat_addAction1 (classLPC, 0, U"To Spectrogram...", 0, 0, NEW_LPC_to_Spectrogram); praat_addAction1 (classLPC, 0, U"To LineSpectralFrequencies...", 0, 0, NEW_LPC_to_LineSpectralFrequencies); - + praat_addAction2 (classLPC, 1, classSound, 1, U"Analyse", 0, 0, 0); praat_addAction2 (classLPC, 1, classSound, 1, U"Filter...", 0, 0, NEW1_LPC_Sound_filter); praat_addAction2 (classLPC, 1, classSound, 1, U"Filter (inverse)", 0, 0, NEW1_LPC_Sound_filterInverse); @@ -1171,15 +1385,19 @@ void praat_uvafon_LPC_init () { praat_addAction2 (classLPC, 1, classSound, 1, U"Filter with filter at time...", 0, 0, NEW1_LPC_Sound_filterWithFilterAtTime); praat_addAction2 (classLPC, 1, classSound, 1, U"Filter (inverse) with filter at time...", 0, 0, NEW1_LPC_Sound_filterInverseWithFilterAtTime); - - praat_addAction1 (classSound, 0, U"To LPC (autocorrelation)...", U"To Formant (sl)...", 1, NEW_Sound_to_LPC_autocorrelation); - praat_addAction1 (classSound, 0, U"To LPC (covariance)...", U"To LPC (autocorrelation)...", 1, NEW_Sound_to_LPC_covariance); - praat_addAction1 (classSound, 0, U"To LPC (burg)...", U"To LPC (covariance)...", 1, NEW_Sound_to_LPC_burg); - praat_addAction1 (classSound, 0, U"To LPC (marple)...", U"To LPC (burg)...", 1, NEW_Sound_to_LPC_marple); - praat_addAction1 (classSound, 0, U"To MFCC...", U"To LPC (marple)...", 1, NEW_Sound_to_MFCC); - praat_addAction1 (classSound, 0, U"To Formant (robust)...", U"To Formant (sl)...", 2, NEW_Sound_to_Formant_robust); praat_addAction1 (classSound, 0, U"To PowerCepstrogram...", U"To Harmonicity (gne)...", 1, NEW_Sound_to_PowerCepstrogram); praat_addAction1 (classSound, 0, U"To PowerCepstrogram (hillenbrand)...", U"To Harmonicity (gne)...", praat_HIDDEN + praat_DEPTH_1, NEW_Sound_to_PowerCepstrogram_hillenbrand); + praat_addAction1 (classSound, 0, U"To Formant (robust)...", U"To Formant (sl)...", 2, NEW_Sound_to_Formant_robust); + praat_addAction1 (classSound, 0, U"To FormantPath...", U"To Formant (robust)...", 2, NEW_Sound_to_FormantPath); + praat_addAction1 (classSound, 0, U"To FormantPath (burg)...", U"To FormantPath...", 1, NEW_Sound_to_FormantPath_burg); + praat_addAction1 (classSound, 0, U"To LPC", U"To FormantPath...", 1, nullptr); + praat_addAction1 (classSound, 0, U"To LPC (autocorrelation)...", U"To LPC", 2, NEW_Sound_to_LPC_autocorrelation); + praat_addAction1 (classSound, 0, U"To LPC (covariance)...", U"To LPC (autocorrelation)...", 2, NEW_Sound_to_LPC_covariance); + praat_addAction1 (classSound, 0, U"To LPC (burg)...", U"To LPC (covariance)...", 2, NEW_Sound_to_LPC_burg); + praat_addAction1 (classSound, 0, U"To LPC (marple)...", U"To LPC (burg)...", 2, NEW_Sound_to_LPC_marple); + praat_addAction1 (classSound, 0, U"To MFCC...", U"To LPC (marple)...", 1, NEW_Sound_to_MFCC); + praat_addAction2 (classSound, 1, classFormantPath, 1, U"View & Edit", 0, 0, WINDOW_Sound_FormantPath_createFormantPathEditor); + praat_addAction3 (classSound, 1, classTextGrid, 1, classFormantPath, 1, U"View & Edit", 0, 0, WINDOW_Sound_TextGrid_FormantPath_createFormantPathEditor); praat_addAction1 (classVocalTract, 0, U"Draw segments...", U"Draw", 0, GRAPHICS_VocalTract_drawSegments); praat_addAction1 (classVocalTract, 1, U"Get length", U"Draw segments...", 0, REAL_VocalTract_getLength); diff --git a/Makefile b/Makefile index 494e4249..0c85a425 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ # File: Makefile # Makefile for Praat. -# Paul Boersma, 8 March 2020 +# Paul Boersma, 24 May 2020 # System-dependent definitions of CC, LIBS, ICON and MAIN_ICON should be in # makefile.defs, which has to be copied and renamed @@ -43,7 +43,7 @@ all: external/portaudio/libportaudio.a \ external/flac/libflac.a external/mp3/libmp3.a \ external/glpk/libglpk.a \ - external/clapack/liblapack.a external/clapack/libblas.a \ + external/clapack/libclapack.a \ external/gsl/libgsl.a \ $(LIBS) diff --git a/README.md b/README.md index 830ce19a..a85fd20f 100644 --- a/README.md +++ b/README.md @@ -86,7 +86,7 @@ and under Cygwin install the Devel packages x86_64-w64-mingw32 (for 64-bit targe and/or i686-w64-mingw32 (for 32-bit targets). Move the Praat sources directory somewhere in your `/home/yourname` tree, e.g. as `/home/yourname/praats` and/or `/home/yourname/praats32`; -the folders `fon` and `sys` shoudl be visible within these folders. +the folders `fon` and `sys` should be visible within these folders. If you want to build Praat's 64-bit edition, type cd ~/praats @@ -123,7 +123,7 @@ try the target `praat_mac64_a` (static) or `praat_mac64_so` (dynamic). **Notarization.** If you want others to be able to use your Mac app, you will probably have to not only *sign* the executable, but also *notarize* it. To this end, -do Xcode (11.2) -> Product -> Archive -> Distribute App -> Developer ID -> Upload -> +do Xcode (version 12) -> Product -> Archive -> Distribute App -> Developer ID -> Upload -> Automatically manage signing -> Upload -> ...wait... (“Package Approved”) ...wait... (“Ready to distribute”) -> Export Notarized App). If your Praat.app was built into `~/builds/mac_products/Configuration64`, then you can save the notarized @@ -145,18 +145,21 @@ To set up the required system libraries, install some graphics and sound package sudo apt-get install libjack-dev To set up your source tree for Linux, go to Praat's sources directory (where the folders `fon` and `sys` are) -and type one of the three following commands: +and type one of the four following commands: # on Ubuntu command line cp makefiles/makefile.defs.linux.pulse ./makefile.defs + # on Ubuntu command line + cp makefiles/makefile.defs.linux.pulse_static ./makefile.defs + # on Chromebook command line cp makefiles/makefile.defs.chrome64 ./makefile.defs # on Raspberry Pi command line cp makefiles/makefile.defs.linux.rpi ./makefile.defs -To build the Praat executable, type `make`. +To build the Praat executable, type `make` or `make -j12`. If your Unix isn’t Linux, you may have to edit the library names in the makefile (you may need pthread, gtk-x11-2.0, gdk-x11-2.0, atk-1.0, pangoft2-1.0, gdk_pixbuf-2.0, m, pangocairo-1.0, cairo, gio-2.0, pango-1.0, freetype, fontconfig, gobject-2.0, gmodule-2.0, gthread-2.0, rt, glib-2.0, asound, jack). @@ -166,7 +169,7 @@ If you do have `libgtk2.0-dev` (and its dependencies), do cp makefiles/makefile.defs.linux.silent ./makefile.defs -Then type `make` to build the program. If your Unix isn’t Linux, +Then type `make` or `make -j12` to build the program. If your Unix isn’t Linux, you may have to edit the library names in the makefile (you may need pthread, gtk-x11-2.0, gdk-x11-2.0, atk-1.0, pangoft2-1.0, gdk_pixbuf-2.0, m, pangocairo-1.0, cairo, gio-2.0, pango-1.0, freetype, fontconfig, gobject-2.0, gmodule-2.0, gthread-2.0, rt, glib-2.0). @@ -180,8 +183,8 @@ which creates the executable `praat_nogui`. If you don't need graphics (e.g. PNG cp makefiles/makefile.defs.linux.barren ./makefile.defs -which creates the executable `praat_barren`. Then type `make` to build the program. If your Unix isn’t Linux, -you may have to edit the library names in the makefile. +which creates the executable `praat_barren`. Then type `make` or `make -j12` to build the program. +If your Unix isn’t Linux, you may have to edit the library names in the makefile. ## 4. Compiling the source code on all platforms simultaneously @@ -280,6 +283,12 @@ assuming that it uses the `bash` shell): make -j12 )" alias praat="~/praats/praat" alias praat-run="praat-build && praat" + alias praatt-build="( cd ~/praatst &&\ + rsync -rptvz $PRAAT_SOURCES/ $PRAAT_EXCLUDES . &&\ + cp makefiles/makefile.defs.linux.pulse_static makefile.defs &&\ + make -j12 )" + alias praatt="~/praatst/praatt" + alias praatt-run="praatt-build && praatt" Building Praat this way takes 2 minutes and 10 seconds (optimization level O3). @@ -490,14 +499,16 @@ On Ubuntu you can define # in Ubuntu:~/.bash_aliases alias praat-dist="praat-build && rsync -t ~/praats/praat /media/psf/Home/builds/linux64" + alias praatt-dist="praatt-build && rsync -t ~/praatst/praat_static /media/psf/Home/builds/linux64" alias praatb-dist="praatb-build && rsync -t ~/praatsb/praat_barren /media/psf/Home/builds/linux64" alias praatn-dist="praatn-build && rsync -t ~/praatsn/praat_nogui /media/psf/Home/builds/linux64" alias praatc-dist="praatc-build && rsync -t ~/praatsc/praat /media/psf/Home/builds/chrome64" -so that you can “upload” the four executables to the Mac with +so that you can “upload” the five executables to the Mac with # on Ubuntu command line praat-dist + praatt-dist praatb-dist praatn-dist praatc-dist @@ -518,6 +529,10 @@ you can issue the following commands to create the packages and install them in tar cvf praat$(PRAAT_VERSION)_linux64.tar praat &&\ gzip praat$(PRAAT_VERSION)_linux64.tar &&\ mv praat$(PRAAT_VERSION)_linux64.tar.gz $PRAAT_WWW ) + ( cd ~/builds/linux64 &&\ + tar cvf praat$(PRAAT_VERSION)_linux64static.tar praat_static &&\ + gzip praat$(PRAAT_VERSION)_linux64static.tar &&\ + mv praat$(PRAAT_VERSION)_linux64static.tar.gz $PRAAT_WWW ) ( cd ~/builds/linux64 &&\ tar cvf praat$(PRAAT_VERSION)_linux64barren.tar praat_barren &&\ gzip praat$(PRAAT_VERSION)_linux64barren.tar &&\ diff --git a/artsynth/ArtwordEditor.cpp b/artsynth/ArtwordEditor.cpp index f3ffa302..13adb37c 100644 --- a/artsynth/ArtwordEditor.cpp +++ b/artsynth/ArtwordEditor.cpp @@ -1,6 +1,6 @@ /* ArtwordEditor.cpp * - * Copyright (C) 1992-2013,2015-2019 Paul Boersma + * Copyright (C) 1992-2013,2015-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -83,14 +83,16 @@ static void gui_radiobutton_cb_toggle (ArtwordEditor me, GuiRadioButtonEvent eve } static void gui_drawingarea_cb_expose (ArtwordEditor me, GuiDrawingArea_ExposeEvent /* event */) { - if (! my graphics) return; + if (! my graphics) + return; Artword artword = (Artword) my data; Graphics_clearWs (my graphics.get()); Artword_draw (artword, my graphics.get(), my muscle, true); } -static void gui_drawingarea_cb_click (ArtwordEditor me, GuiDrawingArea_ClickEvent event) { - if (! my graphics) return; +static void gui_drawingarea_cb_mouse (ArtwordEditor me, GuiDrawingArea_MouseEvent event) { + if (! my graphics) + return; Artword artword = (Artword) my data; Graphics_setWindow (my graphics.get(), 0, artword -> totalTime, -1.0, 1.0); Graphics_setInner (my graphics.get()); @@ -116,7 +118,9 @@ void structArtwordEditor :: v_createChildren () { GuiButton_createShown (our windowForm, 10, 130, dy + 410, dy + 410 + Gui_PUSHBUTTON_HEIGHT, U"Remove target", gui_button_cb_removeTarget, this, 0); drawingArea = GuiDrawingArea_createShown (our windowForm, 170, 470, dy + 10, dy + 310, - gui_drawingarea_cb_expose, gui_drawingarea_cb_click, nullptr, nullptr, this, 0); + gui_drawingarea_cb_expose, gui_drawingarea_cb_mouse, + nullptr, nullptr, this, 0 + ); GuiLabel_createShown (our windowForm, 220, 270, dy + 340, dy + 340 + Gui_LABEL_HEIGHT, U"Time:", 0); time = GuiText_createShown (our windowForm, 270, 370, dy + 340, dy + 340 + Gui_TEXTFIELD_HEIGHT, 0); diff --git a/artsynth/Artword_Speaker.cpp b/artsynth/Artword_Speaker.cpp index 11fc3060..09725553 100644 --- a/artsynth/Artword_Speaker.cpp +++ b/artsynth/Artword_Speaker.cpp @@ -1,6 +1,6 @@ /* Artword_Speaker.cpp * - * Copyright (C) 1992-2005,2011,2015-2017,2019 Paul Boersma + * Copyright (C) 1992-2005,2011,2015-2017,2019,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -20,7 +20,7 @@ #include "Artword_Speaker.h" void Artword_Speaker_draw (Artword artword, Speaker speaker, Graphics g, int numberOfSteps) { - double oldLineWidth = Graphics_inqLineWidth (g); + const double oldLineWidth = Graphics_inqLineWidth (g); autoArt art = Art_create (); for (int i = 0; i <= numberOfSteps; i ++) { Artword_intoArt (artword, art.get(), i * artword -> totalTime / numberOfSteps); diff --git a/artsynth/Speaker.cpp b/artsynth/Speaker.cpp index 627df9dd..5674fe0d 100644 --- a/artsynth/Speaker.cpp +++ b/artsynth/Speaker.cpp @@ -1,6 +1,6 @@ /* Speaker.cpp * - * Copyright (C) 1992-2005,2007,2011,2012,2015-2018 Paul Boersma + * Copyright (C) 1992-2005,2007,2011,2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -48,14 +48,14 @@ autoSpeaker Speaker_create (conststring32 kindOfSpeaker, int16 numberOfVocalCord /* That was a male speaker, so we need scaling for other speakers: */ double scaling; - if (str32equ (kindOfSpeaker, U"Male")) my relativeSize = 1.1; - else if (str32equ (kindOfSpeaker, U"Child")) my relativeSize = 0.7; + if (Melder_equ_firstCharacterCaseInsensitive (kindOfSpeaker, U"male")) my relativeSize = 1.1; + else if (Melder_equ_firstCharacterCaseInsensitive (kindOfSpeaker, U"child")) my relativeSize = 0.7; else my relativeSize = 1.0; scaling = my relativeSize; /* Laryngeal system. Data for male speaker from Ishizaka and Flanagan. */ - if (str32equ (kindOfSpeaker, U"Female")) { + if (Melder_equ_firstCharacterCaseInsensitive (kindOfSpeaker, U"female")) { my lowerCord.thickness = 1.4e-3; // dx, in metres my upperCord.thickness = 0.7e-3; my cord.length = 10e-3; @@ -63,7 +63,7 @@ autoSpeaker Speaker_create (conststring32 kindOfSpeaker, int16 numberOfVocalCord my upperCord.mass = 0.01e-3; my lowerCord.k1 = 10; // Newtons per metre my upperCord.k1 = 4; - } else if (str32equ (kindOfSpeaker, U"Male")) { + } else if (Melder_equ_firstCharacterCaseInsensitive (kindOfSpeaker, U"male")) { my lowerCord.thickness = 2.0e-3; // dx, in metres my upperCord.thickness = 1.0e-3; my cord.length = 18e-3; @@ -71,7 +71,7 @@ autoSpeaker Speaker_create (conststring32 kindOfSpeaker, int16 numberOfVocalCord my upperCord.mass = 0.05e-3; my lowerCord.k1 = 12; // Newtons per metre my upperCord.k1 = 4; - } else /* "Child" */ { + } else /* "child" */ { my lowerCord.thickness = 0.7e-3; // dx, in metres my upperCord.thickness = 0.3e-3; my cord.length = 6e-3; diff --git a/artsynth/manual_Artsynth.cpp b/artsynth/manual_Artsynth.cpp index c50a2a37..de448f7b 100644 --- a/artsynth/manual_Artsynth.cpp +++ b/artsynth/manual_Artsynth.cpp @@ -1,6 +1,6 @@ /* manual_Artsynth.cpp * - * Copyright (C) 1992-2005,2007,2010,2011,2014-2017 Paul Boersma + * Copyright (C) 1992-2005,2007,2010,2011,2014-2017,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -21,7 +21,7 @@ void manual_Artsynth_init (ManPages me); void manual_Artsynth_init (ManPages me) { -MAN_BEGIN (U"Articulatory synthesis", U"ppgb", 201101028) +MAN_BEGIN (U"Articulatory synthesis", U"ppgb", 20111028) INTRO (U"This is a description of the articulatory synthesis package in Praat. " "For a detailed description of the physics and mathematics behind the model, " "see @@Boersma (1998)@, chapters 2 and 3. " diff --git a/artsynth/praat_Artsynth.cpp b/artsynth/praat_Artsynth.cpp index c2932cc7..65254483 100644 --- a/artsynth/praat_Artsynth.cpp +++ b/artsynth/praat_Artsynth.cpp @@ -217,9 +217,9 @@ DIRECT (MOVIE_Artword_Speaker_Sound_playMovie) { FORM (NEW1_Speaker_create, U"Create a Speaker", U"Create Speaker...") { WORD (name, U"Name", U"speaker") OPTIONMENUSTR (kindOfSpeaker, U"Kind of speaker", 1) - OPTION (U"Female") - OPTION (U"Male") - OPTION (U"Child") + OPTION (U"female") + OPTION (U"male") + OPTION (U"child") OPTIONMENUSTR (numberOfTubesInGlottis, U"Number of tubes in glottis", 2) OPTION (U"1") OPTION (U"2") diff --git a/dwsys/FileInMemorySet.cpp b/dwsys/FileInMemorySet.cpp index 900302aa..05021c64 100644 --- a/dwsys/FileInMemorySet.cpp +++ b/dwsys/FileInMemorySet.cpp @@ -216,15 +216,14 @@ integer FileInMemorySet_findNumberOfMatches_path (FileInMemorySet me, kMelder_st bool FileInMemorySet_hasDirectory (FileInMemorySet me, conststring32 name) { bool match = false; - autoMelderString regex; + autoMelderString searchString; + MelderString_append (& searchString, U"/", name, U"/"); for (integer i = 1; i <= my size; i ++) { const FileInMemory fim = (FileInMemory) my at [i]; - MelderString_append (& regex, U".*/", name, U"/.*"); - if (Melder_stringMatchesCriterion (fim -> d_path.get(), kMelder_string :: MATCH_REGEXP, regex.string, true)) { + if (str32str (fim -> d_path.get(), searchString.string)) { match = true; break; } - MelderString_empty (& regex); } return match; } diff --git a/dwsys/NUM2.cpp b/dwsys/NUM2.cpp index 5b0204aa..7f1a86a3 100644 --- a/dwsys/NUM2.cpp +++ b/dwsys/NUM2.cpp @@ -88,6 +88,20 @@ struct pdf2_struct { double df2; }; +void NUMgetGridDimensions (integer n, integer *out_nrow, integer *out_ncol) { + integer ncol = 1; + integer nrow = n; + if (n > 3) { + nrow = 1 + Melder_ifloor (sqrt (n - 0.5)); + ncol = 1 + Melder_ifloor ((n - 1) / nrow); + } + if (out_nrow) + *out_nrow = nrow; + if (out_ncol) + *out_ncol = ncol; + +} + void MATprintMatlabForm (constMATVU const& m, conststring32 name) { constexpr integer npc = 5; const ldiv_t n = ldiv (m.ncol, npc); @@ -585,22 +599,6 @@ struct nr2_struct { VEC x, c; }; -static double nr2_func (double b, double *df, void *data) { - const struct nr2_struct *me = (struct nr2_struct *) data; - - longdouble f = my delta - 0.5 * b / my alpha; - longdouble derivative = - 0.5 / my alpha; - for (integer i = 1; i <= my numberOfTerms; i ++) { - const longdouble c1 = (my c [i] - b); - const longdouble c2 = my x [i] / c1; - const longdouble c2sq = c2 * c2; - f -= c2sq; - derivative -= 2.0 * c2sq / c1; - } - *df = (double) derivative; - return (double)f; -} - static double bolzanoFunction (double b, void *data) { const struct nr2_struct *me = (struct nr2_struct *) data; longdouble f = my delta - 0.5 * b / my alpha; @@ -719,7 +717,7 @@ autoVEC newVECsolveWeaklyConstrainedLinearRegression (constMAT const& a, constVE xCx += x [j] * x [j] / c [j]; const double bmin = ( delta > 0.0 ? - xCx / delta : -2.0 * sqrt (alpha * xCx) ); - const double eps = (c [a.ncol] - bmin) * tol; + //const double eps = (c [a.ncol] - bmin) * tol; /* Find the root of d(psi(b)/db in interval (bmin, c [m]) */ @@ -1689,150 +1687,151 @@ integer NUMgetIntersectionsWithRectangle (double x1, double y1, double x2, doubl return ni; } -bool NUMclipLineWithinRectangle (double xl1, double yl1, double xl2, double yl2, double xr1, double yr1, double xr2, double yr2, double *out_xo1, double *out_yo1, double *out_xo2, double *out_yo2) { - integer ncrossings = 0; +bool NUMclipLineWithinRectangle (double line_x1, double line_y1, double line_x2, double line_y2, double rect_x1, double rect_y1, double rect_x2, double rect_y2, double *out_line_x1, double *out_line_y1, double *out_line_x2, double *out_line_y2) { + integer numberOfRectangleCrossings = 0; double x, y, a, b; - double xc [5], yc [5], xmin, xmax, ymin, ymax; - double xo1 = xl1, yo1 = yl1, xo2 = xl2, yo2 = yl2; - - // This test first because we expect the majority of the tested segments to be within the rectangle - - if (xl1 >= xr1 && xl1 <= xr2 && yl1 >= yr1 && yl1 <= yr2 && - xl2 >= xr1 && xl2 <= xr2 && yl2 >= yr1 && yl2 <= yr2) + double crossing_x [5], crossing_y [5], xmin, xmax, ymin, ymax; + double segment_x1 = line_x1, segment_y1 = line_y1, segment_x2 = line_x2, segment_y2 = line_y2; + /* + This test first because we expect the majority of the tested segments to be within the rectangle + */ + if (line_x1 >= rect_x1 && line_x1 <= rect_x2 && line_y1 >= rect_y1 && line_y1 <= rect_y2 && + line_x2 >= rect_x1 && line_x2 <= rect_x2 && line_y2 >= rect_y1 && line_y2 <= rect_y2) goto end; - - // All lines that are completely outside the rectangle - - if ( (xl1 <= xr1 && xl2 <= xr1) || (xl1 >= xr2 && xl2 >= xr2) || - (yl1 <= yr1 && yl2 <= yr1) || (yl1 >= yr2 && yl2 >= yr2)) + /* + All lines that are completely outside the rectangle + */ + if ( (line_x1 <= rect_x1 && line_x2 <= rect_x1) || (line_x1 >= rect_x2 && line_x2 >= rect_x2) || + (line_y1 <= rect_y1 && line_y2 <= rect_y1) || (line_y1 >= rect_y2 && line_y2 >= rect_y2)) return false; - - - // At least line spans (part of) the rectangle. - // Get extremes in x and y of the line for easy testing further on. + /* + At least line spans (part of) the rectangle. + Get extremes in x and y of the line for easy testing further on. + */ bool xswap, yswap; - if (xl1 < xl2) { - xmin = xl1; - xmax = xl2; + if (line_x1 < line_x2) { + xmin = line_x1; + xmax = line_x2; xswap = false; } else { - xmin = xl2; - xmax = xl1; + xmin = line_x2; + xmax = line_x1; xswap = true; } - if (yl1 < yl2) { - ymin = yl1; - ymax = yl2; + if (line_y1 < line_y2) { + ymin = line_y1; + ymax = line_y2; yswap = false; } else { - ymin = yl2; - ymax = yl1; + ymin = line_y2; + ymax = line_y1; yswap = true; } - if (yl1 == yl2) { - if (xmin < xr1) - xo1 = xr1; - if (xmax > xr2) - xo2 = xr2; + if (line_y1 == line_y2) { + if (xmin < rect_x1) + segment_x1 = rect_x1; + if (xmax > rect_x2) + segment_x2 = rect_x2; if (xswap) - std::swap (xo1, xo2); + std::swap (segment_x1, segment_x2); goto end; } - if (xl1 == xl2) { - if (ymin < yr1) - yo1 = yr1; - if (ymax > yr2) - yo2 = yr2; + if (line_x1 == line_x2) { + if (ymin < rect_y1) + segment_y1 = rect_y1; + if (ymax > rect_y2) + segment_y2 = rect_y2; if (yswap) - std::swap (yo1, yo2); + std::swap (segment_y1, segment_y2); goto end; } - - // Now we know that the line from (x1,y1) to (x2,y2) is neither horizontal nor vertical. - // Parametrize it as y = ax + b - - a = (yl1 - yl2) / (xl1 - xl2); - b = yl1 - a * xl1; - - - // To determine the crossings we have to avoid counting the crossings in a corner twice. - // Therefore we test the corners inclusive (..<=..<=..) on the vertical borders of the rectangle - // and exclusive (..<..<) at the horizontal borders. - - - y = a * xr1 + b; // Crossing at y with left border: x = xr1 - - if (y >= yr1 && y <= yr2 && xmin < xr1) { // Within vertical range? - xc [++ ncrossings] = xr1; - yc [ncrossings] = y; - xc [2] = xmax; - yc [2] = xl1 > xl2 ? yl1 : yl2; + /* + Now we know that the line from (line_x1,line_y1) to (line_x2,line_y2) is neither horizontal nor vertical. + We can parametrize it as y = ax + b + */ + a = (line_y1 - line_y2) / (line_x1 - line_x2); + b = line_y1 - a * line_x1; + + /* + To determine the crossings we have to avoid counting the crossings in a corner twice. + Therefore we test the corners inclusive (..<=..<=..) on the vertical borders of the rectangle + and exclusive (..<..<) at the horizontal borders. + */ + + y = a * rect_x1 + b; // Crossing at y with left border: x = rect_x1 + + if (y >= rect_y1 && y <= rect_y2 && xmin < rect_x1) { // Within vertical range? + crossing_x [++ numberOfRectangleCrossings] = rect_x1; + crossing_y [numberOfRectangleCrossings] = y; + crossing_x [2] = xmax; + crossing_y [2] = line_x1 > line_x2 ? line_y1 : line_y2; } - x = (yr2 - b) / a; // Crossing at x with top border: y = yr2 - - if (x > xr1 && x < xr2 && ymax > yr2) { // Within horizontal range? - xc [++ ncrossings] = x; - yc [ncrossings] = yr2; - if (ncrossings == 1) { - yc [2] = ymin; - xc [2] = yl1 < yl2 ? xl1 : xl2; + x = (rect_y2 - b) / a; // Crossing at x with top border: y = rect_y2 + + if (x > rect_x1 && x < rect_x2 && ymax > rect_y2) { // Within horizontal range? + crossing_x [++ numberOfRectangleCrossings] = x; + crossing_y [numberOfRectangleCrossings] = rect_y2; + if (numberOfRectangleCrossings == 1) { + crossing_y [2] = ymin; + crossing_x [2] = line_y1 < line_y2 ? line_x1 : line_x2; } } - y = a * xr2 + b; // Crossing at y with right border: x = xr2 + y = a * rect_x2 + b; // Crossing at y with right border: x = rect_x2 - if (y >= yr1 && y <= yr2 && xmax > xr2) { // Within vertical range? - xc [++ ncrossings] = xr2; - yc [ncrossings] = y; - if (ncrossings == 1) { - xc [2] = xmin; - yc [2] = xl1 < xl2 ? yl1 : yl2; + if (y >= rect_y1 && y <= rect_y2 && xmax > rect_x2) { // Within vertical range? + crossing_x [++ numberOfRectangleCrossings] = rect_x2; + crossing_y [numberOfRectangleCrossings] = y; + if (numberOfRectangleCrossings == 1) { + crossing_x [2] = xmin; + crossing_y [2] = line_x1 < line_x2 ? line_y1 : line_y2; } } - x = (yr1 - b) / a; // Crossing at x with bottom border: y = yr1 + x = (rect_y1 - b) / a; // Crossing at x with bottom border: y = rect_y1 - if (x > xr1 && x < xr2 && ymin < yr1) { - xc [++ ncrossings] = x; - yc [ncrossings] = yr1; - if (ncrossings == 1) { - yc [2] = ymax; - xc [2] = yl1 > yl2 ? xl1 : xl2; + if (x > rect_x1 && x < rect_x2 && ymin < rect_y1) { + crossing_x [++ numberOfRectangleCrossings] = x; + crossing_y [numberOfRectangleCrossings] = rect_y1; + if (numberOfRectangleCrossings == 1) { + crossing_y [2] = ymax; + crossing_x [2] = line_y1 > line_y2 ? line_x1 : line_x2; } } - if (ncrossings == 0) + if (numberOfRectangleCrossings == 0) return false; - Melder_require (ncrossings <= 2, + Melder_require (numberOfRectangleCrossings <= 2, U"Too many crossings found."); /* - if start and endpoint of line are outside rectangle and ncrossings == 1, than the line only touches. + If start and endpoint of line are outside rectangle and numberOfRectangleCrossings == 1, than the line only touches. */ - if (ncrossings == 1 && (xl1 < xr1 || xl1 > xr2 || yl1 < yr1 || yl1 > yr2) && - (xl2 < xr1 || xl2 > xr2 || yl2 < yr1 || yl2 > yr2)) + + if (numberOfRectangleCrossings == 1 && (line_x1 < rect_x1 || line_x1 > rect_x2 || line_y1 < rect_y1 || line_y1 > rect_y2) && + (line_x2 < rect_x1 || line_x2 > rect_x2 || line_y2 < rect_y1 || line_y2 > rect_y2)) goto end; - if ((xc [1] > xc [2] && ! xswap) || (xc [1] < xc [2] && xswap)) { - std::swap (xc [1], xc [2]); - std::swap (yc [1], yc [2]); + if ((crossing_x [1] > crossing_x [2] && ! xswap) || (crossing_x [1] < crossing_x [2] && xswap)) { + std::swap (crossing_x [1], crossing_x [2]); + std::swap (crossing_y [1], crossing_y [2]); } - xo1 = xc [1]; - yo1 = yc [1]; - xo2 = xc [2]; - yo2 = yc [2]; + segment_x1 = crossing_x [1]; + segment_y1 = crossing_y [1]; + segment_x2 = crossing_x [2]; + segment_y2 = crossing_y [2]; end: - if (out_xo1) - *out_xo1 = xo1; - if (out_yo1) - *out_yo1 = yo1; - if (out_xo2) - *out_xo2 = xo2; - if (out_yo2) - *out_yo2 = yo2; + if (out_line_x1) + *out_line_x1 = segment_x1; + if (out_line_y1) + *out_line_y1 = segment_y1; + if (out_line_x2) + *out_line_x2 = segment_x2; + if (out_line_y2) + *out_line_y2 = segment_y2; return true; } diff --git a/dwsys/NUM2.h b/dwsys/NUM2.h index b9f5d01c..e673f836 100644 --- a/dwsys/NUM2.h +++ b/dwsys/NUM2.h @@ -20,7 +20,6 @@ /* djmw 20020815 GPL header - djmw 20121024 Latest modification. */ #include @@ -36,6 +35,11 @@ */ #define NUMeps 2.3e-16 +void NUMgetGridDimensions (integer n, integer *out_nrow, integer *out_ncol); +/* Get dimensions of a grid for n elements where nrow*ncol >= n */ + + +autoINTVEC newINTVECfromString (conststring32 s); autoVEC newVECfromString (conststring32 s); /* return array with the numbers found */ @@ -974,11 +978,9 @@ integer NUMgetIntersectionsWithRectangle (double x1, double y1, double x2, doubl The returned value is the number of intersections found and is either 0 or 1 or 2. */ -bool NUMclipLineWithinRectangle (double xl1, double yl1, double xl2, double yl2, double xr1, double yr1, - double xr2, double yr2, double *out_xo1, double *out_yo1, double *out_xo2, double *out_yo2); +bool NUMclipLineWithinRectangle (double line_x1, double line_y1, double line_x2, double line_y2, double rect_x1, double rect_y1, double rect_x2, double rect_y2, double *out_line_x1, double *out_line_y1, double *out_line_x2, double *out_line_y2); /* - If true, then returns in (xo1, yo1) and (xo2, yo2) the coordinates of that piece of the line (xl1, yl1)..(xl2, yl2) - that can be drawn within the rectangle with lowerleft corner (xr1, yr1) and upperright (xr2, yr2). + If true, then returns in (out_line_x1, out_line_y1) and (out_line_x2, out_line_y2) the coordinates of start and end points of the line (line_x1, line_y1)..(line_x2, line_y2) that can be drawn within the rectangle with lowerleft corner (rect_x1, rect_y1) and upperright (rect_x2, rect_y2). Returns false if there is nothing to be drawn inside. */ diff --git a/dwsys/NUMstring.cpp b/dwsys/NUMstring.cpp index d8175ba3..4ddac5eb 100644 --- a/dwsys/NUMstring.cpp +++ b/dwsys/NUMstring.cpp @@ -33,6 +33,16 @@ autoVEC newVECfromString (conststring32 s) { return numbers; } +autoINTVEC newINTVECfromString (conststring32 s) { + autoSTRVEC tokens = newSTRVECtokenize (s); + if (tokens.size < 1) + Melder_throw (U"Empty string."); + autoINTVEC numbers = newINTVECraw (tokens.size); + for (integer inum = 1; inum <= tokens.size; inum ++) + numbers [inum] = Melder_atoi (tokens [inum].get()); + return numbers; +} + char32 *strstr_regexp (conststring32 string, conststring32 search_regexp) { char32 *charp = nullptr; regexp *compiled_regexp = CompileRE_throwable (search_regexp, 0); @@ -49,15 +59,19 @@ static autoSTRVEC string32vector_searchAndReplace_literal (constSTRVEC me, conststring32 search, conststring32 replace, int maximumNumberOfReplaces, integer *out_numberOfMatches, integer *out_numberOfStringMatches) { - if (! search || ! replace) - return autoSTRVEC(); + /* + Sanitize input. + */ + if (! search) + search = U""; + if (! replace) + replace = U""; + autoSTRVEC result (me.size); integer nmatches_sub = 0, nmatches = 0, nstringmatches = 0; for (integer i = 1; i <= me.size; i ++) { - conststring32 string = ( me [i] ? me [i] : U"" ); // treat null as an empty string - - result [i] = newSTRreplace (string, search, replace, maximumNumberOfReplaces, & nmatches_sub); + result [i] = newSTRreplace (me [i], search, replace, maximumNumberOfReplaces, & nmatches_sub); if (nmatches_sub > 0) { nmatches += nmatches_sub; nstringmatches ++; @@ -74,8 +88,13 @@ static autoSTRVEC string32vector_searchAndReplace_regexp (constSTRVEC me, conststring32 searchRE, conststring32 replaceRE, int maximumNumberOfReplaces, integer *out_numberOfMatches, integer *out_numberOfStringMatches) { - if (! searchRE || ! replaceRE) - return autoSTRVEC(); + /* + Sanitize input. + */ + if (! searchRE) + searchRE = U""; + if (! replaceRE) + replaceRE = U""; integer nmatches_sub = 0; @@ -85,8 +104,7 @@ static autoSTRVEC string32vector_searchAndReplace_regexp (constSTRVEC me, integer nmatches = 0, nstringmatches = 0; for (integer i = 1; i <= me.size; i ++) { - conststring32 string = ( me [i] ? me [i] : U"" ); // treat null as an empty string - result [i] = newSTRreplace_regex (string, compiledRE, replaceRE, maximumNumberOfReplaces, & nmatches_sub); + result [i] = newSTRreplace_regex (me [i], compiledRE, replaceRE, maximumNumberOfReplaces, & nmatches_sub); if (nmatches_sub > 0) { nmatches += nmatches_sub; nstringmatches ++; diff --git a/dwsys/SVD.cpp b/dwsys/SVD.cpp index 7860731e..239619a3 100644 --- a/dwsys/SVD.cpp +++ b/dwsys/SVD.cpp @@ -153,7 +153,7 @@ void SVD_compute (SVD me) { void SVD_getSquared_preallocated (SVD me, bool inverse, MAT const& m) { Melder_assert (m.nrow == m.ncol && m.ncol == my numberOfColumns); for (integer i = 1; i <= my numberOfColumns; i ++) { - for (integer j = 1; j <= my numberOfColumns; j ++) { + for (integer j = i; j <= my numberOfColumns; j ++) { longdouble val = 0.0; for (integer k = 1; k <= my numberOfColumns; k ++) { if (my d [k] > 0.0) { @@ -162,7 +162,7 @@ void SVD_getSquared_preallocated (SVD me, bool inverse, MAT const& m) { val += my v [i] [k] * my v [j] [k] * factor; } } - m [i] [j] = double (val); + m [i] [j] = m [j] [i] = double (val); } } } diff --git a/dwtest/test_Covariance.praat b/dwtest/test_Covariance.praat index efbf4357..ca4593cf 100644 --- a/dwtest/test_Covariance.praat +++ b/dwtest/test_Covariance.praat @@ -30,6 +30,7 @@ procedure test_Morrison_example_4_3 assert .dof1 == 4 .dof2 = extractNumber (.report$, "Degrees of freedom 2:") assert .dof2 = 44 + removeObject: .covariance1, .covariance2 endproc procedure test_Morrison_example_7_3 @@ -82,4 +83,4 @@ procedure test_Morrison_example_3_5 removeObject: .cor endproc -;Difference \ No newline at end of file +;Difference diff --git a/dwtest/test_SpeechSynthesizer.praat b/dwtest/test_SpeechSynthesizer.praat index 0f74e8aa..bc452b44 100644 --- a/dwtest/test_SpeechSynthesizer.praat +++ b/dwtest/test_SpeechSynthesizer.praat @@ -18,7 +18,6 @@ for ilang to numberOfLanguages selectObject: voiceslist voice$ = Get value: randomInteger (1, numberOfVoices), "name" appendInfo: " ", voice$ - # some voices have spaces! ss = Create SpeechSynthesizer: language$, voice$ sound = To Sound: "a e u", "no" ;Play diff --git a/dwtools/CC.cpp b/dwtools/CC.cpp index 31c08b20..c4a929c5 100644 --- a/dwtools/CC.cpp +++ b/dwtools/CC.cpp @@ -118,17 +118,15 @@ void CC_paint (CC me, Graphics g, double xmin, double xmax, integer cmin, intege } } -void CC_drawC0 (CC me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool garnish) { - (void) garnish; - +void CC_drawC0 (CC me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool /* garnish */) { if (xmin >= xmax) { xmin = my xmin; xmax = my xmax; } - integer bframe, eframe; - (void) Sampled_getWindowSamples (me, xmin, xmax, & bframe, & eframe); - integer numberOfSelected = eframe - bframe + 1; + integer numberOfSelected = Sampled_getWindowSamples (me, xmin, xmax, & bframe, & eframe); + if (numberOfSelected <= 0) + return; autoVEC c = newVECraw (numberOfSelected); for (integer i = 1; i <= numberOfSelected; i ++) { const CC_Frame cf = & my frame [bframe + i - 1]; diff --git a/dwtools/ComplexSpectrogram.cpp b/dwtools/ComplexSpectrogram.cpp index b9c20095..7c94d183 100644 --- a/dwtools/ComplexSpectrogram.cpp +++ b/dwtools/ComplexSpectrogram.cpp @@ -146,7 +146,7 @@ autoSound ComplexSpectrogram_to_Sound (ComplexSpectrogram me, double stretchFact autoSound synthesisWindow = Sound_createSimple (1, synthesisWindowDuration, samplingFrequency); const double newDuration = (my xmax - my xmin) * stretchFactor; autoSound thee = Sound_createSimple (1, newDuration, samplingFrequency); //TODO - double thyStartTime; + //double thyStartTime; for (integer iframe = 1; iframe <= my nx; iframe ++) { // "original" sound : const double tmid = Sampled_indexToX (me, iframe); @@ -155,23 +155,21 @@ autoSound ComplexSpectrogram_to_Sound (ComplexSpectrogram me, double stretchFact const integer startSample = rightSample - halfnsamp_window; const integer endSample = std::min (startSample + nsamp_window - 1, thy nx); - const double startTime = Sampled_indexToX (thee.get(), startSample); - if (iframe == 1) - thyStartTime = Sampled_indexToX (thee.get(), startSample); + //const double startTime = Sampled_indexToX (thee.get(), startSample); + //if (iframe == 1) + // thyStartTime = Sampled_indexToX (thee.get(), startSample); //integer endSample = leftSample + halfnsamp_window; // New Sound with stretch - const integer thyStartSample = Sampled_xToLowIndex (thee.get(), thyStartTime); - const double thyEndTime = thyStartTime + my dx * stretchFactor; - const integer thyEndSample = Sampled_xToLowIndex (thee.get(), thyEndTime); - const integer stretchedStepSizeSamples = thyEndSample - thyStartSample + 1; + //const integer thyStartSample = Sampled_xToLowIndex (thee.get(), thyStartTime); + //const double thyEndTime = thyStartTime + my dx * stretchFactor; + //const integer thyEndSample = Sampled_xToLowIndex (thee.get(), thyEndTime); //double extraTime = (thyStartSample - startSample + 1) * thy dx; - const double extraTime = thyStartTime - startTime; + //const double extraTime = thyStartTime - startTime; spectrum -> z [1] [1] = sqrt (my z [1] [iframe]); for (integer ifreq = 2; ifreq <= my ny; ifreq ++) { - const double f = my y1 + (ifreq - 1) * my dy; + //const double f = my y1 + (ifreq - 1) * my dy; const double a = sqrt (my z [ifreq] [iframe]); - double dummy; - const double extraPhase = 2.0 * NUMpi * modf (extraTime * f, & dummy); // fractional part + //double dummy; const double phi = my phase [ifreq] [iframe]; // + extraPhase; spectrum -> z [1] [ifreq] = a * cos (phi); spectrum -> z [2] [ifreq] = a * sin (phi); diff --git a/dwtools/Confusion.cpp b/dwtools/Confusion.cpp index eba9f56d..a8001cea 100644 --- a/dwtools/Confusion.cpp +++ b/dwtools/Confusion.cpp @@ -342,10 +342,10 @@ autoConfusion Confusion_condense (Confusion me, conststring32 search, conststrin U"Both row and column labels should be present."); autoSTRVEC rowLabels = string32vector_searchAndReplace (my rowLabels.get(), - search, replace, maximumNumberOfReplaces, & nmatches, & nstringmatches, use_regexp); + search, replace, maximumNumberOfReplaces, & nmatches, & nstringmatches, use_regexp); autoSTRVEC columnLabels = string32vector_searchAndReplace (my columnLabels.get(), - search, replace, maximumNumberOfReplaces, & nmatches, & nstringmatches, use_regexp); + search, replace, maximumNumberOfReplaces, & nmatches, & nstringmatches, use_regexp); autoStrings srow = Thing_new (Strings); srow -> numberOfStrings = my numberOfRows; @@ -370,11 +370,9 @@ autoConfusion Confusion_condense (Confusion me, conststring32 search, conststrin autoINTVEC rowIndex = create_index (srow -> strings.get(), drow -> rowLabels.get()); autoINTVEC columnIndex = create_index (scol -> strings.get(), dcol -> rowLabels.get()); - for (integer i = 1; i <= my numberOfRows; i ++) { - for (integer j = 1; j <= my numberOfColumns; j ++) { + for (integer i = 1; i <= my numberOfRows; i ++) + for (integer j = 1; j <= my numberOfColumns; j ++) thy data [rowIndex [i]] [columnIndex [j]] += my data [i] [j]; - } - } return thee; } catch (MelderError) { Melder_throw (me, U": not condensed."); diff --git a/dwtools/Covariance.cpp b/dwtools/Covariance.cpp index 3b15ecc0..6475ebab 100644 --- a/dwtools/Covariance.cpp +++ b/dwtools/Covariance.cpp @@ -345,10 +345,10 @@ double Covariance_getMarginalProbabilityAtPosition (Covariance me, constVECVU co } /* Precondition ||v|| = 1 */ -void Covariance_getMarginalDensityParameters (Covariance me, constVECVU const& v, double *out_mu, double *out_stdev) { +void Covariance_getMarginalDensityParameters (Covariance me, constVECVU const& v, double *out_mean, double *out_stdev) { Melder_assert (v.size == my numberOfColumns); - if (out_mu) - *out_mu = NUMinner (v, my centroid.get()); + if (out_mean) + *out_mean = NUMinner (v, my centroid.get()); if (out_stdev) { longdouble stdev = 0.0; if (my numberOfRows == 1) // 1xn diagonal matrix @@ -375,7 +375,7 @@ double Covariances_getMultivariateCentroidDifference (Covariance me, Covariance U"The number of observations should be larger than the number of variables."); double dif = 0.0; for (integer i = 1; i <= p; i ++) { - double dist = my centroid [i] - thy centroid [i]; + const double dist = my centroid [i] - thy centroid [i]; dif += dist * dist; } dif = sqrt (dif); diff --git a/dwtools/Covariance.h b/dwtools/Covariance.h index 53129e0d..791a195a 100644 --- a/dwtools/Covariance.h +++ b/dwtools/Covariance.h @@ -76,7 +76,7 @@ autoCovariance Covariance_create_reduceStorage (integer dimension, kSSCPstorage */ /* Precondition ||vector|| = 1 */ -void Covariance_getMarginalDensityParameters (Covariance me, constVECVU const& vector, double *p_mu, double *p_stdev); +void Covariance_getMarginalDensityParameters (Covariance me, constVECVU const& vector, double *out_mean, double *out_stdev); double Covariance_getMarginalProbabilityAtPosition (Covariance me, constVECVU const& vector, double x); diff --git a/dwtools/DTW.cpp b/dwtools/DTW.cpp index 7a0eba1d..c54545dd 100644 --- a/dwtools/DTW.cpp +++ b/dwtools/DTW.cpp @@ -993,7 +993,10 @@ static void DTW_checkSlopeConstraints (DTW me, double band, int slope) { dtw_slope = 1.0 / dtw_slope; Melder_require (dtw_slope <= slopes [slope], - U"There is a conflict between the chosen slope constraint and the relative duration. The duration ratio of the longest and the shortest object is ", dtw_slope, U". This implies that the largest slope in the constraint must have a value greater or equal to this ratio."); + U"There is a conflict between the chosen slope constraint and the relative duration. " + U"The duration ratio of the longest and the shortest object is ", dtw_slope, + U". This implies that the largest slope in the constraint must have a value greater than or equal to this ratio." + ); } catch (MelderError) { Melder_throw (U"Slope constraints cannot be met."); } diff --git a/dwtools/DataModeler.cpp b/dwtools/DataModeler.cpp index c9f2b3f1..14e9ee2e 100644 --- a/dwtools/DataModeler.cpp +++ b/dwtools/DataModeler.cpp @@ -289,35 +289,24 @@ double DataModeler_getParameterStandardDeviation (DataModeler me, integer index) double DataModeler_getVarianceOfParameters (DataModeler me, integer fromIndex, integer toIndex, integer *out_numberOfFreeParameters) { double variance = undefined; - if (toIndex < fromIndex || (toIndex == 0 && fromIndex == 0)) { - fromIndex = 1; - toIndex = my numberOfParameters; - } - integer numberOfFreeParameters = 0; - if (fromIndex <= toIndex && fromIndex > 0 && toIndex <= my numberOfParameters) { - variance = 0; - for (integer ipar = fromIndex; ipar <= toIndex; ipar ++) { - if (my parameters [ipar] .status != kDataModelerParameter::FIXED_) { - variance += my parameterCovariances -> data [ipar] [ipar]; - numberOfFreeParameters ++; - } + getAutoNaturalNumbersWithinRange (& fromIndex, & toIndex, my numberOfParameters, U"parameter"); + integer numberOfFreeParameters = 0; + variance = 0; + for (integer ipar = fromIndex; ipar <= toIndex; ipar ++) { + if (my parameters [ipar] .status != kDataModelerParameter::FIXED_) { + variance += my parameterCovariances -> data [ipar] [ipar]; + numberOfFreeParameters ++; } - } - + } if (out_numberOfFreeParameters) *out_numberOfFreeParameters = numberOfFreeParameters; return variance; } void DataModeler_setParametersFree (DataModeler me, integer fromIndex, integer toIndex) { - if (toIndex < fromIndex || (toIndex == 0 && fromIndex == 0)) { - fromIndex = 1; - toIndex = my numberOfParameters; - } - if (fromIndex <= toIndex && fromIndex > 0 && toIndex <= my numberOfParameters) { - for (integer ipar = fromIndex; ipar <= toIndex; ipar ++) - my parameters [ipar] .status = kDataModelerParameter::FREE; - } + getAutoNaturalNumbersWithinRange (& fromIndex, & toIndex, my numberOfParameters, U"parameter"); + for (integer ipar = fromIndex; ipar <= toIndex; ipar ++) + my parameters [ipar] .status = kDataModelerParameter::FREE; } void DataModeler_setParameterValuesToZero (DataModeler me, double numberOfSigmas) { @@ -349,10 +338,9 @@ integer DataModeler_getNumberOfFixedParameters (DataModeler me) { static integer DataModeler_getNumberOfValidDataPoints (DataModeler me) { integer numberOfValidDataPoints = 0; - for (integer ipoint = 1; ipoint <= my numberOfDataPoints; ipoint ++) { + for (integer ipoint = 1; ipoint <= my numberOfDataPoints; ipoint ++) if (my data [ipoint] .status != kDataModelerData::INVALID) numberOfValidDataPoints ++; - } return numberOfValidDataPoints; } @@ -366,10 +354,9 @@ void DataModeler_setTolerance (DataModeler me, double tolerance) { double DataModeler_getDegreesOfFreedom (DataModeler me) { integer numberOfDataPoints = 0; - for (integer ipoint = 1; ipoint <= my numberOfDataPoints; ipoint ++) { + for (integer ipoint = 1; ipoint <= my numberOfDataPoints; ipoint ++) if (my data [ipoint] .status != kDataModelerData::INVALID) numberOfDataPoints ++; - } const double ndf = numberOfDataPoints - DataModeler_getNumberOfFreeParameters (me); return ndf; } @@ -383,7 +370,7 @@ autoVEC DataModeler_getDataPointsWeights (DataModeler me, kDataModelerWeights we if (weighData == kDataModelerWeights::EQUAL_WEIGHTS) { /* We weigh with the inverse of the standard deviation of the data to give - subsequent Chi squared tests a meaningful interpretation. + subsequent Chi squared tests a meaningful interpretation. */ const double stdev = DataModeler_getDataStandardDeviation (me); Melder_require (isdefined (stdev), @@ -467,12 +454,11 @@ double DataModeler_getChiSquaredQ (DataModeler me, double *out_prob, double *out double DataModeler_getWeightedMean (DataModeler me) { double ysum = 0.0, wsum = 0.0; autoVEC weights = DataModeler_getDataPointsWeights (me, my weighData); - for (integer ipoint = 1; ipoint <= my numberOfDataPoints; ipoint ++) { + for (integer ipoint = 1; ipoint <= my numberOfDataPoints; ipoint ++) if (my data [ipoint] .status != kDataModelerData::INVALID) { ysum += my data [ipoint] .y * weights [ipoint]; wsum += weights [ipoint]; } - } return ysum / wsum; } @@ -548,13 +534,12 @@ integer DataModeler_drawingSpecifiers_x (DataModeler me, double *xmin, double *x return *ixmax - *ixmin + 1; } -void DataModeler_drawOutliersMarked_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - double numberOfSigmas, conststring32 mark, double marksFontSize, double horizontalOffset_mm) +void DataModeler_drawOutliersMarked_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, double numberOfSigmas, conststring32 mark, double marksFontSize) { integer ixmin, ixmax; - if (DataModeler_drawingSpecifiers_x (me, & xmin, & xmax, & ixmin, & ixmax) < 1) return; + if (DataModeler_drawingSpecifiers_x (me, & xmin, & xmax, & ixmin, & ixmax) < 1) + return; autoVEC zscores = DataModeler_getZScores (me); - const double horizontalOffset_wc = Graphics_dxMMtoWC (g, horizontalOffset_mm); Graphics_setWindow (g, xmin, xmax, ymin, ymax); Graphics_setFontSize (g, marksFontSize); @@ -565,32 +550,27 @@ void DataModeler_drawOutliersMarked_inside (DataModeler me, Graphics g, double x const double x = my data [ipoint] .x, y = my data [ipoint] .y; if (x >= xmin && x <= xmax && y >= ymin && y <= ymax) if (fabs (zscores [ipoint]) > numberOfSigmas) - Graphics_text (g, x + horizontalOffset_wc, y, mark); + Graphics_text (g, x, y, mark); } } Graphics_setFontSize (g, currentFontSize); } -void DataModeler_draw_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, bool errorbars, bool connectPoints, double barWidth_mm, double horizontalOffset_mm, bool drawDots) +void DataModeler_draw_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool estimated, integer numberOfParameters, bool errorbars, bool connectPoints, double barWidth_wc, bool drawDots) { Function_unidirectionalAutowindow (me, & xmin, & xmax); - integer ixmin = 2; - while (my data [ixmin] .x < xmin && ixmin < my numberOfDataPoints) + + integer ixmin = 1; + while (ixmin <= my numberOfDataPoints && my data [ixmin] .x < xmin) ixmin ++; - ixmin --; - integer ixmax = my numberOfDataPoints - 1; - while (my data [ixmax] .x > xmax && ixmax > 1) + integer ixmax = my numberOfDataPoints; + while (ixmax > 0 && my data [ixmax] .x > xmax) ixmax --; - ixmax ++; - if (ixmin >= ixmax) + if (ixmin > ixmax) return; // nothing to draw - numberOfParameters = ( numberOfParameters > my numberOfParameters ? my numberOfParameters : numberOfParameters ); - autovector parameters = newvectorcopy (my parameters.all()); + getAutoNaturalNumberWithinRange (& numberOfParameters, my numberOfParameters); Graphics_setWindow (g, xmin, xmax, ymin, ymax); - const double horizontalOffset_wc = Graphics_dxMMtoWC (g, horizontalOffset_mm); - const double barWidth_wc = ( barWidth_mm <= 0.0 ? 0.0 : Graphics_dxMMtoWC (g, barWidth_mm) ); double x1, y1, x2, y2; bool x1defined = false, x2defined = false; for (integer ipoint = ixmin; ipoint <= ixmax; ipoint ++) { @@ -598,21 +578,21 @@ void DataModeler_draw_inside (DataModeler me, Graphics g, double xmin, double xm const double x = my data [ipoint] .x, y = my data [ipoint].y; if (! x1defined) { x1 = x; - y1 = ( estimated ? my f_evaluate (me, x, parameters.get()) : y ); + y1 = ( estimated ? my f_evaluate (me, x, my parameters.get()) : y ); x1defined = true; } else { x2 = x; - y2 = ( estimated ? my f_evaluate (me, x, parameters.get()) : y ); + y2 = ( estimated ? my f_evaluate (me, x, my parameters.get()) : y ); x2defined = true; } if (x1defined && drawDots) { if (y >= ymin && y <= ymax) - Graphics_speckle (g, x + horizontalOffset_wc, y); + Graphics_speckle (g, x, y); } if (x2defined) { // if (x1defined && x2defined) if (connectPoints) { double xo1, yo1, xo2, yo2; - if (NUMclipLineWithinRectangle (x1 + horizontalOffset_wc, y1, x2 + horizontalOffset_wc, y2, + if (NUMclipLineWithinRectangle (x1, y1, x2, y2, xmin, ymin, xmax, ymax, & xo1, & yo1, & xo2, & yo2)) { Graphics_line (g, xo1, yo1, xo2, yo2); } @@ -631,9 +611,9 @@ void DataModeler_draw_inside (DataModeler me, Graphics g, double xmin, double xm bool topOutside = yt > ymax, bottomOutside = yb < ymin; yt = ( topOutside ? ymax : yt ); yb = ( bottomOutside ? ymin : yb ); - Graphics_line (g, x1 + horizontalOffset_wc, yb, x1 + horizontalOffset_wc, yt); + Graphics_line (g, x1, yb, x1, yt); if (barWidth_wc > 0.0 && ! estimated) { - double xl = x1 - 0.5 * barWidth_wc + horizontalOffset_wc; + double xl = x1 - 0.5 * barWidth_wc; double xr = xl + barWidth_wc; if (! topOutside) Graphics_line (g, xl, yt, xr, yt); @@ -645,19 +625,40 @@ void DataModeler_draw_inside (DataModeler me, Graphics g, double xmin, double xm } } -void DataModeler_drawTrack_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool estimated, integer numberOfParameters, double horizontalOffset_mm) +void DataModeler_drawModel_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, integer numberOfPoints) { + Function_bidirectionalAutowindow (me, & xmin, & xmax); + autoVEC x = newVECraw (numberOfPoints), y = newVECraw (numberOfPoints); + const double dx = (xmax - xmin) / numberOfPoints; + for (integer ipoint = 1; ipoint <= numberOfPoints; ipoint ++) { + x [ipoint] = xmin + (ipoint - 1) * dx; + y [ipoint] = my f_evaluate (me, x [ipoint], my parameters.get()); + } + if (ymin == 0.0 && ymax == 0.0) { + ymin = NUMmin (y.get()); + ymax = NUMmax (y.get()); + } + Graphics_setWindow (g, xmin, xmax, ymin, ymax); + for (integer ipoint = 2; ipoint <= numberOfPoints; ipoint ++) { + double segment_x1, segment_y1, segment_x2, segment_y2; + if (NUMclipLineWithinRectangle (x [ipoint - 1], y [ipoint - 1], x [ipoint], y [ipoint], + xmin, ymin, xmax, ymax, & segment_x1, & segment_y1, & segment_x2, & segment_y2)) + Graphics_line (g, segment_x1, segment_y1, segment_x2, segment_y2); + } +} + +void DataModeler_drawTrack_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool estimated, integer numberOfParameters) { const bool errorbars = false, connectPoints = true; const double barWidth_mm = 0; - DataModeler_draw_inside (me, g, xmin, xmax, ymin, ymax, estimated, numberOfParameters, errorbars, connectPoints, barWidth_mm, horizontalOffset_mm, 0); + DataModeler_draw_inside (me, g, xmin, xmax, ymin, ymax, estimated, numberOfParameters, errorbars, connectPoints, barWidth_mm, 0); } void DataModeler_drawTrack (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, double horizontalOffset_mm, bool garnish) { + bool estimated, integer numberOfParameters, bool garnish) { if (ymax <= ymin) DataModeler_getExtremaY (me, & ymin, & ymax); Graphics_setInner (g); - DataModeler_drawTrack_inside (me, g, xmin, xmax, ymin, ymax, estimated, numberOfParameters, horizontalOffset_mm); + DataModeler_drawTrack_inside (me, g, xmin, xmax, ymin, ymax, estimated, numberOfParameters); Graphics_unsetInner (g); if (garnish) { Graphics_drawInnerBox (g); @@ -666,20 +667,19 @@ void DataModeler_drawTrack (DataModeler me, Graphics g, double xmin, double xmax } } -void DataModeler_speckle_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, bool errorbars, double barWidth_mm, double horizontalOffset_mm) { +void DataModeler_speckle_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool estimated, integer numberOfParameters, bool errorbars, double barWidth_wc) { bool connectPoints = false; - DataModeler_draw_inside (me, g, xmin, xmax, ymin, ymax, estimated, numberOfParameters, errorbars, connectPoints, barWidth_mm, horizontalOffset_mm, 1); + DataModeler_draw_inside (me, g, xmin, xmax, ymin, ymax, estimated, numberOfParameters, errorbars, connectPoints, barWidth_wc, 1); } void DataModeler_speckle (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, bool errorbars, double barWidth_mm, double horizontalOffset_mm, bool garnish) + bool estimated, integer numberOfParameters, bool errorbars, double barWidth_mm, bool garnish) { if (ymax <= ymin) DataModeler_getExtremaY (me, & ymin, & ymax); Graphics_setInner (g); DataModeler_speckle_inside (me, g, xmin, xmax, ymin, ymax, - estimated, numberOfParameters, errorbars, barWidth_mm, horizontalOffset_mm); + estimated, numberOfParameters, errorbars, barWidth_mm); Graphics_unsetInner (g); if (garnish) { Graphics_drawInnerBox (g); @@ -732,8 +732,6 @@ void DataModeler_init (DataModeler me, double xmin, double xmax, integer numberO Melder_require (numberOfParameters > 0, U"The number of parameters should be greater than zero."); - Melder_require (numberOfParameters <= numberOfDataPoints, - U"The number of parameters should not exceed the number of data points"); my parameters = newvectorzero (numberOfParameters); for (integer ipar = 1; ipar <= numberOfParameters; ipar ++) @@ -788,6 +786,8 @@ void DataModeler_fit (DataModeler me) { if (numberOfFreeParameters == 0) return; const integer numberOfValidDataPoints = DataModeler_getNumberOfValidDataPoints (me); + if (numberOfValidDataPoints - numberOfFreeParameters < 0) + return; autoVEC yEstimation = newVECzero (numberOfValidDataPoints); autoVEC term = newVECzero (my numberOfParameters); autovector fixedParameters = newvectorcopy (my parameters.all()); diff --git a/dwtools/DataModeler.h b/dwtools/DataModeler.h index 8bcb4b40..9e768a37 100644 --- a/dwtools/DataModeler.h +++ b/dwtools/DataModeler.h @@ -33,6 +33,28 @@ #include "DataModeler_def.h" +static inline void getAutoNaturalNumbersWithinRange (integer *from, integer *to, integer maximum, conststring32 text) { + if (*from <= 0) + *from = 1; + if (*to == 0) + *to = maximum; + if (*to < *from) { + *from = 1; + *to = maximum; + } + if (*to > maximum) + *to = maximum; + Melder_require (*from <= maximum, + U"The start index of the ", text, U" range should not be larger than ", maximum, U"."); +} + +static inline void getAutoNaturalNumberWithinRange (integer *number, integer maximum) { + if (*number == 0 || *number > maximum) + *number = maximum; + if (*number < 0) + *number = 1; +} + void DataModeler_init (DataModeler me, double xmin, double xmax, integer numberOfDataPoints, integer numberOfParameters, kDataModelerFunction type); autoDataModeler DataModeler_create (double xmin, double xmax, integer numberOfDataPoints, integer numberOfParameters, kDataModelerFunction type); @@ -47,23 +69,23 @@ integer DataModeler_drawingSpecifiers_x (DataModeler me, double *xmin, double *x void DataModeler_drawBasisFunction_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, integer iterm, bool scale, integer numberOfPoints); -void DataModeler_draw_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, bool errorbars, bool connectPoints, double barWidth_mm, double horizontalOffset_mm, bool drawDots); +void DataModeler_drawModel_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, integer numberOfPoints); + +void DataModeler_draw_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool estimated, integer numberOfParameters, bool errorbars, bool connectPoints, double barWidth_mm, bool drawDots); -void DataModeler_speckle_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, bool errorbars, double barWidth_mm, double horizontalOffset_mm); +void DataModeler_speckle_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, bool estimated, integer numberOfParameters, bool errorbars, double barWidth_mm); void DataModeler_speckle (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, bool errorbars, double barWidth_mm, double horizontalOffset_mm, bool garnish); + bool estimated, integer numberOfParameters, bool errorbars, double barWidth_mm, bool garnish); void DataModeler_drawTrack (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, double horizontalOffset_mm, bool garnish); + bool estimated, integer numberOfParameters, bool garnish); void DataModeler_drawTrack_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - bool estimated, integer numberOfParameters, double horizontalOffset_mm); + bool estimated, integer numberOfParameters); void DataModeler_drawOutliersMarked_inside (DataModeler me, Graphics g, double xmin, double xmax, double ymin, double ymax, - double numberOfSigmas, conststring32 mark, double marksFontSize, double horizontalOffset_mm); + double numberOfSigmas, conststring32 mark, double marksFontSize); void DataModeler_normalProbabilityPlot (DataModeler me, Graphics g, integer numberOfQuantiles, double numberOfSigmas, double labelSize, conststring32 label, bool garnish); /* Get the y-value of the fitted function at x */ diff --git a/dwtools/DataModeler_enums.h b/dwtools/DataModeler_enums.h index 3d76210d..d555e304 100644 --- a/dwtools/DataModeler_enums.h +++ b/dwtools/DataModeler_enums.h @@ -9,8 +9,9 @@ * * This code is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * * You should have received a copy of the GNU General Public License * along with this work. If not, see . diff --git a/dwtools/Discriminant.cpp b/dwtools/Discriminant.cpp index d7f6d72c..c5fd2815 100644 --- a/dwtools/Discriminant.cpp +++ b/dwtools/Discriminant.cpp @@ -38,8 +38,6 @@ #include "Discriminant.h" #include "SSCP.h" #include "Eigen_and_SSCP.h" -#include "Eigen_and_TableOfReal.h" -#include "SVD.h" #include "NUM2.h" #include "TableOfReal_extensions.h" @@ -375,394 +373,4 @@ void Discriminant_drawConcentrationEllipses (Discriminant me, Graphics g, double } } -autoDiscriminant TableOfReal_to_Discriminant (TableOfReal me) { - try { - autoDiscriminant thee = Thing_new (Discriminant); - const integer dimension = my numberOfColumns; - - Melder_require (NUMdefined (my data.get()), - U"There should be no undefined elements in the table."); - Melder_require (TableOfReal_hasRowLabels (me), - U"All rows should be labeled."); - - autoTableOfReal mew = TableOfReal_sortOnlyByRowLabels (me); - if (! TableOfReal_hasColumnLabels (mew.get())) - TableOfReal_setSequentialColumnLabels (mew.get(), 0, 0, U"c", 1, 1); - - thy groups = TableOfReal_to_SSCPList_byLabel (mew.get()); - thy total = TableOfReal_to_SSCP (mew.get(), 0, 0, 0, 0); - - if ((thy numberOfGroups = thy groups -> size) < 2) - Melder_throw (U"Number of groups should be greater than one."); - - TableOfReal_centreColumns_byRowLabel (mew.get()); - - // Overall centroid and apriori probabilities and costs. - - autoVEC centroid = newVECzero (dimension); - autoMAT between = newMATzero (thy numberOfGroups, dimension); - thy aprioriProbabilities = newVECraw (thy numberOfGroups); - - longdouble sum = 0.0; - for (integer k = 1; k <= thy numberOfGroups; k ++) { - const SSCP m = thy groups->at [k]; - const double scale = SSCP_getNumberOfObservations (m); - centroid.all() += scale * m -> centroid.all(); - sum += scale; - } - centroid.all() /= double (sum); - - for (integer k = 1; k <= thy numberOfGroups; k ++) { - const SSCP m = thy groups->at [k]; - const double scale = SSCP_getNumberOfObservations (m); - thy aprioriProbabilities [k] = scale / my numberOfRows; - between.row (k) <<= m -> centroid.all() - centroid.all(); - between.row (k) *= sqrt (scale); - } - - // We need to solve B'B.x = lambda W'W.x, where B'B and W'W are the between and within covariance matrices. - // We do not calculate these covariance matrices directly from the data but instead use the GSVD to solve for - // the eigenvalues and eigenvectors of the equation. - - thy eigen = Thing_new (Eigen); - Eigen_initFromSquareRootPair (thy eigen.get(), between.get(), mew -> data.get()); - - /* - Costs. - */ - thy costs = newMATraw (thy numberOfGroups, thy numberOfGroups); - - thy costs.get() <<= 1.0; - thy costs.diagonal() <<= 0.0; - - return thee; - } catch (MelderError) { - Melder_throw (me, U": Discriminant not created."); - } -} - -autoConfiguration Discriminant_TableOfReal_to_Configuration (Discriminant me, TableOfReal thee, integer numberOfDimensions) { - try { - Melder_require (thy numberOfColumns == my eigen -> dimension, - U"The number of columns in the TableOfReal (", thy numberOfColumns, U") should be equal to the dimension of the eigenvectors of the Discriminant (", my eigen -> dimension, U")."); - if (numberOfDimensions == 0) - numberOfDimensions = Discriminant_getNumberOfFunctions (me); - Melder_require (numberOfDimensions <= my eigen -> numberOfEigenvalues, - U"The number of dimensions should not exceed the number of eigenvectors in the Discriminant (", my eigen -> numberOfEigenvalues, U")."); - autoConfiguration him = Configuration_create (thy numberOfRows, numberOfDimensions); - MATmul (his data.get(), thy data.get(), my eigen -> eigenvectors.horizontalBand (1, numberOfDimensions).transpose ()); - TableOfReal_copyLabels (thee, him.get(), 1, 0); - TableOfReal_setSequentialColumnLabels (him.get(), 0, 0, U"Eigenvector ", 1, 1); - return him; - } catch (MelderError) { - Melder_throw (U"Configuration not created."); - } -} - -autoTableOfReal Discriminant_TableOfReal_mahalanobis (Discriminant me, TableOfReal thee, integer group, bool poolCovarianceMatrices) { - try { - Melder_require (group > 0 && group <= my numberOfGroups, - U"Group should be in the range [1, ", my numberOfGroups, U"]."); - autoSSCP pool = SSCPList_to_SSCP_pool (my groups.get()); - autoCovariance covg = SSCP_to_Covariance (pool.get(), my numberOfGroups); - autoCovariance cov = SSCP_to_Covariance (my groups->at [group], 1); - autoTableOfReal him; - if (poolCovarianceMatrices) { // use group mean instead of overall mean! - covg -> centroid.all() <<= cov -> centroid.all(); - him = Covariance_TableOfReal_mahalanobis (covg.get(), thee, false); - } else { - him = Covariance_TableOfReal_mahalanobis (cov.get(), thee, false); - } - return him; - } catch (MelderError) { - Melder_throw (U"TableOfReal not created."); - } -} - -autoClassificationTable Discriminant_TableOfReal_to_ClassificationTable (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices, bool useAprioriProbabilities) { - try { - const integer numberOfGroups = Discriminant_getNumberOfGroups (me); - const integer dimension = Eigen_getDimensionOfComponents (my eigen.get()); - - Melder_require (dimension == thy numberOfColumns, - U"The number of columns should agree with the dimension of the discriminant."); - - autoVEC log_p = newVECraw (numberOfGroups); - autoVEC log_apriori = newVECraw (numberOfGroups); - autoVEC ln_determinant = newVECraw (numberOfGroups); - autoVEC buf = newVECraw (dimension); - - autovector sscpvec = newvectorzero (numberOfGroups); - autoSSCP pool = SSCPList_to_SSCP_pool (my groups.get()); - autoClassificationTable him = ClassificationTable_create (thy numberOfRows, numberOfGroups); - his rowLabels.all() <<= thy rowLabels.all(); - - /* - Scale the sscp to become a covariance matrix. - */ - pool -> data.get() *= 1.0 / (pool -> numberOfObservations - numberOfGroups); - - double lnd; - autoSSCPList agroups; - SSCPList groups; // ppgb FIXME dit kan niet goed izjn - if (poolCovarianceMatrices) { - /* - Covariance matrix S can be decomposed as S = L.L'. Calculate L^-1. - L^-1 will be used later in the Mahalanobis distance calculation: - v'.S^-1.v == v'.L^-1'.L^-1.v == (L^-1.v)'.(L^-1.v). - */ - if (Melder_debug == 52) - Melder_casual (U"***** before lower Cholesky inverse: \n", pool -> data.all()); - MATlowerCholeskyInverse_inplace (pool -> data.get(), & lnd); - if (Melder_debug == 52) - Melder_casual (U"***** after lower Cholesky inverse: \n", pool -> data.all()); - for (integer j = 1; j <= numberOfGroups; j ++) { - ln_determinant [j] = lnd; - sscpvec [j] = pool.get(); - } - groups = my groups.get(); - } else { - /* - Calculate the inverses of all group covariance matrices. - In case of a singular matrix, substitute inverse of pooled. - */ - agroups = Data_copy (my groups.get()); - groups = agroups.get(); - integer npool = 0; - for (integer j = 1; j <= numberOfGroups; j ++) { - const SSCP t = groups->at [j]; - const integer no = Melder_ifloor (SSCP_getNumberOfObservations (t)); - t -> data.get() *= 1.0 / (no - 1); - - sscpvec [j] = groups->at [j]; - try { - MATlowerCholeskyInverse_inplace (t -> data.get(), & ln_determinant [j]); - } catch (MelderError) { - /* - Clear the error. - Try the alternative: the pooled covariance matrix. - */ - Melder_clearError (); - if (npool == 0) - MATlowerCholeskyInverse_inplace (pool -> data.get(), & lnd); - npool ++; - sscpvec [j] = pool.get(); - ln_determinant [j] = lnd; - } - } - if (npool > 0) - Melder_warning (npool, U" groups use pooled covariance matrix."); - } - - /* - Labels for columns in ClassificationTable - */ - for (integer j = 1; j <= numberOfGroups; j ++) { - conststring32 name = Thing_getName (my groups->at [j]); - if (! name) - name = U"?"; - TableOfReal_setColumnLabel (him.get(), j, name); - } - - /* - Normalize the sum of the apriori probabilities to 1. - Next take ln (p) because otherwise probabilities might be too small to represent. - */ - if (Melder_debug == 52) - Melder_casual (U"***** before normalizing priors: \n", my aprioriProbabilities.all()); - VECnormalize_inplace (my aprioriProbabilities.get(), 1.0, 1.0); - if (Melder_debug == 52) - Melder_casual (U"***** after normalizing priors: \n", my aprioriProbabilities.all()); - const double logg = log (numberOfGroups); - for (integer j = 1; j <= numberOfGroups; j ++) - log_apriori [j] = ( useAprioriProbabilities ? log (my aprioriProbabilities [j]) : - logg ); - - /* - Generalized squared distance function: - D^2(x) = (x - mu)' S^-1 (x - mu) + ln (determinant(S)) - 2 ln (apriori) - */ - for (integer i = 1; i <= thy numberOfRows; i ++) { - double norm = 0.0, pt_max = -1e308; - for (integer j = 1; j <= numberOfGroups; j ++) { - const SSCP t = groups->at [j]; - const double md = NUMmahalanobisDistanceSquared (sscpvec [j] -> data.get(), thy data.row (i), t -> centroid.get()); - if (Melder_debug == 52) - Melder_casual (U"***** Mahalanobis distance (squared): ", i, U" ", j, U" ", md); - const double pt = log_apriori [j] - 0.5 * (ln_determinant [j] + md); - if (pt > pt_max) - pt_max = pt; - log_p [j] = pt; - } - for (integer j = 1; j <= numberOfGroups; j ++) - norm += log_p [j] = exp (log_p [j] - pt_max); - for (integer j = 1; j <= numberOfGroups; j ++) - his data [i] [j] = log_p [j] / norm; - } - return him; - } catch (MelderError) { - Melder_throw (U"ClassificationTable from Discriminant & TableOfReal not created."); - } -} - -autoClassificationTable Discriminant_TableOfReal_to_ClassificationTable_dw (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices, bool useAprioriProbabilities, double alpha, double minProb, autoTableOfReal *displacements) { - try { - const integer g = Discriminant_getNumberOfGroups (me); - const integer p = Eigen_getDimensionOfComponents (my eigen.get()); - const integer m = thy numberOfRows; - - Melder_require (p == thy numberOfColumns, - U"The number of columns does not agree with the dimension of the discriminant."); - - autoVEC log_p = newVECraw (g); - autoVEC log_apriori = newVECraw (g); - autoVEC ln_determinant = newVECraw (g); - autoVEC buf = newVECraw (p); - autoVEC displacement = newVECraw (p); - autoVEC x = newVECzero (p); - autovector sscpvec = newvectorzero (g); - autoSSCP pool = SSCPList_to_SSCP_pool (my groups.get()); - autoClassificationTable him = ClassificationTable_create (m, g); - his rowLabels.all() <<= thy rowLabels.all(); - autoTableOfReal adisplacements = Data_copy (thee); - - /* - Scale the sscp to become a covariance matrix. - */ - - pool -> data.get() *= 1.0 / (pool -> numberOfObservations - g); - - double lnd; - autoSSCPList agroups; - SSCPList groups; - if (poolCovarianceMatrices) { - - /* - Covariance matrix S can be Cholesky decomposed as S = L.L'. - Calculate L^-1. - L^-1 will be used later in the Mahalanobis distance calculation: - v'.S^-1.v = v'.L^-1'.L^-1.v = (L^-1.v)'.(L^-1.v). - */ - - MATlowerCholeskyInverse_inplace (pool -> data.get(), & lnd); - for (integer j = 1; j <= g; j ++) { - ln_determinant [j] = lnd; - sscpvec [j] = pool.get(); - } - groups = my groups.get(); - } else { - - /* - Calculate the inverses of all group covariance matrices. - In case of a singular matrix, substitute inverse of pooled. - */ - - agroups = Data_copy (my groups.get()); - groups = agroups.get(); - integer npool = 0; - for (integer j = 1; j <= g; j ++) { - const SSCP t = groups->at [j]; - const integer no = Melder_ifloor (SSCP_getNumberOfObservations (t)); - t -> data.get() *= 1.0 / (no - 1); - - sscpvec [j] = groups->at [j]; - try { - MATlowerCholeskyInverse_inplace (t -> data.get(), & ln_determinant [j]); - } catch (MelderError) { - - /* - Clear the error. - Try the alternative: the pooled covariance matrix. - */ - - Melder_clearError (); - if (npool == 0) - MATlowerCholeskyInverse_inplace (pool -> data.get(), & lnd); - npool ++; - sscpvec [j] = pool.get(); - ln_determinant [j] = lnd; - } - } - if (npool > 0) - Melder_warning (npool, U" groups use pooled covariance matrix."); - } - - /* - Labels for columns in ClassificationTable - */ - - for (integer j = 1; j <= g; j ++) { - conststring32 name = Thing_getName (my groups->at [j]); - if (! name) - name = U"?"; - TableOfReal_setColumnLabel (him.get(), j, name); - } - - /* - Normalize the sum of the apriori probabilities to 1. - Next take ln (p) because otherwise probabilities might be too small to represent. - */ - - const double logg = log (g); - VECnormalize_inplace (my aprioriProbabilities.get(), 1.0, 1.0); - for (integer j = 1; j <= g; j ++) { - log_apriori [j] = ( useAprioriProbabilities ? log (my aprioriProbabilities [j]) : - logg ); - } - - /* - Generalized squared distance function: - D^2(x) = (x - mu)' S^-1 (x - mu) + ln (determinant(S)) - 2 ln (apriori) - */ - - for (integer i = 1; i <= m; i ++) { - SSCP winner; - double norm = 0, pt_max = -1e308; - integer iwinner = 1; - for (integer k = 1; k <= p; k ++) - x [k] = thy data [i] [k] + displacement [k]; - for (integer j = 1; j <= g; j ++) { - const SSCP t = groups->at [j]; - const double md = NUMmahalanobisDistanceSquared (sscpvec [j] -> data.get(), x.get(), t -> centroid.get()); - const double pt = log_apriori [j] - 0.5 * (ln_determinant [j] + md); - if (pt > pt_max) { - pt_max = pt; - iwinner = j; - } - log_p [j] = pt; - } - for (integer j = 1; j <= g; j ++) - norm += log_p [j] = exp (log_p [j] - pt_max); - - for (integer j = 1; j <= g; j ++) - his data [i] [j] = log_p [j] / norm; - - /* - Save old displacement, calculate new displacement - */ - - winner = groups->at [iwinner]; - for (integer k = 1; k <= p; k ++) { - adisplacements -> data [i] [k] = displacement [k]; - if (his data [i] [iwinner] > minProb) { - double delta_k = winner -> centroid [k] - x [k]; - displacement [k] += alpha * delta_k; - } - } - } - *displacements = adisplacements.move(); - return him; - } catch (MelderError) { - Melder_throw (U"ClassificationTable for Weenink procedure not created."); - } -} - -autoConfiguration TableOfReal_to_Configuration_lda (TableOfReal me, integer numberOfDimensions) { - try { - autoDiscriminant thee = TableOfReal_to_Discriminant (me); - autoConfiguration him = Discriminant_TableOfReal_to_Configuration (thee.get(), me, numberOfDimensions); - return him; - } catch (MelderError) { - Melder_throw (me, U": Configuration with lda data not created."); - } -} - /* End of file Discriminant.cpp */ diff --git a/dwtools/Discriminant.h b/dwtools/Discriminant.h index 8f219981..07c25855 100644 --- a/dwtools/Discriminant.h +++ b/dwtools/Discriminant.h @@ -18,10 +18,8 @@ * along with this work. If not, see . */ -#include "Graphics.h" -#include "Configuration.h" -#include "ClassificationTable.h" #include "Eigen.h" +#include "Graphics.h" #include "SSCP.h" #include "Discriminant_def.h" @@ -75,19 +73,4 @@ autoStrings Discriminant_extractGroupLabels (Discriminant me); void Discriminant_setGroupLabels (Discriminant me, Strings thee); -autoConfiguration Discriminant_TableOfReal_to_Configuration (Discriminant me, TableOfReal thee, integer numberOfDimensions); - -autoClassificationTable Discriminant_TableOfReal_to_ClassificationTable - (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices, bool useAprioriProbabilities); - -autoClassificationTable Discriminant_TableOfReal_to_ClassificationTable_dw - (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices, bool useAprioriProbabilities, double alpha, double minProb, autoTableOfReal *displacements); - -autoTableOfReal Discriminant_TableOfReal_mahalanobis (Discriminant me, TableOfReal thee, integer group, bool poolCovarianceMatrices); -/* Mahalanobis distance with respect to group mean */ - -autoDiscriminant TableOfReal_to_Discriminant (TableOfReal me); - -autoConfiguration TableOfReal_to_Configuration_lda (TableOfReal me, integer numberOfDimensions); - #endif /* _Discriminant_h_ */ diff --git a/dwtools/Discriminant_PatternList_Categories.cpp b/dwtools/Discriminant_PatternList_Categories.cpp index e95c5627..f0eaa3b3 100644 --- a/dwtools/Discriminant_PatternList_Categories.cpp +++ b/dwtools/Discriminant_PatternList_Categories.cpp @@ -21,7 +21,7 @@ */ #include "Discriminant_PatternList_Categories.h" -#include "TableOfReal.h" +#include "TableOfReal_and_Discriminant.h" #include "Matrix_Categories.h" autoDiscriminant PatternList_Categories_to_Discriminant (PatternList me, Categories thee) { diff --git a/dwtools/HMM.cpp b/dwtools/HMM.cpp index 5ba7d5f9..e6da8a30 100644 --- a/dwtools/HMM.cpp +++ b/dwtools/HMM.cpp @@ -69,7 +69,6 @@ Thing_implement (HMMStateSequence, Strings, 0); */ // helpers -static integer NUMget_line_intersection_with_circle (double xc, double yc, double r, double a, double b, double *out_x1, double *out_y1, double *out_x2, double *out_y2); autoHMMObservation HMMObservation_create (conststring32 label, integer numberOfComponents, integer dimension, kHMMstorage storage); integer HMM_HMMObservationSequence_getLongestSequence (HMM me, HMMObservationSequence thee, integer symbolNumber); @@ -93,7 +92,6 @@ autoStringsIndex HMM_HMMStateSequence_to_StringsIndex (HMM me, HMMStateSequence autoHMMViterbi HMMViterbi_create (integer nstates, integer ntimes); -static autoHMMViterbi HMM_to_HMMViterbi (HMM me, integer *obs, integer ntimes); // evaluate the numbers given to probabilities static autoVEC NUMwstring_to_probs (conststring32 s, integer nwanted) { @@ -113,6 +111,7 @@ static autoVEC NUMwstring_to_probs (conststring32 s, integer nwanted) { return numbers; } +#if 0 static integer NUMget_line_intersection_with_circle (double xc, double yc, double r, double a, double b, double *out_x1, double *out_y1, double *out_x2, double *out_y2) { const double ca = a * a + 1.0, bmyc = (b - yc); const double cb = 2.0 * (a * bmyc - xc); @@ -139,6 +138,7 @@ static integer NUMget_line_intersection_with_circle (double xc, double yc, doubl *out_y2 = y2; return nroots; } +#endif // D(l_1,l_2)=1/n( log p(O_2|l_1) - log p(O_2|l_2) static double HMM_HMM_getCrossEntropy_asym (HMM me, HMM thee, integer observationLength) { @@ -866,7 +866,7 @@ static autoINTVEC HMM_HMMObservationSequenceBag_getStateSequences (HMM me, HMMOb Melder_assert (numberOfElements == numberOfElements2); return stateSequenceNumbers; } - +#if 0 static void HMM_smoothInitialStateProbs_naive (HMM me, double minProb) { for (integer is = 1; is <= my numberOfStates; is ++) my initialStateProbs [is] = std::max (my initialStateProbs [is], minProb ); @@ -894,7 +894,7 @@ static void HMM_smoothEmissionProbs_naive (HMM me, double minProb) { for (integer irow = 1; irow <= my numberOfStates; irow ++) VECnormalize_inplace (my emissionProbs.row (irow).part (1, my numberOfStates), 1.0, 1.0); } - +#endif /* For a not hidden markov model there is an analytical solution for the state transition probabilities */ diff --git a/dwtools/ICA.cpp b/dwtools/ICA.cpp index 7e0d0328..2a564ef4 100644 --- a/dwtools/ICA.cpp +++ b/dwtools/ICA.cpp @@ -95,7 +95,7 @@ static double diagonalityMeasure (MAT v) { } /* - This routine is modeled after qdiag.m from Andreas Ziehe, Pavel Laskov, Guido Nolte, Klaus-Robert Müller, + This routine is modelled after qdiag.m from Andreas Ziehe, Pavel Laskov, Guido Nolte, Klaus-Robert Müller, A Fast Algorithm for Joint Diagonalization with Non-orthogonal Transformations and its Application to Blind Source Separation, Journal of Machine Learning Research 5 (2004), 777–800. */ @@ -182,7 +182,7 @@ static void Diagonalizer_CrossCorrelationTableList_ffdiag (Diagonalizer me, Cros } /* - The folowing two routines are modeled after qdiag.m from + The folowing two routines are modelled after qdiag.m from R. Vollgraf and K. Obermayer, Quadratic Optimization for Simultaneous Matrix Diagonalization, IEEE Transaction on Signal Processing, 2006, */ diff --git a/dwtools/Intensity_extensions.cpp b/dwtools/Intensity_extensions.cpp index 2ef77fe9..f84108dc 100644 --- a/dwtools/Intensity_extensions.cpp +++ b/dwtools/Intensity_extensions.cpp @@ -63,8 +63,8 @@ autoTextGrid Intensity_to_TextGrid_detectSilences (Intensity me, return thee; double intensity_max_db, intensity_min_db, xOfMaximum, xOfMinimum; - Vector_getMaximumAndX (me, 0.0, 0.0, 1, NUM_PEAK_INTERPOLATE_PARABOLIC, & intensity_max_db, & xOfMaximum); - Vector_getMinimumAndX (me, 0.0, 0.0, 1, NUM_PEAK_INTERPOLATE_PARABOLIC, & intensity_min_db, & xOfMinimum); + Vector_getMaximumAndX (me, 0.0, 0.0, 1, kVector_peakInterpolation :: PARABOLIC, & intensity_max_db, & xOfMaximum); + Vector_getMinimumAndX (me, 0.0, 0.0, 1, kVector_peakInterpolation :: PARABOLIC, & intensity_min_db, & xOfMinimum); double intensity_dbRange = intensity_max_db - intensity_min_db; if (intensity_dbRange < 10.0) diff --git a/dwtools/IntervalTierNavigator.cpp b/dwtools/IntervalTierNavigator.cpp new file mode 100644 index 00000000..e61885a7 --- /dev/null +++ b/dwtools/IntervalTierNavigator.cpp @@ -0,0 +1,314 @@ +/* IntervalTierNavigator.cpp + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "IntervalTierNavigator.h" +#include "NUM2.h" + + +#include "enums_getText.h" +#include "IntervalTierNavigator_enums.h" +#include "enums_getValue.h" +#include "IntervalTierNavigator_enums.h" + +Thing_implement (IntervalTierNavigator, Function, 0); + +void structIntervalTierNavigator :: v_info () { + MelderInfo_writeLine (U"Navigation:"); + if (navigationLabels) { + MelderInfo_writeLine (U"\tName: ", navigationLabels -> name.get()); + MelderInfo_writeLine (U"\tNumber of labels: ", navigationLabels -> strings.size); + if (leftContextLabels) { + MelderInfo_writeLine (U"\tLeft context name: ", leftContextLabels -> name.get()); + MelderInfo_writeLine (U"\tLeft criterion: ", kMelder_string_getText (leftContextCriterion)); + MelderInfo_writeLine (U"\tNumber of left context labels: ", leftContextLabels -> strings.size); + } else { + MelderInfo_writeLine (U"\tNo left context navigation labels defined"); + } + if (rightContextLabels) { + MelderInfo_writeLine (U"\tRight context name: ", rightContextLabels -> name.get()); + MelderInfo_writeLine (U"\tRight criterion: ", kMelder_string_getText (rightContextCriterion)); + MelderInfo_writeLine (U"\tNumber of right context labels: ", rightContextLabels -> strings.size); + } else { + MelderInfo_writeLine (U"\tNo right context navigation labels defined"); + } + MelderInfo_writeLine (U"\tMatch context: ", kContextCombination_getText (contextCombination)); + MelderInfo_writeLine (U"\tMatch context only: ", ( matchContextOnly ? U"yes" : U"no" )); + MelderInfo_writeLine (U"\tNumber of interval matches: ", IntervalTierNavigator_getNumberOfMatches (this), U" out of ", intervalTier -> intervals . size); + } else { + MelderInfo_writeLine (U"\tNo navigation labels defined"); + } +} + +autoIntervalTierNavigator IntervalTierNavigator_createFromTextGrid (TextGrid me, integer navigationTier) { + try { + TextGrid_checkSpecifiedTierIsIntervalTier (me, navigationTier); + IntervalTier intervalTier = static_cast (my tiers -> at [navigationTier]); + autoIntervalTierNavigator thee = IntervalTierNavigator_create (intervalTier); + return thee; + } catch (MelderError) { + Melder_throw (U"IntervalTierNavigator not created from ", me, U"."); + } +} + +autoIntervalTierNavigator IntervalTierNavigator_create (IntervalTier me) { + try { + autoIntervalTierNavigator thee = Thing_new (IntervalTierNavigator); + Function_init (thee.get(), my xmin, my xmax); + thy intervalTier = me; + return thee; + } catch (MelderError) { + Melder_throw (U"IntervalTierNavigator not created."); + } +} + +autoIntervalTierNavigator IntervalTierNavigator_createEmpty (IntervalTier me) { + autoIntervalTierNavigator thee = Thing_new (IntervalTierNavigator); + Function_init (thee.get(), my xmin, my xmax); + thy intervalTier = me; + return thee; +} + + +void IntervalTierNavigator_setNavigationLabels (IntervalTierNavigator me, Strings navigationLabels, kMelder_string criterion) { + try { + my navigationLabels = Data_copy (navigationLabels); + Thing_setName (my navigationLabels.get(), navigationLabels -> name.get()); + my navigationCriterion = criterion; + my contextCombination = kContextCombination::NO_LEFT_AND_NO_RIGHT; + } catch (MelderError) { + Melder_throw (me, U": cannot set navigation labels from ", navigationLabels, U"."); + } +} + +void IntervalTierNavigator_setLeftContextNavigationLabels (IntervalTierNavigator me, Strings leftContextLabels, kMelder_string criterion) { + try { + my leftContextLabels = Data_copy (leftContextLabels); + Thing_setName (my leftContextLabels.get(), leftContextLabels -> name.get()); + my leftContextCriterion = criterion; + my contextCombination = kContextCombination::LEFT; + my lookBackFrom = 1; + my lookBackTo = 1; + } catch (MelderError) { + Melder_throw (me, U": cannot set left context labels from ", leftContextLabels, U"."); + } +} + +void IntervalTierNavigator_setRightContextNavigationLabels (IntervalTierNavigator me, Strings rightContextLabels, kMelder_string criterion) { + try { + my rightContextLabels = Data_copy (rightContextLabels); + Thing_setName (my rightContextLabels.get(), rightContextLabels -> name.get()); + my rightContextCriterion = criterion; + my contextCombination = kContextCombination::RIGHT; + my lookForwardFrom = 1; + my lookForwardTo = 1; + } catch (MelderError) { + Melder_throw (me, U": cannot set right context labels from ", rightContextLabels, U"."); + } +} + +void IntervalTierNavigator_setNavigationContext (IntervalTierNavigator me, integer lookBackFrom, integer lookBackTo, integer lookForwardFrom, integer lookForwardTo, kContextCombination contextCombination, bool matchContextOnly) { + bool hasLeftContext = ( my leftContextLabels && my leftContextLabels -> strings.size > 0 ); + bool hasRightContext = ( my rightContextLabels && my rightContextLabels -> strings.size > 0 ); + if (contextCombination == kContextCombination::LEFT) + Melder_require (hasLeftContext, + U"For this option you should have left context labels installed."); + if (contextCombination == kContextCombination::RIGHT) + Melder_require (hasRightContext, + U"For this option you should have right context labels installed."); + if (contextCombination == kContextCombination::LEFT_AND_RIGHT || contextCombination == kContextCombination::LEFT_OR_RIGHT_NOT_BOTH || + contextCombination == kContextCombination::LEFT_OR_RIGHT_OR_BOTH) + Melder_require (hasLeftContext && hasRightContext, + U"For this option you should have left and right context labels installed."); + if (matchContextOnly) + Melder_require (hasLeftContext || hasRightContext, + U"It is not possible to match only the context because you have neither left nor right context labels installed."); + Melder_require (lookBackFrom > 0 && lookBackTo > 0, + U"The left context interval distance should be positive."); + Melder_require (lookForwardFrom > 0 && lookForwardTo > 0, + U"The right context interval distance should be positive."); + my matchContextOnly = matchContextOnly; + my contextCombination = contextCombination; + my lookBackFrom = std::min (lookBackFrom, lookBackTo); + my lookBackTo = std::max (lookBackFrom, lookBackTo); + my lookForwardFrom = std::min (lookForwardFrom, lookForwardTo); + my lookForwardTo = std::max (lookForwardFrom, lookForwardTo); +} + +/* + 1. To determine if an item is in a set, we can simply start to test whether it is equal to the first element + if so we are done. If not check the second element etc until we get a match (or not). + 2. To determine whether an item is not in the set, we need to reverse the test until it fails. +*/ +bool STRVEChasMatch (constSTRVEC const& labels, kMelder_string criterion, conststring32 label) { + if (criterion == kMelder_string :: EQUAL_TO || criterion == kMelder_string :: CONTAINS || + criterion == kMelder_string :: STARTS_WITH || criterion == kMelder_string :: ENDS_WITH || + criterion == kMelder_string :: CONTAINS_WORD || criterion == kMelder_string :: CONTAINS_WORD_STARTING_WITH || + criterion == kMelder_string :: CONTAINS_WORD_ENDING_WITH || criterion == kMelder_string :: CONTAINS_INK || + criterion == kMelder_string :: CONTAINS_INK_STARTING_WITH || criterion == kMelder_string :: CONTAINS_INK_ENDING_WITH) { + for (integer istring = 1; istring <= labels.size; istring ++) + if (Melder_stringMatchesCriterion (label, criterion, labels [istring], true)) + return true; + } else { + for (integer istring = 1; istring <= labels.size; istring ++) + if (! Melder_stringMatchesCriterion (label, criterion, labels [istring], true)) + return false; + return true; + } + return false; +} + +static bool IntervalTierNavigator_isNavigationMatch (IntervalTierNavigator me, integer intervalNumber) { + conststring32 label = my intervalTier -> intervals . at [intervalNumber] -> text.get(); + return ( my navigationLabels && STRVEChasMatch (my navigationLabels -> strings.get(), my navigationCriterion, label) ); +} + +static bool IntervalTierNavigator_isLeftContextMatch (IntervalTierNavigator me, integer intervalNumber) { + if (! my leftContextLabels) + return false; + if (intervalNumber - my lookBackFrom < 1) + return false; + integer startInterval = std::max (1_integer, intervalNumber - my lookBackFrom); + integer endInterval = std::max (1_integer, intervalNumber - my lookBackTo); + for (integer interval = startInterval; interval >= endInterval; interval --) { + conststring32 label = my intervalTier -> intervals . at [interval] -> text.get(); + if (STRVEChasMatch (my leftContextLabels -> strings.get(), my leftContextCriterion, label)) + return true; + } + return false; +} + +static bool IntervalTierNavigator_isRightContextMatch (IntervalTierNavigator me, integer intervalNumber) { + if (! my rightContextLabels) + return false; + if (intervalNumber + my lookForwardFrom > my intervalTier -> intervals.size) + return false; + const integer startInterval = std::min (my intervalTier -> intervals.size, intervalNumber + my lookForwardFrom); + const integer endInterval = std::min (my intervalTier -> intervals.size, intervalNumber + my lookForwardTo); + for (integer interval = startInterval; interval <= endInterval; interval ++) { + conststring32 label = my intervalTier -> intervals . at [interval] -> text.get(); + if (STRVEChasMatch (my rightContextLabels -> strings.get(), my rightContextCriterion, label)) + return true; + } + return false; +} + +bool IntervalTierNavigator_isLabelMatch (IntervalTierNavigator me, integer intervalNumber) { + Melder_require (intervalNumber > 0 && intervalNumber <= my intervalTier -> intervals . size, + U"The interval number should be in the range from 1 to ", my intervalTier -> intervals . size, U"."); + const bool isNavigationMatch = ( my matchContextOnly ? true : IntervalTierNavigator_isNavigationMatch (me, intervalNumber) ); + if (! isNavigationMatch || my contextCombination == kContextCombination::NO_LEFT_AND_NO_RIGHT) + return isNavigationMatch; + + if (my contextCombination == kContextCombination::LEFT_AND_RIGHT) + return ( IntervalTierNavigator_isLeftContextMatch (me, intervalNumber) && + IntervalTierNavigator_isRightContextMatch (me, intervalNumber) ); + else if (my contextCombination == kContextCombination::RIGHT) + return IntervalTierNavigator_isRightContextMatch (me, intervalNumber); + else if (my contextCombination == kContextCombination::LEFT) + return IntervalTierNavigator_isLeftContextMatch (me, intervalNumber); + else if (my contextCombination == kContextCombination::LEFT_OR_RIGHT_OR_BOTH) + return ( IntervalTierNavigator_isLeftContextMatch (me, intervalNumber) || + IntervalTierNavigator_isRightContextMatch (me, intervalNumber) ); + else if (my contextCombination == kContextCombination::LEFT_OR_RIGHT_NOT_BOTH) + return ( IntervalTierNavigator_isLeftContextMatch (me, intervalNumber) == ! IntervalTierNavigator_isRightContextMatch (me, intervalNumber) ); + return false; +} + +integer IntervalTierNavigator_getNumberOfMatches (IntervalTierNavigator me) { + if (! my navigationLabels) + return 0; + integer numberOfMatches = 0; + for (integer interval = 1; interval <= my intervalTier -> intervals . size; interval ++) + if (IntervalTierNavigator_isLabelMatch (me, interval)) + numberOfMatches ++; + return numberOfMatches; +} + +/* + return 0 if time < my xmin + return intervals .size + 1 if time > my xmax +*/ +integer IntervalTierNavigator_getNavigationStartInterval (IntervalTierNavigator me, double time) { + integer intervalNumber = IntervalTier_timeToIndex (my intervalTier, time); + if (intervalNumber == 0) { + if (time < my xmin) { + intervalNumber = 0; // start + } else if (time > my xmax) + intervalNumber = my intervalTier -> intervals .size + 1; // end + } + return intervalNumber; +} + +integer IntervalTierNavigator_getNextMatchingIntervalNumberFromNumber (IntervalTierNavigator me, integer intervalNumber) { + if (! my navigationLabels) + return 0; + const integer startInterval = std::min (std::max (0_integer, intervalNumber), my intervalTier -> intervals .size + 1); + for (integer interval = startInterval + 1; interval <= my intervalTier -> intervals . size; interval ++) + if (IntervalTierNavigator_isLabelMatch (me, interval)) + return interval; + return 0; +} + +integer IntervalTierNavigator_getNextMatchingIntervalNumberFromTime (IntervalTierNavigator me, double time) { + if (! my navigationLabels) + return 0; + integer startInterval = IntervalTierNavigator_getNavigationStartInterval (me, time); + return IntervalTierNavigator_getNextMatchingIntervalNumberFromNumber (me, startInterval); +} + + +TextInterval IntervalTierNavigator_getNextMatchingInterval (IntervalTierNavigator me, double time) { + const integer interval = IntervalTierNavigator_getNextMatchingIntervalNumberFromTime (me, time); + if (interval == 0) + return nullptr; + return my intervalTier -> intervals . at [interval]; +} + +integer IntervalTierNavigator_getPreviousMatchingIntervalNumberFromNumber (IntervalTierNavigator me, integer intervalNumber) { + if (! my navigationLabels) + return 0; + const integer startInterval = std::min (std::max (0_integer, intervalNumber), my intervalTier -> intervals .size + 1); + for (integer interval = startInterval - 1; interval > 0; interval --) + if (IntervalTierNavigator_isLabelMatch (me, interval)) + return interval; + return 0; +} + +integer IntervalTierNavigator_getPreviousMatchingIntervalNumberFromTime (IntervalTierNavigator me, double time) { + if (! my navigationLabels) + return 0; + integer startInterval = IntervalTierNavigator_getNavigationStartInterval (me, time); + return IntervalTierNavigator_getPreviousMatchingIntervalNumberFromNumber (me, startInterval); +} + +TextInterval IntervalTierNavigator_getPreviousMatchingInterval (IntervalTierNavigator me, double time) { + const integer interval = IntervalTierNavigator_getPreviousMatchingIntervalNumberFromTime (me, time); + if (interval == 0) + return nullptr; + return my intervalTier -> intervals . at [interval]; +} + +bool IntervalTierNavigator_atMatchingEnd (IntervalTierNavigator me, double time) { + return ( IntervalTierNavigator_getNextMatchingIntervalNumberFromTime (me, time) == 0 ); +} + +bool IntervalTierNavigator_atMatchingStart (IntervalTierNavigator me, double time) { + return ( IntervalTierNavigator_getPreviousMatchingIntervalNumberFromTime (me, time) == 0 ); +} + +/* End of file IntervalTierNavigator.cpp */ diff --git a/dwtools/IntervalTierNavigator.h b/dwtools/IntervalTierNavigator.h new file mode 100644 index 00000000..a9d34485 --- /dev/null +++ b/dwtools/IntervalTierNavigator.h @@ -0,0 +1,80 @@ +#ifndef _IntervalTierNavigator_h_ +#define _IntervalTierNavigator_h_ +/* IntervalTierNavigator.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "TextGrid.h" +#include "melder.h" + +#include "IntervalTierNavigator_enums.h" + +Thing_define (IntervalTierNavigator, Function) { + IntervalTier intervalTier; + autoStrings leftContextLabels; + kMelder_string leftContextCriterion; + integer lookBackFrom, lookBackTo; + autoStrings rightContextLabels; + kMelder_string rightContextCriterion; + integer lookForwardFrom, lookForwardTo; + autoStrings navigationLabels; + kMelder_string navigationCriterion; + kContextCombination contextCombination; + bool matchContextOnly; + void v_info () + override; +}; + +autoIntervalTierNavigator IntervalTierNavigator_createFromTextGrid (TextGrid me, integer navigationTier); + +autoIntervalTierNavigator IntervalTierNavigator_create (IntervalTier me); + +autoIntervalTierNavigator IntervalTierNavigator_createEmpty (IntervalTier me); + +/* + Especially for editors where the TextGrid(View) is not stable +*/ +void IntervalTierNavigator_setBeginPosition (IntervalTierNavigator me, double time); + +static inline bool IntervalTierNavigator_isNavigationPossible (IntervalTierNavigator me) { + return my navigationLabels || my leftContextLabels || my rightContextLabels; +} + +bool IntervalTierNavigator_isLabelMatch (IntervalTierNavigator me, integer intervalNumber); + +integer IntervalTierNavigator_getNumberOfMatches (IntervalTierNavigator me); + +integer IntervalTierNavigator_getNextMatchingIntervalNumberFromNumber (IntervalTierNavigator me, integer intervalNumber); +integer IntervalTierNavigator_getNextMatchingIntervalNumberFromTime (IntervalTierNavigator me, double time); +TextInterval IntervalTierNavigator_getNextMatchingInterval (IntervalTierNavigator me, double time); + +integer IntervalTierNavigator_getPreviousMatchingIntervalNumberFromNumber (IntervalTierNavigator me, integer intervalNumber); +integer IntervalTierNavigator_getPreviousMatchingIntervalNumberFromTime (IntervalTierNavigator me, double time); +TextInterval IntervalTierNavigator_getPreviousMatchingInterval (IntervalTierNavigator me, double time); + +bool IntervalTierNavigator_atMatchingEnd (IntervalTierNavigator me, double time); +bool IntervalTierNavigator_atMatchingStart (IntervalTierNavigator me, double time); + +void IntervalTierNavigator_setNavigationLabels (IntervalTierNavigator me, Strings navigationLabels, kMelder_string criterion); + +void IntervalTierNavigator_setLeftContextNavigationLabels (IntervalTierNavigator me, Strings leftContextLabels, kMelder_string criterion); + +void IntervalTierNavigator_setRightContextNavigationLabels (IntervalTierNavigator me, Strings rightContextLabels, kMelder_string criterion); + +void IntervalTierNavigator_setNavigationContext (IntervalTierNavigator me, integer lookBackFrom, integer lookBackTo, integer lookForwardFrom, integer lookForwardTo, kContextCombination contextCombination, bool matchContextOnly); + +#endif /* _IntervalTierNavigator_h_ */ diff --git a/dwtools/IntervalTierNavigator_enums.h b/dwtools/IntervalTierNavigator_enums.h new file mode 100644 index 00000000..c1eed88f --- /dev/null +++ b/dwtools/IntervalTierNavigator_enums.h @@ -0,0 +1,29 @@ +/* IntervalTierNavigator_enums.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +enums_begin (kContextCombination, 1) + enums_add (kContextCombination, 1, LEFT, U"left") + enums_add (kContextCombination, 2, RIGHT, U"right") + enums_add (kContextCombination, 3, LEFT_AND_RIGHT, U"left and right") + enums_add (kContextCombination, 4, LEFT_OR_RIGHT_NOT_BOTH, U"left or right, not both") + enums_add (kContextCombination, 5, LEFT_OR_RIGHT_OR_BOTH, U"left or right or both") + enums_add (kContextCombination, 6, NO_LEFT_AND_NO_RIGHT, U"no left and no right") +enums_end (kContextCombination, 6, NO_LEFT_AND_NO_RIGHT) + + +/* End of file IntervalTierNavigator_enums.h */ diff --git a/dwtools/KlattGrid.cpp b/dwtools/KlattGrid.cpp index a68bab8b..870753dc 100644 --- a/dwtools/KlattGrid.cpp +++ b/dwtools/KlattGrid.cpp @@ -1134,7 +1134,7 @@ static autoSound PhonationGrid_PhonationTier_to_Sound_voiced (PhonationGrid me, // Scale voiced part and add breathiness during open phase if (p -> flowDerivative) { - const double extremum = Vector_getAbsoluteExtremum (him.get(), 0.0, 0.0, Vector_VALUE_INTERPOLATION_CUBIC); + const double extremum = Vector_getAbsoluteExtremum (him.get(), 0.0, 0.0, kVector_peakInterpolation :: CUBIC); if (isundef (lastVal)) lastVal = 0.0; for (integer i = 1; i <= his nx; i ++) { diff --git a/dwtools/KlattGridEditors.cpp b/dwtools/KlattGridEditors.cpp index b57ded71..57261bb5 100644 --- a/dwtools/KlattGridEditors.cpp +++ b/dwtools/KlattGridEditors.cpp @@ -1,4 +1,4 @@ -/* KlattGridEditors.c +/* KlattGridEditors.cpp * * Copyright (C) 2009-2019 david Weenink * @@ -36,6 +36,8 @@ static void KlattGrid_Editor_defaultPlay (KlattGrid me, double tmin, double tmax /************************** KlattGrid_RealTierEditor *********************************/ +Thing_implement (KlattGrid_RealTierArea, RealTierArea, 0); + Thing_implement (KlattGrid_RealTierEditor, RealTierEditor, 0); static void menu_cb_KlattGridHelp (KlattGrid_RealTierEditor, EDITOR_ARGS_DIRECT) { @@ -47,17 +49,19 @@ void structKlattGrid_RealTierEditor :: v_createHelpMenuItems (EditorMenu menu) { EditorMenu_addCommand (menu, U"KlattGrid help", 0, menu_cb_KlattGridHelp); } -void structKlattGrid_RealTierEditor :: v_play (double ltmin, double ltmax) { - KlattGrid_Editor_defaultPlay (klattgrid, ltmin, ltmax); +void structKlattGrid_RealTierEditor :: v_play (double startTime, double endTime) { + KlattGrid_Editor_defaultPlay (klattgrid, startTime, endTime); } -void KlattGrid_RealTierEditor_init (KlattGrid_RealTierEditor me, conststring32 title, KlattGrid klattgrid, RealTier data) { +void KlattGrid_RealTierEditor_init (KlattGrid_RealTierEditor me, ClassInfo viewClass, conststring32 title, KlattGrid klattgrid, RealTier data) { my klattgrid = klattgrid; - RealTierEditor_init (me, title, data, nullptr, false); + RealTierEditor_init (me, viewClass, title, data, nullptr, false); } /************************** KlattGrid_PitchTierEditor *********************************/ +Thing_implement (KlattGrid_PitchTierArea, KlattGrid_RealTierArea, 0); + Thing_implement (KlattGrid_PitchTierEditor, KlattGrid_RealTierEditor, 0); static void menu_cb_KlattGrid_PitchTierEditorHelp (KlattGrid_PitchTierEditor, EDITOR_ARGS_DIRECT) { @@ -77,7 +81,7 @@ autoKlattGrid_PitchTierEditor KlattGrid_PitchTierEditor_create (conststring32 ti try { autoKlattGrid_PitchTierEditor me = Thing_new (KlattGrid_PitchTierEditor); const RealTier tier = klattgrid -> phonation -> pitch.get(); - KlattGrid_RealTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_RealTierEditor_init (me.get(), classKlattGrid_PitchTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid pitch window not created."); @@ -86,6 +90,8 @@ autoKlattGrid_PitchTierEditor KlattGrid_PitchTierEditor_create (conststring32 ti /************************** KlattGrid_IntensityTierEditor *********************************/ +Thing_implement (KlattGrid_IntensityTierArea, KlattGrid_RealTierArea, 0); + Thing_implement (KlattGrid_IntensityTierEditor, KlattGrid_RealTierEditor, 0); static void menu_cb_IntensityTierHelp (KlattGrid_IntensityTierEditor, EDITOR_ARGS_DIRECT) { @@ -97,19 +103,21 @@ void structKlattGrid_IntensityTierEditor :: v_createHelpMenuItems (EditorMenu me EditorMenu_addCommand (menu, U"IntensityTier help", 0, menu_cb_IntensityTierHelp); } -void KlattGrid_IntensityTierEditor_init (KlattGrid_IntensityTierEditor me, conststring32 title, KlattGrid klattgrid, RealTier tier) { - KlattGrid_RealTierEditor_init (me, title, klattgrid, tier); +void KlattGrid_IntensityTierEditor_init (KlattGrid_IntensityTierEditor me, ClassInfo viewClass, conststring32 title, KlattGrid klattgrid, RealTier tier) { + KlattGrid_RealTierEditor_init (me, viewClass, title, klattgrid, tier); } /************************** KlattGrid_DecibelTierEditor *********************************/ +Thing_implement (KlattGrid_DecibelTierArea, KlattGrid_IntensityTierArea, 0); + Thing_implement (KlattGrid_DecibelTierEditor, KlattGrid_IntensityTierEditor, 0); autoKlattGrid_DecibelTierEditor KlattGrid_DecibelTierEditor_create (conststring32 title, KlattGrid klattgrid, RealTier tier) { try { autoKlattGrid_DecibelTierEditor me = Thing_new (KlattGrid_DecibelTierEditor); - KlattGrid_IntensityTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_IntensityTierEditor_init (me.get(), classKlattGrid_DecibelTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid decibel window not created."); @@ -118,13 +126,15 @@ autoKlattGrid_DecibelTierEditor KlattGrid_DecibelTierEditor_create (conststring3 /************************** KlattGrid_VoicingAmplitudeTierEditor *********************************/ +Thing_implement (KlattGrid_VoicingAmplitudeTierArea, KlattGrid_IntensityTierArea, 0); + Thing_implement (KlattGrid_VoicingAmplitudeTierEditor, KlattGrid_IntensityTierEditor, 0); autoKlattGrid_VoicingAmplitudeTierEditor KlattGrid_VoicingAmplitudeTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_VoicingAmplitudeTierEditor me = Thing_new (KlattGrid_VoicingAmplitudeTierEditor); const RealTier tier = klattgrid -> phonation -> voicingAmplitude.get(); - KlattGrid_IntensityTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_IntensityTierEditor_init (me.get(), classKlattGrid_VoicingAmplitudeTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid voicing amplitude window not created."); @@ -133,13 +143,15 @@ autoKlattGrid_VoicingAmplitudeTierEditor KlattGrid_VoicingAmplitudeTierEditor_cr /************************** KlattGrid_AspirationAmplitudeTierEditor *********************************/ +Thing_implement (KlattGrid_AspirationAmplitudeTierArea, KlattGrid_IntensityTierArea, 0); + Thing_implement (KlattGrid_AspirationAmplitudeTierEditor, KlattGrid_IntensityTierEditor, 0); autoKlattGrid_AspirationAmplitudeTierEditor KlattGrid_AspirationAmplitudeTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_AspirationAmplitudeTierEditor me = Thing_new (KlattGrid_AspirationAmplitudeTierEditor); const RealTier tier = klattgrid -> phonation -> aspirationAmplitude.get(); - KlattGrid_IntensityTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_IntensityTierEditor_init (me.get(), classKlattGrid_AspirationAmplitudeTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid aspiration amplitude window not created."); @@ -148,13 +160,15 @@ autoKlattGrid_AspirationAmplitudeTierEditor KlattGrid_AspirationAmplitudeTierEdi /************************** KlattGrid_BreathinessAmplitudeTierEditor *********************************/ +Thing_implement (KlattGrid_BreathinessAmplitudeTierArea, KlattGrid_IntensityTierArea, 0); + Thing_implement (KlattGrid_BreathinessAmplitudeTierEditor, KlattGrid_IntensityTierEditor, 0); autoKlattGrid_BreathinessAmplitudeTierEditor KlattGrid_BreathinessAmplitudeTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_BreathinessAmplitudeTierEditor me = Thing_new (KlattGrid_BreathinessAmplitudeTierEditor); const RealTier tier = klattgrid -> phonation -> breathinessAmplitude.get(); - KlattGrid_IntensityTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_IntensityTierEditor_init (me.get(), classKlattGrid_BreathinessAmplitudeTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid breathiness amplitude window not created."); @@ -163,13 +177,15 @@ autoKlattGrid_BreathinessAmplitudeTierEditor KlattGrid_BreathinessAmplitudeTierE /************************** KlattGrid_SpectralTiltTierEditor *********************************/ +Thing_implement (KlattGrid_SpectralTiltTierArea, KlattGrid_IntensityTierArea, 0); + Thing_implement (KlattGrid_SpectralTiltTierEditor, KlattGrid_IntensityTierEditor, 0); autoKlattGrid_SpectralTiltTierEditor KlattGrid_SpectralTiltTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_SpectralTiltTierEditor me = Thing_new (KlattGrid_SpectralTiltTierEditor); const RealTier tier = klattgrid -> phonation -> spectralTilt.get(); - KlattGrid_IntensityTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_IntensityTierEditor_init (me.get(), classKlattGrid_SpectralTiltTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid spectral tilt window not created."); @@ -178,13 +194,15 @@ autoKlattGrid_SpectralTiltTierEditor KlattGrid_SpectralTiltTierEditor_create (co /************************** KlattGrid_FricationBypassTierEditor *********************************/ +Thing_implement (KlattGrid_FricationBypassTierArea, KlattGrid_IntensityTierArea, 0); + Thing_implement (KlattGrid_FricationBypassTierEditor, KlattGrid_IntensityTierEditor, 0); autoKlattGrid_FricationBypassTierEditor KlattGrid_FricationBypassTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_FricationBypassTierEditor me = Thing_new (KlattGrid_FricationBypassTierEditor); const RealTier tier = klattgrid -> frication -> bypass.get(); - KlattGrid_IntensityTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_IntensityTierEditor_init (me.get(), classKlattGrid_FricationBypassTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid frication bypass window not created."); @@ -193,13 +211,15 @@ autoKlattGrid_FricationBypassTierEditor KlattGrid_FricationBypassTierEditor_crea /************************** KlattGrid_FricationAmplitudeTierEditor *********************************/ +Thing_implement (KlattGrid_FricationAmplitudeTierArea, KlattGrid_IntensityTierArea, 0); + Thing_implement (KlattGrid_FricationAmplitudeTierEditor, KlattGrid_IntensityTierEditor, 0); autoKlattGrid_FricationAmplitudeTierEditor KlattGrid_FricationAmplitudeTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_FricationAmplitudeTierEditor me = Thing_new (KlattGrid_FricationAmplitudeTierEditor); const RealTier tier = klattgrid -> frication -> fricationAmplitude.get(); - KlattGrid_IntensityTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_IntensityTierEditor_init (me.get(), classKlattGrid_FricationAmplitudeTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid frication amplitude window not created."); @@ -208,13 +228,15 @@ autoKlattGrid_FricationAmplitudeTierEditor KlattGrid_FricationAmplitudeTierEdito /************************** KlattGrid_OpenPhaseTierEditor *********************************/ +Thing_implement (KlattGrid_OpenPhaseTierArea, KlattGrid_RealTierArea, 0); + Thing_implement (KlattGrid_OpenPhaseTierEditor, KlattGrid_RealTierEditor, 0); autoKlattGrid_OpenPhaseTierEditor KlattGrid_OpenPhaseTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_OpenPhaseTierEditor me = Thing_new (KlattGrid_OpenPhaseTierEditor); const RealTier tier = klattgrid -> phonation -> openPhase.get(); - KlattGrid_RealTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_RealTierEditor_init (me.get(), classKlattGrid_OpenPhaseTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid open phase window not created."); @@ -223,13 +245,15 @@ autoKlattGrid_OpenPhaseTierEditor KlattGrid_OpenPhaseTierEditor_create (conststr /************************** KlattGrid_CollisionPhaseTierEditor *********************************/ +Thing_implement (KlattGrid_CollisionPhaseTierArea, KlattGrid_RealTierArea, 0); + Thing_implement (KlattGrid_CollisionPhaseTierEditor, KlattGrid_RealTierEditor, 0); autoKlattGrid_CollisionPhaseTierEditor KlattGrid_CollisionPhaseTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_CollisionPhaseTierEditor me = Thing_new (KlattGrid_CollisionPhaseTierEditor); const RealTier tier = klattgrid -> phonation -> collisionPhase.get(); - KlattGrid_RealTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_RealTierEditor_init (me.get(), classKlattGrid_CollisionPhaseTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid collision phase window not created."); @@ -238,13 +262,15 @@ autoKlattGrid_CollisionPhaseTierEditor KlattGrid_CollisionPhaseTierEditor_create /************************** KlattGrid_Power1TierEditor *********************************/ +Thing_implement (KlattGrid_Power1TierArea, KlattGrid_RealTierArea, 0); + Thing_implement (KlattGrid_Power1TierEditor, KlattGrid_RealTierEditor, 0); autoKlattGrid_Power1TierEditor KlattGrid_Power1TierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_Power1TierEditor me = Thing_new (KlattGrid_Power1TierEditor); const RealTier tier = klattgrid -> phonation -> power1.get(); - KlattGrid_RealTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_RealTierEditor_init (me.get(), classKlattGrid_Power1TierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid power1 window not created."); @@ -253,13 +279,15 @@ autoKlattGrid_Power1TierEditor KlattGrid_Power1TierEditor_create (conststring32 /************************** KlattGrid_Power2TierEditor *********************************/ +Thing_implement (KlattGrid_Power2TierArea, KlattGrid_RealTierArea, 0); + Thing_implement (KlattGrid_Power2TierEditor, KlattGrid_RealTierEditor, 0); autoKlattGrid_Power2TierEditor KlattGrid_Power2TierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_Power2TierEditor me = Thing_new (KlattGrid_Power2TierEditor); const RealTier tier = klattgrid -> phonation -> power2.get(); - KlattGrid_RealTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_RealTierEditor_init (me.get(), classKlattGrid_Power2TierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid power2 window not created."); @@ -268,13 +296,15 @@ autoKlattGrid_Power2TierEditor KlattGrid_Power2TierEditor_create (conststring32 /************************** KlattGrid_FlutterTierEditor *********************************/ +Thing_implement (KlattGrid_FlutterTierArea, KlattGrid_RealTierArea, 0); + Thing_implement (KlattGrid_FlutterTierEditor, KlattGrid_RealTierEditor, 0); autoKlattGrid_FlutterTierEditor KlattGrid_FlutterTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_FlutterTierEditor me = Thing_new (KlattGrid_FlutterTierEditor); const RealTier tier = klattgrid -> phonation -> flutter.get(); - KlattGrid_RealTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_RealTierEditor_init (me.get(), classKlattGrid_FlutterTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid flutter window not created."); @@ -283,13 +313,15 @@ autoKlattGrid_FlutterTierEditor KlattGrid_FlutterTierEditor_create (conststring3 /************************** KlattGrid_DoublePulsingTierEditor *********************************/ +Thing_implement (KlattGrid_DoublePulsingTierArea, KlattGrid_RealTierArea, 0); + Thing_implement (KlattGrid_DoublePulsingTierEditor, KlattGrid_RealTierEditor, 0); autoKlattGrid_DoublePulsingTierEditor KlattGrid_DoublePulsingTierEditor_create (conststring32 title, KlattGrid klattgrid) { try { autoKlattGrid_DoublePulsingTierEditor me = Thing_new (KlattGrid_DoublePulsingTierEditor); const RealTier tier = klattgrid -> phonation -> doublePulsing.get(); - KlattGrid_RealTierEditor_init (me.get(), title, klattgrid, tier); + KlattGrid_RealTierEditor_init (me.get(), classKlattGrid_DoublePulsingTierArea, title, klattgrid, tier); return me; } catch (MelderError) { Melder_throw (U"KlattGrid double pulsing window not created."); @@ -304,8 +336,8 @@ static bool FormantGrid_isEmpty (FormantGrid me) { return my formants.size == 0 || my bandwidths.size == 0; } -void structKlattGrid_FormantGridEditor :: v_play (double ltmin, double ltmax) { - KlattGrid_Editor_defaultPlay (klattgrid, ltmin, ltmax); +void structKlattGrid_FormantGridEditor :: v_play (double startTime, double endTime) { + KlattGrid_Editor_defaultPlay (klattgrid, startTime, endTime); } autoKlattGrid_FormantGridEditor KlattGrid_FormantGridEditor_create (conststring32 title, KlattGrid data, kKlattGridFormantType formantType) { diff --git a/dwtools/KlattGridEditors.h b/dwtools/KlattGridEditors.h index a242b3ce..f68a1fb8 100644 --- a/dwtools/KlattGridEditors.h +++ b/dwtools/KlattGridEditors.h @@ -24,32 +24,37 @@ #include "RealTierEditor.h" #include "FormantGridEditor.h" +Thing_define (KlattGrid_RealTierArea, RealTierArea) { +}; Thing_define (KlattGrid_RealTierEditor, RealTierEditor) { KlattGrid klattgrid; void v_createHelpMenuItems (EditorMenu menu) override; - void v_play (double tmin, double tmax) + void v_play (double startTime, double endTime) override; }; -void KlattGrid_RealTierEditor_init (KlattGrid_RealTierEditor me, conststring32 title, KlattGrid klattgrid, RealTier data); +void KlattGrid_RealTierEditor_init (KlattGrid_RealTierEditor me, ClassInfo areaClass, conststring32 title, KlattGrid klattgrid, RealTier data); -Thing_define (KlattGrid_OpenPhaseTierEditor, KlattGrid_RealTierEditor) { - double v_minimumLegalValue () +Thing_define (KlattGrid_OpenPhaseTierArea, KlattGrid_RealTierArea) { + double v_minimumLegalY () override { return 0.0; } - double v_maximumLegalValue () + double v_maximumLegalY () override { return 1.0; } - conststring32 v_quantityText () - override { return U"Open phase (0..1)"; } conststring32 v_rightTickUnits () override { return U""; } double v_defaultYmin () override { return 0.0; } double v_defaultYmax () override { return 1.0; } +}; + +Thing_define (KlattGrid_OpenPhaseTierEditor, KlattGrid_RealTierEditor) { + conststring32 v_quantityText () + override { return U"Open phase (0..1)"; } conststring32 v_setRangeTitle () override { return U"Set open phase range..."; } conststring32 v_defaultYminText () @@ -65,19 +70,22 @@ Thing_define (KlattGrid_OpenPhaseTierEditor, KlattGrid_RealTierEditor) { autoKlattGrid_OpenPhaseTierEditor KlattGrid_OpenPhaseTierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_CollisionPhaseTierEditor, KlattGrid_RealTierEditor) { - double v_minimumLegalValue () +Thing_define (KlattGrid_CollisionPhaseTierArea, KlattGrid_RealTierArea) { + double v_minimumLegalY () override { return 0.0; } - double v_maximumLegalValue () + double v_maximumLegalY () override { return 1.0; } - conststring32 v_quantityText () - override { return U"Collision phase (0..1)"; } conststring32 v_rightTickUnits () override { return U""; } double v_defaultYmin () override { return 0.0; } double v_defaultYmax () override { return 0.1; } +}; + +Thing_define (KlattGrid_CollisionPhaseTierEditor, KlattGrid_RealTierEditor) { + conststring32 v_quantityText () + override { return U"Collision phase (0..1)"; } conststring32 v_setRangeTitle () override { return U"Set collision phase range..."; } conststring32 v_defaultYminText () @@ -93,17 +101,20 @@ Thing_define (KlattGrid_CollisionPhaseTierEditor, KlattGrid_RealTierEditor) { autoKlattGrid_CollisionPhaseTierEditor KlattGrid_CollisionPhaseTierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_Power1TierEditor, KlattGrid_RealTierEditor) { - double v_minimumLegalValue () +Thing_define (KlattGrid_Power1TierArea, KlattGrid_RealTierArea) { + double v_minimumLegalY () override { return 0.0; } - conststring32 v_quantityText () - override { return U"Power1"; } conststring32 v_rightTickUnits () override { return U""; } double v_defaultYmin () override { return 0.0; } double v_defaultYmax () override { return 4.0; } +}; + +Thing_define (KlattGrid_Power1TierEditor, KlattGrid_RealTierEditor) { + conststring32 v_quantityText () + override { return U"Power1"; } conststring32 v_setRangeTitle () override { return U"Set power1 range..."; } conststring32 v_defaultYminText () @@ -119,17 +130,20 @@ Thing_define (KlattGrid_Power1TierEditor, KlattGrid_RealTierEditor) { autoKlattGrid_Power1TierEditor KlattGrid_Power1TierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_Power2TierEditor, KlattGrid_RealTierEditor) { - double v_minimumLegalValue () +Thing_define (KlattGrid_Power2TierArea, KlattGrid_RealTierArea) { + double v_minimumLegalY () override { return 0.0; } - conststring32 v_quantityText () - override { return U"Power2"; } conststring32 v_rightTickUnits () override { return U""; } double v_defaultYmin () override { return 0.0; } double v_defaultYmax () override { return 5.0; } +}; + +Thing_define (KlattGrid_Power2TierEditor, KlattGrid_RealTierEditor) { + conststring32 v_quantityText () + override { return U"Power2"; } conststring32 v_setRangeTitle () override { return U"Set power2 range..."; } conststring32 v_defaultYminText () @@ -145,19 +159,22 @@ Thing_define (KlattGrid_Power2TierEditor, KlattGrid_RealTierEditor) { autoKlattGrid_Power2TierEditor KlattGrid_Power2TierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_DoublePulsingTierEditor, KlattGrid_RealTierEditor) { - double v_minimumLegalValue () +Thing_define (KlattGrid_DoublePulsingTierArea, KlattGrid_RealTierArea) { + double v_minimumLegalY () override { return 0.0; } - double v_maximumLegalValue () + double v_maximumLegalY () override { return 1.0; } - conststring32 v_quantityText () - override { return U"Double pulsing (0..1)"; } conststring32 v_rightTickUnits () override { return U""; } double v_defaultYmin () override { return 0.0; } double v_defaultYmax () override { return 1.0; } +}; + +Thing_define (KlattGrid_DoublePulsingTierEditor, KlattGrid_RealTierEditor) { + conststring32 v_quantityText () + override { return U"Double pulsing (0..1)"; } conststring32 v_setRangeTitle () override { return U"Set double pulsing range..."; } conststring32 v_defaultYminText () @@ -173,19 +190,22 @@ Thing_define (KlattGrid_DoublePulsingTierEditor, KlattGrid_RealTierEditor) { autoKlattGrid_DoublePulsingTierEditor KlattGrid_DoublePulsingTierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_PitchTierEditor, KlattGrid_RealTierEditor) { - void v_createHelpMenuItems (EditorMenu menu) - override; - double v_minimumLegalValue () +Thing_define (KlattGrid_PitchTierArea, KlattGrid_RealTierArea) { + double v_minimumLegalY () override { return 0.0; } - conststring32 v_quantityText () - override { return U"Frequency (Hz)"; } conststring32 v_rightTickUnits () override { return U" Hz"; } double v_defaultYmin () override { return 50.0; } double v_defaultYmax () override { return 600.0; } +}; + +Thing_define (KlattGrid_PitchTierEditor, KlattGrid_RealTierEditor) { + void v_createHelpMenuItems (EditorMenu menu) + override; + conststring32 v_quantityText () + override { return U"Frequency (Hz)"; } conststring32 v_setRangeTitle () override { return U"Set frequency range..."; } conststring32 v_defaultYminText () @@ -201,19 +221,22 @@ Thing_define (KlattGrid_PitchTierEditor, KlattGrid_RealTierEditor) { autoKlattGrid_PitchTierEditor KlattGrid_PitchTierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_FlutterTierEditor, KlattGrid_RealTierEditor) { - double v_minimumLegalValue () +Thing_define (KlattGrid_FlutterTierArea, KlattGrid_RealTierArea) { + double v_minimumLegalY () override { return 0.0; } - double v_maximumLegalValue () + double v_maximumLegalY () override { return 1.0; } - conststring32 v_quantityText () - override { return U"Flutter (0..1)"; } conststring32 v_rightTickUnits () override { return U""; } double v_defaultYmin () override { return 0.0; } double v_defaultYmax () override { return 1.0; } +}; + +Thing_define (KlattGrid_FlutterTierEditor, KlattGrid_RealTierEditor) { + conststring32 v_quantityText () + override { return U"Flutter (0..1)"; } conststring32 v_setRangeTitle () override { return U"Set flutter range..."; } conststring32 v_defaultYminText () @@ -229,17 +252,20 @@ Thing_define (KlattGrid_FlutterTierEditor, KlattGrid_RealTierEditor) { autoKlattGrid_FlutterTierEditor KlattGrid_FlutterTierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_IntensityTierEditor, KlattGrid_RealTierEditor) { - void v_createHelpMenuItems (EditorMenu menu) - override; - conststring32 v_quantityText () - override { return U"Intensity (dB)"; } +Thing_define (KlattGrid_IntensityTierArea, KlattGrid_RealTierArea) { conststring32 v_rightTickUnits () override { return U" dB"; } double v_defaultYmin () override { return 50.0; } double v_defaultYmax () override { return 100.0; } +}; + +Thing_define (KlattGrid_IntensityTierEditor, KlattGrid_RealTierEditor) { + void v_createHelpMenuItems (EditorMenu menu) + override; + conststring32 v_quantityText () + override { return U"Intensity (dB)"; } conststring32 v_setRangeTitle () override { return U"Set intensity range..."; } conststring32 v_defaultYminText () @@ -252,18 +278,21 @@ Thing_define (KlattGrid_IntensityTierEditor, KlattGrid_RealTierEditor) { override { return U"Maximum intensity (dB)"; } }; -void KlattGrid_IntensityTierEditor_init (KlattGrid_IntensityTierEditor me, conststring32 title, KlattGrid klattgrid, RealTier tier); +void KlattGrid_IntensityTierEditor_init (KlattGrid_IntensityTierEditor me, ClassInfo viewClass, conststring32 title, KlattGrid klattgrid, RealTier tier); -Thing_define (KlattGrid_DecibelTierEditor, KlattGrid_IntensityTierEditor) { - conststring32 v_quantityText () - override { return U"Amplitude (dB)"; } +Thing_define (KlattGrid_DecibelTierArea, KlattGrid_IntensityTierArea) { conststring32 v_rightTickUnits () override { return U" dB"; } double v_defaultYmin () override { return -30.0; } double v_defaultYmax () override { return 30.0; } +}; + +Thing_define (KlattGrid_DecibelTierEditor, KlattGrid_IntensityTierEditor) { + conststring32 v_quantityText () + override { return U"Amplitude (dB)"; } conststring32 v_setRangeTitle () override { return U"Set amplitude range..."; } conststring32 v_defaultYminText () @@ -279,29 +308,41 @@ Thing_define (KlattGrid_DecibelTierEditor, KlattGrid_IntensityTierEditor) { autoKlattGrid_DecibelTierEditor KlattGrid_DecibelTierEditor_create (conststring32 title, KlattGrid klattgrid, RealTier data); +Thing_define (KlattGrid_VoicingAmplitudeTierArea, KlattGrid_IntensityTierArea) { +}; + Thing_define (KlattGrid_VoicingAmplitudeTierEditor, KlattGrid_IntensityTierEditor) { }; autoKlattGrid_VoicingAmplitudeTierEditor KlattGrid_VoicingAmplitudeTierEditor_create (conststring32 title, KlattGrid klattgrid); +Thing_define (KlattGrid_AspirationAmplitudeTierArea, KlattGrid_IntensityTierArea) { +}; + Thing_define (KlattGrid_AspirationAmplitudeTierEditor, KlattGrid_IntensityTierEditor) { }; autoKlattGrid_AspirationAmplitudeTierEditor KlattGrid_AspirationAmplitudeTierEditor_create (conststring32 title, KlattGrid klattgrid); +Thing_define (KlattGrid_BreathinessAmplitudeTierArea, KlattGrid_IntensityTierArea) { +}; + Thing_define (KlattGrid_BreathinessAmplitudeTierEditor, KlattGrid_IntensityTierEditor) { }; autoKlattGrid_BreathinessAmplitudeTierEditor KlattGrid_BreathinessAmplitudeTierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_SpectralTiltTierEditor, KlattGrid_IntensityTierEditor) { +Thing_define (KlattGrid_SpectralTiltTierArea, KlattGrid_IntensityTierArea) { double v_defaultYmin () override { return -50.0; } double v_defaultYmax () override { return 10.0; } +}; + +Thing_define (KlattGrid_SpectralTiltTierEditor, KlattGrid_IntensityTierEditor) { conststring32 v_defaultYminText () override { return U"-50.0"; } conststring32 v_defaultYmaxText () @@ -311,11 +352,14 @@ Thing_define (KlattGrid_SpectralTiltTierEditor, KlattGrid_IntensityTierEditor) { autoKlattGrid_SpectralTiltTierEditor KlattGrid_SpectralTiltTierEditor_create (conststring32 title, KlattGrid klattgrid); -Thing_define (KlattGrid_FricationBypassTierEditor, KlattGrid_IntensityTierEditor) { +Thing_define (KlattGrid_FricationBypassTierArea, KlattGrid_IntensityTierArea) { double v_defaultYmin () override { return -50.0; } double v_defaultYmax () override { return 10.0; } +}; + +Thing_define (KlattGrid_FricationBypassTierEditor, KlattGrid_IntensityTierEditor) { conststring32 v_defaultYminText () override { return U"-50.0"; } conststring32 v_defaultYmaxText () @@ -325,6 +369,9 @@ Thing_define (KlattGrid_FricationBypassTierEditor, KlattGrid_IntensityTierEditor autoKlattGrid_FricationBypassTierEditor KlattGrid_FricationBypassTierEditor_create (conststring32 title, KlattGrid klattgrid); +Thing_define (KlattGrid_FricationAmplitudeTierArea, KlattGrid_IntensityTierArea) { +}; + Thing_define (KlattGrid_FricationAmplitudeTierEditor, KlattGrid_IntensityTierEditor) { }; @@ -334,7 +381,7 @@ autoKlattGrid_FricationAmplitudeTierEditor KlattGrid_FricationAmplitudeTierEdito Thing_define (KlattGrid_FormantGridEditor, FormantGridEditor) { KlattGrid klattgrid; - void v_play (double tmin, double tmax) + void v_play (double startTime, double endTime) override; bool v_hasSourceMenu () override { return false; } diff --git a/dwtools/Makefile b/dwtools/Makefile index a2fd2590..97c6eea0 100644 --- a/dwtools/Makefile +++ b/dwtools/Makefile @@ -1,10 +1,10 @@ # Makefile of the library "dwtools" # David Weenink and Paul Boersma -# 7 April 2020 +# 2 June 2020 include ../makefile.defs -CPPFLAGS = -I ../kar -I ../melder -I ../LPC -I ../fon -I ../sys -I ../stat -I ../dwsys -I ../external/portaudio -I ../external/espeak -I ../external/clapack -I ../EEG -I ../kar +CPPFLAGS = -I . -I ../kar -I ../melder -I ../LPC -I ../fon -I ../sys -I ../stat -I ../dwsys -I ../external/portaudio -I ../external/espeak -I ../external/clapack -I ../EEG OBJECTS = ActivationList.o AffineTransform.o \ Categories.o CategoriesEditor.o \ @@ -21,10 +21,10 @@ OBJECTS = ActivationList.o AffineTransform.o \ Eigen_and_TableOfReal.o\ Eigen_and_SSCP.o Excitations.o \ espeakdata_FileInMemory.o \ - FilterBank.o FormantGrid_extensions.o FormantModeler.o \ + FilterBank.o FormantGrid_extensions.o \ GaussianMixture.o \ HMM.o \ - ICA.o Intensity_extensions.o \ + ICA.o Intensity_extensions.o IntervalTierNavigator.o \ LFCC.o LongSound_extensions.o \ KlattGrid.o KlattGridEditors.o KlattTable.o \ Ltas_extensions.o \ @@ -34,6 +34,7 @@ OBJECTS = ActivationList.o AffineTransform.o \ Minimizers.o MixingMatrix.o \ Matrix_and_NMF.o Matrix_extensions.o \ Matrix_Categories.o MDS.o \ + NavigationContext.o \ OptimalCeilingTier.o OptimalCeilingTierEditor.o \ PatternList.o PCA.o \ Pitch_extensions.o Polynomial_to_Spectrum.o \ @@ -48,9 +49,9 @@ OBJECTS = ActivationList.o AffineTransform.o \ SpeechSynthesizer.o SpeechSynthesizer_and_TextGrid.o \ Table_and_Strings.o Table_extensions.o TableOfReal_and_SVD.o \ TableOfReal_extensions.o \ - TableOfReal_and_Permutation.o \ + TableOfReal_and_Discriminant.o TableOfReal_and_Permutation.o \ TextGrid_and_DurationTier.o TextGrid_and_PitchTier.o TextGrid_extensions.o \ - VowelEditor.o \ + TextGridNavigator.o TextGridView.o VowelEditor.o \ praat_MDS_init.o praat_BSS_init.o praat_HMM_init.o \ praat_KlattGrid_init.o praat_DataModeler_init.o praat_David_init.o diff --git a/dwtools/Minimizers.cpp b/dwtools/Minimizers.cpp index 0f41875d..ff0006ee 100644 --- a/dwtools/Minimizers.cpp +++ b/dwtools/Minimizers.cpp @@ -26,15 +26,10 @@ Thing_implement (Minimizer, Thing, 0); static void classMinimizer_afterHook (Minimizer me, Thing /* boss */) { if (my success || ! my gmonitor) return; - - if (my start == 1) { - Minimizer_drawHistory (me, my gmonitor, 0, my maximumNumberOfIterations, 0.0, 1.1 * my history [1], 1); - Graphics_textTop (my gmonitor, false, Melder_cat (U"Dimension of search space: ", my numberOfParameters)); - } Graphics_beginMovieFrame (my gmonitor, nullptr); - Graphics_setInner (my gmonitor); - Graphics_line (my gmonitor, my iteration, my history [my iteration], my iteration, my history [my iteration]); - Graphics_unsetInner (my gmonitor); + Graphics_clearWs (my gmonitor); + Minimizer_drawHistory (me, my gmonitor, 0, my maximumNumberOfIterations, 0.0, 1.1 * my history [1], 1); + Graphics_textTop (my gmonitor, false, Melder_cat (U"Dimension of search space: ", my numberOfParameters)); Graphics_endMovieFrame (my gmonitor, 0.0); Melder_monitor ((double) (my iteration) / my maximumNumberOfIterations, U"Iterations: ", my iteration, U", Function calls: ", my numberOfFunctionCalls, U", Cost: ", my minimum); @@ -51,11 +46,8 @@ void Minimizer_init (Minimizer me, integer numberOfParameters, Daata object) { } static void monitor_off (Minimizer me) { - Melder_monitor (1.1); - if (my gmonitor) { - Graphics_clearWs (my gmonitor); // DON'T forget (my gmonitor) - my gmonitor = nullptr; - } + Melder_monitor (1.0); + my gmonitor = nullptr; } void Minimizer_minimize (Minimizer me, integer maximumNumberOfIterations, double tolerance, int monitor) { @@ -63,15 +55,12 @@ void Minimizer_minimize (Minimizer me, integer maximumNumberOfIterations, double my tolerance = tolerance; if (maximumNumberOfIterations <= 0) return; - if (my iteration + maximumNumberOfIterations > my maximumNumberOfIterations) { my maximumNumberOfIterations += maximumNumberOfIterations; my history. resize (my maximumNumberOfIterations); } if (monitor) my gmonitor = (Graphics) Melder_monitor (0.0, U"Starting..."); - - my start = 1; // for my after() my v_minimize (); if (monitor) monitor_off (me); @@ -137,19 +126,15 @@ void Minimizer_reset (Minimizer me, constVEC const& guess) { void Minimizer_drawHistory (Minimizer me, Graphics g, integer iFrom, integer iTo, double hmin, double hmax, bool garnish) { if (my history.size == 0) return; - if (iTo <= iFrom) { iFrom = 1; iTo = my iteration; } integer itmin = iFrom, itmax = iTo; - if (itmin < 1) - itmin = 1; - if (itmax > my iteration) - itmax = my iteration; + Melder_clipLeft (1_integer, & itmin); + Melder_clipRight (& itmax, my iteration); if (hmax <= hmin) NUMextrema (my history.part (itmin, itmax), & hmin, & hmax); - if (hmax <= hmin) { hmin -= 0.5 * fabs (hmin); hmax += 0.5 * fabs (hmax); diff --git a/dwtools/Minimizers.h b/dwtools/Minimizers.h index 93d10275..22ddafd7 100644 --- a/dwtools/Minimizers.h +++ b/dwtools/Minimizers.h @@ -32,7 +32,7 @@ Thing_define (Minimizer, Thing) { Daata object; /* reference to the object that uses this Minimizer */ integer numberOfFunctionCalls; /* the number of times 'func' has been called */ bool success; /* indicates whether I'm done */ - integer start; /* start iteration series */ + //integer start; /* start iteration series */ integer maximumNumberOfIterations; /* the current maximum number of iterations */ integer iteration; /* the current number of iterations */ void (*afterHook) (Minimizer me, Thing boss); /* to be called after each iteration */ diff --git a/dwtools/NavigationContext.cpp b/dwtools/NavigationContext.cpp new file mode 100644 index 00000000..d0a90a77 --- /dev/null +++ b/dwtools/NavigationContext.cpp @@ -0,0 +1,236 @@ +/* NavigationContext.cpp + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "NavigationContext.h" +#include "NUM2.h" + + +#include "enums_getText.h" +#include "NavigationContext_enums.h" +#include "enums_getValue.h" +#include "NavigationContext_enums.h" +#include "Strings_extensions.h" + +#include "oo_DESTROY.h" +#include "NavigationContext_def.h" +#include "oo_COPY.h" +#include "NavigationContext_def.h" +#include "oo_EQUAL.h" +#include "NavigationContext_def.h" +#include "oo_CAN_WRITE_AS_ENCODING.h" +#include "NavigationContext_def.h" +#include "oo_WRITE_TEXT.h" +#include "NavigationContext_def.h" +#include "oo_READ_TEXT.h" +#include "NavigationContext_def.h" +#include "oo_WRITE_BINARY.h" +#include "NavigationContext_def.h" +#include "oo_READ_BINARY.h" +#include "NavigationContext_def.h" +#include "oo_DESCRIPTION.h" +#include "NavigationContext_def.h" + + +Thing_implement (NavigationContext, Daata, 0); + +/* + 1. To determine if an item is in a set, we can simply start to test whether it is equal to the first element + if so we are done. If not check the second element etc until we get a match (or not). + 2. To determine whether an item is not in the set, we need to reverse the test until it fails. +*/ +static bool STRVEChasMatch (constSTRVEC const& labels, kMelder_string criterion, conststring32 label) { + if (criterion == kMelder_string :: EQUAL_TO || criterion == kMelder_string :: CONTAINS || + criterion == kMelder_string :: STARTS_WITH || criterion == kMelder_string :: ENDS_WITH || + criterion == kMelder_string :: CONTAINS_WORD || criterion == kMelder_string :: CONTAINS_WORD_STARTING_WITH || + criterion == kMelder_string :: CONTAINS_WORD_ENDING_WITH || criterion == kMelder_string :: CONTAINS_INK || + criterion == kMelder_string :: CONTAINS_INK_STARTING_WITH || criterion == kMelder_string :: CONTAINS_INK_ENDING_WITH) { + for (integer istring = 1; istring <= labels.size; istring ++) + if (Melder_stringMatchesCriterion (label, criterion, labels [istring], true)) + return true; + } else { + for (integer istring = 1; istring <= labels.size; istring ++) + if (! Melder_stringMatchesCriterion (label, criterion, labels [istring], true)) + return false; + return true; + } + return false; +} + +void structNavigationContext :: v_info () { + MelderInfo_writeLine (U"Navigation:"); + if (navigationLabels) { + MelderInfo_writeLine (U"\tName: ", navigationLabels -> name.get()); + MelderInfo_writeLine (U"\tNumber of labels: ", navigationLabels -> strings.size); + } else { + MelderInfo_writeLine (U"\tNo navigation labels defined"); + } + if (leftContextLabels) { + MelderInfo_writeLine (U"\tLeft context name: ", leftContextLabels -> name.get()); + MelderInfo_writeLine (U"\tLeft criterion: ", kMelder_string_getText (leftContextCriterion)); + MelderInfo_writeLine (U"\tNumber of left context labels: ", leftContextLabels -> strings.size); + } else { + MelderInfo_writeLine (U"\tNo left context navigation labels defined"); + } + if (rightContextLabels) { + MelderInfo_writeLine (U"\tRight context name: ", rightContextLabels -> name.get()); + MelderInfo_writeLine (U"\tRight criterion: ", kMelder_string_getText (rightContextCriterion)); + MelderInfo_writeLine (U"\tNumber of right context labels: ", rightContextLabels -> strings.size); + } else { + MelderInfo_writeLine (U"\tNo right context navigation labels defined"); + } + MelderInfo_writeLine (U"\tMatch context: ", kContext_combination_getText (combinationCriterion)); + MelderInfo_writeLine (U"\tMatch context only: ", ( matchContextOnly ? U"yes" : U"no" )); +} + +void NavigationContext_init (NavigationContext me) { + my navigationLabels = Thing_new (Strings); + my leftContextLabels = Thing_new (Strings); + my rightContextLabels = Thing_new (Strings); +} + +autoNavigationContext NavigationContext_createNonEmptyItemNavigation () { + try { + autoNavigationContext me = Thing_new (NavigationContext); + NavigationContext_init (me.get()); + Strings_insert (my navigationLabels.get(), 0, U""); + my navigationCriterion = kMelder_string::NOT_EQUAL_TO; + my combinationCriterion = kContext_combination::NO_LEFT_AND_NO_RIGHT; + return me; + } catch (MelderError) { + Melder_throw (U"TextGridNavigationContext not created."); + } +} + +autoNavigationContext Strings_to_NavigationContext (Strings me, kMelder_string navigationCriterion) { + try { + autoNavigationContext thee = Thing_new (NavigationContext); + NavigationContext_init (thee.get()); + thy navigationLabels = Data_copy (me); + Thing_setName (thy navigationLabels.get(), my name.get()); + thy navigationCriterion = navigationCriterion; + thy combinationCriterion = kContext_combination::NO_LEFT_AND_NO_RIGHT; + return thee; + } catch (MelderError) { + Melder_throw (me, U": could not convert to NavigationContext."); + } +} + +autoNavigationContext NavigationContext_create (conststring32 name, conststring32 navigationName, conststring32 navigation_string, kMelder_string navigationCriterion, conststring32 leftContextName, conststring32 leftContext_string, kMelder_string leftContextCriterion, conststring32 rightContextName, conststring32 rightContext_string, kMelder_string rightContextCriterion, kContext_combination combinationCriterion, bool contextOnly) { + try { + autoNavigationContext me = Thing_new (NavigationContext); + NavigationContext_init (me.get()); + my navigationLabels = Strings_createAsTokens (navigation_string, U" "); + Thing_setName (my navigationLabels.get(), navigationName); + my navigationCriterion = navigationCriterion; + my leftContextLabels = Strings_createAsTokens (leftContext_string, U" "); + Thing_setName (my leftContextLabels.get(), leftContextName); + my leftContextCriterion = leftContextCriterion; + my rightContextLabels = Strings_createAsTokens (rightContext_string, U" "); + Thing_setName (my rightContextLabels.get(), rightContextName); + my rightContextCriterion = rightContextCriterion; + my combinationCriterion = combinationCriterion; + my matchContextOnly = contextOnly; + return me; + } catch (MelderError) { + Melder_throw (U"NavigationContext could not be created from vowels string."); + } +} + +void NavigationContext_modifyNavigationLabels (NavigationContext me, Strings labels, kMelder_string criterion) { + try { + my navigationLabels = Data_copy (labels); + Thing_setName (my navigationLabels.get(), labels -> name.get()); + my navigationCriterion = criterion; + if (my leftContextLabels) { + if (my rightContextLabels) + my combinationCriterion = kContext_combination::LEFT_AND_RIGHT; + else + my combinationCriterion = kContext_combination::LEFT; + } else if (my rightContextLabels) { + my combinationCriterion = kContext_combination::RIGHT; + } else { + my combinationCriterion = kContext_combination::NO_LEFT_AND_NO_RIGHT; + } + } catch (MelderError) { + Melder_throw (me, U": cannot set navigation labels from ", labels, U"."); + } +} + +void NavigationContext_modifyLeftContextLabels (NavigationContext me, Strings labels, kMelder_string criterion) { + try { + my leftContextLabels = Data_copy (labels); + Thing_setName (my leftContextLabels.get(), labels -> name.get()); + my leftContextCriterion = criterion; + my combinationCriterion = kContext_combination::LEFT; + if (! my navigationLabels) + my matchContextOnly = true; + if (my rightContextLabels) + my combinationCriterion = kContext_combination::LEFT_AND_RIGHT; + } catch (MelderError) { + Melder_throw (me, U": cannot set left context labels from ", labels, U"."); + } +} + +void NavigationContext_modifyRightContextLabels (NavigationContext me, Strings labels, kMelder_string criterion) { + try { + my rightContextLabels = Data_copy (labels); + Thing_setName (my rightContextLabels.get(), labels -> name.get()); + my rightContextCriterion = criterion; + my combinationCriterion = kContext_combination::LEFT; + if (! my navigationLabels) + my matchContextOnly = true; + if (my leftContextLabels) + my combinationCriterion = kContext_combination::LEFT_AND_RIGHT; + } catch (MelderError) { + Melder_throw (me, U": cannot set right context labels from ", labels, U"."); + } +} + +void NavigationContext_modifyContextCombination (NavigationContext me, kContext_combination combinationCriterion, bool matchContextOnly) { + bool hasLeftContext = ( my leftContextLabels && my leftContextLabels -> strings.size > 0 ); + bool hasRightContext = ( my rightContextLabels && my rightContextLabels -> strings.size > 0 ); + if (combinationCriterion == kContext_combination::LEFT) + Melder_require (hasLeftContext, + U"For this option the NavigationContext should have left context labels."); + if (combinationCriterion == kContext_combination::RIGHT) + Melder_require (hasRightContext, + U"For this option the NavigationContext should have right context labels."); + if (combinationCriterion == kContext_combination::LEFT_AND_RIGHT || combinationCriterion == kContext_combination::LEFT_OR_RIGHT_NOT_BOTH || + combinationCriterion == kContext_combination::LEFT_OR_RIGHT_OR_BOTH) + Melder_require (hasLeftContext && hasRightContext, + U"For this option the NavigationContext should have left and right context labels."); + if (matchContextOnly) + Melder_require (hasLeftContext || hasRightContext, + U"For this option the NavigationContext should have left or right context labels."); + my matchContextOnly = matchContextOnly; + my combinationCriterion = combinationCriterion; +} + +bool NavigationContext_isNavigationLabel (NavigationContext me, conststring32 label) { + return ( my navigationLabels && STRVEChasMatch (my navigationLabels -> strings.get(), my navigationCriterion, label) ); +} + +bool NavigationContext_isLeftContextLabel (NavigationContext me, conststring32 label) { + return ( my leftContextLabels && STRVEChasMatch (my leftContextLabels -> strings.get(), my leftContextCriterion, label) ); +} + +bool NavigationContext_isRightContextLabel (NavigationContext me, conststring32 label) { + return ( my rightContextLabels && STRVEChasMatch (my rightContextLabels -> strings.get(), my rightContextCriterion, label) ); +} + +/* End of file NavigationContext.cpp */ diff --git a/dwtools/NavigationContext.h b/dwtools/NavigationContext.h new file mode 100644 index 00000000..0d91e076 --- /dev/null +++ b/dwtools/NavigationContext.h @@ -0,0 +1,48 @@ +#ifndef _NavigationContext_h_ +#define _NavigationContext_h_ +/* NavigationContext.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "Strings_.h" +#include "TextGrid.h" +#include "melder.h" + +#include "NavigationContext_enums.h" + +#include "NavigationContext_def.h" + +autoNavigationContext NavigationContext_create (conststring32 name, conststring32 navigationName, conststring32 navigation_string, kMelder_string navigationCriterion, conststring32 leftContextName, conststring32 leftContext_string, kMelder_string leftContextCriterion, conststring32 rightContextName, conststring32 rightContext_string, kMelder_string rightContextCriterion, kContext_combination combinationCriterion, bool contextOnly); + +autoNavigationContext Strings_to_NavigationContext (Strings me, kMelder_string criterion); + +void NavigationContext_modifyNavigationLabels (NavigationContext me, Strings labels, kMelder_string criterion); + +void NavigationContext_modifyLeftContextLabels (NavigationContext me, Strings labels, kMelder_string criterion); + +void NavigationContext_modifyRightContextLabels (NavigationContext me, Strings labels, kMelder_string criterion); + +bool NavigationContext_isNavigationLabel (NavigationContext me, conststring32 label); + +bool NavigationContext_isLeftContextLabel (NavigationContext me, conststring32 label); + +bool NavigationContext_isRightContextLabel (NavigationContext me, conststring32 label); + +void NavigationContext_modifyContextCombination (NavigationContext me, kContext_combination combinationCriterion, bool matchContextOnly); + + +#endif /* _NavigationContext_h_ */ diff --git a/dwtools/NavigationContext_def.h b/dwtools/NavigationContext_def.h new file mode 100644 index 00000000..71677874 --- /dev/null +++ b/dwtools/NavigationContext_def.h @@ -0,0 +1,42 @@ +/* NavigationContext_def.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#define ooSTRUCT NavigationContext +oo_DEFINE_CLASS (NavigationContext, Daata) + + oo_OBJECT (Strings, 0, navigationLabels) // because oo_STRING_Vector needs size + oo_ENUM (kMelder_string, navigationCriterion) + + oo_OBJECT (Strings, 0, leftContextLabels) + oo_ENUM (kMelder_string, leftContextCriterion) + + oo_OBJECT (Strings, 0, rightContextLabels) + oo_ENUM (kMelder_string, rightContextCriterion) + + oo_ENUM (kContext_combination, combinationCriterion) + oo_BOOLEAN (matchContextOnly) + + #if oo_DECLARING + void v_info () + override; + #endif + +oo_END_CLASS (NavigationContext) +#undef ooSTRUCT + + /* End of file NavigationContext_def.h */ diff --git a/dwtools/NavigationContext_enums.h b/dwtools/NavigationContext_enums.h new file mode 100644 index 00000000..6a4cb9b4 --- /dev/null +++ b/dwtools/NavigationContext_enums.h @@ -0,0 +1,28 @@ +/* NavigationContext_enums.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +enums_begin (kContext_combination, 1) + enums_add (kContext_combination, 1, LEFT, U"left") + enums_add (kContext_combination, 2, RIGHT, U"right") + enums_add (kContext_combination, 3, LEFT_AND_RIGHT, U"left and right") + enums_add (kContext_combination, 4, LEFT_OR_RIGHT_NOT_BOTH, U"left or right, not both") + enums_add (kContext_combination, 5, LEFT_OR_RIGHT_OR_BOTH, U"left or right or both") + enums_add (kContext_combination, 6, NO_LEFT_AND_NO_RIGHT, U"no left and no right") +enums_end (kContext_combination, 6, NO_LEFT_AND_NO_RIGHT) + +/* End of file NavigationContext_enums.h */ diff --git a/dwtools/OptimalCeilingTierEditor.cpp b/dwtools/OptimalCeilingTierEditor.cpp index 512cb74b..6f74582e 100644 --- a/dwtools/OptimalCeilingTierEditor.cpp +++ b/dwtools/OptimalCeilingTierEditor.cpp @@ -19,6 +19,8 @@ #include "OptimalCeilingTierEditor.h" #include "EditorM.h" +Thing_implement (OptimalCeilingTierArea, RealTierArea, 0); + Thing_implement (OptimalCeilingTierEditor, RealTierEditor, 0); static void menu_cb_OptimalCeilingTierHelp (OptimalCeilingTierEditor, EDITOR_ARGS_DIRECT) { Melder_help (U"OptimalCeilingTier"); } @@ -28,17 +30,17 @@ void structOptimalCeilingTierEditor :: v_createHelpMenuItems (EditorMenu menu) { EditorMenu_addCommand (menu, U"OptimalCeilingTier help", 0, menu_cb_OptimalCeilingTierHelp); } -void structOptimalCeilingTierEditor :: v_play (double fromTime, double toTime) { +void structOptimalCeilingTierEditor :: v_play (double startTime, double endTime) { if (our d_sound.data) - Sound_playPart (our d_sound.data, fromTime, toTime, theFunctionEditor_playCallback, this); + Sound_playPart (our d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); //else - // OptimalCeilingTier_playPart (data, fromTime, toTime, false); + // OptimalCeilingTier_playPart (data, startTime, endTime, false); } autoOptimalCeilingTierEditor OptimalCeilingTierEditor_create (conststring32 title, OptimalCeilingTier octier, Sound sound, bool ownSound) { try { autoOptimalCeilingTierEditor me = Thing_new (OptimalCeilingTierEditor); - RealTierEditor_init (me.get(), title, (RealTier) octier, sound, ownSound); + RealTierEditor_init (me.get(), classOptimalCeilingTierArea, title, octier, sound, ownSound); return me; } catch (MelderError) { Melder_throw (U"OptimalCeilingTier window not created."); diff --git a/dwtools/OptimalCeilingTierEditor.h b/dwtools/OptimalCeilingTierEditor.h index 64cfbb18..0e5cff3d 100644 --- a/dwtools/OptimalCeilingTierEditor.h +++ b/dwtools/OptimalCeilingTierEditor.h @@ -2,7 +2,7 @@ #define _OptimalCeilingTierEditor_h_ /* OptimalCeilingTierEditor.h * - * Copyright (C) 2015 David Weenink, 2017 Paul Boersma + * Copyright (C) 2015 David Weenink, 2017,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -22,19 +22,22 @@ #include "OptimalCeilingTier.h" #include "Sound.h" +Thing_define (OptimalCeilingTierArea, RealTierArea) { + conststring32 v_rightTickUnits () + override { return U" Hz"; } + double v_defaultYmin () + override { return 4000.0; } + double v_defaultYmax () + override { return 6000.0; } +}; + Thing_define (OptimalCeilingTierEditor, RealTierEditor) { void v_createHelpMenuItems (EditorMenu menu) override; - void v_play (double fromTime, double toTime) + void v_play (double startTime, double endTime) override; conststring32 v_quantityText () override { return U"Frequency (Hz)"; } - conststring32 v_rightTickUnits () - override { return U" Hz"; } - double v_defaultYmin () - override { return 4000.0; } - double v_defaultYmax () - override { return +6000.0; } conststring32 v_setRangeTitle () override { return U"Set frequency range..."; } conststring32 v_defaultYminText () diff --git a/dwtools/Polygon_extensions.cpp b/dwtools/Polygon_extensions.cpp index baab1080..acf4f238 100644 --- a/dwtools/Polygon_extensions.cpp +++ b/dwtools/Polygon_extensions.cpp @@ -231,7 +231,7 @@ autoPolygon Sound_to_Polygon (Sound me, integer channel, double tmin, double tma his x [k] = tmin; his y [k ++] = CLIP_Y (level, ymin, ymax); his x [k] = tmin; - double y = Vector_getValueAtX (me, tmin, channel, Vector_VALUE_INTERPOLATION_LINEAR); + double y = Vector_getValueAtX (me, tmin, channel, kVector_valueInterpolation :: LINEAR); his y [k ++] = CLIP_Y (y, ymin, ymax); for (integer i = i1; i <= i2; i ++) { y = my z [channel] [i]; @@ -239,7 +239,7 @@ autoPolygon Sound_to_Polygon (Sound me, integer channel, double tmin, double tma his y [k ++] = CLIP_Y (y, ymin, ymax); } his x [k] = tmax; - y = Vector_getValueAtX (me, tmax, channel, Vector_VALUE_INTERPOLATION_LINEAR); + y = Vector_getValueAtX (me, tmax, channel, kVector_valueInterpolation :: LINEAR); his y [k ++] = CLIP_Y (y, ymin, ymax); his x [k] = tmax; his y [k ++] = CLIP_Y (level, ymin, ymax); @@ -288,7 +288,7 @@ autoPolygon Sounds_to_Polygon_enclosed (Sound me, Sound thee, integer channel, d /* my starting point at tmin */ - double y = Vector_getValueAtX (me, tmin, ( my ny == 1 ? 1 : channel ), Vector_VALUE_INTERPOLATION_LINEAR); + double y = Vector_getValueAtX (me, tmin, ( my ny == 1 ? 1 : channel ), kVector_valueInterpolation :: LINEAR); integer k = 1; his x [k] = tmin; his y [k ++] = CLIP_Y (y, ymin, ymax); @@ -304,13 +304,13 @@ autoPolygon Sounds_to_Polygon_enclosed (Sound me, Sound thee, integer channel, d // my end point at tmax - y = Vector_getValueAtX (me, tmax, ( my ny == 1 ? 1 : channel ), Vector_VALUE_INTERPOLATION_LINEAR); + y = Vector_getValueAtX (me, tmax, ( my ny == 1 ? 1 : channel ), kVector_valueInterpolation :: LINEAR); his x [k] = tmax; his y [k ++] = y; // thy starting point at tmax - y = Vector_getValueAtX (thee, tmax, ( thy ny == 1 ? 1 : channel ), Vector_VALUE_INTERPOLATION_LINEAR); + y = Vector_getValueAtX (thee, tmax, ( thy ny == 1 ? 1 : channel ), kVector_valueInterpolation :: LINEAR); his x [k] = tmax; his y [k ++] = y; @@ -325,7 +325,7 @@ autoPolygon Sounds_to_Polygon_enclosed (Sound me, Sound thee, integer channel, d // thy end point at tmin - y = Vector_getValueAtX (thee, tmin, ( thy ny == 1 ? 1 : channel ), Vector_VALUE_INTERPOLATION_LINEAR); + y = Vector_getValueAtX (thee, tmin, ( thy ny == 1 ? 1 : channel ), kVector_valueInterpolation :: LINEAR); his x [k] = tmin; his y [k] = y; diff --git a/dwtools/SSCP.cpp b/dwtools/SSCP.cpp index 1eb733b4..ccbd186d 100644 --- a/dwtools/SSCP.cpp +++ b/dwtools/SSCP.cpp @@ -210,29 +210,42 @@ void SSCP_drawTwoDimensionalEllipse_inside (SSCP me, Graphics g, double scale, c autoVEC x = newVECraw (nsteps + 1); autoVEC y = newVECraw (nsteps + 1); /* - Get principal axes and orientation for the ellipse by performing the - eigen decomposition of a symmetric 2-by-2 matrix. - Principal axes are a and b with eigenvector/orientation (cs, sn). + From the eigenvalues and eigenvectors of the symmetrical sscp matrix we + can calculate the length and directions of the principal axes of the ellipse. */ - double a, b, cs, sn; - NUMeigencmp22 (my data [1] [1], my data [1] [2], my data [2] [2], & a, & b, & cs, & sn); + double eval1, eval2, cosine, sine; + NUMeigencmp22 (my data [1] [1], my data [1] [2], my data [2] [2], & eval1, & eval2, & cosine, & sine); /* - 1. Take sqrt to get units of 'std_dev' + 1. Parametrize as standard ellipse with horizontal radius a and vertical radius b and origin at (0,0) as + x = a cos(phi) + y = b sin(phi) */ - const double axisLength_a = scale * sqrt (a) / 2.0; - const double axisLength_b = scale * sqrt (b) / 2.0; - x [nsteps + 1] = x [1] = my centroid [1] + cs * axisLength_a; - y [nsteps + 1] = y [1] = my centroid [2] + sn * axisLength_a; // axisLength_a is no mistake! + const double a = scale * sqrt (eval1) / 2.0; + const double b = scale * sqrt (eval2) / 2.0; const double angle_inc = NUM2pi / nsteps; - double angle = 0.0; - for (integer i = 2; i <= nsteps; i ++, angle += angle_inc) { - const double xc = axisLength_a * cos (angle); - const double yc = axisLength_b * sin (angle); - const double xt = xc * cs - yc * sn; - y [i] = my centroid [2] + xc * sn + yc * cs; - x [i] = my centroid [1] + xt; + for (integer i = 1; i <= nsteps + 1; i ++) { + const double phi = (i - 1) * angle_inc; + x [i] = a * cos (phi); + y [i] = b * sin (phi); } + /* + 2. Rotate x axis to the eigenvector 1 (cosine, sine) + |x'| | cosine -sine | |x| + | | = | | * | | + |y'| | sine cosine | |y| + */ + for (integer i = 1; i <= nsteps + 1; i ++) { + double xp = cosine * x [i] - sine * y [i]; + y [i] = sine * x [i] + cosine * y[i]; + x [i] = xp; + } + /* + 3. Translate to the centroid + */ + x.get() += my centroid [1]; + y.get() += my centroid [2]; Graphics_polyline (g, nsteps + 1, & x [1], & y [1]); + if (label && fontSize > 0.0) { const double oldFontSize = Graphics_inqFontSize (g); Graphics_setFontSize (g, fontSize); diff --git a/dwtools/Sound_extensions.cpp b/dwtools/Sound_extensions.cpp index 6e47c35e..7c74e117 100644 --- a/dwtools/Sound_extensions.cpp +++ b/dwtools/Sound_extensions.cpp @@ -1062,13 +1062,11 @@ double Sound_getNearestLevelCrossing (Sound me, integer channel, double position if (leftSample > my nx) return undefined; const integer rightSample = leftSample + 1; - integer ileft, iright; - double leftCrossing, rightCrossing; /* Are we already at a level crossing? */ if (leftSample >= 1 && rightSample <= my nx && - (amplitude [leftSample] >= level) != (amplitude [rightSample] >= level)) + (amplitude [leftSample] >= level) != (amplitude [rightSample] >= level)) { const double crossing = interpolate (me, leftSample, channel, level); return searchDirection == kSoundSearchDirection::LEFT ? @@ -1076,32 +1074,36 @@ double Sound_getNearestLevelCrossing (Sound me, integer channel, double position ( crossing >= position ? crossing : undefined ); } - if (searchDirection == kSoundSearchDirection::LEFT || - searchDirection == kSoundSearchDirection::NEAREST) { - for (ileft = leftSample - 1; ileft >= 1; ileft --) - if ((amplitude [ileft] >= level) != (amplitude [ileft + 1] >= level)) + double leftCrossing = undefined; + if (searchDirection == kSoundSearchDirection::LEFT || searchDirection == kSoundSearchDirection::NEAREST) { + for (integer ileft = leftSample - 1; ileft >= 1; ileft --) + if ((amplitude [ileft] >= level) != (amplitude [ileft + 1] >= level)) { + leftCrossing = interpolate (me, ileft, channel, level); break; - leftCrossing = interpolate (me, ileft, channel, level); + } if (searchDirection == kSoundSearchDirection::LEFT) - return ileft < 1 ? undefined: leftCrossing; + return leftCrossing; } if (rightSample < 1) return undefined; - if (searchDirection == kSoundSearchDirection::RIGHT || - searchDirection == kSoundSearchDirection::NEAREST) { - for (iright = rightSample + 1; iright <= my nx; iright ++) - if ((amplitude [iright] >= level) != (amplitude [iright - 1] >= level)) + double rightCrossing = undefined; + if (searchDirection == kSoundSearchDirection::RIGHT || searchDirection == kSoundSearchDirection::NEAREST) { + for (integer iright = rightSample + 1; iright <= my nx; iright ++) + if ((amplitude [iright] >= level) != (amplitude [iright - 1] >= level)) { + rightCrossing = interpolate (me, iright - 1, channel, level); break; - rightCrossing = interpolate (me, iright - 1, channel, level); + } if (searchDirection == kSoundSearchDirection::RIGHT) - return iright > my nx ? undefined : rightCrossing; + return rightCrossing; } - - if (ileft < 1 && iright > my nx) - return undefined; - return ileft < 1 ? rightCrossing : ( iright > my nx ? leftCrossing : - ( position - leftCrossing < rightCrossing - position ? leftCrossing : rightCrossing ) ); + + return + isdefined (leftCrossing) && isdefined (rightCrossing) ? + ( position - leftCrossing < rightCrossing - position ? leftCrossing : rightCrossing ) + : isdefined (leftCrossing) ? leftCrossing + : isdefined (rightCrossing) ? rightCrossing + : undefined; } double Sound_localPeak (Sound me, double fromTime, double toTime, double reference) { @@ -1127,7 +1129,7 @@ void Sound_into_Sound (Sound me, Sound to, double startTime) { const integer index = Sampled_xToNearestIndex (me, startTime); for (integer i = 1; i <= to -> nx; i ++) { const integer j = index - 1 + i; - to -> z [1] [i] = j < 1 || j > my nx ? 0.0 : my z [1] [j]; + to -> z [1] [i] = (j < 1 || j > my nx ? 0.0 : my z [1] [j]); } } @@ -1652,23 +1654,24 @@ static void Sound_fadeOut_general (Sound me, int channel, double time, double fa } } -void Sound_fade (Sound me, int channel, double t, double fadeTime, int inout, bool fadeGlobal) { +void Sound_fade (Sound me, int channel, double t, double fadeTime, bool fadeOut, bool fadeGlobal) { integer numberOfSamples = Melder_ifloor (fabs (fadeTime) / my dx); double t1 = t, t2 = t1 + fadeTime; - const conststring32 fade_inout = inout > 0 ? U"out" : U"in"; + bool fadeIn = ! fadeOut; + const conststring32 fade_string = ( fadeOut ? U"out" : U"in" ); Melder_require (channel >= 0 && channel <= my ny, U"Invalid channel number: ", channel, U"."); if (t > my xmax) { t = my xmax; - if (inout <= 0) { // fade in + if (fadeIn) { Melder_warning (U"The start time of the fade-in is after the end time of the sound. The fade-in will not happen."); return; } } else if (t < my xmin) { t = my xmin; - if (inout > 0) { // fade out + if (fadeOut) { Melder_warning (U"The start time of the fade-out is before the start time of the sound. The fade-out will not happen."); return; } @@ -1680,7 +1683,7 @@ void Sound_fade (Sound me, int channel, double t, double fadeTime, int inout, bo t1 = t; t2 = t + fadeTime; } else { - Melder_warning (U"You have given a \"Fade time\" of zero seconds. The fade-", fade_inout, U" will not happen."); + Melder_warning (U"You have given a \"Fade time\" of zero seconds. The fade-", fade_string, U" will not happen."); return; } integer i0 = 0, iystart, iyend; @@ -1695,12 +1698,12 @@ void Sound_fade (Sound me, int channel, double t, double fadeTime, int inout, bo if (istart < 1) istart = 1; if (istart >= my nx) { - Melder_warning (U"The part to fade ", fade_inout, U" lies after the end time of the sound. The fade-", fade_inout, U" will not happen."); + Melder_warning (U"The part to fade ", fade_string, U" lies after the end time of the sound. The fade-", fade_string, U" will not happen."); return; } integer iend = Sampled_xToNearestIndex (me, t2); if (iend <= 1) { - Melder_warning (U"The part to fade ", fade_inout, U" lies before the start time of the sound. Fade-", fade_inout, U" will be incomplete."); + Melder_warning (U"The part to fade ", fade_string, U" lies before the start time of the sound. Fade-", fade_string, U" will be incomplete."); return; } if (iend > my nx) @@ -1714,17 +1717,17 @@ void Sound_fade (Sound me, int channel, double t, double fadeTime, int inout, bo */ if (fadeTime < 0) i0 = numberOfSamples - (iend - istart + 1); - Melder_warning (U"The fade time is larger than the part of the sound to fade ", fade_inout, U". Fade-", fade_inout, U" will be incomplete."); + Melder_warning (U"The fade time is larger than the part of the sound to fade ", fade_string, U". Fade-", fade_string, U" will be incomplete."); } for (integer ichannel = iystart; ichannel <= iyend; ichannel ++) { for (integer i = istart; i <= iend; i ++) { double cosp = cos (NUMpi * (i0 + i - istart) / (numberOfSamples - 1)); - if (inout <= 0) + if (fadeIn) cosp = -cosp; // fade-in my z [ichannel] [i] *= 0.5 * (1.0 + cosp); } if (fadeGlobal) { - if (inout <= 0) { + if (fadeIn) { if (istart > 1) my z [ichannel].part (1, istart - 1) <<= 0.0; } else { @@ -1886,7 +1889,7 @@ static void Sound_findIntermediatePoint_bs (Sound me, integer ichannel, integer xmid = 0.5 * (xleft + xright); // the bisection for (integer channel = 1; channel <= my ny; channel ++) - thy z [channel] [2] = Vector_getValueAtX (me, xmid, channel, Vector_VALUE_INTERPOLATION_LINEAR); + thy z [channel] [2] = Vector_getValueAtX (me, xmid, channel, kVector_valueInterpolation :: LINEAR); Formula_compile (interpreter, thee.get(), formula, kFormula_EXPRESSION_TYPE_NUMERIC, true); Formula_Result result; Formula_run (ichannel, 2, & result); @@ -2197,7 +2200,7 @@ static void Sound_findNoise (Sound me, double minimumNoiseDuration, double *nois *noiseStart = undefined; *noiseEnd = undefined; autoIntensity const intensity = Sound_to_Intensity (me, 20.0, 0.005, true); - double tmin = Vector_getXOfMinimum (intensity.get(), intensity -> xmin, intensity -> xmax, 1) - minimumNoiseDuration / 2.0; + double tmin = Vector_getXOfMinimum (intensity.get(), intensity -> xmin, intensity -> xmax, kVector_peakInterpolation :: PARABOLIC) - minimumNoiseDuration / 2.0; double tmax = tmin + minimumNoiseDuration; if (tmin < my xmin) { tmin = my xmin; diff --git a/dwtools/Sound_extensions.h b/dwtools/Sound_extensions.h index bbd9976a..fccb9c49 100644 --- a/dwtools/Sound_extensions.h +++ b/dwtools/Sound_extensions.h @@ -127,7 +127,7 @@ void Sound_scale_dB (Sound me, double level_dB); where extremum is the maximum of the absolute values the signal values. */ -void Sound_fade (Sound me, int channel, double t, double fadeTime, int inout, bool fadeGlobal); +void Sound_fade (Sound me, int channel, double t, double fadeTime, bool fadeOut, bool fadeGlobal); /* if inout <= 0 fade in with (1-cos)/2 else fade out with (1+cos)/2 channel = 0 (all), 1 (left), 2 (right). */ diff --git a/dwtools/Spectrogram_extensions.cpp b/dwtools/Spectrogram_extensions.cpp index 2f165744..525083c3 100644 --- a/dwtools/Spectrogram_extensions.cpp +++ b/dwtools/Spectrogram_extensions.cpp @@ -573,6 +573,7 @@ void BandFilterSpectrogram_equalizeIntensities (BandFilterSpectrogram me, double } } +#if 0 static void BandFilterSpectrogram_PCA_drawComponent (BandFilterSpectrogram me, PCA thee, Graphics g, integer component, double dblevel, double frequencyOffset, double scale, double tmin, double tmax, double fmin, double fmax) { Melder_require (component > 0 && component <= thy numberOfEigenvalues, U"Component too large."); @@ -587,6 +588,7 @@ static void BandFilterSpectrogram_PCA_drawComponent (BandFilterSpectrogram me, P his z [component] [j] = frequencyOffset + scale * his z [component] [j]; Matrix_drawRows (him.get(), g, tmin, tmax, component - 0.5, component + 0.5, fmin, fmax); } +#endif /* * MelSpectrograms_to_DTW (MelSpectrogram me, MelSpectrogram thee, dtw-params); diff --git a/dwtools/SpeechSynthesizer.cpp b/dwtools/SpeechSynthesizer.cpp index 40d205ea..f012eee2 100644 --- a/dwtools/SpeechSynthesizer.cpp +++ b/dwtools/SpeechSynthesizer.cpp @@ -601,8 +601,8 @@ static autoTextGrid Table_to_TextGrid (Table me, conststring32 text, double xmin } } -static void espeakdata_SetVoiceByName (conststring32 languageName, conststring32 voiceName) -{ +#if 0 +static void espeakdata_SetVoiceByName (conststring32 languageName, conststring32 voiceName) { espeak_VOICE voice_selector; memset (& voice_selector, 0, sizeof voice_selector); @@ -614,6 +614,7 @@ static void espeakdata_SetVoiceByName (conststring32 languageName, conststring32 SetVoiceStack (& voice_selector, Melder_peek32to8 (voiceName)); } } +#endif autoSound SpeechSynthesizer_to_Sound (SpeechSynthesizer me, conststring32 text, autoTextGrid *tg, autoTable *events) { try { @@ -651,7 +652,7 @@ autoSound SpeechSynthesizer_to_Sound (SpeechSynthesizer me, conststring32 text, espeak_ng_SetParameter (espeakCAPITALS, 0, 0); espeak_ng_SetParameter (espeakPUNCTUATION, espeakPUNCT_NONE, 0); - status = espeak_ng_InitializeOutput (ENOUTPUT_MODE_SYNCHRONOUS, 2048, nullptr); + status = espeak_ng_InitializeOutput (ENOUTPUT_MODE_SYNCHRONOUS, 2048, nullptr); espeak_SetSynthCallback (synthCallback); if (! Melder_equ (my d_phonemeSet.get(), my d_languageName.get())) { const conststring32 phonemeCode = SpeechSynthesizer_getPhonemeCode (me); @@ -695,7 +696,7 @@ autoSound SpeechSynthesizer_to_Sound (SpeechSynthesizer me, conststring32 text, return thee; } catch (MelderError) { espeak_Terminate (); - Melder_throw (U"Text not played."); + Melder_throw (U"SpeechSynthesizer: text not converted to Sound."); } } diff --git a/dwtools/SpeechSynthesizer_and_TextGrid.cpp b/dwtools/SpeechSynthesizer_and_TextGrid.cpp index 13a217e2..c7927dd8 100644 --- a/dwtools/SpeechSynthesizer_and_TextGrid.cpp +++ b/dwtools/SpeechSynthesizer_and_TextGrid.cpp @@ -44,19 +44,19 @@ static void IntervalTier_checkRange (IntervalTier me, integer startInterval, int U"The specified interval range end number (", endinterval, U") exceeds the number of intervals (", my intervals.size, U") in this tier."); } -autoSound SpeechSynthesizer_TextInterval_to_Sound (SpeechSynthesizer me, TextInterval thee, autoTextGrid *p_tg) +autoSound SpeechSynthesizer_TextInterval_to_Sound (SpeechSynthesizer me, TextInterval thee, autoTextGrid *out_textgrid) { try { - Melder_require (thy text && thy text[0] != U'\0', + Melder_require (thy text && thy text [0] != U'\0', U"TextInterval should not be empty."); - autoSound him = SpeechSynthesizer_to_Sound (me, thy text.get(), p_tg, nullptr); + autoSound him = SpeechSynthesizer_to_Sound (me, thy text.get(), out_textgrid, nullptr); return him; } catch (MelderError) { Melder_throw (U"Sound not created from TextInterval."); } } -autoSound SpeechSynthesizer_TextGrid_to_Sound (SpeechSynthesizer me, TextGrid thee, integer tierNumber, integer iinterval, autoTextGrid *p_tg) { +autoSound SpeechSynthesizer_TextGrid_to_Sound (SpeechSynthesizer me, TextGrid thee, integer tierNumber, integer iinterval, autoTextGrid *out_textgrid) { try { TextGrid_checkSpecifiedTierNumberWithinRange (thee, tierNumber); const IntervalTier intervalTier = (IntervalTier) thy tiers->at [tierNumber]; @@ -64,7 +64,7 @@ autoSound SpeechSynthesizer_TextGrid_to_Sound (SpeechSynthesizer me, TextGrid th U"Tier ", tierNumber, U" is not an interval tier."); Melder_require (iinterval > 0 && iinterval <= intervalTier -> intervals.size, U"Interval ", iinterval, U" does not exist on tier ", tierNumber, U"."); - return SpeechSynthesizer_TextInterval_to_Sound (me, intervalTier -> intervals.at [iinterval], p_tg); + return SpeechSynthesizer_TextInterval_to_Sound (me, intervalTier -> intervals.at [iinterval], out_textgrid); } catch (MelderError) { Melder_throw (U"Sound not created from textGrid."); } diff --git a/dwtools/Strings_extensions.cpp b/dwtools/Strings_extensions.cpp index 43abd7bf..5734889a 100644 --- a/dwtools/Strings_extensions.cpp +++ b/dwtools/Strings_extensions.cpp @@ -130,7 +130,7 @@ autoStrings Strings_change (Strings me, conststring32 search, conststring32 repl try { autoStrings thee = Thing_new (Strings); autoSTRVEC strings = string32vector_searchAndReplace (my strings.get(), - search, replace, maximumNumberOfReplaces, nmatches, nstringmatches, use_regexp); + search, replace, maximumNumberOfReplaces, nmatches, nstringmatches, use_regexp); thy numberOfStrings = my numberOfStrings; thy strings = std::move (strings); return thee; diff --git a/dwtools/TableOfReal_and_Discriminant.cpp b/dwtools/TableOfReal_and_Discriminant.cpp new file mode 100644 index 00000000..253a2d0f --- /dev/null +++ b/dwtools/TableOfReal_and_Discriminant.cpp @@ -0,0 +1,438 @@ +/* TableOfReal_and_Discriminant.cpp + * + * Copyright (C) 1993-2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "TableOfReal_and_Discriminant.h" + +autoDiscriminant TableOfReal_to_Discriminant (TableOfReal me) { + try { + autoDiscriminant thee = Thing_new (Discriminant); + const integer dimension = my numberOfColumns; + + Melder_require (NUMdefined (my data.get()), + U"There should be no undefined elements in the table."); + Melder_require (TableOfReal_hasRowLabels (me), + U"All rows should be labeled."); + + autoTableOfReal mew = TableOfReal_sortOnlyByRowLabels (me); + if (! TableOfReal_hasColumnLabels (mew.get())) + TableOfReal_setSequentialColumnLabels (mew.get(), 0, 0, U"c", 1, 1); + + thy groups = TableOfReal_to_SSCPList_byLabel (mew.get()); + thy total = TableOfReal_to_SSCP (mew.get(), 0, 0, 0, 0); + + if ((thy numberOfGroups = thy groups -> size) < 2) + Melder_throw (U"Number of groups should be greater than one."); + + TableOfReal_centreColumns_byRowLabel (mew.get()); + + // Overall centroid and apriori probabilities and costs. + + autoVEC centroid = newVECzero (dimension); + autoMAT between = newMATzero (thy numberOfGroups, dimension); + thy aprioriProbabilities = newVECraw (thy numberOfGroups); + + longdouble sum = 0.0; + for (integer k = 1; k <= thy numberOfGroups; k ++) { + const SSCP m = thy groups->at [k]; + const double scale = SSCP_getNumberOfObservations (m); + centroid.all() += scale * m -> centroid.all(); + sum += scale; + } + centroid.all() /= double (sum); + + for (integer k = 1; k <= thy numberOfGroups; k ++) { + const SSCP m = thy groups->at [k]; + const double scale = SSCP_getNumberOfObservations (m); + thy aprioriProbabilities [k] = scale / my numberOfRows; + between.row (k) <<= m -> centroid.all() - centroid.all(); + between.row (k) *= sqrt (scale); + } + + // We need to solve B'B.x = lambda W'W.x, where B'B and W'W are the between and within covariance matrices. + // We do not calculate these covariance matrices directly from the data but instead use the GSVD to solve for + // the eigenvalues and eigenvectors of the equation. + + thy eigen = Thing_new (Eigen); + Eigen_initFromSquareRootPair (thy eigen.get(), between.get(), mew -> data.get()); + + /* + Costs. + */ + thy costs = newMATraw (thy numberOfGroups, thy numberOfGroups); + + thy costs.get() <<= 1.0; + thy costs.diagonal() <<= 0.0; + + return thee; + } catch (MelderError) { + Melder_throw (me, U": Discriminant not created."); + } +} + + +autoTableOfReal Discriminant_TableOfReal_mahalanobis (Discriminant me, TableOfReal thee, integer group, bool poolCovarianceMatrices) { + try { + Melder_require (group > 0 && group <= my numberOfGroups, + U"Group should be in the range [1, ", my numberOfGroups, U"]."); + autoSSCP pool = SSCPList_to_SSCP_pool (my groups.get()); + autoCovariance covg = SSCP_to_Covariance (pool.get(), my numberOfGroups); + autoCovariance cov = SSCP_to_Covariance (my groups->at [group], 1); + autoTableOfReal him; + if (poolCovarianceMatrices) { // use group mean instead of overall mean! + covg -> centroid.all() <<= cov -> centroid.all(); + him = Covariance_TableOfReal_mahalanobis (covg.get(), thee, false); + } else { + him = Covariance_TableOfReal_mahalanobis (cov.get(), thee, false); + } + return him; + } catch (MelderError) { + Melder_throw (U"TableOfReal not created."); + } +} + +autoTableOfReal Discriminant_TableOfReal_mahalanobis_all (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices) { + autoCovariance covg; + if (poolCovarianceMatrices) { + autoSSCP pool = SSCPList_to_SSCP_pool (my groups.get()); + covg = SSCP_to_Covariance (pool.get(), my numberOfGroups); + } + autoTableOfReal him = TableOfReal_create (thy numberOfRows, 1); + his rowLabels.all() <<= thy rowLabels.all(); + for (integer igroup = 1 ; igroup <= my numberOfGroups; igroup ++) { + conststring32 label = Thing_getName (my groups->at [igroup]); + autoCovariance cov = SSCP_to_Covariance (my groups->at [igroup], 1); + autoTableOfReal groupMahalanobis; + if (poolCovarianceMatrices) { + covg -> centroid.all() <<= cov -> centroid.all(); + groupMahalanobis = Covariance_TableOfReal_mahalanobis (covg.get(), thee, false); + } else { + groupMahalanobis = Covariance_TableOfReal_mahalanobis (cov.get(), thee, false); + } + for (integer idata = 1; idata <= thy numberOfRows; idata ++) + if (Melder_equ (label, his rowLabels [idata].get())) + his data [idata] [1] = groupMahalanobis-> data [idata] [1]; + } + return him; +} + +autoClassificationTable Discriminant_TableOfReal_to_ClassificationTable (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices, bool useAprioriProbabilities) { + try { + const integer numberOfGroups = Discriminant_getNumberOfGroups (me); + const integer dimension = Eigen_getDimensionOfComponents (my eigen.get()); + + Melder_require (dimension == thy numberOfColumns, + U"The number of columns should agree with the dimension of the discriminant."); + + autoVEC log_p = newVECraw (numberOfGroups); + autoVEC log_apriori = newVECraw (numberOfGroups); + autoVEC ln_determinant = newVECraw (numberOfGroups); + autoVEC buf = newVECraw (dimension); + + autovector sscpvec = newvectorzero (numberOfGroups); + autoSSCP pool = SSCPList_to_SSCP_pool (my groups.get()); + autoClassificationTable him = ClassificationTable_create (thy numberOfRows, numberOfGroups); + his rowLabels.all() <<= thy rowLabels.all(); + + /* + Scale the sscp to become a covariance matrix. + */ + pool -> data.get() *= 1.0 / (pool -> numberOfObservations - numberOfGroups); + + double lnd; + autoSSCPList agroups; + SSCPList groups; // ppgb FIXME dit kan niet goed izjn + if (poolCovarianceMatrices) { + /* + Covariance matrix S can be decomposed as S = L.L'. Calculate L^-1. + L^-1 will be used later in the Mahalanobis distance calculation: + v'.S^-1.v == v'.L^-1'.L^-1.v == (L^-1.v)'.(L^-1.v). + */ + if (Melder_debug == 52) + Melder_casual (U"***** before lower Cholesky inverse: \n", pool -> data.all()); + MATlowerCholeskyInverse_inplace (pool -> data.get(), & lnd); + if (Melder_debug == 52) + Melder_casual (U"***** after lower Cholesky inverse: \n", pool -> data.all()); + for (integer j = 1; j <= numberOfGroups; j ++) { + ln_determinant [j] = lnd; + sscpvec [j] = pool.get(); + } + groups = my groups.get(); + } else { + /* + Calculate the inverses of all group covariance matrices. + In case of a singular matrix, substitute inverse of pooled. + */ + agroups = Data_copy (my groups.get()); + groups = agroups.get(); + integer npool = 0; + for (integer j = 1; j <= numberOfGroups; j ++) { + const SSCP t = groups->at [j]; + const integer no = Melder_ifloor (SSCP_getNumberOfObservations (t)); + t -> data.get() *= 1.0 / (no - 1); + + sscpvec [j] = groups->at [j]; + try { + MATlowerCholeskyInverse_inplace (t -> data.get(), & ln_determinant [j]); + } catch (MelderError) { + /* + Clear the error. + Try the alternative: the pooled covariance matrix. + */ + Melder_clearError (); + if (npool == 0) + MATlowerCholeskyInverse_inplace (pool -> data.get(), & lnd); + npool ++; + sscpvec [j] = pool.get(); + ln_determinant [j] = lnd; + } + } + if (npool > 0) + Melder_warning (npool, U" groups use pooled covariance matrix."); + } + + /* + Labels for columns in ClassificationTable + */ + for (integer j = 1; j <= numberOfGroups; j ++) { + conststring32 name = Thing_getName (my groups->at [j]); + if (! name) + name = U"?"; + TableOfReal_setColumnLabel (him.get(), j, name); + } + + /* + Normalize the sum of the apriori probabilities to 1. + Next take ln (p) because otherwise probabilities might be too small to represent. + */ + if (Melder_debug == 52) + Melder_casual (U"***** before normalizing priors: \n", my aprioriProbabilities.all()); + VECnormalize_inplace (my aprioriProbabilities.get(), 1.0, 1.0); + if (Melder_debug == 52) + Melder_casual (U"***** after normalizing priors: \n", my aprioriProbabilities.all()); + const double logg = log (numberOfGroups); + for (integer j = 1; j <= numberOfGroups; j ++) + log_apriori [j] = ( useAprioriProbabilities ? log (my aprioriProbabilities [j]) : - logg ); + + /* + Generalized squared distance function: + D^2(x) = (x - mu)' S^-1 (x - mu) + ln (determinant(S)) - 2 ln (apriori) + */ + for (integer i = 1; i <= thy numberOfRows; i ++) { + double norm = 0.0, pt_max = -1e308; + for (integer j = 1; j <= numberOfGroups; j ++) { + const SSCP t = groups->at [j]; + const double md = NUMmahalanobisDistanceSquared (sscpvec [j] -> data.get(), thy data.row (i), t -> centroid.get()); + if (Melder_debug == 52) + Melder_casual (U"***** Mahalanobis distance (squared): ", i, U" ", j, U" ", md); + const double pt = log_apriori [j] - 0.5 * (ln_determinant [j] + md); + if (pt > pt_max) + pt_max = pt; + log_p [j] = pt; + } + for (integer j = 1; j <= numberOfGroups; j ++) + norm += log_p [j] = exp (log_p [j] - pt_max); + for (integer j = 1; j <= numberOfGroups; j ++) + his data [i] [j] = log_p [j] / norm; + } + return him; + } catch (MelderError) { + Melder_throw (U"ClassificationTable from Discriminant & TableOfReal not created."); + } +} + +autoClassificationTable Discriminant_TableOfReal_to_ClassificationTable_dw (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices, bool useAprioriProbabilities, double alpha, double minProb, autoTableOfReal *displacements) { + try { + const integer g = Discriminant_getNumberOfGroups (me); + const integer p = Eigen_getDimensionOfComponents (my eigen.get()); + const integer m = thy numberOfRows; + + Melder_require (p == thy numberOfColumns, + U"The number of columns does not agree with the dimension of the discriminant."); + + autoVEC log_p = newVECraw (g); + autoVEC log_apriori = newVECraw (g); + autoVEC ln_determinant = newVECraw (g); + autoVEC buf = newVECraw (p); + autoVEC displacement = newVECraw (p); + autoVEC x = newVECzero (p); + autovector sscpvec = newvectorzero (g); + autoSSCP pool = SSCPList_to_SSCP_pool (my groups.get()); + autoClassificationTable him = ClassificationTable_create (m, g); + his rowLabels.all() <<= thy rowLabels.all(); + autoTableOfReal adisplacements = Data_copy (thee); + + /* + Scale the sscp to become a covariance matrix. + */ + + pool -> data.get() *= 1.0 / (pool -> numberOfObservations - g); + + double lnd; + autoSSCPList agroups; + SSCPList groups; + if (poolCovarianceMatrices) { + + /* + Covariance matrix S can be Cholesky decomposed as S = L.L'. + Calculate L^-1. + L^-1 will be used later in the Mahalanobis distance calculation: + v'.S^-1.v = v'.L^-1'.L^-1.v = (L^-1.v)'.(L^-1.v). + */ + + MATlowerCholeskyInverse_inplace (pool -> data.get(), & lnd); + for (integer j = 1; j <= g; j ++) { + ln_determinant [j] = lnd; + sscpvec [j] = pool.get(); + } + groups = my groups.get(); + } else { + + /* + Calculate the inverses of all group covariance matrices. + In case of a singular matrix, substitute inverse of pooled. + */ + + agroups = Data_copy (my groups.get()); + groups = agroups.get(); + integer npool = 0; + for (integer j = 1; j <= g; j ++) { + const SSCP t = groups->at [j]; + const integer no = Melder_ifloor (SSCP_getNumberOfObservations (t)); + t -> data.get() *= 1.0 / (no - 1); + + sscpvec [j] = groups->at [j]; + try { + MATlowerCholeskyInverse_inplace (t -> data.get(), & ln_determinant [j]); + } catch (MelderError) { + + /* + Clear the error. + Try the alternative: the pooled covariance matrix. + */ + + Melder_clearError (); + if (npool == 0) + MATlowerCholeskyInverse_inplace (pool -> data.get(), & lnd); + npool ++; + sscpvec [j] = pool.get(); + ln_determinant [j] = lnd; + } + } + if (npool > 0) + Melder_warning (npool, U" groups use pooled covariance matrix."); + } + + /* + Labels for columns in ClassificationTable + */ + + for (integer j = 1; j <= g; j ++) { + conststring32 name = Thing_getName (my groups->at [j]); + if (! name) + name = U"?"; + TableOfReal_setColumnLabel (him.get(), j, name); + } + + /* + Normalize the sum of the apriori probabilities to 1. + Next take ln (p) because otherwise probabilities might be too small to represent. + */ + + const double logg = log (g); + VECnormalize_inplace (my aprioriProbabilities.get(), 1.0, 1.0); + for (integer j = 1; j <= g; j ++) { + log_apriori [j] = ( useAprioriProbabilities ? log (my aprioriProbabilities [j]) : - logg ); + } + + /* + Generalized squared distance function: + D^2(x) = (x - mu)' S^-1 (x - mu) + ln (determinant(S)) - 2 ln (apriori) + */ + + for (integer i = 1; i <= m; i ++) { + SSCP winner; + double norm = 0, pt_max = -1e308; + integer iwinner = 1; + for (integer k = 1; k <= p; k ++) + x [k] = thy data [i] [k] + displacement [k]; + for (integer j = 1; j <= g; j ++) { + const SSCP t = groups->at [j]; + const double md = NUMmahalanobisDistanceSquared (sscpvec [j] -> data.get(), x.get(), t -> centroid.get()); + const double pt = log_apriori [j] - 0.5 * (ln_determinant [j] + md); + if (pt > pt_max) { + pt_max = pt; + iwinner = j; + } + log_p [j] = pt; + } + for (integer j = 1; j <= g; j ++) + norm += log_p [j] = exp (log_p [j] - pt_max); + + for (integer j = 1; j <= g; j ++) + his data [i] [j] = log_p [j] / norm; + + /* + Save old displacement, calculate new displacement + */ + + winner = groups->at [iwinner]; + for (integer k = 1; k <= p; k ++) { + adisplacements -> data [i] [k] = displacement [k]; + if (his data [i] [iwinner] > minProb) { + double delta_k = winner -> centroid [k] - x [k]; + displacement [k] += alpha * delta_k; + } + } + } + *displacements = adisplacements.move(); + return him; + } catch (MelderError) { + Melder_throw (U"ClassificationTable for Weenink procedure not created."); + } +} + + +autoConfiguration Discriminant_TableOfReal_to_Configuration (Discriminant me, TableOfReal thee, integer numberOfDimensions) { + try { + Melder_require (thy numberOfColumns == my eigen -> dimension, + U"The number of columns in the TableOfReal (", thy numberOfColumns, U") should be equal to the dimension of the eigenvectors of the Discriminant (", my eigen -> dimension, U")."); + if (numberOfDimensions == 0) + numberOfDimensions = Discriminant_getNumberOfFunctions (me); + Melder_require (numberOfDimensions <= my eigen -> numberOfEigenvalues, + U"The number of dimensions should not exceed the number of eigenvectors in the Discriminant (", my eigen -> numberOfEigenvalues, U")."); + autoConfiguration him = Configuration_create (thy numberOfRows, numberOfDimensions); + MATmul (his data.get(), thy data.get(), my eigen -> eigenvectors.horizontalBand (1, numberOfDimensions).transpose ()); + TableOfReal_copyLabels (thee, him.get(), 1, 0); + TableOfReal_setSequentialColumnLabels (him.get(), 0, 0, U"Eigenvector ", 1, 1); + return him; + } catch (MelderError) { + Melder_throw (U"Configuration not created."); + } +} + +autoConfiguration TableOfReal_to_Configuration_lda (TableOfReal me, integer numberOfDimensions) { + try { + autoDiscriminant thee = TableOfReal_to_Discriminant (me); + autoConfiguration him = Discriminant_TableOfReal_to_Configuration (thee.get(), me, numberOfDimensions); + return him; + } catch (MelderError) { + Melder_throw (me, U": Configuration with lda data not created."); + } +} + +/* End of file TableOfReal_and_Discriminant.cpp */ diff --git a/dwtools/TableOfReal_and_Discriminant.h b/dwtools/TableOfReal_and_Discriminant.h new file mode 100644 index 00000000..5ac968cf --- /dev/null +++ b/dwtools/TableOfReal_and_Discriminant.h @@ -0,0 +1,41 @@ +#ifndef _TableOfReal_and_Discriminant_h_ +#define _TableOfReal_and_Discriminant_h_ +/* TableOfReal_and_Discriminant.h + * + * Copyright (C) 1993-2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "ClassificationTable.h" +#include "Configuration.h" +#include "Covariance.h" +#include "Discriminant.h" +#include "TableOfReal.h" + +autoDiscriminant TableOfReal_to_Discriminant (TableOfReal me); + +autoTableOfReal Discriminant_TableOfReal_mahalanobis (Discriminant me, TableOfReal thee, integer group, bool poolCovarianceMatrices); + +autoTableOfReal Discriminant_TableOfReal_mahalanobis_all (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices); + +autoClassificationTable Discriminant_TableOfReal_to_ClassificationTable (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices, bool useAprioriProbabilities); + +autoClassificationTable Discriminant_TableOfReal_to_ClassificationTable_dw (Discriminant me, TableOfReal thee, bool poolCovarianceMatrices, bool useAprioriProbabilities, double alpha, double minProb, autoTableOfReal *displacements); + +autoConfiguration Discriminant_TableOfReal_to_Configuration (Discriminant me, TableOfReal thee, integer numberOfDimensions); + +autoConfiguration TableOfReal_to_Configuration_lda (TableOfReal me, integer numberOfDimensions); + +#endif /* _TableOfReal_and_Discriminant_h_ */ diff --git a/dwtools/Table_extensions.cpp b/dwtools/Table_extensions.cpp index c6e92016..1e9d7a8d 100644 --- a/dwtools/Table_extensions.cpp +++ b/dwtools/Table_extensions.cpp @@ -4418,12 +4418,14 @@ static bool Graphics_getConnectingLine (Graphics g, conststring32 text1, double return drawLine; } -// take the xcolumn as labels if non-numeric column else as numbers and arrange distances accordingly. +/* + Take the xcolumn as labels if non-numeric column else as numbers and arrange distances accordingly. +*/ void Table_lineGraphWhere (Table me, Graphics g, integer xcolumn, double xmin, double xmax, integer ycolumn, double ymin, double ymax, conststring32 symbol, double angle, bool garnish, conststring32 formula, Interpreter interpreter) { try { Melder_require (ycolumn >= 1 && ycolumn <= my numberOfColumns, U"The column for the vertical axis should exist."); - Melder_require (xcolumn >= 1 && xcolumn <= my numberOfColumns, + Melder_require (xcolumn >= 0 && xcolumn <= my numberOfColumns, // 0 == no column given U"The column for the horizontal axis should exist."); autoINTVEC selectedRows = Table_findRowsMatchingCriterion (me, formula, interpreter); diff --git a/dwtools/TextGridNavigator.cpp b/dwtools/TextGridNavigator.cpp new file mode 100644 index 00000000..cec1d81c --- /dev/null +++ b/dwtools/TextGridNavigator.cpp @@ -0,0 +1,596 @@ +/* TextGridNavigator.cpp + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "TextGridNavigator.h" + +#include "enums_getText.h" +#include "TextGridNavigator_enums.h" +#include "enums_getValue.h" +#include "TextGridNavigator_enums.h" + +#include "oo_DESTROY.h" +#include "TextGridNavigator_def.h" +#include "oo_COPY.h" +#include "TextGridNavigator_def.h" +#include "oo_EQUAL.h" +#include "TextGridNavigator_def.h" +#include "oo_CAN_WRITE_AS_ENCODING.h" +#include "TextGridNavigator_def.h" +#include "oo_WRITE_TEXT.h" +#include "TextGridNavigator_def.h" +#include "oo_READ_TEXT.h" +#include "TextGridNavigator_def.h" +#include "oo_WRITE_BINARY.h" +#include "TextGridNavigator_def.h" +#include "oo_READ_BINARY.h" +#include "TextGridNavigator_def.h" +#include "oo_DESCRIPTION.h" +#include "TextGridNavigator_def.h" + + +Thing_implement (TierNavigationContext, Daata, 0); +Thing_implement (IntervalTierNavigationContext, TierNavigationContext, 0); +Thing_implement (TextTierNavigationContext, TierNavigationContext, 0); + +void structTierNavigationContext :: v_info () { + structNavigationContext :: v_info (); + MelderInfo_writeLine (U"Tier number: ", tierNumber); +} + +integer structTierNavigationContext :: v_getSize (Function tier) { + return 0; +}; + +integer structTierNavigationContext :: v_getIndexFromTime (Function anyTier, double time) { + return 0; +} + +double structTierNavigationContext :: v_getLeftTime (Function anyTier, integer index) { + return anyTier->xmin; +} + +double structTierNavigationContext :: v_getRightTime (Function anyTier, integer index) { + return anyTier -> xmax; +} + +conststring32 structTierNavigationContext ::v_getLabel (Function anyTier, integer index) { + return U""; +} + +void structIntervalTierNavigationContext :: v_info () { + structNavigationContext :: v_info (); +} + +void structTextTierNavigationContext :: v_info () { + structNavigationContext :: v_info (); +} + +void TierNavigationContext_init (TierNavigationContext me, NavigationContext thee, integer tierNumber ) { + my navigationLabels = Data_copy (thy navigationLabels.get()); + my navigationCriterion = thy navigationCriterion; + my leftContextLabels = Data_copy (thy leftContextLabels.get()); + my leftContextCriterion = thy leftContextCriterion; + my rightContextLabels = Data_copy (thy rightContextLabels.get()); + my rightContextCriterion = thy rightContextCriterion; + my combinationCriterion = thy combinationCriterion; + my matchContextOnly = thy matchContextOnly; + my tierNumber = tierNumber; + my rightContextFrom = my rightContextTo = 1; + my leftContextFrom = my leftContextTo = 1; +} + +autoIntervalTierNavigationContext IntervalTierNavigationContext_create (NavigationContext navigationContext, integer tierNumber) { + try { + autoIntervalTierNavigationContext me = Thing_new (IntervalTierNavigationContext); + TierNavigationContext_init (me.get(), navigationContext, tierNumber); + return me; + } catch (MelderError) { + Melder_throw (U"IntervalTierNavigationContext not created from ", navigationContext); + } +} + +autoTextTierNavigationContext TextTierNavigationContext_create (NavigationContext navigationContext, integer tierNumber) { + try { + autoTextTierNavigationContext me = Thing_new (TextTierNavigationContext); + TierNavigationContext_init (me.get(), navigationContext, tierNumber); + return me; + } catch (MelderError) { + Melder_throw (U"TextTierNavigationContext not created from ", navigationContext); + } +} + +void TierNavigationContext_setItemOrientation (TierNavigationContext me, kNavigatableTier_match matchCriterion) { + my matchCriterion = matchCriterion; +} + +Thing_implement (TextGridNavigator, Function, 0); + +void structTextGridNavigator :: v_info () { + const integer navigationTierNumber = TextGridNavigator_getTierNumberFromContextNumber (this, 1); + integer navigationTierSize; + for (integer icontext = 1; icontext <= tierNavigationContext.size; icontext ++) { + const integer tierNumber = TextGridNavigator_getTierNumberFromContextNumber (this, icontext); + const TierNavigationContext tnc = our tierNavigationContext.at [icontext]; + const Function anyTier = our textgrid -> tiers -> at [tierNumber]; + const integer tierSize = tnc -> v_getSize (anyTier); + if (icontext == 1) + navigationTierSize = tierSize; + MelderInfo_writeLine (U"Tier number: ", tierNumber, ( icontext== 1 ? U" (navigation tier)" : U" (sub search tier)" )); + tnc -> v_info (); + MelderInfo_writeLine (U"\tNumber of matches on tier ", tierNumber, U":"); + MelderInfo_writeLine (U"\t\tNavigation labels only: ", + Tier_getNumberOfNavigationOnlyMatches (anyTier, tnc), U" (from ", tierSize, U")"); + MelderInfo_writeLine (U"\t\tLeft context labels only: ", + Tier_getNumberOfLeftContextOnlyMatches (anyTier, tnc), U" (from ", tierSize, U")"); + MelderInfo_writeLine (U"\t\tRight context labels only: ", + Tier_getNumberOfRightContextOnlyMatches (anyTier, tnc), U" (from ", tierSize, U")"); + MelderInfo_writeLine (U"\t\tCombined contexts: ", Tier_getNumberOfMatches (anyTier, tnc), U" (from ", tierSize, U")"); + if (icontext > 1) + MelderInfo_writeLine (U"\tMatch criterion to tier number ", navigationTierNumber, U": ", kNavigatableTier_match_getText (tnc -> matchCriterion)); + } + + MelderInfo_writeLine (U"Number of complete matches: ", TextGridNavigator_getNumberOfMatches (this), U" (from ", navigationTierSize, U")"); +} + +autoTextGridNavigator TextGridNavigator_create (TextGrid textgrid, NavigationContext navigationContext, integer tierNumber) { + try { + autoTextGridNavigator me = Thing_new (TextGridNavigator); + Function_init (me.get(), textgrid -> xmin, textgrid -> xmax); + my textgrid = Data_copy (textgrid); + TextGridNavigator_addNavigationContext (me.get(), navigationContext, tierNumber, kNavigatableTier_match::TOUCHES_LEFT_AND_RIGHT); + Melder_require (TextGridNavigator_getNumberOfMatches (me.get())> 0, + U"There are no matches on tier number (", tierNumber, U"). Maybe you should change the tier number?"); + return me; + } catch (MelderError) { + Melder_throw (U"TextGridNavigator could not be created from ", textgrid, U" and ", navigationContext); + } +} + +static bool TextGridNavigator_isNavigatableTierInUse (TextGridNavigator me, integer tierNumber) { + if (my tierNavigationContext.size == 0) + return false; + for (integer icontext = 1; icontext <= my tierNavigationContext. size; icontext ++) + if (my tierNavigationContext. at [icontext] -> tierNumber == tierNumber) + return true; + return false; +} + +static void TextGridNavigator_checkNavigatableTierIsNotInUse (TextGridNavigator me, integer tierNumber) { + Melder_require (! TextGridNavigator_isNavigatableTierInUse (me, tierNumber), + U": tier number ", tierNumber, U" is already in use."); +} + +void TextGridNavigator_addNavigationContext (TextGridNavigator me, NavigationContext thee, integer tierNumber, kNavigatableTier_match matchCriterion) { + try { + TextGrid_checkSpecifiedTierNumberWithinRange (my textgrid.get(), tierNumber); + TextGridNavigator_checkNavigatableTierIsNotInUse (me, tierNumber); + autoTierNavigationContext tierNavigationContext; + if (my textgrid -> tiers -> at [tierNumber] -> classInfo == classIntervalTier) + tierNavigationContext = IntervalTierNavigationContext_create (thee, tierNumber); + else + tierNavigationContext = TextTierNavigationContext_create (thee, tierNumber); + tierNavigationContext -> matchCriterion = matchCriterion; + my tierNavigationContext.addItem_move (tierNavigationContext.move()); + } catch (MelderError) { + Melder_throw (me, U": could not add navigation context ", thee, U"."); + } +} + +void TextGridNavigator_replaceTextGrid (TextGridNavigator me, TextGrid thee) { + try { + Melder_require (thy tiers -> size == my textgrid -> tiers -> size, + U"The TextGrid should have the same number of tiers as the one you want to replace (", my textgrid -> tiers->size, U")."); + for (integer icontext = 1; icontext <= my tierNavigationContext. size; icontext ++) { + const TierNavigationContext navigationContext = my tierNavigationContext. at [icontext]; + const integer tierNumber = navigationContext -> tierNumber; + Melder_require (thy tiers -> at [tierNumber] -> classInfo == my textgrid -> tiers -> at [tierNumber] -> classInfo, + U"The TextGrid should have the same kind of tiers at the same positions as the original you want to replace "); + } + my textgrid = Data_copy (thee); + + my tierNavigationContext. at [1] -> current = 0; // offLeft + } catch (MelderError) { + Melder_throw (me, U": cannot reset with ", thee, U"."); + } +} + +integer TextGridNavigator_getTierNumberFromContextNumber (TextGridNavigator me, integer contextNumber) { + Melder_require (contextNumber > 0 && contextNumber <= my tierNavigationContext . size, + U"The context number should be between 1 and ", my tierNavigationContext . size, U".)"); + return my tierNavigationContext . at [contextNumber] -> tierNumber; +} + +integer TextGridNavigator_getContextNumberFromTierNumber (TextGridNavigator me, integer tierNumber) { + TextGrid_checkSpecifiedTierNumberWithinRange (my textgrid.get(), tierNumber); + for (integer icontext = 1; icontext <= my tierNavigationContext . size; icontext ++) { + const TierNavigationContext tnc = my tierNavigationContext . at [icontext]; + if (tnc -> tierNumber == tierNumber) + return tierNumber; + } + return 0; +} + +void TextGridNavigator_modifyNavigationContextCriterions (TextGridNavigator me, integer tierNumber, kContext_combination combinationCriterion, bool matchContextOnly, kNavigatableTier_match matchCriterion) { + const integer contextNumber = TextGridNavigator_getContextNumberFromTierNumber (me, tierNumber); + Melder_require (contextNumber > 0, + U"The tier number you specified has no navigation. "); + const TierNavigationContext tnc = my tierNavigationContext . at [contextNumber]; + const bool hasLeftContext = ( tnc -> leftContextLabels && tnc -> leftContextLabels -> strings.size > 0 ); + const bool hasRightContext = ( tnc -> rightContextLabels && tnc -> rightContextLabels -> strings.size > 0 ); + if (combinationCriterion == kContext_combination::LEFT) + Melder_require (hasLeftContext, + U"For this option you should have left context labels installed."); + if (combinationCriterion == kContext_combination::RIGHT) + Melder_require (hasRightContext, + U"For this option you should have right context labels installed."); + if (combinationCriterion == kContext_combination::LEFT_AND_RIGHT || combinationCriterion == kContext_combination::LEFT_OR_RIGHT_NOT_BOTH || + combinationCriterion == kContext_combination::LEFT_OR_RIGHT_OR_BOTH) + Melder_require (hasLeftContext && hasRightContext, + U"For this option you should have left and right context labels installed."); + if (matchContextOnly) + Melder_require (hasLeftContext || hasRightContext, + U"It is not possible to match only the context because you have neither left nor right context labels installed."); + tnc -> matchContextOnly = matchContextOnly; + tnc -> combinationCriterion = combinationCriterion; + tnc -> matchCriterion = matchCriterion; +} + +void TextGridNavigator_modifyLeftAndRightContextRange (TextGridNavigator me, integer tierNumber, integer leftContextFrom, integer leftContextTo, integer rightContextFrom, integer rightContextTo) { + const integer contextNumber = TextGridNavigator_getContextNumberFromTierNumber (me, tierNumber); + Melder_require (contextNumber > 0, + U"The tier number you specified has no navigation. "); + TierNavigationContext tnc = my tierNavigationContext .at [contextNumber]; + Melder_require (leftContextFrom > 0 && leftContextTo > 0, + U"The left context interval distance should be positive."); + Melder_require (rightContextFrom > 0 && rightContextTo > 0, + U"The right context interval distance should be positive."); + tnc -> leftContextFrom = std::min (leftContextFrom, leftContextTo); + tnc -> leftContextTo = std::max (leftContextTo, leftContextTo); + tnc -> rightContextFrom = std::min (rightContextFrom, rightContextTo); + tnc -> rightContextTo = std::max (rightContextFrom, rightContextTo); +} + +void TextGridNavigator_modifyMatchingRange (TextGridNavigator me, integer tierNumber, integer maximumLookAhead, integer maximumLookBack) { + const integer contextNumber = TextGridNavigator_getContextNumberFromTierNumber (me, tierNumber); + Melder_require (contextNumber > 0, + U"The tier number you specified has no navigation. "); + TierNavigationContext tnc = my tierNavigationContext . at [contextNumber]; + tnc -> maximumLookAhead = maximumLookAhead; + tnc -> maximumLookBack = maximumLookBack; +} + +static bool Tier_isNavigationMatch (Function me, integer index, TierNavigationContext tnc) { + conststring32 label = tnc -> v_getLabel (me, index); + return NavigationContext_isNavigationLabel (tnc, label); +} + +static bool Tier_isLeftContextMatch (Function me, integer index, TierNavigationContext tnc) { + if (! tnc -> leftContextLabels) + return false; + if (index - tnc -> leftContextFrom < 1) + return false; + const integer startIndex = std::max (1_integer, index - tnc -> leftContextFrom); + const integer endIndex = std::max (1_integer, index - tnc -> leftContextTo); + for (integer i = startIndex; i >= endIndex; i --) { + conststring32 label = tnc -> v_getLabel (me, i); + if (NavigationContext_isLeftContextLabel (tnc, label)) + return true; + } + return false; +} + +static bool Tier_isRightContextMatch (Function me, integer index, TierNavigationContext tnc) { + if (! tnc -> rightContextLabels) + return false; + integer mySize = tnc -> v_getSize (me); + if (index + tnc -> rightContextFrom > mySize) + return false; + const integer startInterval = std::min (mySize, index + tnc -> rightContextTo); + const integer endInterval = std::min (mySize, index + tnc -> rightContextTo); + for (integer i = startInterval; i <= endInterval; i ++) { + conststring32 label = tnc -> v_getLabel (me, i); + if (NavigationContext_isRightContextLabel (tnc, label)) + return true; + } + return false; +} + +integer Tier_getNumberOfRightContextOnlyMatches (Function me, TierNavigationContext tnc) { + if (tnc -> rightContextLabels -> numberOfStrings == 0) + return 0; + integer numberOfMatches = 0; + for (integer index = 1; index <= tnc -> v_getSize (me); index ++) { + conststring32 label = tnc -> v_getLabel (me, index); + if (NavigationContext_isRightContextLabel (tnc, label)) + numberOfMatches ++; + } + return numberOfMatches; +} + +integer Tier_getNumberOfLeftContextOnlyMatches (Function me, TierNavigationContext tnc) { + if (tnc -> leftContextLabels -> numberOfStrings == 0) + return 0; + integer numberOfMatches = 0; + for (integer index = 1; index <= tnc -> v_getSize (me); index ++) { + conststring32 label = tnc -> v_getLabel (me, index); + if (NavigationContext_isLeftContextLabel (tnc, label)) + numberOfMatches ++; + } + return numberOfMatches; +} + +integer Tier_getNumberOfNavigationOnlyMatches (Function me, TierNavigationContext tnc) { + if (tnc -> navigationLabels -> numberOfStrings == 0) + return 0; + integer numberOfMatches = 0; + for (integer index = 1; index <= tnc -> v_getSize (me); index ++) { + conststring32 label = tnc -> v_getLabel (me, index); + if (NavigationContext_isNavigationLabel (tnc, label)) + numberOfMatches ++; + } + return numberOfMatches; +} + +static bool Tier_isLabelMatch (Function me, integer index, TierNavigationContext tnc) { + if (index < 1 && index > tnc -> v_getSize (me)) + return false; + const bool isNavigationMatch = ( tnc -> matchContextOnly ? true : Tier_isNavigationMatch (me, index, tnc) ); + if (! isNavigationMatch || tnc -> combinationCriterion == kContext_combination::NO_LEFT_AND_NO_RIGHT) + return isNavigationMatch; + bool isMatch = false; + if (tnc -> combinationCriterion == kContext_combination::LEFT_AND_RIGHT) + isMatch = Tier_isLeftContextMatch (me, index, tnc) && + Tier_isRightContextMatch (me, index, tnc); + else if (tnc -> combinationCriterion == kContext_combination::RIGHT) + isMatch = Tier_isRightContextMatch (me, index, tnc); + else if (tnc -> combinationCriterion == kContext_combination::LEFT) + isMatch = Tier_isLeftContextMatch (me, index, tnc); + else if (tnc -> combinationCriterion == kContext_combination::LEFT_OR_RIGHT_OR_BOTH) + isMatch = Tier_isLeftContextMatch (me, index, tnc) || + Tier_isRightContextMatch (me, index, tnc); + else if (tnc -> combinationCriterion == kContext_combination::LEFT_OR_RIGHT_NOT_BOTH) + isMatch = Tier_isLeftContextMatch (me, index, tnc) == ! Tier_isRightContextMatch (me, index, tnc); + return isMatch; +} + +integer Tier_getNumberOfMatches(Function me, TierNavigationContext tnc) { + integer numberOfMatches = 0; + for (integer index = 1; index <= tnc -> v_getSize (me); index ++) { + if (Tier_isLabelMatch (me, index, tnc)) + numberOfMatches ++; + } + return numberOfMatches; +} + +integer TextGridNavigator_getNumberOfMatchesInAContext (TextGridNavigator me, integer icontext) { + Melder_require (icontext > 0 && icontext <= my tierNavigationContext.size, + U"The context number should be between 1 and ", my tierNavigationContext.size, U"."); + const TierNavigationContext tnc = my tierNavigationContext . at [icontext]; + const Function anyTier = my textgrid -> tiers -> at [tnc -> tierNumber]; + const integer numberOfMatches = Tier_getNumberOfMatches (anyTier, tnc); + return numberOfMatches; +} + +integer TextGridNavigator_getNumberOfMatches (TextGridNavigator me) { + const TierNavigationContext tnc = my tierNavigationContext . at [1]; + const Function anyTier = my textgrid -> tiers -> at [tnc -> tierNumber]; + integer numberOfMatches = 0; + for (integer index = 1; index <= tnc -> v_getSize (anyTier); index ++) + if (TextGridNavigator_isLabelMatch (me, index)) + numberOfMatches ++; + return numberOfMatches; +} + +bool TextGridNavigator_isLabelMatch (TextGridNavigator me, integer indexInNavigationTier) { + const TierNavigationContext tnc1 = my tierNavigationContext . at [1]; + const Function navigationTier = my textgrid -> tiers -> at [tnc1 -> tierNumber]; + if (! Tier_isLabelMatch (navigationTier, indexInNavigationTier, tnc1)) + return false; + if (my tierNavigationContext.size == 1) + return true; + /* + We have a match at the navigation tier, now check the subordinate tiers + */ + const double leftTime = tnc1 -> v_getLeftTime (navigationTier, indexInNavigationTier); + const double rightTime = tnc1 -> v_getRightTime (navigationTier, indexInNavigationTier); + const double midTime = 0.5 * (leftTime + rightTime); + for (integer icontext = 2; icontext <= my tierNavigationContext . size; icontext ++) { + const TierNavigationContext tnc = my tierNavigationContext . at [icontext]; + const Function anyTier = my textgrid -> tiers -> at [tnc -> tierNumber]; + const integer referenceIndex = tnc -> v_getIndexFromTime (anyTier, midTime); + const integer tierSize = tnc -> v_getSize (anyTier); + + bool matchFound = false; + const integer startIndex = ( tnc -> maximumLookBack > 0 ? std::max (1_integer, referenceIndex - tnc -> maximumLookBack) : 1 ); + const integer endIndex = ( tnc -> maximumLookAhead > 0 ? std::min (referenceIndex + tnc -> maximumLookAhead, tierSize) : tierSize ); + if (tnc -> matchCriterion == kNavigatableTier_match::IS_SOMEWHERE) { + for (integer index = startIndex; index <= endIndex; index ++) { + if (Tier_isLabelMatch (anyTier, index, tnc)) { + matchFound = true; + break; + } + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::IS_LEFT) { + for (integer index = referenceIndex; index >= startIndex; index --) { + if (Tier_isLabelMatch (anyTier, index, tnc)) { + const double rightTime_sub = tnc -> v_getRightTime (anyTier, index); + if (rightTime_sub <= leftTime) { + matchFound = true; + break; + } + } + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::TOUCHES_LEFT) { + for (integer index = referenceIndex; index >= startIndex; index --) { + if (Tier_isLabelMatch (anyTier, index, tnc)) { + const double rightTime_sub = tnc -> v_getRightTime (anyTier, index); + if (rightTime_sub == leftTime) { + matchFound = true; + break; + } else if (rightTime_sub < leftTime) + break; + } + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::OVERLAPS_LEFT) { + // OVERLAPS_LEFT tmin2 < tmin && tmax2 <= tmax + for (integer index = referenceIndex; index >= startIndex; index --) { + if (Tier_isLabelMatch (anyTier, index, tnc)) { + const double rightTime_sub = tnc -> v_getRightTime (anyTier, index); + const double leftTime_sub = tnc -> v_getLeftTime (anyTier, index); + if (leftTime_sub < leftTime && rightTime_sub <= rightTime ) { + matchFound = true; + break; + } else if (rightTime_sub < leftTime) + break; + } + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::IS_INSIDE) { + if (Tier_isLabelMatch (anyTier, referenceIndex, tnc)) { + const double rightTime_sub = tnc -> v_getRightTime (anyTier, referenceIndex); + const double leftTime_sub = tnc -> v_getLeftTime (anyTier, referenceIndex); + if (leftTime_sub >= leftTime && rightTime_sub <= rightTime) + matchFound = true; + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::OVERLAPS_RIGHT) { + // OVERLAPS_RIGHT tmin2 >= tmin && tmax2 > tmax + for (integer index = referenceIndex; index <= endIndex; index ++) { + if (Tier_isLabelMatch (anyTier, index, tnc)) { + const double rightTime_sub = tnc -> v_getRightTime (anyTier, index); + const double leftTime_sub = tnc -> v_getLeftTime (anyTier, index); + if (leftTime_sub >= leftTime && rightTime_sub > rightTime) { + matchFound = true; + break; + } else if (leftTime_sub >= rightTime) + break; + } + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::TOUCHES_RIGHT) { + for (integer index = referenceIndex; index <= endIndex; index ++) { + if (Tier_isLabelMatch (anyTier, index, tnc)) { + const double leftTime_sub = tnc -> v_getLeftTime (anyTier, index); + if (leftTime_sub == rightTime) { + matchFound = true; + break; + } else if (leftTime_sub > rightTime) + break; + } + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::IS_RIGHT) { + for (integer index = referenceIndex; index <= endIndex; index ++) { + if (Tier_isLabelMatch (anyTier, index, tnc)) { + const double leftTime_sub = tnc -> v_getLeftTime (anyTier, index); + if (leftTime_sub >= rightTime) { + matchFound = true; + break; + } + } + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::OVERLAPS_LEFT_AND_RIGHT) { + if (Tier_isLabelMatch (anyTier, referenceIndex, tnc)) { + const double rightTime_sub = tnc -> v_getRightTime (anyTier, referenceIndex); + const double leftTime_sub = tnc -> v_getLeftTime (anyTier, referenceIndex); + if (leftTime_sub <= leftTime && rightTime_sub >= rightTime) + matchFound = true; + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::TOUCHES_LEFT_AND_RIGHT) { + if (Tier_isLabelMatch (anyTier, referenceIndex, tnc)) { + const double rightTime_sub = tnc -> v_getRightTime (anyTier, referenceIndex); + const double leftTime_sub = tnc -> v_getLeftTime (anyTier, referenceIndex); + if (leftTime_sub == leftTime && rightTime_sub == rightTime) + matchFound = true; + } + } else if (tnc -> matchCriterion == kNavigatableTier_match::IS_OUTSIDE) { + for (integer index = startIndex; index <= endIndex; index ++) { + if (Tier_isLabelMatch (anyTier, index, tnc)) { + const double rightTime_sub = tnc -> v_getRightTime (anyTier, index); + const double leftTime_sub = tnc -> v_getLeftTime (anyTier, index); + if (rightTime_sub <= leftTime || leftTime_sub >= rightTime) { + matchFound = true; + break; + } + } + } + } + if (! matchFound) + return false; + } + return true; +} + +integer TextGridNavigator_setCurrentAtTime (TextGridNavigator me, double time) { + const TierNavigationContext tnc = my tierNavigationContext. at [1]; + const Function anyTier = my textgrid -> tiers-> at [tnc -> tierNumber]; + const integer index = tnc -> v_getIndexFromTime (anyTier, time); + tnc -> current = index; + return index; +} + +integer TextGridNavigator_next (TextGridNavigator me) { + const TierNavigationContext tnc = my tierNavigationContext.at [1]; + const Function anyTier = my textgrid -> tiers-> at [tnc -> tierNumber]; + const integer current = tnc -> current; + for (integer index = current + 1; index <= tnc -> v_getSize (anyTier); index ++) { + if (TextGridNavigator_isLabelMatch (me, index)) { + tnc -> current = index; + return index; + } + } + return 0; +} + +integer TextGridNavigator_getNextMatchAfterTime (TextGridNavigator me, double time) { + TextGridNavigator_setCurrentAtTime (me, time); + return TextGridNavigator_next (me); +} + +integer TextGridNavigator_previous (TextGridNavigator me) { + const TierNavigationContext tnc = my tierNavigationContext.at [1]; + const integer current = tnc -> current; + for (integer index = current - 1; index > 0; index --) { + if (TextGridNavigator_isLabelMatch (me, index)) { + tnc -> current = index; + return index; + } + } + return 0; +} + +integer TextGridNavigator_getPreviousMatchBeforeTime (TextGridNavigator me, double time) { + TextGridNavigator_setCurrentAtTime (me, time); + return TextGridNavigator_previous (me); +} + +double TextGridNavigator_getCurrentStartTime (TextGridNavigator me) { + const TierNavigationContext tnc = my tierNavigationContext.at [1]; + const Function navigationTier = my textgrid -> tiers -> at [tnc -> tierNumber]; + return tnc -> v_getLeftTime (navigationTier, tnc -> current); +} + +double TextGridNavigator_getCurrentEndTime (TextGridNavigator me) { + const TierNavigationContext tnc = my tierNavigationContext.at [1]; + const Function navigationTier = my textgrid -> tiers -> at [tnc -> tierNumber]; + return tnc -> v_getRightTime (navigationTier, tnc -> current); +} + +conststring32 TextGridNavigator_getCurrentLabel (TextGridNavigator me) { + const TierNavigationContext tnc = my tierNavigationContext.at [1]; + const Function navigationTier = my textgrid -> tiers -> at [tnc -> tierNumber]; + return tnc -> v_getLabel (navigationTier, tnc -> current); +} + +/* End of file TextGridNavigator.cpp */ diff --git a/dwtools/TextGridNavigator.h b/dwtools/TextGridNavigator.h new file mode 100644 index 00000000..993e827a --- /dev/null +++ b/dwtools/TextGridNavigator.h @@ -0,0 +1,214 @@ +#ifndef _TextGridNavigator_h_ +#define _TextGridNavigator_h_ +/* TextGridNavigator.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "NavigationContext.h" +#include "TextGrid.h" +#include "melder.h" + +#include "TextGridNavigator_enums.h" +#include "TextGridNavigator_def.h" + +/* + The purpose of a TextGridNavigator is to find successive elements that match a criterion on one selected tier, the navigation tier. + The criterion depends on "navigation contexts". + Each navigation context handles only one particular tier. By combining different navigation contexts we + can construct searches that extend over multiple tears. The simplest navigation context consists of only a single label that + has to be matched. + A somewhat more involved context has, instead of a single label, a set of labels where one of the set has to be matched. + The most extensive navigation context involves right and a left context sets of labels, that have to be matched too. + + As an example consider a TextGris with a tier whose intervals have been labeled with IPA symbols /a, i, \ct, o, f, p etc/. + A very simple navigation context that consists of the navigiation set with IPA vowel symbols (u, i, a), a left context + set with /b, p/ and a right context set with /f, s/ would find all vowels /u, e, a/ that are preceded by a /b/ or a /p/ and + followed by a /f/ or and /s/ (if the match condition EQUALS were used). + If another tier of the TextGrid contains syntactic labels we can construct a new navigation context on for this tier and + combine it with the previous context to search for items that also match the syntactic context. +*/ + +Thing_define (IntervalTierNavigationContext, TierNavigationContext) { + + void v_info () + override; + + integer v_getSize (Function anyTier) { + IntervalTier me = reinterpret_cast (anyTier); + return my intervals.size; + } + + integer v_getIndexFromTime (Function anyTier, double time) { + IntervalTier me = reinterpret_cast (anyTier); + integer index; + if (time < my xmin) + index = 0; // offLeft + else if (time > my xmax) + index = my intervals .size + 1; // offRight + else + index = IntervalTier_timeToLowIndex (me, time); + return index; + } + + double v_getLeftTime (Function anyTier, integer index) { + IntervalTier me = reinterpret_cast (anyTier); + if (index < 1 || index > my intervals.size) + return undefined; + TextInterval interval = my intervals . at [index]; + return interval -> xmin; + } + + double v_getRightTime (Function anyTier, integer index) { + IntervalTier me = reinterpret_cast (anyTier); + if (index < 1 || index > my intervals.size) + return undefined; + TextInterval interval = my intervals . at [index]; + return interval -> xmax; + } + + conststring32 v_getLabel (Function anyTier, integer index) { + IntervalTier me = reinterpret_cast (anyTier); + if (index < 1 || index > my intervals.size) + return U"-- undefined --"; + TextInterval interval = my intervals . at [index]; + return interval -> text.get(); + } +}; + +Thing_define (TextTierNavigationContext, TierNavigationContext) { + + void v_info () + override; + + integer v_getSize (Function anyTier) { + TextTier me = reinterpret_cast (anyTier); + return my points.size; + } + + integer v_getIndexFromTime (Function anyTier, double time) { + TextTier me = reinterpret_cast (anyTier); + integer index; + if (time < my xmin) + index = 0; // offLeft + else if (time > my xmax) + index = my points .size + 1; // offRight + else + index = AnyTier_timeToNearestIndex (me -> asAnyTier(), time); + return index; + } + + double v_getLeftTime (Function anyTier, integer index) { + TextTier me = reinterpret_cast (anyTier); + if (index < 1 || index > my points.size) + return undefined; + TextPoint point = my points . at [index]; + return point -> number; + } + + double v_getRightTime (Function anyTier, integer index) { + TextTier me = reinterpret_cast (anyTier); + if (index < 1 || index > my points.size) + return undefined; + TextPoint point = my points . at [index]; + return point -> number;; + } + + conststring32 v_getLabel (Function anyTier, integer index) { + TextTier me = reinterpret_cast (anyTier); + if (index < 1 || index > my points.size) + return U"-- undefined --"; + TextPoint point = my points . at [index]; + return point -> mark.get(); + } +}; + +autoIntervalTierNavigationContext IntervalTierNavigationContext_create (NavigationContext navigationContext, integer tierNumber); + +autoTextTierNavigationContext TextTierNavigationContext_create (NavigationContext navigationContext, integer tierNumber); + +autoTextGridNavigator TextGridNavigator_create (TextGrid textgrid, NavigationContext navigationContext, integer tierNumber); + + +/* + Add navigation context for a tier. + The matchCriterion determines how a match in this tier relates to a match on the navigation tier. + Suppose we have an interval on the navigation tier that matches. Its domain is [tmin, tmax] + (a TextPoint has tmin == tmax). The potential match in the tier we add has domain [tmin2, tmax2]. + Constraint: Relation between matched domains: + IS_LEFT tmax2 <= tmin + TOUCHES_LEFT tmax2 == tmin + OVERLAPS_LEFT tmin2 < tmin && tmax2 <= tmax + INSIDE tmin2 >= tmin && tmax2 <= tmax + OVERLAPS_RIGHT tmin2 >= tmin && tmax2 > tmax + TOUCHES_RIGHT tmin2 == tmax + IS_RIGHT tmin2 >= tmax + IS_OUTSIDE tmax2 <= tmin || tmin2 >= tmax (IS_LEFT || IS_RIGHT) + OVERLAPS_LEFT_AND_RIGHT tmin2 < tmin && tmax2 > tmax + TOUCHES_LEFT_AND_RIGHT tmin2 == tmin && tmax2 == tmax +*/ +void TextGridNavigator_addNavigationContext (TextGridNavigator me, NavigationContext thee, integer tierNumber, kNavigatableTier_match matchCriterion); + +void TextGridNavigator_modifyMatchingRange (TextGridNavigator me, integer tierNumber, integer maximumLookAhead, integer maximumLookBack); + +void TextGridNavigator_modifyLeftAndRightContextRange (TextGridNavigator me, integer tierNumber, integer leftContextFrom, integer leftContextTo, integer rightContextFrom, integer rightContextTo); + +void TextGridNavigator_modifyNavigationContextCriterions (TextGridNavigator me, integer tierNumber, kContext_combination combinationCriterion, bool matchContextOnly, kNavigatableTier_match matchCriterion); + +void TextGridNavigator_replaceTextGrid (TextGridNavigator me, TextGrid thee); + +bool TextGridNavigator_isLabelMatch (TextGridNavigator me, integer indexInNavigationTier); + +integer TextGridNavigator_getNumberOfMatchesInAContext (TextGridNavigator me, integer icontext); + +integer TextGridNavigator_getNumberOfMatches (TextGridNavigator me); + +integer TextGridNavigator_getTierNumberFromContextNumber (TextGridNavigator me, integer contextNumber); +integer TextGridNavigator_getContextNumberFromTierNumber (TextGridNavigator me, integer tierNumber); + +integer TextGridNavigator_getCurrentFromTime (TextGridNavigator me, double time); + +integer TextGridNavigator_next (TextGridNavigator me); + +integer TextGridNavigator_getNextMatchAfterTime (TextGridNavigator me, double time); + +integer TextGridNavigator_previous (TextGridNavigator me); + +integer TextGridNavigator_getPreviousMatchBeforeTime (TextGridNavigator me, double time); + +double TextGridNavigator_getCurrentStartTime (TextGridNavigator me); + +double TextGridNavigator_getCurrentEndTime (TextGridNavigator me); + +static inline integer TextGridNavigator_getFirstMatch (TextGridNavigator me) { + return TextGridNavigator_getNextMatchAfterTime (me, my xmin - 0.1); +} + +static inline integer TextGridNavigator_getLastMatch (TextGridNavigator me) { + return TextGridNavigator_getPreviousMatchBeforeTime (me, my xmax + 0.1); +} + +conststring32 TextGridNavigator_getCurrentLabel (TextGridNavigator me); + +integer Tier_getNumberOfLeftContextOnlyMatches (Function me, TierNavigationContext tnc); + +integer Tier_getNumberOfRightContextOnlyMatches (Function me, TierNavigationContext tnc); + +integer Tier_getNumberOfNavigationOnlyMatches (Function me, TierNavigationContext tnc); + +integer Tier_getNumberOfMatches (Function me, TierNavigationContext tnc); + +#endif /* _TextGridNavigator_h_ */ diff --git a/dwtools/TextGridNavigator_def.h b/dwtools/TextGridNavigator_def.h new file mode 100644 index 00000000..25dfb5ae --- /dev/null +++ b/dwtools/TextGridNavigator_def.h @@ -0,0 +1,63 @@ +/* TextGridNavigator_def.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#define ooSTRUCT TierNavigationContext +oo_DEFINE_CLASS (TierNavigationContext, NavigationContext) + + oo_INTEGER (tierNumber) + oo_INTEGER (leftContextFrom) + oo_INTEGER (leftContextTo) + + oo_INTEGER (rightContextFrom) + oo_INTEGER (rightContextTo) + + oo_INTEGER (current) // (offLeft) 0 <= current <= size + 1 : (offRight) + oo_INTEGER (maximumLookAhead) // don't go further than this number of steps from current + oo_INTEGER (maximumLookBack) // don't go back more than this number of steps from current + + oo_ENUM (kNavigatableTier_match, matchCriterion) // how does a 'match' in this tier relate to the navigation tier + + #if oo_DECLARING + void v_info () + override; + virtual integer v_getSize (Function tier); + virtual integer v_getIndexFromTime (Function tier, double time); + virtual double v_getLeftTime (Function tier, integer index); + virtual double v_getRightTime (Function tier, integer index); + virtual conststring32 v_getLabel (Function tier, integer index); + #endif + +oo_END_CLASS (TierNavigationContext) +#undef ooSTRUCT + +#define ooSTRUCT TextGridNavigator +oo_DEFINE_CLASS (TextGridNavigator, Function) + + oo_OBJECT (TextGrid, 0, textgrid) + oo_COLLECTION_OF (OrderedOf, tierNavigationContext, TierNavigationContext, 0) + + #if oo_DECLARING + void v_info () + override; + #endif + +oo_END_CLASS (TextGridNavigator) +#undef ooSTRUCT + + + /* End of file TextGridNavigator_def.h */ diff --git a/dwtools/TextGridNavigator_enums.h b/dwtools/TextGridNavigator_enums.h new file mode 100644 index 00000000..f522425c --- /dev/null +++ b/dwtools/TextGridNavigator_enums.h @@ -0,0 +1,33 @@ +/* TextGridNavigator_enums.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +enums_begin (kNavigatableTier_match, 0) + enums_add (kNavigatableTier_match, 1, IS_LEFT, U"is left") + enums_add (kNavigatableTier_match, 2, TOUCHES_LEFT, U"touches left") + enums_add (kNavigatableTier_match, 3, OVERLAPS_LEFT, U"overlaps left") + enums_add (kNavigatableTier_match, 4, IS_INSIDE, U"is inside") + enums_add (kNavigatableTier_match, 5, OVERLAPS_RIGHT, U"overlaps right") + enums_add (kNavigatableTier_match, 6, TOUCHES_RIGHT, U"touches right") + enums_add (kNavigatableTier_match, 7, IS_RIGHT, U"is right") + enums_add (kNavigatableTier_match, 8, OVERLAPS_LEFT_AND_RIGHT, U"overlaps left and right") + enums_add (kNavigatableTier_match, 9, TOUCHES_LEFT_AND_RIGHT, U"touches left and right") + enums_add (kNavigatableTier_match,10, IS_OUTSIDE, U"is outside") + enums_add (kNavigatableTier_match,11, IS_SOMEWHERE, U"is somewhere") +enums_end (kNavigatableTier_match, 11, OVERLAPS_LEFT_AND_RIGHT) + +/* End of fileTextGridNavigator_enums_enums.h */ diff --git a/dwtools/TextGridView.cpp b/dwtools/TextGridView.cpp new file mode 100644 index 00000000..12fd16dc --- /dev/null +++ b/dwtools/TextGridView.cpp @@ -0,0 +1,126 @@ +/* TextGridView.cpp + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "TextGridView.h" +#include "NUM2.h" + + +Thing_implement (TextGridView, TextGrid, 0); + +void structTextGridView :: v_info () { + structDaata :: v_info (); + MelderInfo_writeLine (U"Time domain:", xmin, U" to ", xmax, U" seconds"); +} + + +void TextGridView_setDefaultView (TextGridView me) { + my tierNumbers.resize (my origin -> tiers -> size); + my tiers -> size = 0; + for (integer itier = 1; itier <= my origin -> tiers -> size; itier ++) { + const Function anyTier = my origin -> tiers -> at [itier]; + my tiers -> _insertItem_ref (anyTier, itier); + my tierNumbers [itier] = itier; + } +} + +integer TextGridView_getViewTierNumber (TextGridView me, integer originTierNumber) { + if (originTierNumber < 1 || originTierNumber > my origin -> tiers -> size) + return 0; + for (integer inum = 1; inum <= my tierNumbers.size; inum ++) + if (my tierNumbers [inum] == originTierNumber) + return inum; + return 0; +} + +bool TextGridView_isDefaultView (TextGridView me) { + if (my tiers -> size != my origin -> tiers -> size) + return false; + for (integer itier = 1; itier <= my tiers -> size; itier ++) + if (my tierNumbers [itier] != itier) + return false; + return true; +} + +autoTextGridView TextGridView_create (TextGrid me) { + try { + autoTextGridView thee = Thing_new (TextGridView); + thy tiers = FunctionList_create (); + thy tiers -> _initializeOwnership (false); + thy xmin = my xmin; + thy xmax = my xmax; + thy origin = me; + TextGridView_setDefaultView (thee.get()); + return thee; + } catch (MelderError) { + Melder_throw (U"TextGridView not created."); + } +} + +autoTextGrid TextGridView_to_TextGrid (TextGridView me) { + autoTextGrid thee = TextGrid_createWithoutTiers (my xmin, my xmax); + for (integer itier = 1; itier <= my tiers -> size; itier ++) { + autoFunction tierCopy = Data_copy (my tiers -> at [itier]); + thy tiers -> addItem_move (tierCopy.move()); + } + return thee; +} + +void TextGridView_checkNewView (TextGridView me, constINTVEC const& newTierNumbers) { + const integer size = my origin -> tiers -> size; + const integer min = NUMmin (newTierNumbers); + const integer max = NUMmax (newTierNumbers); + Melder_require (min > 0, + U"A tier number should be positive."); + Melder_require (max <= my origin -> tiers -> size, + U"A tier number should not exceed ", size, U" (=the number of tiers in the original TextGrid)."); +} + +void TextGridView_modifyView (TextGridView me, constINTVEC const& newTierNumbers) { + TextGridView_checkNewView (me, newTierNumbers); + my tierNumbers.resize (newTierNumbers.size); + my tiers -> size = 0; + for (integer itier = 1; itier <= newTierNumbers.size; itier ++) { + const integer originNumber = newTierNumbers [itier]; + const Function anyTier = my origin -> tiers -> at [originNumber]; + my tiers -> _insertItem_ref (anyTier, itier); + my tierNumbers [itier] = originNumber; + } +} + +void TextGridView_viewAllWithSelectedOnTop (TextGridView me, integer selected) { + const integer originSize = my origin -> tiers -> size; + Melder_require (selected >= 0 && selected <= originSize, + U"The selected tier number should not exceed ", originSize, U"."); + autoINTVEC tierNumbers = newINTVEClinear (originSize, 1, 1); + if (selected > 0) { + integer selectedPosition = 0; + for (integer inum = 1; inum <= tierNumbers.size; inum ++) + if (tierNumbers [inum] == selected) { + selectedPosition = inum; + break; + } + if (selectedPosition != 1) { + for (integer inum = selectedPosition; inum > 1; inum --) + tierNumbers [inum] = tierNumbers [inum - 1]; + tierNumbers [1] = selected; + } + } + TextGridView_modifyView (me, tierNumbers.get()); +} + +/* End of file TextGridView.cpp */ diff --git a/dwtools/TextGridView.h b/dwtools/TextGridView.h new file mode 100644 index 00000000..6e74a3f9 --- /dev/null +++ b/dwtools/TextGridView.h @@ -0,0 +1,71 @@ +#ifndef _TextGridView_h_ +#define _TextGridView_h_ +/* TextGridView.h + * + * Copyright (C) 2020 David Weenink + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "TextGrid.h" +#include "melder.h" + +/* + A TextGridView offers a view on a TextGrid. + With a TexGridView you can determine _which_ tiers of a TextGrid are exposed and in _what_ order. + There is no limit on how often you can have a tier exposed. The array 'tierNumbers' logs which tiers + and in what order they are exposed. + Suppose you have a TextGrid with three tiers and 'tierNumbers' is an array with two elements, + say 3 and 1, the TextGridView behaves like a TextGrid with only two tiers. Its first tier is the original + TextGrid's tier 3 and its second tier is the original TextGrid's tier number 1. + If 'tierNumbers' has five elements, for example 1, 2, 3, 2 and 1, then The TextGridView behaves as if it had + 5 tiers. Its tier number 1 and 5 are both equal to the original TextGrid's tier number 1, etc. + The TextGridView can be destroyed at any time because it only contains links to the original TextGrid. +*/ +Thing_define (TextGridView, TextGrid) { + TextGrid origin; + autoINTVEC tierNumbers; + void v_info () + override; +}; + + +void TextGridView_setDefaultView (TextGridView me); + +integer TextGridView_getViewTierNumber (TextGridView me, integer originTierNumber); + +static inline integer TextGridView_getOriginTierNumber (TextGridView me, integer viewTierNumber) { + if (viewTierNumber < 1 || viewTierNumber > my tiers -> size) + return 0; + return my tierNumbers [viewTierNumber]; +} + +bool TextGridView_isDefaultView (TextGridView me); + +static inline bool TextGridView_hasTierInView (TextGridView me, integer tierNumber) { + return TextGridView_getViewTierNumber (me, tierNumber) != 0; +} + +autoTextGridView TextGridView_create (TextGrid me); + +autoTextGrid TextGridView_to_TextGrid (TextGridView me); + +void TextGridView_checkNewView (TextGridView me, constINTVEC const& newTierNumbers); + +void TextGridView_modifyView (TextGridView me, constINTVEC const& newTierNumbers); + +void TextGridView_viewAllWithSelectedOnTop (TextGridView me, integer selected); + + +#endif /* _TextGridView_h_ */ diff --git a/dwtools/TextGrid_and_PitchTier.cpp b/dwtools/TextGrid_and_PitchTier.cpp index ab23be7a..ffec4b90 100644 --- a/dwtools/TextGrid_and_PitchTier.cpp +++ b/dwtools/TextGrid_and_PitchTier.cpp @@ -271,6 +271,7 @@ autoPitchTier IntervalTier_PitchTier_to_PitchTier (IntervalTier me, PitchTier th } } +#if 0 static autoPitchTier TextGrid_PitchTier_to_PitchTier (TextGrid me, PitchTier thee, integer tierNumber, conststring32 times_string, int time_offset, conststring32 pitches_string, int pitch_unit, int pitch_as, int pitchAnchor_status, kMelder_string which, conststring32 criterion) { try { @@ -280,6 +281,7 @@ static autoPitchTier TextGrid_PitchTier_to_PitchTier (TextGrid me, PitchTier the Melder_throw (me, U": cannot create PitchTier."); } } +#endif /* We specify pitches as tone levels (1 - numberOfToneLevels). These levels are relative to the pitch range of a speaker. diff --git a/dwtools/VowelEditor.cpp b/dwtools/VowelEditor.cpp index 113d5e24..c6ab3df7 100644 --- a/dwtools/VowelEditor.cpp +++ b/dwtools/VowelEditor.cpp @@ -1,6 +1,6 @@ /* VowelEditor.cpp * - * Copyright (C) 2008-2020 David Weenink, 2015,2017,2018 Paul Boersma + * Copyright (C) 2008-2020 David Weenink, 2015-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -22,8 +22,8 @@ trajectory --> path ???? In this drawing area a cursor can be moved around by a mouse. The position of the cursor is related to the F1 and F2 frequencies. On_mouse_down the position of the cursor is sampled (Not at fixed intervals!). - This results in a series of (x,y) values that will be transformed to (F1,F2) values in Hertz - The corresponding sound wil be made audible after the mouse is released. + This results in a series of (x,y) values that will be transformed to (F1,F2) values in Hertz. + The corresponding sound is made audible after the mouse is released. The user graphics area is the F1-F2 plane: here the origin is at the top-right with log(F2) on the horizontal axis and log(F1) on the vertical axis (i.e. log (F1) top-down, log(F2) right-to-left) @@ -82,8 +82,6 @@ Thing_implement (VowelEditor, Editor, 0); #define MARGIN_TOP 50 #define MARGIN_BOTTOM (60+STATUS_INFO) -#define MICROSECPRECISION(x) (round((x)*1000000)/1000000) - #pragma mark - class TrajectoryPointTier Thing_implement (TrajectoryPoint, AnyPoint, 0); @@ -180,7 +178,7 @@ static void Trajectory_setColour (Trajectory me, double startTime, double endTim use that two points in a trajectory never bear the same time. We also have to guard against rounding down in the forms. For example an endTime - of 0.4632200000000007 might be shown in the form as '0.46322' + of 0.4632200000000007 might be shown in the form as '0.46322'. */ TrajectoryPoint p2, p1 = my points.at [endIndex]; if (p1 -> number == endTime) { @@ -263,11 +261,6 @@ static void clipF1F2 (VowelEditor me, double *f1, double *f2) { Melder_clip (my p_window_f2min, f2, my p_window_f2max); } -static void clipXY (double *x, double *y) { - Melder_clip (0.0, x, 1.0); - Melder_clip (0.0, y, 1.0); -} - static void VowelEditor_updateFromF0StartAndSlopeTextWidgets (VowelEditor me) { double f0 = getRealFromTextWidget (my f0TextField); Melder_clip (my p_f0_minimum, & f0, my p_f0_maximum); @@ -293,7 +286,7 @@ static double VowelEditor_updateFromDurationTextWidget (VowelEditor me) { if (isundef (duration) || duration < my p_trajectory_minimumDuration) duration = my p_trajectory_minimumDuration; my pref_trajectory_duration () = my p_trajectory_duration = duration; - GuiText_setString (my durationTextField, Melder_double (MICROSECPRECISION (duration))); + GuiText_setString (my durationTextField, Melder_fixed (duration, 6)); Trajectory_newDuration (my trajectory.get(), duration); return duration; } @@ -317,9 +310,7 @@ static void Sound_fadeIn (Sound me, double duration, bool fromFirstNonZeroSample istart ++; } } - if (numberOfSamples > my nx - istart + 1) - numberOfSamples = my nx - istart + 1; - + Melder_clipRight (& numberOfSamples, my nx - istart + 1); for (integer i = 1; i <= numberOfSamples; i ++) { const double phase = NUMpi * (i - 1) / (numberOfSamples - 1); my z [1] [istart + i - 1] *= 0.5 * (1.0 - cos (phase)); @@ -328,14 +319,12 @@ static void Sound_fadeIn (Sound me, double duration, bool fromFirstNonZeroSample static void Sound_fadeOut (Sound me, double duration) { integer numberOfSamples = Melder_ifloor (duration / my dx); - - if (numberOfSamples > my nx) - numberOfSamples = my nx; + Melder_clipRight (& numberOfSamples, my nx); if (numberOfSamples < 2) return; const integer istart = my nx - numberOfSamples; /* - Only one channel + Only one channel. */ for (integer i = 1; i <= numberOfSamples; i ++) { const double phase = NUMpi * (i - 1) / (numberOfSamples - 1); @@ -351,7 +340,7 @@ static double VowelEditor_getF0AtTime (VowelEditor me, double time) { static void VowelEditor_updateTrajectorySpecification (VowelEditor me) { /* - Always update; GuiObject text might have changed + Always update; GuiObject text might have changed. */ VowelEditor_updateFromDurationTextWidget (me); VowelEditor_updateFromF0StartAndSlopeTextWidgets (me); @@ -397,7 +386,7 @@ static autoPitchTier VowelEditor_to_PitchTier (VowelEditor me) { } static autoSound VowelEditor_createTargetSound (VowelEditor me) { try { - VowelEditor_updateTrajectorySpecification (me); // update pitch and duration + VowelEditor_updateTrajectorySpecification (me); // update pitch and duration autoFormantGrid formantGrid = VowelEditor_to_FormantGrid (me); autoPitchTier pitchTier = VowelEditor_to_PitchTier (me); autoSound thee = PitchTier_to_Sound_pulseTrain (pitchTier.get(), my p_synthesis_samplingFrequency, 0.7, 0.05, 30, false); @@ -413,11 +402,12 @@ static autoSound VowelEditor_createTargetSound (VowelEditor me) { /* Precondition: trajectory points are all different */ static void VowelEditor_drawF1F2Trajectory (VowelEditor me, Graphics g) { - Melder_assert (my trajectory -> points.size >= 2); + if (my trajectory -> points.size < 2) + return; - const integer glt = Graphics_inqLineType (g); - const double glw = Graphics_inqLineWidth (g); - const MelderColour colour_save = Graphics_inqColour (g); + const int savedLineType = Graphics_inqLineType (g); + const double savedLineWidth = Graphics_inqLineWidth (g); + const MelderColour savedColour = Graphics_inqColour (g); Graphics_setInner (g); Graphics_setWindow (g, 0.0, 1.0, 0.0, 1.0); @@ -432,7 +422,7 @@ static void VowelEditor_drawF1F2Trajectory (VowelEditor me, Graphics g) { double x1 = getx (firstPoint -> f2); double y1 = gety (firstPoint -> f1); double t1 = firstPoint -> number; - MelderColour colour = firstPoint -> colour; // firstpoint determines colour of segment + MelderColour colour = firstPoint -> colour; // first point determines colour of segment Graphics_setColour (g, colour); integer imark = 1; for (integer it = 2; it <= my trajectory -> points.size; it ++) { @@ -443,7 +433,7 @@ static void VowelEditor_drawF1F2Trajectory (VowelEditor me, Graphics g) { Graphics_setLineWidth (g, my p_trajectory_lineWidth); Graphics_line (g, x1, y1, x2, y2); /* - draw line orthogonal to the trajectory at regular points + Draw line orthogonal to the trajectory at regular points. */ double markTime; while ((markTime = my p_trajectory_markEvery * imark) < t2) { @@ -462,9 +452,9 @@ static void VowelEditor_drawF1F2Trajectory (VowelEditor me, Graphics g) { const double xm = x1 + s * dx; const double ym = y1 + s * dy; const double d = sqrt (dx * dx + dy * dy); - double v = my p_trajectory_markLength / (2.0 * d); // d > 0 - double xl1 = xm - v * dy, yl1 = ym + v * dx; - double xl2 = xm + v * dy, yl2 = ym - v * dx; + const double v = my p_trajectory_markLength / (2.0 * d); // d > 0 + const double xl1 = xm - v * dy, yl1 = ym + v * dx; + const double xl2 = xm + v * dy, yl2 = ym - v * dx; Graphics_setLineWidth (g, 1); Graphics_line (g, xl1, yl1, xl2, yl2); imark ++; @@ -477,37 +467,37 @@ static void VowelEditor_drawF1F2Trajectory (VowelEditor me, Graphics g) { colour = point -> colour; } } - // Arrow at end + /* + Arrow at end. + */ { const integer n = my trajectory -> points.size; - const double gas = Graphics_inqArrowSize (g), arrowSize = 1.0; - const double size = 10.0 * arrowSize * Graphics_getResolution (g) / 75.0 / my width; - const double sizeSquared = size * size; + const double savedArrowSize = Graphics_inqArrowSize (g), arrowSize = 1.0; + double resolution = Graphics_getResolution (g); Graphics_setArrowSize (g, arrowSize); - integer it = 1; + integer it = 0; const TrajectoryPoint lastPoint = my trajectory -> points.at [n]; TrajectoryPoint point; - while (it <= n - 1) { + while (++ it <= (n - 1)) { point = my trajectory -> points.at [n - it]; - const double dx = getx (lastPoint -> f2) - getx (point -> f2); - const double dy = gety (lastPoint -> f1) - gety (point -> f1); + const double dx = resolution * (getx (lastPoint -> f2) - getx (point -> f2)); + const double dy = resolution * (gety (lastPoint -> f1) - gety (point -> f1)); const double d2 = dx * dx + dy * dy; - if (d2 > sizeSquared) + if (sqrt (d2) > arrowSize) break; - it ++; } Graphics_arrow (g, getx (point -> f2), gety (point -> f1), getx (lastPoint -> f2), gety (lastPoint -> f1)); - Graphics_setArrowSize (g, gas); + Graphics_setArrowSize (g, savedArrowSize); } Graphics_unsetInner (g); - Graphics_setColour (g, colour_save); - Graphics_setLineType (g, glt); - Graphics_setLineWidth (g, glw); + Graphics_setLineType (g, savedLineType); + Graphics_setLineWidth (g, savedLineWidth); + Graphics_setColour (g, savedColour); } static void Table_addColumnIfNotExists_size (Table me, double size) { - const integer col_size = Table_findColumnIndexFromColumnLabel (me, U"Size"); - if (col_size == 0) { + const integer sizeColumn = Table_findColumnIndexFromColumnLabel (me, U"Size"); + if (sizeColumn == 0) { Table_appendColumn (me, U"Size"); for (integer irow = 1; irow <= my rows.size; irow ++) Table_setNumericValue (me, irow, my numberOfColumns, size); @@ -515,8 +505,8 @@ static void Table_addColumnIfNotExists_size (Table me, double size) { } static void Table_addColumnIfNotExists_colour (Table me, conststring32 colour) { - integer col_colour = Table_findColumnIndexFromColumnLabel (me, U"Colour"); - if (col_colour == 0) { + const integer colourColumn = Table_findColumnIndexFromColumnLabel (me, U"Colour"); + if (colourColumn == 0) { Table_appendColumn (me, U"Colour"); for (integer irow = 1; irow <= my rows.size; irow ++) Table_setStringValue (me, irow, my numberOfColumns, colour); @@ -526,7 +516,7 @@ static void Table_addColumnIfNotExists_colour (Table me, conststring32 colour) { static void VowelEditor_getVowelMarksFromFile (VowelEditor me) { try { Melder_require (str32len (my p_marks_fileName) > 0, - U"There is no file defined with vowel marks."); + U"No file with vowel marks has been defined."); structMelderFile file { }; Melder_pathToFile (my p_marks_fileName, & file); autoDaata data = Data_readFromFile (& file); @@ -535,7 +525,7 @@ static void VowelEditor_getVowelMarksFromFile (VowelEditor me) { autoTable newMarks = data.static_cast_move (); /* - Require columns Vowel F1 & F2 to be present + Require columns Vowel F1 and F2 to be present. */ Table_getColumnIndexFromColumnLabel (newMarks.get(), U"Vowel"); Table_getColumnIndexFromColumnLabel (newMarks.get(), U"F1"); @@ -589,7 +579,7 @@ static void VowelEditor_drawBackground (VowelEditor me, Graphics g) { Graphics_setGrey (g, 0.5); const double fontSize = Graphics_inqFontSize (g); /* - Draw the marks + Draw the marks. */ if (my marks) { const integer col_vowel = Table_getColumnIndexFromColumnLabel (my marks.get(), U"Vowel"); @@ -621,9 +611,9 @@ static void VowelEditor_drawBackground (VowelEditor me, Graphics g) { } } Graphics_setFontSize (g, fontSize); - Graphics_setGrey (g, 0.0); // black + Graphics_setColour (g, Melder_BLACK); /* - Draw the line F1=F2 + Draw the line F1=F2. */ double xl1, yl1, xl2, yl2; VowelEditor_getXYFromF1F2 (me, my p_window_f2min, my p_window_f2min, & xl1, & yl1); @@ -634,12 +624,12 @@ static void VowelEditor_drawBackground (VowelEditor me, Graphics g) { double y [] = { yl1, yl2, 0.0 }; Graphics_setGrey (g, 0.6); Graphics_fillArea (g, 3, x , y); - Graphics_setGrey (g, 0.0); // black + Graphics_setColour (g, Melder_BLACK); Graphics_line (g, xl1, yl1, xl2, yl2); } } /* - Draw the horizontal grid lines + Draw the horizontal grid lines. */ if (my p_grid_df1 < (my p_window_f1max - my p_window_f1min)) { integer iline = Melder_iroundDown ((my p_window_f1min + my p_grid_df1) / my p_grid_df1); @@ -655,10 +645,10 @@ static void VowelEditor_drawBackground (VowelEditor me, Graphics g) { iline ++; } Graphics_setLineType (g, Graphics_DRAWN); - Graphics_setGrey (g, 0.0); // black + Graphics_setColour (g, Melder_BLACK); } /* - Draw the vertical grid lines + Draw the vertical grid lines. */ if (my p_grid_df2 < (my p_window_f2max - my p_window_f2min)) { integer iline = Melder_iroundDown ((my p_window_f2min + my p_grid_df2) / my p_grid_df2); @@ -674,12 +664,12 @@ static void VowelEditor_drawBackground (VowelEditor me, Graphics g) { iline ++; } Graphics_setLineType (g, Graphics_DRAWN); - Graphics_setGrey (g, 0.0); // black + Graphics_setColour (g, Melder_BLACK); } Graphics_setLineWidth (g, 2.0); Graphics_rectangle (g, 0.0, 1.0, 0.0, 1.0); Graphics_unsetInner (g); - Graphics_setGrey (g, 0.0); // black + Graphics_setGrey (g, 0.0); // black Graphics_markLeft (g, 0.0, false, true, false, Melder_double (my p_window_f1max)); Graphics_markLeft (g, 1.0, false, true, false, Melder_double (my p_window_f1min)); Graphics_markTop (g, 0.0, false, true, false, Melder_double (my p_window_f2max)); @@ -955,7 +945,7 @@ static void menu_cb_newTrajectory (VowelEditor me, EDITOR_ARGS_FORM) { Trajectory_addPoint (my trajectory.get(), 0.0, startF1, startF2, colour); clipF1F2 (me, & endF1, & endF2); Trajectory_addPoint (my trajectory.get(), newDuration, endF1, endF2, colour); - GuiText_setString (my durationTextField, Melder_double (MICROSECPRECISION (newDuration))); + GuiText_setString (my durationTextField, Melder_fixed (newDuration, 6)); my pref_trajectory_newDuration () = my p_trajectory_newDuration = newDuration; pref_str32cpy2 (my pref_trajectory_colour (), my p_trajectory_colour, colour_string); Graphics_updateWs (my graphics.get()); @@ -979,8 +969,8 @@ static void menu_cb_extendTrajectory (VowelEditor me, EDITOR_ARGS_FORM) { const double endTime = startTime + extendDuration; clipF1F2 (me, & toF1, & toF2); Trajectory_addPoint (my trajectory.get(), endTime, toF1, toF2, colour); - GuiText_setString (my durationTextField, Melder_double (MICROSECPRECISION (endTime))); - GuiText_setString (my extendTextField, Melder_double (MICROSECPRECISION (extendDuration))); + GuiText_setString (my durationTextField, Melder_fixed (endTime, 6)); + GuiText_setString (my extendTextField, Melder_fixed (extendDuration, 6)); my pref_trajectory_extendDuration () = my p_trajectory_extendDuration = extendDuration; my pref_trajectory_duration () = my p_trajectory_duration = endTime; pref_str32cpy2 (my pref_trajectory_colour (), my p_trajectory_colour, colour_string); @@ -998,7 +988,7 @@ static void menu_cb_modifyTrajectoryDuration (VowelEditor me, EDITOR_ARGS_FORM) U"The duration should be larger than ", my p_trajectory_minimumDuration, U" s."); my pref_trajectory_duration () = my p_trajectory_duration = newDuration; Trajectory_newDuration (my trajectory.get(), newDuration); - GuiText_setString (my durationTextField, Melder_double (MICROSECPRECISION (newDuration))); + GuiText_setString (my durationTextField, Melder_fixed (newDuration, 6)); EDITOR_END } @@ -1104,92 +1094,69 @@ static void gui_drawingarea_cb_resize (VowelEditor me, GuiDrawingArea_ResizeEven Graphics_setWsWindow (my graphics.get(), 0.0, my width, 0.0, my height); Graphics_setViewport (my graphics.get(), 0.0, my width, 0.0, my height); Graphics_updateWs (my graphics.get()); - - /* Save the current shell size as the user's preference */ - - my pref_shell_width () = my p_shell_width = GuiShell_getShellWidth (my windowForm); - my pref_shell_height () = my p_shell_height = GuiShell_getShellHeight (my windowForm); + /* + Save the current shell size as the user's preference. + */ + my pref_shell_width() = my p_shell_width = GuiShell_getShellWidth (my windowForm); + my pref_shell_height() = my p_shell_height = GuiShell_getShellHeight (my windowForm); } // shift key always extends what already is. // Special case : !soundFollowsMouse. The first click just defines the vowel's first f1f2-position, -static void gui_drawingarea_cb_click (VowelEditor me, GuiDrawingArea_ClickEvent event) { - const double t0 = Melder_clock (); - integer iskipped = 0; - struct structGuiButtonEvent gb_event { 0 }; +static void gui_drawingarea_cb_mouse (VowelEditor me, GuiDrawingArea_MouseEvent event) { + static double anchorTime; + static double previousX; + static double previousY; + static double dt; Graphics_setInner (my graphics.get()); - - double x, y, t, f1, f2, dt = 0.0; - Graphics_getMouseLocation (my graphics.get(), & x, & y); - clipXY (& x, & y); + double mouseX, mouseY; + Graphics_DCtoWC (my graphics.get(), event -> x, event -> y, & mouseX, & mouseY); + Melder_clip (0.0, & mouseX, 1.0); + Melder_clip (0.0, & mouseY, 1.0); + double f1, f2; + VowelEditor_getF1F2FromXY (me, mouseX, mouseY, & f1, & f2); MelderColour colour = MelderColour_fromColourNameOrRGBString (my p_trajectory_colour); - if (event -> shiftKeyPressed) { - VowelEditor_updateFromExtendDurationTextWidget (me); - (my shiftKeyPressed) ++; - t = dt = my trajectory -> xmax + my p_trajectory_extendDuration; - VowelEditor_getF1F2FromXY (me, x, y, & f1, & f2); - Trajectory_addPoint (my trajectory.get(), t, f1, f2, colour); - GuiText_setString (my durationTextField, Melder_double (t)); - goto end; + if (event -> isClick()) { + anchorTime = Melder_clock (); + if (event -> shiftKeyPressed) { + VowelEditor_updateFromExtendDurationTextWidget (me); + const double duration = dt = my trajectory -> xmax + my p_trajectory_extendDuration; + Trajectory_addPoint (my trajectory.get(), duration, f1, f2, colour); + GuiText_setString (my durationTextField, Melder_double (duration)); + } else { + const double duration = dt = 0.0; + my trajectory = Trajectory_create (my p_trajectory_minimumDuration); + Trajectory_addPoint (my trajectory.get(), duration, f1, f2, colour); + GuiText_setString (my durationTextField, Melder_double (duration)); + if (! my p_soundFollowsMouse) + Trajectory_addPoint (my trajectory.get(), my p_trajectory_minimumDuration, f1, f2, colour); + } + previousX = mouseX; + previousY = mouseY; } else { - t = 0.0; - my shiftKeyPressed = 0; - my trajectory = Trajectory_create (my p_trajectory_minimumDuration); - VowelEditor_getF1F2FromXY (me, x, y, & f1, & f2); - Trajectory_addPoint (my trajectory.get(), t, f1, f2, colour); - GuiText_setString (my durationTextField, Melder_double (t)); - if (! my p_soundFollowsMouse) { - Trajectory_addPoint (my trajectory.get(), my p_trajectory_minimumDuration, f1, f2, colour); - goto end; + double duration = Melder_clock () - anchorTime + dt; + if (mouseX != previousX || mouseY != previousY) { + Trajectory_addPoint (my trajectory.get(), duration, f1, f2, colour); + GuiText_setString (my durationTextField, Melder_fixed (duration, 6)); + previousX = mouseX; + previousY = mouseY; } - } - Graphics_xorOn (my graphics.get(), colour); - while (Graphics_mouseStillDown (my graphics.get())) { - double xp = x, yp = y; - t = Melder_clock () - t0 + dt; // Get relative time in seconds from the clock - Graphics_getMouseLocation (my graphics.get(), & x, & y); - clipXY (& x, & y); - /* - If the new point equals the previous one: no tier update - */ - if (xp == x && y == y) { - iskipped ++; - continue; + if (event -> isDrop()) { + if (my trajectory -> points.size == 1) { + /* + Add a point with a slightly modified second formant because successive points should not have equal f1 and f2 values. + */ + Melder_clipLeft (my p_trajectory_minimumDuration, & duration); + GuiText_setString (my durationTextField, Melder_fixed (duration, 6)); + Trajectory_addPoint (my trajectory.get(), duration, f1, 1.00001 * f2, colour); // points have to be different + } + autoSound sound = VowelEditor_createTargetSound (me); + Sound_play (sound.get(), nullptr, nullptr); } - iskipped = 0; - Graphics_line (my graphics.get(), xp, yp, x, y); - - VowelEditor_getF1F2FromXY (me, x, y, & f1, & f2); - Trajectory_addPoint (my trajectory.get(), t, f1, f2, colour); - GuiText_setString (my durationTextField, Melder_double (MICROSECPRECISION (t))); - } - t = Melder_clock () - t0; - /* - If there is only one point in the trajectory this could have two causes: - 1. only one click, too short for mouse-down to catch - 2. a mouse-down with no movement. - Add a point with a slightly modified second formant because successive points should not have equal f1 and f2 values. - */ - if (my trajectory -> points.size == 1) { - Melder_clipLeft (my p_trajectory_minimumDuration, & t); - GuiText_setString (my durationTextField, Melder_double (MICROSECPRECISION (t))); - Trajectory_addPoint (my trajectory.get(), t, f1, 1.00001 * f2, colour); // points have to be different } - Graphics_xorOff (my graphics.get()); - -end: Graphics_unsetInner (my graphics.get()); - - //if (! my shiftKeyPressed) - // my vowel = athee.move(); - //Melder_assert (! athee); - gui_button_cb_play (me, & gb_event); -} - -#if 0 -static void gui_drawingarea_cb_key (VowelEditor /* me */, GuiDrawingArea_KeyEvent /* event */) { + Graphics_updateWs (my graphics.get()); } -#endif static void updateWidgets (void *void_me) { iam (VowelEditor); @@ -1242,7 +1209,7 @@ void structVowelEditor :: v_createHelpMenuItems (EditorMenu menu) { void structVowelEditor :: v_createChildren () { - const int button_width = 90, text_width = 95, status_info_width = 330; + const int button_width = 90, text_width = 95, status_info_width = 400; int top, bottom, bottom_widgets_top, bottom_widgets_bottom, bottom_widgets_halfway; // Three buttons on a row: Play, Reverse, Publish @@ -1257,7 +1224,7 @@ void structVowelEditor :: v_createChildren () right = left + button_width; publishButton = GuiButton_createShown (our windowForm, left, right, top, bottom, U"Publish", gui_button_cb_publish, this, 0); /* - Four Text widgets with the label on top: Duration, Extend, f0, Slope + Four Text widgets with the label on top: Duration, Extend, f0, Slope. Make the f0 slope button 10 wider to accomodate the text We wil not use a callback from a Text widget. It will get called multiple times during the editing of the text. Better to have all editing done and then query the widget for its value! @@ -1317,9 +1284,11 @@ void structVowelEditor :: v_createChildren () gui_drawingarea_cb_expose, gui_drawingarea_cb_click, gui_drawingarea_cb_key, gui_drawingarea_cb_resize, this, 0); */ drawingArea = GuiDrawingArea_createShown (our windowForm, 0, 0, Machine_getMenuBarHeight (), -MARGIN_BOTTOM, - gui_drawingarea_cb_expose, gui_drawingarea_cb_click, nullptr, gui_drawingarea_cb_resize, this, 0); - width = GuiControl_getWidth (drawingArea); - height = GuiControl_getHeight (drawingArea); + gui_drawingarea_cb_expose, gui_drawingarea_cb_mouse, // TODO: mouse-dragged and mouse-up events + nullptr, gui_drawingarea_cb_resize, this, 0 + ); + our width = GuiControl_getWidth (drawingArea); + our height = GuiControl_getHeight (drawingArea); } autoVowelEditor VowelEditor_create (conststring32 title, Daata data) { @@ -1331,7 +1300,7 @@ autoVowelEditor VowelEditor_create (conststring32 title, Daata data) { my p_shell_width = Melder_atof (my default_shell_width ()); my p_shell_height = Melder_atof (my default_shell_height ()); } - Editor_init (me.get(), 0, 0, my p_shell_width, my p_shell_height, title, data); + Editor_init (me.get(), 0, 0, my pref_shell_width(), my pref_shell_height(), title, data); #if motif Melder_assert (XtWindow (my drawingArea -> d_widget)); #endif @@ -1363,8 +1332,8 @@ autoVowelEditor VowelEditor_create (conststring32 title, Daata data) { if (str32len (my p_synthesis_extraFBPairs) == 0) pref_str32cpy (my p_synthesis_extraFBPairs, my default_synthesis_extraFBPairs ()); my extraFrequencyBandwidthPairs = newVECfromString (my p_synthesis_extraFBPairs); - Melder_assert (my extraFrequencyBandwidthPairs.size >= 4); // For deprecated Set F3 & F4 - my p_soundFollowsMouse = true; // No real preference yet + Melder_assert (my extraFrequencyBandwidthPairs.size >= 4); // for deprecated Set F3 & F4 + my p_soundFollowsMouse = true; // no real preference yet if (my p_synthesis_samplingFrequency <= 0.0) my p_synthesis_samplingFrequency = Melder_atof (my default_synthesis_samplingFrequency ()); if (my p_trajectory_minimumDuration <= 0.0) @@ -1384,7 +1353,7 @@ autoVowelEditor VowelEditor_create (conststring32 title, Daata data) { my p_f0_maximum = Melder_atof (my default_f0_maximum ()); } GuiText_setString (my f0SlopeTextField, Melder_double (my p_f0_slope)); - GuiText_setString (my durationTextField, U"0.2"); // Source has been created + GuiText_setString (my durationTextField, U"0.2"); // source has been created GuiText_setString (my extendTextField, Melder_double (my p_trajectory_extendDuration)); if (my p_grid_df1 <= 0) my p_grid_df1 = Melder_atof (my default_grid_df1 ()); @@ -1394,10 +1363,10 @@ autoVowelEditor VowelEditor_create (conststring32 title, Daata data) { /* This exdents because it's a hack: */ - struct structGuiDrawingArea_ResizeEvent event { my drawingArea, 0 }; + /*struct structGuiDrawingArea_ResizeEvent event { my drawingArea, 0 }; event. width = GuiControl_getWidth (my drawingArea); event. height = GuiControl_getHeight (my drawingArea); - gui_drawingarea_cb_resize (me.get(), & event); + gui_drawingarea_cb_resize (me.get(), & event);*/ } updateWidgets (me.get()); trace (U"exit"); diff --git a/dwtools/VowelEditor.h b/dwtools/VowelEditor.h index 273fda65..e842d5db 100644 --- a/dwtools/VowelEditor.h +++ b/dwtools/VowelEditor.h @@ -41,9 +41,8 @@ Thing_define (Trajectory, Function) { #include "VowelEditor_enums.h" Thing_define (VowelEditor, Editor) { - int shiftKeyPressed; autoGraphics graphics; // the drawing - short width, height; // size of drawing area in pixels + int width, height; // size of drawing area in pixels autoTable marks; // Vowel, F1, F2, Colour autoTrajectory trajectory; autoVEC extraFrequencyBandwidthPairs; diff --git a/dwtools/VowelEditor_prefs.h b/dwtools/VowelEditor_prefs.h index 3b0a6c18..82796647 100644 --- a/dwtools/VowelEditor_prefs.h +++ b/dwtools/VowelEditor_prefs.h @@ -19,7 +19,7 @@ prefs_begin (VowelEditor) - prefs_add_int_with_data (VowelEditor, shell_width, 1, U"700") + prefs_add_int_with_data (VowelEditor, shell_width, 1, U"800") prefs_add_int_with_data (VowelEditor, shell_height, 1, U"700") prefs_add_bool_with_data (VowelEditor, soundFollowsMouse, 1, true) prefs_add_enum_with_data (VowelEditor, window_frequencyScale, 1, kVowelEditor_frequencyScale, LOGARITHMIC) diff --git a/dwtools/espeakdata_FileInMemory.cpp b/dwtools/espeakdata_FileInMemory.cpp index 23ff94f4..1d75b2e6 100644 --- a/dwtools/espeakdata_FileInMemory.cpp +++ b/dwtools/espeakdata_FileInMemory.cpp @@ -37,6 +37,7 @@ autoTable espeakdata_voices_propertiesTable; autoStrings espeakdata_voices_names; autoStrings espeakdata_languages_names; +#if 0 static integer Table_getRownumberOfStringInColumn (Table me, conststring32 string, integer icol) { integer row = 0; if (icol > 0 && icol <= my numberOfColumns) { @@ -49,7 +50,7 @@ static integer Table_getRownumberOfStringInColumn (Table me, conststring32 strin } return row; } - +#endif void espeakdata_praat_init () { try { espeak_ng_FileInMemoryManager = create_espeak_ng_FileInMemoryManager (); diff --git a/dwtools/manual_KlattGrid.cpp b/dwtools/manual_KlattGrid.cpp index 6abc4b29..b62b5838 100644 --- a/dwtools/manual_KlattGrid.cpp +++ b/dwtools/manual_KlattGrid.cpp @@ -76,7 +76,7 @@ DEFINITION (U"model resonances in the nasal tract. Because the form of the nasal TAG (U"##Nasal antiformants") DEFINITION (U"model dips in the spectrum caused by leakage to the nasal tract.") ENTRY (U"Interaction between source and filter") -NORMAL (U"The interaction between source and filter is modeled by two formant grids.") +NORMAL (U"The interaction between source and filter is modelled by two formant grids.") TAG (U"##Tracheal formants") DEFINITION (U"model one aspect of the coupling of the trachea with the vocal tract transfer function, namely, by the " "introduction of extra formants (and antiformants) that sometimes distort vowel spectra to a varying degrees. " @@ -89,7 +89,7 @@ DEFINITION (U"The values in this grid model the number of hertz that the oral fo "source waveform, a non-linear interaction between the first formant and the fundamental frequency, a truncation of " "the first formant and tracheal formants and antiformants. ") ENTRY (U"The frication section") -NORMAL (U"The frication section is modeled with a frication formant grid, with formant frequencies, bandwidths and (separate) " +NORMAL (U"The frication section is modelled with a frication formant grid, with formant frequencies, bandwidths and (separate) " "amplitudes (dB), a frication by-pass tier (dB) and an amplitude tier (dB SPL) that governs the frication noise source.") ENTRY (U"A minimal synthesizer") NORMAL (U"The following script produces a minimal voiced sound. The first line creates the standard KlattGrid." diff --git a/dwtools/manual_dwtools.cpp b/dwtools/manual_dwtools.cpp index 570a6c7d..3c46b576 100644 --- a/dwtools/manual_dwtools.cpp +++ b/dwtools/manual_dwtools.cpp @@ -25,6 +25,7 @@ #include "ManPagesM.h" #include "Sound_extensions.h" #include "TableOfReal_extensions.h" +#include "TableOfReal_and_Discriminant.h" #include "Table_extensions.h" #include "Configuration.h" #include "Discriminant.h" @@ -1346,7 +1347,7 @@ DEFINITION (U"the initial phase of the cosine wave.") TAG (U"##Addition factor# (standard value: 0)") DEFINITION (U"determines the degree of asymmetry in the spectrum of the gammatone. " "The zero default value gives a gammatone. A value unequal to zero results in a " - "so called %gammachirp. A negative value is used in auditory filter modeling to " + "so called %gammachirp. A negative value is used in auditory filter modelling to " "guarantee the usual direction of filter asymmetry, which corresponds to an upward " "glide in instantaneous frequency.") TAG (U"##Scale amplitudes") @@ -2533,7 +2534,7 @@ NORMAL (U"The gammatone function has a monotone carrier (the tone) with an " "envelope that is a gamma distribution function. The amplitude spectrum is essentially " "symmetric on a linear frequency scale. This function is used in some time-domain " "auditory models to simulate the spectral analysis performed by the basilar membrane. " - "It was popularized in auditory modeling by @@Johannesma (1972)@. @@Flanagan (1960)@ " + "It was popularized in auditory modelling by @@Johannesma (1972)@. @@Flanagan (1960)@ " "already used it to model basilar membrane motion.") MAN_END @@ -4054,7 +4055,7 @@ DEFINITION (U"denoising takes place in (overlapping) windows of this length.") TAG (U"##Filter frequency range (Hz)") DEFINITION (U"before denoising the sound will be @@Sound: Filter (pass Hann band)...|band-pass filtered@. ") TAG (U"##Noise reduction method") -DEFINITION (U"The method of %%spectral subtraction% was defined in @@Boll (1979)@. The variant implemented is modeled " +DEFINITION (U"The method of %%spectral subtraction% was defined in @@Boll (1979)@. The variant implemented is modelled " "after a script by Ton Wempe.") MAN_END @@ -4924,7 +4925,7 @@ SCRIPT (5,3, U"pb = Create formant table (Peterson & Barney 1952)\n" ) MAN_END -MAN_BEGIN (U"Table: Line graph where...", U"djmw", 20170829) +MAN_BEGIN (U"Table: Line graph where...", U"djmw", 20200629) INTRO (U"Draws a line graph from the data in a column of the selected @Table. In a line plot the horizontal axis can have a nominal scale or a numeric scale. The data point are connected by line segments.") ENTRY (U"Settings") SCRIPT (7, Manual_SETTINGS_WINDOW_HEIGHT (8), U"" @@ -4967,47 +4968,47 @@ CODE (U" 7.5 0.12 0.02") CODE (U" 17.5 0.10 0.02") NORMAL (U"We can reproduce fig. 3 from Ganong (1980) with the following script, where we labeled the word - nonword curve with \"wn\" and the nonword - word curve with \"nw\". We deselect \"Garnish\" because we want to put special marks at the bottom.") CODE (U"Dotted line\n") -CODE (U"Line graph where: \"dash-tash\", 0, 1, \"VOT\", -20, 20, \"wn\", 0, 0, \"1\"") +CODE (U"Line graph where: \"dash-tash\", 0, 1, \"VOT\", -20, 20, \"wn\", 0, \"no\", \"1\"") CODE (U"Dashed line\n") -CODE (U"Line graph where: \"dask-task\", 0, 1, \"VOT\", -20, 20, \"nw\", 0, 0, \"1\"") +CODE (U"Line graph where: \"dask-task\", 0, 1, \"VOT\", -20, 20, \"nw\", 0, \"no\", \"1\"") CODE (U"Draw inner box") -CODE (U"One mark bottom: 2.5, 0, 1, 0, \"+2.5\"") -CODE (U"One mark bottom: -2.5, 1, 1, 0, \"\"") -CODE (U"One mark bottom: -7.5,1, 1, 0, \"\"") -CODE (U"One mark bottom: 7.5, 0, 1, 0, \"+7.5\"") -CODE (U"One mark bottom: 2.5, 0, 0, 0, \"+2.5\"") -CODE (U"One mark bottom: -20, 0, 0, 0, \"Short VOT\"") -CODE (U"One mark bottom: 20, 0, 0, 0, \"Long VOT\"") +CODE (U"One mark bottom: 2.5, \"no\", \"yes\", \"no\", \"+2.5\"") +CODE (U"One mark bottom: -2.5, \"yes\", \"yes\", \"no\", \"\"") +CODE (U"One mark bottom: -7.5, \"yes\", \"yes\", \"no\", \"\"") +CODE (U"One mark bottom: 7.5, \"no\", \"yes\", \"no\", \"+7.5\"") +CODE (U"One mark bottom: 2.5, \"no\", \"no\", \"no\", \"+2.5\"") +CODE (U"One mark bottom: -20, \"no\", \"no\", \"no\", \"Short VOT\"") +CODE (U"One mark bottom: 20, \"no\", \"no\", \"no\", \"Long VOT\"") CODE (U"Text bottom: 1, \"VOT (ms)\"") -CODE (U"Marks left every: 1, 0.2, 1, 1, 0") +CODE (U"Marks left every: 1, 0.2, \"yes\", \"yes\", \"no\"") CODE (U"Text left: 1, \"Prop. of voiced responses\"") SCRIPT (5,3, U"ganong = Create Table (Ganong 1980)\n" "Dotted line\n" - "Line graph where: \"dash-tash\", 0, 1, \"VOT\", -20, 20, \"wn\", 0, 0, ~1\n" + "Line graph where: \"dash-tash\", 0, 1, \"VOT\", -20, 20, \"wn\", 0, \"no\", ~1\n" "Dashed line\n" - "Line graph where: \"dask-task\", 0, 1, \"VOT\", -20, 20, \"nw\", 0, 0, ~1\n" + "Line graph where: \"dask-task\", 0, 1, \"VOT\", -20, 20, \"nw\", 0, \"no\", ~1\n" "Draw inner box\n" - "One mark bottom: 2.5, 0, 1, 0, \"+2.5\"\n" - "One mark bottom: -2.5, 1, 1, 0, \"\"\n" - "One mark bottom: -7.5,1, 1, 0, \"\"\n" - "One mark bottom: 7.5, 0, 1, 0, \"+7.5\"\n" - "One mark bottom: 2.5, 0, 0, 0, \"+2.5\"\n" - "One mark bottom: -20, 0, 0, 0, \"Short VOT\"\n" - "One mark bottom: 20, 0, 0, 0, \"Long VOT\"\n" + "One mark bottom: 2.5, 0, \"yes\", \"no\", \"+2.5\"\n" + "One mark bottom: -2.5, \"yes\", \"yes\", \"no\", \"\"\n" + "One mark bottom: -7.5, \"yes\", \"yes\", \"no\", \"\"\n" + "One mark bottom: 7.5, \"no\", \"yes\", \"no\", \"+7.5\"\n" + "One mark bottom: 2.5, \"no\", \"no\", \"no\", \"+2.5\"\n" + "One mark bottom: -20, \"no\", \"no\", \"no\", \"Short VOT\"\n" + "One mark bottom: 20, \"no\", \"no\", \"no\", \"Long VOT\"\n" "Text bottom: 1, \"VOT (ms)\"\n" - "Marks left every: 1, 0.2, 1, 1, 0\n" + "Marks left every: 1, 0.2, \"yes\", \"yes\", \"no\"\n" "Text left: 1, \"Prop. of voiced responses\"\n" "removeObject: ganong\n" ) NORMAL (U"As an example of what happens if you don't supply an argument for the \"Horizontal column\" we will use the same table as for the previous plot. However the resulting plot may not be as meaningful (note that the horizontal nominal scale makes all points equidistant in the horizontal direction.)") -CODE (U"Dotted line\")\n") -CODE (U"Line graph where: \"dash-tash\", 0, 1, \"\", 0, 0, \"wn\", 0, 1, ~ 1") -CODE (U"One mark bottom: 1, 0, 1, 0, \"Short VOT\"") +CODE (U"Dotted line\n") +CODE (U"Line graph where: \"dash-tash\", 0, 1, \"\", 0, 0, \"wn\", 0, \"yes\", ~ 1") +CODE (U"One mark bottom: 1, \"no\", \"yes\", \"no\", \"Short VOT\"") SCRIPT (5,3, U"ganong = Create Table (Ganong 1980)\n" "Dotted line\n" - "Line graph where: \"dash-tash\", 0, 1, \"\", 0, 0, \"wn\", 0, 1, ~1\n" - "One mark bottom: 1, 0, 1, 0, \"Short VOT\"\n" + "Line graph where: \"dash-tash\", 0, 1, \"\", 0, 0, \"wn\", 0, \"yes\", ~1\n" + "One mark bottom: 1, \"no\", \"yes\", \"no\", \"Short VOT\"\n" "removeObject: ganong\n" ) MAN_END diff --git a/dwtools/praat_BSS_init.cpp b/dwtools/praat_BSS_init.cpp index 47b88f24..b19913d1 100644 --- a/dwtools/praat_BSS_init.cpp +++ b/dwtools/praat_BSS_init.cpp @@ -76,9 +76,9 @@ FORM (NEW_EEG_to_EEG_bss, U"EEG: To EEG (bss)", U"EEG: To EEG (bss)...") { LABEL (U"To supply rising or falling ranges, use e.g. 2:6 or 5:3.") LABEL (U"Pre-whitening parameters") OPTIONMENUx (whiteningMethod, U"Whitening method", 1, 0) - OPTION (U"No whitening") - OPTION (U"Covariance") - OPTION (U"Correlation") + OPTION (U"no whitening") + OPTION (U"covariance") + OPTION (U"correlation") LABEL (U"Iteration parameters") NATURAL (maximumNumberOfIterations, U"Maximum number of iterations", U"100") POSITIVE (tolerance, U"Tolerance", U"0.001") diff --git a/dwtools/praat_DataModeler_init.cpp b/dwtools/praat_DataModeler_init.cpp index 80b5eed5..26f1f169 100644 --- a/dwtools/praat_DataModeler_init.cpp +++ b/dwtools/praat_DataModeler_init.cpp @@ -1,6 +1,6 @@ /* praat_DataModeler_init.cpp * - * Copyright (C) 2014-2017 David Weenink + * Copyright (C) 2014-2020 David Weenink * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -23,6 +23,7 @@ #include "OptimalCeilingTierEditor.h" #include "Pitch.h" #include "Table_extensions.h" +#include "TextGrid.h" #undef iam #define iam iam_LOOP @@ -50,14 +51,13 @@ FORM (GRAPHICS_DataModeler_speckle, U"DataModeler: Speckle", nullptr) { REAL (ymin, U"left Y range", U"0.0") REAL (ymax, U"right Y range", U"0.0") BOOLEAN (errorBars, U"Draw error bars", 1) - REAL (barWidth_mm, U"Bar width (mm)", U"1.0") - REAL (xOffset_mm, U"Horizontal offset (mm)", U"0.0") + REAL (barWidth_wc, U"Bar width (wc)", U"1.0") BOOLEAN (garnish, U"Garnish", true) OK DO integer order = 6; GRAPHICS_EACH (DataModeler) - DataModeler_speckle (me, GRAPHICS, xmin, xmax,ymin, ymax, 0, order + 1, errorBars, barWidth_mm, xOffset_mm, garnish); + DataModeler_speckle (me, GRAPHICS, xmin, xmax,ymin, ymax, 0, order + 1, errorBars, barWidth_wc, garnish); GRAPHICS_EACH_END } @@ -68,13 +68,12 @@ FORM (GRAPHICS_DataModeler_drawEstimatedTrack, U"DataModeler: Draw estimated tra REAL (ymin, U"left Y range", U"0.0") REAL (ymax, U"right Y range", U"0.0") INTEGER (order, U"Order of polynomials for estimation", U"3") - REAL (xOffset, U"Horizontal offset (mm)", U"0.0") BOOLEAN (garnish, U"Garnish", true) OK DO Melder_require (order >= 0, U"The order should be at least zero."); GRAPHICS_EACH (DataModeler) - DataModeler_drawTrack (me, GRAPHICS, xmin, xmax, ymin, ymax, 1, order + 1, xOffset, garnish); + DataModeler_drawTrack (me, GRAPHICS, xmin, xmax, ymin, ymax, 1, order + 1, garnish); GRAPHICS_EACH_END } @@ -120,8 +119,8 @@ DO } FORM (REAL_DataModeler_getVarianceOfParameters, U"DataModeler: Get variance of parameters", nullptr) { - INTEGER (fromParameter, U"left Parameter range", U"0") - INTEGER (toParameter, U"right Parameter range", U"0") + NATURAL (fromParameter, U"left Parameter range", U"1") + INTEGER (toParameter, U"right Parameter range", U"0 (=all)") OK DO integer nofp; @@ -276,8 +275,8 @@ DO FORM (MODIFY_DataModeler_setDataPointStatus, U"DataModeler: Set data point status", nullptr) { NATURAL (index, U"Index", U"1") OPTIONMENU (dataStatus, U"Status", 1) - OPTION (U"Valid") - OPTION (U"Invalid") + OPTION (U"valid") + OPTION (U"invalid") OK DO kDataModelerData status = dataStatus == 2 ? kDataModelerData::INVALID : kDataModelerData::VALID; @@ -438,13 +437,12 @@ FORM (GRAPHICS_FormantModeler_drawEstimatedTracks, U"FormantModeler: Draw estima NATURAL (fromFormant, U"left Formant range", U"1") NATURAL (toFormant, U"right Formant range", U"3") INTEGER (order, U"Order of polynomials for estimation", U"3") - REAL (xOffset_mm, U"Horizontal offset (mm)", U"0.0") BOOLEAN (garnish, U"Garnish", true) OK DO Melder_require (order >= 0, U"The order should be at least zero."); GRAPHICS_EACH (FormantModeler) - FormantModeler_drawTracks (me, GRAPHICS, fromTime, toTime, maximumFrequency, fromFormant, toFormant, 1, order + 1, xOffset_mm, garnish); + FormantModeler_drawTracks (me, GRAPHICS, fromTime, toTime, maximumFrequency, fromFormant, toFormant, true, order + 1, Melder_BLACK, Melder_BLACK, garnish); GRAPHICS_EACH_END } @@ -454,13 +452,12 @@ FORM (GRAPHICS_FormantModeler_drawTracks, U"FormantModeler: Draw tracks", nullpt REAL (maximumFrequency, U"Maximum frequency (Hz)", U"5500.0") NATURAL (fromFormant, U"left Formant range", U"1") NATURAL (toFormant, U"right Formant range", U"3") - REAL (xOffset_mm, U"Horizontal offset (mm)", U"0.0") BOOLEAN (garnish, U"Garnish", true) OK DO integer order = 6; GRAPHICS_EACH (FormantModeler) - FormantModeler_drawTracks (me, GRAPHICS, fromTime, toTime, maximumFrequency, fromFormant, toFormant, 0, order + 1, xOffset_mm, garnish); + FormantModeler_drawTracks (me, GRAPHICS, fromTime, toTime, maximumFrequency, fromFormant, toFormant, false, order + 1, Melder_BLACK, Melder_BLACK, garnish); GRAPHICS_EACH_END } @@ -471,14 +468,12 @@ FORM (GRAPHICS_FormantModeler_speckle, U"FormantModeler: Speckle", nullptr) { NATURAL (fromFormant, U"left Formant range", U"1") NATURAL (toFormant, U"right Formant range", U"3") BOOLEAN (errorBars, U"Draw error bars", true) - REAL (barWidth_mm, U"Bar width (mm)", U"1.0") - REAL (xOffset_mm, U"Horizontal offset (mm)", U"0.0") BOOLEAN (garnish, U"Garnish", true) OK DO integer order = 6; GRAPHICS_EACH (FormantModeler) - FormantModeler_speckle (me, GRAPHICS, fromTime, toTime, maximumFrequency, fromFormant, toFormant, 0, order + 1, errorBars, barWidth_mm, xOffset_mm, garnish); + FormantModeler_speckle (me, GRAPHICS, fromTime, toTime, maximumFrequency, fromFormant, toFormant, 0, order + 1, errorBars, Melder_BLACK, Melder_BLACK, garnish); GRAPHICS_EACH_END } @@ -491,12 +486,11 @@ FORM (GRAPHICS_FormantModeler_drawOutliersMarked, U"FormantModeler: Draw outlier POSITIVE (numberOfSigmas, U"Number of sigmas", U"3.0") WORD (mark_string, U"Mark", U"o") POSITIVE (fontSize, U"Mark font size", U"12") - REAL (xOffset_mm, U"Horizontal offset (mm)", U"0.0") BOOLEAN (garnish, U"Garnish", false) OK DO GRAPHICS_EACH (FormantModeler) - FormantModeler_drawOutliersMarked (me, GRAPHICS, fromTime, toTime, maximumFrequency, fromFormant, toFormant, numberOfSigmas, mark_string, fontSize, xOffset_mm, garnish); + FormantModeler_drawOutliersMarked (me, GRAPHICS, fromTime, toTime, maximumFrequency, fromFormant, toFormant, numberOfSigmas, mark_string, fontSize, Melder_BLACK, Melder_BLACK, garnish); GRAPHICS_EACH_END } @@ -740,7 +734,7 @@ DO NUMBER_ONE_END (U" (= degrees of freedom of F", formantNumber, U")") } -FORM (REAL_FormantModeler_getSmoothnessValue, U"FormantModeler: Get smoothness value", nullptr) { +FORM (REAL_FormantModeler_getStress, U"FormantModeler: Get stress", nullptr) { INTEGER (fromFormant, U"left Formant range", U"0") INTEGER (toFormant, U"right Formant range", U"0") INTEGER (order, U"Order of polynomials", U"3") @@ -748,16 +742,16 @@ FORM (REAL_FormantModeler_getSmoothnessValue, U"FormantModeler: Get smoothness v OK DO NUMBER_ONE (FormantModeler) - double result = FormantModeler_getSmoothnessValue (me, fromFormant, toFormant, order, power); - NUMBER_ONE_END (U" (= smoothness)") + double result = FormantModeler_getStress (me, fromFormant, toFormant, order, power); + NUMBER_ONE_END (U" (= roughness)") } FORM (REAL_FormantModeler_getAverageDistanceBetweenTracks, U"FormantModeler: Get average distance between tracks", nullptr) { NATURAL (track1, U"Track 1", U"2") NATURAL (track2, U"Track 2", U"3") OPTIONMENU (typeOfData, U"Type of data", 1) - OPTION (U"Data points") - OPTION (U"Modeled") + OPTION (U"data points") + OPTION (U"modelled") OK DO NUMBER_ONE (FormantModeler) @@ -1089,7 +1083,7 @@ DO void praat_DataModeler_init (); void praat_DataModeler_init () { Thing_recognizeClassesByName (classDataModeler, classFormantModeler, classOptimalCeilingTier, classOptimalCeilingTierEditor, nullptr); - + praat_addMenuCommand (U"Objects", U"New", U"Create simple DataModeler...", U"Create ISpline...", praat_HIDDEN + praat_DEPTH_1, NEW1_DataModeler_createSimple); praat_addAction1 (classDataModeler, 0, U"Speckle...", 0, 0, GRAPHICS_DataModeler_speckle); @@ -1173,7 +1167,7 @@ void praat_DataModeler_init () { praat_addAction1 (classFormantModeler, 0, U"Get coefficient of determination...", 0, 1, REAL_FormantModeler_getCoefficientOfDetermination); praat_addAction1 (classFormantModeler, 0, U"Report chi squared", 0, 1, INFO_FormantModeler_reportChiSquared); praat_addAction1 (classFormantModeler, 0, U"Get degrees of freedom...", 0, 1, REAL_FormantModeler_getDegreesOfFreedom); - praat_addAction1 (classFormantModeler, 0, U"Get smoothness value...", 0, 1, REAL_FormantModeler_getSmoothnessValue); + praat_addAction1 (classFormantModeler, 0, U"Get stress...", 0, 1, REAL_FormantModeler_getStress); praat_addAction1 (classFormantModeler, 0, U"Get average distance between tracks...", 0, 1, REAL_FormantModeler_getAverageDistanceBetweenTracks); praat_addAction1 (classFormantModeler, 0, U"Get formants constraints factor...", 0, 1, REAL_FormantModeler_getFormantsConstraintsFactor); diff --git a/dwtools/praat_David_init.cpp b/dwtools/praat_David_init.cpp index fdcc41b5..8cc4976f 100644 --- a/dwtools/praat_David_init.cpp +++ b/dwtools/praat_David_init.cpp @@ -76,6 +76,7 @@ #include "ComplexSpectrogram.h" #include "Confusion.h" #include "Covariance.h" +#include "DataModeler.h" #include "Discriminant.h" #include "EditDistanceTable.h" #include "Editor.h" @@ -91,10 +92,10 @@ #include "FilterBank.h" #include "Formula.h" #include "FormantGridEditor.h" -#include "DataModeler.h" #include "FormantGrid_extensions.h" #include "Intensity_extensions.h" #include "IntensityTierEditor.h" +#include "IntervalTierNavigator.h" #include "Matrix_Categories.h" #include "Matrix_extensions.h" #include "LongSound_extensions.h" @@ -103,6 +104,7 @@ #include "LegendreSeries.h" #include "Ltas_extensions.h" #include "Minimizers.h" +#include "NavigationContext.h" #include "PatternList.h" #include "PCA.h" #include "PitchTierEditor.h" @@ -119,8 +121,10 @@ #include "Strings_extensions.h" #include "SVD.h" #include "Table_extensions.h" +#include "TableOfReal_and_Discriminant.h" #include "TableOfReal_and_Permutation.h" #include "TextGrid_extensions.h" +#include "TextGridNavigator.h" #include "Categories_and_Strings.h" #include "CCA_and_Correlation.h" @@ -624,7 +628,7 @@ DO CONVERT_TWO_END (your name.get(), U"_", my name.get()) } -FORM (NEW_CCA_extractEigen, U"CCA: Exxtract Eigen", nullptr) { +FORM (NEW_CCA_extractEigen, U"CCA: Extract Eigen", nullptr) { OPTIONMENU (choice, U"variablesType", 1) OPTION (U"Dependent") OPTION (U"Independent") @@ -786,7 +790,7 @@ FORM (NEW_Confusion_condense, U"Confusion: Condense", U"Confusion: Condense...") SENTENCE (replace_string, U"Replace", U"high") INTEGER (replaceLimit, U"Replace limit", U"0 (= unlimited)") RADIOx (matchType, U"Search and replace are", 2, 0) - RADIOBUTTON (U"Literals") + RADIOBUTTON (U"literals") RADIOBUTTON (U"Regular Expressions") OK DO @@ -1218,6 +1222,16 @@ DO CONVERT_TWO_END (U"mahalanobis") } +FORM (NEW1_Discriminant_TableOfReal_mahalanobis_all, U"Discriminant & TableOfReal: Mahalanobis all", nullptr) { + BOOLEAN (poolCovariances, U"Pool covariance matrices", false) + OK +DO + CONVERT_TWO (Discriminant, TableOfReal) + autoTableOfReal result = Discriminant_TableOfReal_mahalanobis_all (me, you, poolCovariances); + CONVERT_TWO_END (U"mahalanobis") + +} + DIRECT (INTEGER_Discriminant_getNumberOfEigenvalues) { INTEGER_ONE (Discriminant) integer result = my eigen -> numberOfEigenvalues; @@ -1826,7 +1840,7 @@ FORM (INTEGER_DTW_getMaximumConsecutiveSteps, U"DTW: Get maximum consecutive ste OPTIONMENU (direction, U"Direction", 1) OPTION (U"X") OPTION (U"Y") - OPTION (U"Diagonaal") + OPTION (U"Diagonal") OK DO int direction_code [] = { DTW_START, DTW_X, DTW_Y, DTW_XANDY }; @@ -2110,10 +2124,10 @@ DO FORM (REAL_EditCostsTable_getCosts_others, U"EditCostsTable: Get cost (others)", nullptr) { RADIO (costTypes, U"Others cost type", 1) - RADIOBUTTON (U"Insertion") - RADIOBUTTON (U"Deletion") - RADIOBUTTON (U"Equality") - RADIOBUTTON (U"Inequality") + RADIOBUTTON (U"insertion") + RADIOBUTTON (U"deletion") + RADIOBUTTON (U"equality") + RADIOBUTTON (U"inequality") OK DO NUMBER_ONE (EditCostsTable) @@ -3279,23 +3293,23 @@ DIRECT (NEW1_KlattTable_createExample) { FORM (NEW_KlattTable_to_Sound, U"KlattTable: To Sound", U"KlattTable: To Sound...") { POSITIVE (samplingFrequency, U"Sampling frequency (Hz)", U"16000") RADIO (synthesisModel, U"Synthesis model", 1) - RADIOBUTTON (U"Cascade") - RADIOBUTTON (U"Parallel") + RADIOBUTTON (U"cascade") + RADIOBUTTON (U"parallel") NATURAL (numberOfFormants, U"Number of formants", U"5") POSITIVE (frameDuration, U"Frame duration (s)", U"0.005") REAL (flutter_percentage, U"Flutter percentage (%)", U"0.0") // ppgb: foutgevoelig OPTIONMENU (voicingSource, U"Voicing source", 1) - OPTION (U"Impulsive") - OPTION (U"Natural") + OPTION (U"impulsive") + OPTION (U"natural") OPTIONMENU (soundOutputType, U"Output type", 1) - OPTION (U"Sound") - OPTION (U"Voicing") - OPTION (U"Aspiration") - OPTION (U"Frication") - OPTION (U"Cascade-glottal-output") - OPTION (U"Parallel-glottal-output") - OPTION (U"Bypass-output") - OPTION (U"All-excitations") + OPTION (U"sound") + OPTION (U"voicing") + OPTION (U"aspiration") + OPTION (U"frication") + OPTION (U"cascade-glottal-output") + OPTION (U"parallel-glottal-output") + OPTION (U"bypass-output") + OPTION (U"all-excitations") OK DO if (flutter_percentage < 0.0 || flutter_percentage > 100.0) { @@ -3647,9 +3661,9 @@ DIRECT (COMPVEC_Matrix_listEigenvalues) { FORM (MODIFY_Matrix_scale, U"Matrix: Scale", nullptr) { LABEL (U"self[row, col] := self[row, col] / `Scale factor'") RADIO (scaleMethod, U"Scale factor", 1) - RADIOBUTTON (U"Extremum in matrix") - RADIOBUTTON (U"Extremum in each row") - RADIOBUTTON (U"Extremum in each column") + RADIOBUTTON (U"extremum in matrix") + RADIOBUTTON (U"extremum in each row") + RADIOBUTTON (U"extremum in each column") OK DO MODIFY_EACH (Matrix) @@ -4022,7 +4036,7 @@ FORM (GRAPHICS_MelFilter_drawFilterFunctions, U"MelFilter: Draw filter functions RADIO (frequencyScale, U"Frequency scale", 1) RADIOBUTTON (U"Hertz") RADIOBUTTON (U"Bark") - RADIOBUTTON (U"Mel") + RADIOBUTTON (U"mel") REAL (fromFrequency, U"left Frequency range", U"0.0") REAL (toFrequency, U"right Frequency range", U"0.0") BOOLEAN (dBScale, U"Amplitude scale in dB", false) @@ -4040,7 +4054,7 @@ FORM (GRAPHICS_MelSpectrogram_drawTriangularFilterFunctions, U"MelSpectrogram: D INTEGER (fromFilter, U"left Filter range", U"0") INTEGER (toFilter, U"right Filter range", U"0") RADIO (frequencyScale, U"Frequency scale", 1) - RADIOBUTTON (U"Mel") + RADIOBUTTON (U"mel") RADIOBUTTON (U"Hertz") REAL (fromFrequency, U"left Frequency range", U"0.0") REAL (toFrequency, U"right Frequency range", U"0.0") @@ -4136,11 +4150,11 @@ FORM (INFO_Ltas_reportSpectralTrend, U"Ltas: Report spectral trend", nullptr) { POSITIVE (fromFrequency, U"left Frequency range (Hz)", U"100.0") POSITIVE (toFrequency, U"right Frequency range (Hz)", U"5000.0") OPTIONMENU (frequencyScale, U"Frequency scale", 1) - OPTION (U"Linear") - OPTION (U"Logarithmic") + OPTION (U"linear") + OPTION (U"logarithmic") OPTIONMENU (fitMethod, U"Fit method", 2) - OPTION (U"Least squares") - OPTION (U"Robust") + OPTION (U"least squares") + OPTION (U"robust") OK DO bool logScale = frequencyScale == 2; @@ -4257,6 +4271,53 @@ DIRECT (HELP_MSpline_help) { HELP (U"MSpline") } + +FORM (MODIFY_NavigationContext_modifyContextCombination, U"NavigationContext: Modify context combination", nullptr) { + OPTIONMENU_ENUM (kContext_combination, combinationCriterion, U"How to combine the contexts", kContext_combination::DEFAULT) + BOOLEAN (contextOnly, U"Use context only", false) + OK +DO + MODIFY_EACH (NavigationContext) + NavigationContext_modifyContextCombination (me, combinationCriterion, contextOnly); + MODIFY_EACH_END +} + +FORM (MODIFY_NavigationContext_modifyNavigationLabels, U"NavigationContext: Modify navigation labels", nullptr) { + OPTIONMENU_ENUM (kMelder_string, navigationCriterion, U"Navigation criterion", kMelder_string::DEFAULT) + OK +DO + MODIFY_FIRST_OF_TWO (NavigationContext, Strings) + NavigationContext_modifyNavigationLabels (me, you, navigationCriterion); + MODIFY_FIRST_OF_TWO_END +} + +FORM (MODIFY_NavigationContext_modifyLeftContextLabels, U"NavigationContext: Modify left context labels", nullptr) { + OPTIONMENU_ENUM (kMelder_string, leftContextCriterion, U"Left context criterion", kMelder_string::DEFAULT) + OK +DO + MODIFY_FIRST_OF_TWO (NavigationContext, Strings) + NavigationContext_modifyLeftContextLabels (me, you, leftContextCriterion); + MODIFY_FIRST_OF_TWO_END +} + +FORM (MODIFY_NavigationContext_modifyRightContextLabels, U"NavigationContext: modify right context labels", nullptr) { + OPTIONMENU_ENUM (kMelder_string, rightContextCriterion, U"Right context criterion", kMelder_string::DEFAULT) + OK +DO + MODIFY_FIRST_OF_TWO (NavigationContext, Strings) + NavigationContext_modifyRightContextLabels (me, you, rightContextCriterion); + MODIFY_FIRST_OF_TWO_END +} + +FORM (NEW_TextGrid_and_NavigationContext_to_TextGridNavigator, U"TextGrid & NavigationContext: To TextGridNavigator", nullptr) { + NATURAL (tierNumber, U"Tier number", U"1") + OK +DO + CONVERT_TWO (TextGrid, NavigationContext) + autoTextGridNavigator result = TextGridNavigator_create (me, you, tierNumber); + CONVERT_TWO_END (U"tgn", tierNumber) +} + DIRECT (HELP_NMF_help) { HELP (U"NMF") } @@ -5485,10 +5546,10 @@ FORM (GRAPHICS_Sound_drawWhere, U"Sound: Draw where", U"Sound: Draw where...") { BOOLEAN (garnish, U"Garnish", true) LABEL (U"") OPTIONMENUSTR (drawingMethod, U"Drawing method", 1) - OPTION (U"Curve") - OPTION (U"Bars") - OPTION (U"Poles") - OPTION (U"Speckles") + OPTION (U"curve") + OPTION (U"bars") + OPTION (U"poles") + OPTION (U"speckles") TEXTFIELD (formula, U"Draw only those parts where the following condition holds:", U"x < xmin + (xmax - xmin) / 2; first half") OK DO @@ -5738,7 +5799,7 @@ FORM (MODIFY_Sound_fadeIn, U"Sound: Fade in", U"Sound: Fade in...") { OK DO MODIFY_EACH (Sound) - Sound_fade (me, channel, time, fadeTime, -1.0, silentFromStart); + Sound_fade (me, channel, time, fadeTime, false, silentFromStart); MODIFY_EACH_END } @@ -5750,7 +5811,7 @@ FORM (MODIFY_Sound_fadeOut, U"Sound: Fade out", U"Sound: Fade out...") { OK DO MODIFY_EACH (Sound) - Sound_fade (me, channel, time, fadeTime, 1, silentToEnd); + Sound_fade (me, channel, time, fadeTime, true, silentToEnd); MODIFY_EACH_END } @@ -5758,7 +5819,7 @@ FORM (NEW_Sound_to_KlattGrid_simple, U"Sound: To KlattGrid (simple)", U"Sound: T POSITIVE (timeStep, U"Time step (s)", U"0.005") LABEL (U"Formant determination") NATURAL (numberOfFormants, U"Max. number of formants", U"5") - POSITIVE (maximumFormant, U"Maximum formant (Hz)", U"5500 (= adult female)") + POSITIVE (formantCeiling, U"Formant ceiling (Hz)", U"5500 (= adult female)") POSITIVE (windowLength, U"Window length (s)", U"0.025") POSITIVE (preEmphasisFrequency, U"Pre-emphasis from (Hz)", U"50.0") LABEL (U"Pitch determination") @@ -5770,7 +5831,7 @@ FORM (NEW_Sound_to_KlattGrid_simple, U"Sound: To KlattGrid (simple)", U"Sound: T OK DO CONVERT_EACH (Sound) - autoKlattGrid result = Sound_to_KlattGrid_simple (me, timeStep, numberOfFormants, maximumFormant, windowLength, preEmphasisFrequency, pitchFloor, pitchCeiling, minimumPitch, subtractMean); + autoKlattGrid result = Sound_to_KlattGrid_simple (me, timeStep, numberOfFormants, formantCeiling, windowLength, preEmphasisFrequency, pitchFloor, pitchCeiling, minimumPitch, subtractMean); CONVERT_EACH_END (my name.get()) } @@ -6035,8 +6096,8 @@ FORM (NEW_Spectrum_compressFrequencyDomain, U"Spectrum: Compress frequency domai POSITIVE (maximumFrequency, U"Maximum frequency (Hz)", U"5000.0") INTEGER (interpolationDepth, U"Interpolation depth", U"50") RADIO (scale, U"Interpolation scale", 1) - RADIOBUTTON (U"Linear") - RADIOBUTTON (U"Logarithmic") + RADIOBUTTON (U"linear") + RADIOBUTTON (U"logarithmic") OK DO CONVERT_EACH (Spectrum) @@ -6070,8 +6131,8 @@ DIRECT (HELP_SpeechSynthesizer_help) { FORM (NEW1_ExtractEspeakData, U"SpeechSynthesizer: Extract espeak data", nullptr) { OPTIONMENU (which, U"Data", 1) - OPTION (U"Language properties") - OPTION (U"Voices properties") + OPTION (U"language properties") + OPTION (U"voices properties") OK DO CREATE_ONE @@ -6176,9 +6237,9 @@ DIRECT (INFO_SpeechSynthesizer_getPhonemeSetName) { FORM (MODIFY_SpeechSynthesizer_setTextInputSettings, U"SpeechSynthesizer: Set text input settings", U"SpeechSynthesizer: Set text input settings...") { OPTIONMENU (inputTextFormat, U"Input text format is", 1) - OPTION (U"Text only") - OPTION (U"Phoneme codes only") - OPTION (U"Mixed with tags") + OPTION (U"text only") + OPTION (U"phoneme codes only") + OPTION (U"mixed with tags") OPTIONMENU (inputPhonemeCoding, U"Input phoneme codes are", 1) OPTION (U"Kirshenbaum_espeak") OK @@ -6483,6 +6544,26 @@ DO CREATE_ONE_END (U"chars") } +FORM (NEW1_Create_NavigationContext, U"Create NavigationContext", nullptr) { + WORD (name, U"Name: ", U"plosive_vowel_nasal") + WORD (navigationName, U"Name of navigation labels", U"vowels") + TEXTFIELD (navigation_string, U"Navigation labels", U"i u e o \\as ") + OPTIONMENU_ENUM (kMelder_string, navigationCriterion, U"navigation criterion", kMelder_string::DEFAULT) + WORD (leftContextName, U"Name of left context labels", U"plosives") + TEXTFIELD (leftContext_string, U"Left context labels", U"p b t d k g") + OPTIONMENU_ENUM (kMelder_string, leftContextCriterion, U"Left context criterion", kMelder_string::DEFAULT) + WORD (rightContextName, U"Name of right context labels", U"nasals") + TEXTFIELD (rightContext_string, U"Right context labels", U"m n") + OPTIONMENU_ENUM (kMelder_string, rightContextCriterion, U"right context criterion", kMelder_string::DEFAULT) + OPTIONMENU_ENUM (kContext_combination, combinationCriterion, U"How to combine the contexts", kContext_combination::LEFT_AND_RIGHT) + BOOLEAN (contextOnly, U"Use context only", false) + OK +DO + CREATE_ONE + autoNavigationContext result = NavigationContext_create (name, navigationName, navigation_string, navigationCriterion, leftContextName, leftContext_string, leftContextCriterion, rightContextName, rightContext_string, rightContextCriterion, combinationCriterion, contextOnly); + CREATE_ONE_END (name) +} + FORM (NEW1_old_Strings_createAsTokens, U"Strings: Create as tokens", nullptr) { TEXTFIELD (text, U"Text:", U"There are seven tokens in this text") OK @@ -6492,6 +6573,17 @@ DO CREATE_ONE_END (U"tokens") } +FORM (NEW1_Strings_createFromTokens, U"Strings: Create as tokens", U"Create Strings as tokens...") { + WORD (name, U"Name", U"tokens") + TEXTFIELD (text, U"Text:", U"There are seven tokens in this text") + SENTENCE (separators, U"Separators", U" ,") + OK +DO + CREATE_ONE + autoStrings result = Strings_createAsTokens (text, separators); + CREATE_ONE_END (name) +} + FORM (NEW1_Strings_createAsTokens, U"Strings: Create as tokens", U"Create Strings as tokens...") { TEXTFIELD (text, U"Text:", U"There are seven tokens in this text") SENTENCE (separators, U"Separators", U" ,") @@ -6519,7 +6611,7 @@ FORM (NEW_Strings_change, U"Strings: Change", U"Strings: Change") { SENTENCE (replace_string, U"Replace", U"a") INTEGER (replaceLimit, U"Replace limit", U"0 (= unlimited)") RADIO (stringType, U"Search and replace are:", 1) - RADIOBUTTON (U"Literals") + RADIOBUTTON (U"literals") RADIOBUTTON (U"Regular Expressions") OK DO @@ -6554,6 +6646,15 @@ DO CONVERT_EACH_END (my name.get()) } +FORM (NEW_Strings_to_NavigationContext, U"Strings: To NavigationContext", nullptr) { + OPTIONMENU_ENUM (kMelder_string, navigationCriterion, U"Navigation criterion", kMelder_string::DEFAULT) + OK +DO + CONVERT_EACH (Strings) + autoNavigationContext result = Strings_to_NavigationContext (me, navigationCriterion); + CONVERT_EACH_END (my name.get()) +} + DIRECT (NEW1_Strings_Permutation_permuteStrings) { CONVERT_TWO (Strings, Permutation) autoStrings result = Strings_Permutation_permuteStrings (me, you); @@ -6796,10 +6897,10 @@ DO } FORM (GRAPHICS_Table_drawEllipseWhere, U"Draw ellipse (standard deviation)", nullptr) { - WORD (xColumn_string, U"Horizontal column", U"") + SENTENCE (xColumn_string, U"Horizontal column", U"") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0 (= auto)") - WORD (yColumn_string, U"Vertical column", U"") + SENTENCE (yColumn_string, U"Vertical column", U"") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0 (= auto)") POSITIVE (numberOfSigmas, U"Number of sigmas", U"2.0") @@ -6816,15 +6917,15 @@ DO } FORM (GRAPHICS_Table_drawEllipses, U"Table: Draw ellipses", nullptr) { - WORD (xColumn_string, U"Horizontal column", U"F2") + SENTENCE (xColumn_string, U"Horizontal column", U"F2") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0 (= auto)") - WORD (yColumn_string, U"Vertical column", U"F1") + SENTENCE (yColumn_string, U"Vertical column", U"F1") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0 (= auto)") - WORD (factorColumn_string, U"Factor column", U"Vowel") + SENTENCE (factorColumn_string, U"Factor column", U"Vowel") POSITIVE (numberOfSigmas, U"Number of sigmas", U"1.0") - REAL (fontSize, U"Font size", U"12 (0 = no label)") + REAL (fontSize, U"Font size", U"12.0 (0 = no label)") BOOLEAN (garnish, U"Garnish", true) OK DO @@ -6837,13 +6938,13 @@ DO } FORM (GRAPHICS_Table_drawEllipsesWhere, U"Table: Draw ellipses where", nullptr) { - WORD (xColumn_string, U"Horizontal column", U"F2") + SENTENCE (xColumn_string, U"Horizontal column", U"F2") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0 (= auto)") - WORD (yColumn_string, U"Vertical column", U"F1") + SENTENCE (yColumn_string, U"Vertical column", U"F1") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0 (= auto)") - WORD (factorColumn_string, U"Factor column", U"Vowel") + SENTENCE (factorColumn_string, U"Factor column", U"Vowel") POSITIVE (numberOfSigmas, U"Number of sigmas", U"1.0") REAL (fontSize, U"Font size", U"12 (0 = no label)") BOOLEAN (garnish, U"Garnish", true) @@ -6860,11 +6961,11 @@ DO FORM (GRAPHICS_Table_normalProbabilityPlot, U"Table: Normal probability plot", U"Table: Normal probability plot...") { - WORD (column_string, U"Column", U"F1") + SENTENCE (column_string, U"Column", U"F1") NATURAL (numberOfQuantiles, U"Number of quantiles", U"100") REAL (numberOfSigmas, U"Number of sigmas", U"0.0") NATURAL (labelSize, U"Label size", U"12") - WORD (label, U"Label", U"+") + SENTENCE (label, U"Label", U"+") BOOLEAN (garnish, U"Garnish", true); OK DO @@ -6875,11 +6976,11 @@ DO } FORM (GRAPHICS_Table_normalProbabilityPlotWhere, U"Table: Normal probability plot where", U"Table: Normal probability plot...") { - WORD (column_string, U"Column", U"F0") + SENTENCE (column_string, U"Column", U"F0") NATURAL (numberOfQuantiles, U"Number of quantiles", U"100") REAL (numberOfSigmas, U"Number of sigmas", U"0.0") NATURAL (labelSize, U"Label size", U"12") - WORD (label, U"Label", U"+") + SENTENCE (label, U"Label", U"+") BOOLEAN (garnish, U"Garnish", true); TEXTFIELD (formula, U"Use only data in rows where the following condition holds:", U"1; self$[\"gender\"]=\"male\"") OK @@ -6892,15 +6993,15 @@ DO } FORM (GRAPHICS_Table_quantileQuantilePlot, U"Table: Quantile-quantile plot", U"Table: Quantile-quantile plot...") { - WORD (xColumn_string, U"Horizontal axis column", U"") - WORD (yColumn_string, U"Vertical axis column", U"") + SENTENCE (xColumn_string, U"Horizontal axis column", U"") + SENTENCE (yColumn_string, U"Vertical axis column", U"") NATURAL (numberOfQuantiles, U"Number of quantiles", U"100") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0") NATURAL (labelSize, U"Label size", U"12") - WORD (label, U"Label", U"+") + SENTENCE (label, U"Label", U"+") BOOLEAN (garnish, U"Garnish", true); OK DO @@ -6912,17 +7013,17 @@ DO } FORM (GRAPHICS_Table_quantileQuantilePlot_betweenLevels, U"Table: Quantile-quantile plot (between levels)", U"Table: Quantile-quantile plot...") { - WORD (dataColumn_string, U"Data column", U"F0") - WORD (factorColumn_string, U"Factor column", U"Sex") - WORD (xLevel_string, U"Horizontal factor level", U"") - WORD (yLevelString, U"Vertical factor level", U"") + SENTENCE (dataColumn_string, U"Data column", U"F0") + SENTENCE (factorColumn_string, U"Factor column", U"Sex") + SENTENCE (xLevel_string, U"Horizontal factor level", U"") + SENTENCE (yLevelString, U"Vertical factor level", U"") NATURAL (numberOfQuantiles, U"Number of quantiles", U"100") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0") NATURAL (labelSize, U"Label size", U"12") - WORD (label, U"Label", U"+") + SENTENCE (label, U"Label", U"+") BOOLEAN (garnish, U"Garnish", true); OK DO @@ -6934,12 +7035,12 @@ DO } FORM (GRAPHICS_Table_lagPlot, U"Table: lag plot", nullptr) { - WORD (dataColumn_string, U"Data column", U"errors") + SENTENCE (dataColumn_string, U"Data column", U"errors") NATURAL (lag, U"Lag", U"1") REAL (fromXY, U"left Horizontal and vertical range", U"0.0") REAL (toXY, U"right Horizontal and vertical range", U"0.0") NATURAL (labelSize, U"Label size", U"12") - WORD (label, U"Label", U"+") + SENTENCE (label, U"Label", U"+") BOOLEAN (garnish, U"Garnish", true); OK DO @@ -6951,12 +7052,12 @@ DO FORM (GRAPHICS_Table_lagPlotWhere, U"Table: lag plot where", nullptr) { - WORD (dataColumn_string, U"Data column", U"errors") + SENTENCE (dataColumn_string, U"Data column", U"errors") NATURAL (lag, U"Lag", U"1") REAL (fromXY, U"left Horizontal and vertical range", U"0.0") REAL (toXY, U"right Horizontal and vertical range", U"0.0") NATURAL (labelSize, U"Label size", U"12") - WORD (label, U"Label", U"+") + SENTENCE (label, U"Label", U"+") BOOLEAN (garnish, U"Garnish", true); TEXTFIELD (formula, U"Use only data in rows where the following condition holds:", U"1; self$[\"gender\"]=\"male\"") OK @@ -6968,7 +7069,7 @@ DO } FORM (GRAPHICS_Table_distributionPlot, U"Table: Distribution plot", nullptr) { - WORD (dataColumn_string, U"Data column", U"data") + SENTENCE (dataColumn_string, U"Data column", U"data") REAL (minimumValue, U"Minimum value", U"0.0") REAL (maximumValue, U"Maximum value", U"0.0") LABEL (U"Display of the distribution") @@ -6985,7 +7086,7 @@ DO } FORM (GRAPHICS_Table_distributionPlotWhere, U"Table: Distribution plot where", nullptr) { - WORD (dataColumn_string, U"Data column", U"data") + SENTENCE (dataColumn_string, U"Data column", U"data") REAL (minimumValue, U"Minimum value", U"0.0") REAL (maximumValue, U"Maximum value", U"0.0") LABEL (U"Display of the distribution") @@ -7003,14 +7104,14 @@ DO } FORM (GRAPHICS_Table_horizontalErrorBarsPlot, U"Table: Horizontal error bars plot", U"Table: Horizontal error bars plot...") { - WORD (xColumn_string, U"Horizontal column", U"x") + SENTENCE (xColumn_string, U"Horizontal column", U"x") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0") - WORD (yColumn_string, U"Vertical column", U"y") + SENTENCE (yColumn_string, U"Vertical column", U"y") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0") - WORD (lowerErrorColumn_string, U"Lower error value column", U"error1") - WORD (upperErrorColumn_string, U"Upper error value column", U"error2") + SENTENCE (lowerErrorColumn_string, U"Lower error value column", U"error1") + SENTENCE (upperErrorColumn_string, U"Upper error value column", U"error2") REAL (barSize_mm, U"Bar size (mm)", U"1.0") BOOLEAN (garnish, U"Garnish", true); OK @@ -7025,14 +7126,14 @@ DO } FORM (GRAPHICS_Table_horizontalErrorBarsPlotWhere, U"Table: Horizontal error bars plot where", U"Table: Horizontal error bars plot where...") { - WORD (xColumn_string, U"Horizontal column", U"") + SENTENCE (xColumn_string, U"Horizontal column", U"") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0") - WORD (yColumn_string, U"Vertical column", U"") + SENTENCE (yColumn_string, U"Vertical column", U"") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0") - WORD (lowerErrorColumn_string, U"Lower error value column", U"error1") - WORD (upperErrorColumn_string, U"Upper error value column", U"error2") + SENTENCE (lowerErrorColumn_string, U"Lower error value column", U"error1") + SENTENCE (upperErrorColumn_string, U"Upper error value column", U"error2") REAL (barSize_mm, U"Bar size (mm)", U"1.0") BOOLEAN (garnish, U"Garnish", true); TEXTFIELD (formula, U"Use only data in rows where the following condition holds:", U"1; self$[\"gender\"]=\"male\"") @@ -7048,14 +7149,14 @@ DO } FORM (GRAPHICS_Table_verticalErrorBarsPlot, U"Table: Vertical error bars plot", U"Table: Vertical error bars plot...") { - WORD (xColumn_string, U"Horizontal column", U"") + SENTENCE (xColumn_string, U"Horizontal column", U"") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0") - WORD (yColumn_string, U"Vertical column", U"") + SENTENCE (yColumn_string, U"Vertical column", U"") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0") - WORD (lowerErrorColumn_string, U"Lower error value column", U"error1") - WORD (upperErrorColumn_string, U"Upper error value column", U"error2") + SENTENCE (lowerErrorColumn_string, U"Lower error value column", U"error1") + SENTENCE (upperErrorColumn_string, U"Upper error value column", U"error2") REAL (barSize_mm, U"Bar size (mm)", U"1.0") BOOLEAN (garnish, U"Garnish", true); OK @@ -7070,14 +7171,14 @@ DO } FORM (GRAPHICS_Table_verticalErrorBarsPlotWhere, U"Table: Vertical error bars plot where", U"Table: Vertical error bars plot where...") { - WORD (xColumn_string, U"Horizontal column", U"") + SENTENCE (xColumn_string, U"Horizontal column", U"") REAL (xmin, U"left Horizontal range", U"0.0") REAL (xmax, U"right Horizontal range", U"0.0") - WORD (yColumn_string, U"Vertical column", U"") + SENTENCE (yColumn_string, U"Vertical column", U"") REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0") - WORD (lowerErrorColumn_string, U"Lower error value column", U"error1") - WORD (upperErrorColumn_string, U"Upper error value column", U"error2") + SENTENCE (lowerErrorColumn_string, U"Lower error value column", U"error1") + SENTENCE (upperErrorColumn_string, U"Upper error value column", U"error2") REAL (barSize_mm, U"Bar size (mm)", U"1.0") BOOLEAN (garnish, U"Garnish", true); TEXTFIELD (formula, U"Use only data in rows where the following condition holds:", U"1; self$[\"gender\"]=\"male\"") @@ -7106,7 +7207,7 @@ FORM (NEW_Table_extractRowsMahalanobisWhere, U"Table: Extract rows where (mahala RADIO_ENUM (kMelder_number, haveAMahalanobisDistance, U"...have a mahalanobis distance...", kMelder_number::GREATER_THAN) REAL (numberOfSigmas, U"...the number", U"2.0") - WORD (factorColumn_string, U"Factor column", U"") + SENTENCE (factorColumn_string, U"Factor column", U"") TEXTFIELD (formula, U"Process only rows where the following condition holds:", U"1; self$[\"gender\"]=\"male\"") OK DO @@ -7206,9 +7307,9 @@ DO FORM (NEW_TableOfReal_create_weenink1983, U"Create TableOfReal (Weenink 1985)...", U"Create TableOfReal (Weenink 1985)...") { RADIO (speakerGroup, U"Speakers group", 1) - RADIOBUTTON (U"Men") - RADIOBUTTON (U"Women") - RADIOBUTTON (U"Children") + RADIOBUTTON (U"men") + RADIOBUTTON (U"women") + RADIOBUTTON (U"children") OK DO CREATE_ONE @@ -7302,9 +7403,9 @@ FORM (GRAPHICS_TableOfReal_drawVectors, U"Draw vectors", U"TableOfReal: Draw vec REAL (ymin, U"left Vertical range", U"0.0") REAL (ymax, U"right Vertical range", U"0.0") RADIO (vectorType, U"Vector type", 1) - RADIOBUTTON (U"Arrow") - RADIOBUTTON (U"Double arrow") - RADIOBUTTON (U"Line") + RADIOBUTTON (U"arrow") + RADIOBUTTON (U"double arrow") + RADIOBUTTON (U"line") INTEGER (labelSize, U"Label size", U"10") BOOLEAN (garnish, U"Garnish", true) OK @@ -7489,8 +7590,8 @@ DIRECT (NEW1_TablesOfReal_to_Eigen_gsvd) { FORM (NEW1_TableOfReal_TableOfReal_crossCorrelations, U"TableOfReal & TableOfReal: Cross-correlations", nullptr) { OPTIONMENU (between, U"Correlations between", 1) - OPTION (U"Rows") - OPTION (U"Columns") + OPTION (U"rows") + OPTION (U"columns") BOOLEAN (center, U"Center", false) BOOLEAN (normalize, U"Normalize", false) OK @@ -7607,8 +7708,8 @@ DO FORM (MODIFY_TextGrid_extendTime, U"TextGrid: Extend time", U"TextGrid: Extend time...") { POSITIVE (extendDomainBy, U"Extend domain by (s)", U"1.0") RADIO (position, U"At", 1) - RADIOBUTTON (U"End") - RADIOBUTTON (U"Start") + RADIOBUTTON (U"end") + RADIOBUTTON (U"start") OK DO MODIFY_EACH (TextGrid) @@ -7623,7 +7724,7 @@ FORM (MODIFY_TextGrid_replaceIntervalTexts, U"TextGrid: Replace interval texts", SENTENCE (search_string, U"Search", U"a") SENTENCE (replace_string, U"Replace", U"b") RADIO (searchType, U"Search and replace strings are:", 1) - RADIOBUTTON (U"Literals") + RADIOBUTTON (U"literals") RADIOBUTTON (U"Regular Expressions") OK DO @@ -7640,7 +7741,7 @@ FORM (MODIFY_TextGrid_replacePointTexts, U"TextGrid: Replace point texts", U"Tex SENTENCE (search_string, U"Search", U"a") SENTENCE (replace_string, U"Replace", U"b") RADIO (searchType, U"Search and replace strings are:", 1) - RADIOBUTTON (U"Literals") + RADIOBUTTON (U"literals") RADIOBUTTON (U"Regular Expressions") OK DO @@ -7692,6 +7793,73 @@ DO CONVERT_COUPLE_AND_ONE_END (my name.get(), U"_", your name.get()) } +FORM (NEW_TextGrid_NavigationContext_to_TextGridNavigator, U"TextGrid & NavigationContext: To TextGridNavigator", nullptr) { + NATURAL (tierNumber, U"Tier number", U"1") + OK +DO + CONVERT_TWO (TextGrid, NavigationContext) + autoTextGridNavigator result = TextGridNavigator_create (me, you, tierNumber); + CONVERT_TWO_END (my name.get()) +} + +FORM (INTEGER_TextGridNavigator_getNextMatchAfterTime, U"", nullptr) { + REAL (time, U"Time (s)", U"-1.0") + OK +DO + INTEGER_ONE (TextGridNavigator) + integer result = TextGridNavigator_getNextMatchAfterTime (me, time); + INTEGER_ONE_END (U"") +} + +FORM (INTEGER_TextGridNavigator_getPreviousMatchBeforeTime, U"", nullptr) { + REAL (time, U"Time (s)", U"10.0") + OK +DO + INTEGER_ONE (TextGridNavigator) + integer result = TextGridNavigator_getPreviousMatchBeforeTime (me, time); + INTEGER_ONE_END (U"") +} + +DIRECT (INTEGER_TextGridNavigator_getFirstMatch) { + INTEGER_ONE (TextGridNavigator) + double result = TextGridNavigator_getFirstMatch (me); + INTEGER_ONE_END (U"") +} + +DIRECT (INTEGER_TextGridNavigator_getLastMatch) { + INTEGER_ONE (TextGridNavigator) + double result = TextGridNavigator_getLastMatch (me); + INTEGER_ONE_END (U"") +} + +DIRECT (REAL_TextGridNavigator_getCurrentStartTime) { + NUMBER_ONE (TextGridNavigator) + double result = TextGridNavigator_getCurrentStartTime (me); + NUMBER_ONE_END (U" s (start time)") +} + +DIRECT (REAL_TextGridNavigator_getCurrentEndTime) { + NUMBER_ONE (TextGridNavigator) + double result = TextGridNavigator_getCurrentEndTime (me); + NUMBER_ONE_END (U" s (end time)") +} + +DIRECT (INFO_TextGridNavigator_getCurrentLabel) { + STRING_ONE (TextGridNavigator) + conststring32 result = TextGridNavigator_getCurrentLabel (me); + STRING_ONE_END +} + +FORM (MODIFY_TextGridNavigator_addNavigationContext, U"TextGrid & NavigationContext: Add navigation context", nullptr) { + NATURAL (tierNumber, U"Tier number", U"1") + OPTIONMENU_ENUM (kNavigatableTier_match, matchCriterion, U"Timing relation with navigation match", kNavigatableTier_match::DEFAULT) + OK +DO + MODIFY_FIRST_OF_TWO (TextGridNavigator, NavigationContext) + TextGridNavigator_addNavigationContext (me, you, tierNumber, matchCriterion); + MODIFY_FIRST_OF_TWO_END +} + FORM (MODIFY_TextGrid_setTierName, U"TextGrid: Set tier name", U"TextGrid: Set tier name...") { NATURAL (tierNUmber, U"Tier number:", U"1") SENTENCE (name, U"Name", U""); @@ -7955,19 +8123,21 @@ void praat_uvafon_David_init () { classCorrelation, classCovariance, classDiscriminant, classDTW, classEigen, classExcitationList, classEditCostsTable, classEditDistanceTable, classElectroglottogram, - classFileInMemory, classFileInMemorySet, classFileInMemoryManager, classFormantFilter, - classIndex, classKlattTable, classNMF, + classFileInMemory, classFileInMemorySet, classFileInMemoryManager, + classFormantFilter, + classIndex, classIntervalTierNavigator, classKlattTable, classNMF, classPermutation, classISpline, classLegendreSeries, - classMelFilter, classMelSpectrogram, classMSpline, classPatternList, classPCA, classPolynomial, classRoots, + classMelFilter, classMelSpectrogram, classMSpline, classNavigationContext, + classPatternList, classPCA, classPolynomial, classRoots, classSimpleString, classStringsIndex, classSpeechSynthesizer, classSPINET, classSSCP, - classSVD, nullptr); + classSVD, classTextGridNavigator, nullptr); Thing_recognizeClassByOtherName (classExcitationList, U"Excitations"); Thing_recognizeClassByOtherName (classActivationList, U"Activation"); Thing_recognizeClassByOtherName (classPatternList, U"Pattern"); Thing_recognizeClassByOtherName (classFileInMemorySet, U"FilesInMemory"); structVowelEditor :: f_preferences (); - + espeakdata_praat_init (); praat_addMenuCommand (U"Objects", U"Technical", U"Report floating point properties", U"Report integer properties", 0, INFO_Praat_ReportFloatingPointProperties); @@ -7975,7 +8145,6 @@ void praat_uvafon_David_init () { praat_addMenuCommand (U"Objects", U"Goodies", U"Get invTukeyQ...", 0, praat_HIDDEN, REAL_Praat_getInvTukeyQ); praat_addMenuCommand (U"Objects", U"Goodies", U"Get incomplete gamma...", 0, praat_HIDDEN, COMPLEX_Praat_getIncompleteGamma); // praat_addMenuCommand (U"Objects", U"New", U"Create Strings as espeak voices", U"Create Strings as directory list...", praat_DEPTH_1 + praat_HIDDEN, NEW1_Strings_createAsEspeakVoices); - praat_addMenuCommand (U"Objects", U"New", U"Create iris data set", U"Create TableOfReal...", 1, NEW1_CreateIrisDataset); praat_addMenuCommand (U"Objects", U"New", U"Create Permutation...", nullptr, 0, NEW_Permutation_create); praat_addMenuCommand (U"Objects", U"New", U"Polynomial", nullptr, 0, nullptr); praat_addMenuCommand (U"Objects", U"New", U"Create Polynomial...", nullptr, 1, NEW1_Polynomial_create); @@ -7991,23 +8160,29 @@ void praat_uvafon_David_init () { praat_addMenuCommand (U"Objects", U"New", U"Create Sound from Shepard tone...", U"*Create Sound as Shepard tone...", praat_DEPTH_1 | praat_DEPRECATED_2016, NEW_Sound_createAsShepardTone); praat_addMenuCommand (U"Objects", U"New", U"Create Sound from VowelEditor...", U"Create Sound as Shepard tone...", praat_DEPTH_1 | praat_NO_API, WINDOW_VowelEditor_create); praat_addMenuCommand (U"Objects", U"New", U"Create SpeechSynthesizer...", U"Create Sound from VowelEditor...", praat_DEPTH_1, NEW1_SpeechSynthesizer_create); - praat_addMenuCommand (U"Objects", U"New", U"Create formant table (Pols & Van Nierop 1973)", U"Create Table...", 1, NEW1_Table_create_polsVanNierop1973); - praat_addMenuCommand (U"Objects", U"New", U"Create formant table (Peterson & Barney 1952)", U"Create Table...", 1, NEW1_Table_create_petersonBarney1952); - praat_addMenuCommand (U"Objects", U"New", U"Create formant table (Weenink 1985)", U"Create formant table (Peterson & Barney 1952)", 1, NEW1_Table_create_weenink1983); - praat_addMenuCommand (U"Objects", U"New", U"Create H1H2 table (Esposito 2006)", U"Create formant table (Weenink 1985)", praat_DEPTH_1+ praat_HIDDEN, NEW_Table_create_esposito2006); - praat_addMenuCommand (U"Objects", U"New", U"Create Table (Ganong 1980)", U"Create H1H2 table (Esposito 2006)", praat_DEPTH_1+ praat_HIDDEN, NEW_Table_create_ganong1980); - praat_addMenuCommand (U"Objects", U"New", U"Create TableOfReal (Pols 1973)...", U"Create TableOfReal...", 1, NEW1_TableOfReal_create_pols1973); - praat_addMenuCommand (U"Objects", U"New", U"Create TableOfReal (Van Nierop 1973)...", U"Create TableOfReal (Pols 1973)...", 1, NEW_TableOfReal_create_vanNierop1973); - praat_addMenuCommand (U"Objects", U"New", U"Create TableOfReal (Weenink 1985)...", U"Create TableOfReal (Van Nierop 1973)...", 1, NEW_TableOfReal_create_weenink1983); - praat_addMenuCommand (U"Objects", U"New", U"Create TableOfReal (Sandwell 1987)", U"Create TableOfReal (Weenink 1985)...", praat_DEPTH_1+ praat_HIDDEN, NEW_Table_create_sandwell1987); + praat_addMenuCommand (U"Objects", U"New", U"Data sets from the literature", U"Create Table without column names...", 1, nullptr); + praat_addMenuCommand (U"Objects", U"New", U"Create formant table (Peterson & Barney 1952)", U"Data sets from the literature", 2, NEW1_Table_create_petersonBarney1952); + praat_addMenuCommand (U"Objects", U"New", U"Create formant table (Pols & Van Nierop 1973)", U"Create formant table (Peterson & Barney 1952)", 2, NEW1_Table_create_polsVanNierop1973); + praat_addMenuCommand (U"Objects", U"New", U"Create formant table (Weenink 1985)", U"Create formant table (Pols & Van Nierop 1973)", 2, NEW1_Table_create_weenink1983); + praat_addMenuCommand (U"Objects", U"New", U"Create H1H2 table (Esposito 2006)", U"Create formant table (Weenink 1985)", 2, NEW_Table_create_esposito2006); + praat_addMenuCommand (U"Objects", U"New", U"Create Table (Ganong 1980)", U"Create H1H2 table (Esposito 2006)", 2, NEW_Table_create_ganong1980); + praat_addMenuCommand (U"Objects", U"New", U"-- TableOfReals --", U"Create Table (Ganong 1980)", 2, nullptr); + praat_addMenuCommand (U"Objects", U"New", U"Create iris data set", U"-- TableOfReals --" , 2, NEW1_CreateIrisDataset); + praat_addMenuCommand (U"Objects", U"New", U"Create TableOfReal (Pols 1973)...", U"Create iris data set", 2, NEW1_TableOfReal_create_pols1973); + praat_addMenuCommand (U"Objects", U"New", U"Create TableOfReal (Van Nierop 1973)...", U"Create TableOfReal (Pols 1973)...", 2, NEW_TableOfReal_create_vanNierop1973); + praat_addMenuCommand (U"Objects", U"New", U"Create TableOfReal (Weenink 1985)...", U"Create TableOfReal (Van Nierop 1973)...", 2, NEW_TableOfReal_create_weenink1983); + praat_addMenuCommand (U"Objects", U"New", U"Create TableOfReal (Sandwell 1987)", U"Create TableOfReal (Weenink 1985)...", 2, NEW_Table_create_sandwell1987); praat_addMenuCommand (U"Objects", U"New", U"Create simple Confusion...", U"Create TableOfReal (Weenink 1985)...", 1, NEW1_Confusion_createSimple); praat_addMenuCommand (U"Objects", U"New", U"Create simple Covariance...", U"Create simple Confusion...", 1, NEW1_Covariance_createSimple); praat_addMenuCommand (U"Objects", U"New", U"Create simple Correlation...", U"Create simple Covariance...", 1, NEW1_Correlation_createSimple); praat_addMenuCommand (U"Objects", U"New", U"Create empty EditCostsTable...", U"Create simple Covariance...", 1, NEW_EditCostsTable_createEmpty); praat_addMenuCommand (U"Objects", U"New", U"Create KlattTable example", U"Create TableOfReal (Weenink 1985)...", praat_DEPTH_1 + praat_HIDDEN, NEW1_KlattTable_createExample); - praat_addMenuCommand (U"Objects", U"New", U"Create Strings as tokens...", U"Create Strings as directory list...", 1, NEW1_Strings_createAsTokens); - praat_addMenuCommand (U"Objects", U"New", U"Create Strings as characters...", U"Create Strings as tokens...", praat_DEPTH_1 + praat_HIDDEN, NEW1_Strings_createAsCharacters); + praat_addMenuCommand (U"Objects", U"New", U"Create Strings from tokens...", U"Create Strings as directory list...", 1, NEW1_Strings_createFromTokens); + praat_addMenuCommand (U"Objects", U"New", U"Create Strings as tokens...", U"Create Strings from tokens...", praat_DEPTH_1 + praat_HIDDEN, NEW1_Strings_createAsTokens); + praat_addMenuCommand (U"Objects", U"New", U"Create Strings as characters...", U"Create Strings from tokens...", praat_DEPTH_1 + praat_HIDDEN, NEW1_Strings_createAsCharacters); + praat_addMenuCommand (U"Objects", U"New", U"Create NavigationContext...", U"Create Strings as tokens...", praat_DEPTH_1 + praat_HIDDEN, NEW1_Create_NavigationContext); + praat_addMenuCommand (U"Objects", U"New", U"Create simple Polygon...", nullptr, praat_HIDDEN, NEW1_Polygon_createSimple); praat_addMenuCommand (U"Objects", U"New", U"Create Polygon (random vertices)...", nullptr, praat_DEPRECATED_2016, NEW1_Polygon_createFromRandomPoints); @@ -8236,6 +8411,7 @@ void praat_uvafon_David_init () { praat_addAction2 (classDiscriminant, 1, classTableOfReal, 1, U"To Configuration...", nullptr, 0, NEW1_Discriminant_TableOfReal_to_Configuration); praat_addAction2 (classDiscriminant, 1, classTableOfReal, 1, U"To ClassificationTable...", nullptr, 0, NEW1_Discriminant_TableOfReal_to_ClassificationTable); praat_addAction2 (classDiscriminant, 1, classTableOfReal, 1, U"To TableOfReal (mahalanobis)...", nullptr, 0, NEW1_Discriminant_TableOfReal_mahalanobis); + praat_addAction2 (classDiscriminant, 1, classTableOfReal, 1, U"To TableOfReal (mahalanobis, all)...", nullptr, 0, NEW1_Discriminant_TableOfReal_mahalanobis_all); praat_addAction1 (classDTW, 0, U"DTW help", nullptr, 0, HELP_DTW_help); praat_addAction1 (classDTW, 0, DRAW_BUTTON, nullptr, 0, 0); @@ -8502,6 +8678,11 @@ void praat_uvafon_David_init () { praat_addAction1 (classMSpline, 0, U"MSpline help", nullptr, 0, HELP_MSpline_help); praat_Spline_init (classMSpline); + + praat_addAction1 (classNavigationContext, 0, U"Modify context combination...", nullptr, 0, MODIFY_NavigationContext_modifyContextCombination); + praat_addAction2 (classNavigationContext, 1, classStrings, 1, U"Modify navigation labels...", nullptr, 0, MODIFY_NavigationContext_modifyNavigationLabels); + praat_addAction2 (classNavigationContext, 1, classStrings, 1, U"Modify left context labels...", nullptr, 0, MODIFY_NavigationContext_modifyLeftContextLabels); + praat_addAction2 (classNavigationContext, 1, classStrings, 1, U"Modify right context labels...", nullptr, 0, MODIFY_NavigationContext_modifyRightContextLabels); praat_addAction1 (classNMF, 0, U"NMF help", nullptr, 0, HELP_NMF_help); praat_addAction1 (classNMF, 0, U"Paint features...", nullptr, 0, GRAPHICS_NMF_paintFeatures); @@ -8755,6 +8936,7 @@ void praat_uvafon_David_init () { praat_addAction1 (classStrings, 0, U"Change...", U"Replace all...", praat_HIDDEN, NEW_Strings_change); praat_addAction1 (classStrings, 0, U"Extract part...", U"Replace all...", 0, NEW_Strings_extractPart); praat_addAction1 (classStrings, 0, U"To Permutation...", U"To Distributions", 0, NEW_Strings_to_Permutation); + praat_addAction1 (classStrings, 0, U"To NavigationContext...", U"To Distributions", 0, NEW_Strings_to_NavigationContext); praat_addAction1 (classStrings, 2, U"To EditDistanceTable", U"To Distributions", 0, NEW_Strings_to_EditDistanceTable); praat_addAction1 (classSVD, 0, U"SVD help", nullptr, 0, HELP_SVD_help); @@ -8867,6 +9049,18 @@ void praat_uvafon_David_init () { praat_addAction1 (classTextGrid, 0, U"To DurationTier...", U"Concatenate", 0, NEW_TextGrid_to_DurationTier); praat_addAction2 (classTextGrid, 1, classDurationTier, 1, U"To TextGrid (scale times)", nullptr, 0, NEW_TextGrid_DurationTier_to_TextGrid); praat_addAction2 (classTextGrid, 2, classEditCostsTable, 1, U"To Table (text alignment)...", nullptr, 0, NEW1_TextGrids_EditCostsTable_to_Table_textAlignment); + praat_addAction2 (classTextGrid, 1, classNavigationContext, 1, U"To TextGridNavigator...", nullptr, 0, NEW_TextGrid_NavigationContext_to_TextGridNavigator); + + praat_addAction1 (classTextGridNavigator, 1, U"Get first match", nullptr, 0, INTEGER_TextGridNavigator_getFirstMatch); + praat_addAction1 (classTextGridNavigator, 1, U"Get last match", nullptr, 0, INTEGER_TextGridNavigator_getLastMatch); + praat_addAction1 (classTextGridNavigator, 1, U"Get next match after time...", nullptr, 0, INTEGER_TextGridNavigator_getNextMatchAfterTime); + praat_addAction1 (classTextGridNavigator, 1, U"Get previous match before time...", nullptr, 0, INTEGER_TextGridNavigator_getPreviousMatchBeforeTime); + praat_addAction1 (classTextGridNavigator, 1, U"Get current start time", nullptr, 0, REAL_TextGridNavigator_getCurrentStartTime); + praat_addAction1 (classTextGridNavigator, 1, U"Get current end time", nullptr, 0, REAL_TextGridNavigator_getCurrentEndTime); + praat_addAction1 (classTextGridNavigator, 1, U"Get current label", nullptr, 0, INFO_TextGridNavigator_getCurrentLabel); + + praat_addAction2 (classTextGridNavigator, 1, classNavigationContext, 1, U"Add navigation context...", nullptr, 0, MODIFY_TextGridNavigator_addNavigationContext); + INCLUDE_MANPAGES (manual_dwtools_init) INCLUDE_MANPAGES (manual_Permutation_init) diff --git a/dwtools/praat_MDS_init.cpp b/dwtools/praat_MDS_init.cpp index 7f2c7afa..f56fcd4c 100644 --- a/dwtools/praat_MDS_init.cpp +++ b/dwtools/praat_MDS_init.cpp @@ -362,8 +362,8 @@ DO FORM (NEW_Confusion_to_Similarity, U"Confusion: To Similarity", U"Confusion: To Similarity...") { BOOLEAN (normalize, U"Normalize", true) RADIO (symmetrizeMethod, U"Symmetrization", 1) - RADIOBUTTON (U"No symmetrization") - RADIOBUTTON (U"Average (s[i][j] = (c[i][j]+c[j][i])/2)") + RADIOBUTTON (U"no symmetrization") + RADIOBUTTON (U"average (s[i][j] = (c[i][j]+c[j][i])/2)") RADIOBUTTON (U"Houtgast (s[i][j]= sum (min(c[i][k],c[j][k])))") OK DO @@ -390,9 +390,9 @@ DIRECT (NEW_Confusion_to_ContingencyTable) { FORM (NEW_ContingencyTable_to_Configuration_ca, U"ContingencyTable: To Configuration (ca)", U"ContingencyTable: To Configuration (ca)...") { NATURAL (numberOfDimensions, U"Number of dimensions", U"2") RADIO (scalingType, U"Scaling of final configuration", 3) - RADIOBUTTON (U"Row points in centre of gravity of column points") - RADIOBUTTON (U"Column points in centre of gravity of row points") - RADIOBUTTON (U"Row points and column points symmetric") + RADIOBUTTON (U"row points in centre of gravity of column points") + RADIOBUTTON (U"column points in centre of gravity of row points") + RADIOBUTTON (U"row points and column points symmetric") OK DO CONVERT_EACH (ContingencyTable) @@ -1337,7 +1337,7 @@ void praat_uvafon_MDS_init () { praat_addAction1 (classConfiguration, 2, U"To Procrustes...", nullptr, 1, NEW1_Configurations_to_Procrustes); praat_addAction1 (classConfiguration, 2, U"To AffineTransform (congruence)...", nullptr, 1, NEW1_Configurations_to_AffineTransform_congruence); - praat_addAction1 (classConfusion, 0, U"To ContingencyTable", U"To Matrix", 0, NEW_Confusion_to_ContingencyTable); + praat_addAction1 (classConfusion, 0, U"To ContingencyTable", U"To Matrix", 1, NEW_Confusion_to_ContingencyTable); praat_addAction1 (classConfusion, 0, U"To Proximity -", U"Analyse", 0, nullptr); praat_addAction1 (classConfusion, 0, U"To Dissimilarity (pdf)...", U"To Proximity -", 1, NEW_Confusion_to_Dissimilarity_pdf); praat_addAction1 (classConfusion, 0, U"To Similarity...", U"To Proximity -", 1, NEW_Confusion_to_Similarity); @@ -1419,8 +1419,8 @@ void praat_uvafon_MDS_init () { praat_addAction1 (classTableOfReal, 0, U"To Salience", nullptr, 1, NEW_TableOfReal_to_Salience); praat_addAction1 (classTableOfReal, 0, U"To Weight", nullptr, 1, NEW_TableOfReal_to_Weight); praat_addAction1 (classTableOfReal, 0, U"To ScalarProduct", nullptr, 1, NEW_TableOfReal_to_ScalarProduct); - praat_addAction1 (classTableOfReal, 0, U"To Configuration", nullptr, 1, NEW_TableOfReal_to_Configuration); praat_addAction1 (classTableOfReal, 0, U"To ContingencyTable", nullptr, 1, NEW_TableOfReal_to_ContingencyTable); + praat_addAction1 (classTableOfReal, 0, U"To Configuration", nullptr, 1, NEW_TableOfReal_to_Configuration); praat_TableOfReal_init2 (classWeight); diff --git a/external/clapack/Makefile b/external/clapack/Makefile index b970129c..6e1f9b15 100644 --- a/external/clapack/Makefile +++ b/external/clapack/Makefile @@ -1,25 +1,27 @@ -# -# Top Level Makefile for CLAPACK -# -# 20200320 David Weenink +# Makefile of the library "external/clapack" +# David Weenink, 13 March 2020 +# Paul Boersma, 24 May 2020 include ../../makefile.defs -.PHONY: all -all: blaslib lapacklib - cp blas/libblas.a . - cp lapack/liblapack.a . +CPPFLAGS = -I ../../melder -.PHONY: blaslib -blaslib: - $(MAKE) -C blas +OBJECTS = blas.o \ + lapack.o lapack_dg.o lapack_dlaq.o \ + lapack_dlar.o lapack_ds.o lapack_dt.o -.PHONY: lapacklib -lapacklib: - $(MAKE) -C lapack +.PHONY: all clean + +all: libclapack.a -.PHONY: clean clean: - $(MAKE) -C blas clean - $(MAKE) -C lapack clean - rm -f *.a + $(RM) $(OBJECTS) + $(RM) libclapack.a + +libclapack.a: $(OBJECTS) + touch libclapack.a + rm libclapack.a + $(AR) cq libclapack.a $(OBJECTS) + $(RANLIB) libclapack.a + +$(OBJECTS): *.h ../../melder/*.h diff --git a/external/clapack/READ_ME.TXT b/external/clapack/READ_ME.TXT index 83e12642..15d6d02d 100644 --- a/external/clapack/READ_ME.TXT +++ b/external/clapack/READ_ME.TXT @@ -103,7 +103,7 @@ This stack smashing error occured in dlaqr0.c where an "array" dimensioned as ch char jbcmpz[1]; .... if (*wantz) { - *(unsigned char *)jbcmpz[1] = 'V'; // illegal write to memory into one byte of the canary + *(unsigned char *)jbcmpz[1] = 'V'; // illegal write to memory into one byte of the array } else { *(unsigned char *)jbcmpz[1] = 'N'; // illegal write to memory } @@ -122,10 +122,10 @@ To correct these bugs we have to dimension jbcmpz[3] and always close the string jbcmpz [2] = '\0'; nwr = ilaenv_(&c__13, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); -There are more occasions in clapack that don't properly close the third argument passed to ilaenv. In routines dhseqr dgesvd, dormbr, dormqr, dormlq, dormql, dormqr, dormrq, dormtr, and dormrz, character arrays of dimension 2 are passed without proper closing the string with a null byte. We corrected this too. +There are more occasions in clapack that don't properly close the third argument passed to ilaenv. In routines dhseqr, dgesvd, dormbr, dormqr, dormlq, dormql, dormqr, dormrq, dormtr, and dormrz, character arrays of dimension 2 are passed without proper closing the string with a null byte. We corrected this too. Two other bugs were found by Paul Boersma: -The return value in dlamch has to be declared volatile, otherwise the whole routine is optimized away and a wrong result may occur. +The return value in dlamc3_ has to be declared volatile, otherwise the whole routine is optimized away and a wrong result may occur. double dlamc3_(double *a, double *b) { volatile double ret_val; ret_val = *a + *b; diff --git a/external/clapack/blas.cpp b/external/clapack/blas.cpp new file mode 100644 index 00000000..cb515e64 --- /dev/null +++ b/external/clapack/blas.cpp @@ -0,0 +1,8734 @@ +#include "cblas.h" +#include "f2cP.h" + +double dasum_(integer *n, double *dx, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + double ret_val, d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + integer i__, m, mp1; + double dtemp; + integer nincx; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* takes the sum of the absolute values. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dx; + + /* Function Body */ + ret_val = 0.; + dtemp = 0.; + if (*n <= 0 || *incx <= 0) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dtemp += (d__1 = dx[i__], abs(d__1)); +/* L10: */ + } + ret_val = dtemp; + return ret_val; + +/* code for increment equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 6; + if (m == 0) { + goto L40; + } + i__2 = m; + for (i__ = 1; i__ <= i__2; ++i__) { + dtemp += (d__1 = dx[i__], abs(d__1)); +/* L30: */ + } + if (*n < 6) { + goto L60; + } +L40: + mp1 = m + 1; + i__2 = *n; + for (i__ = mp1; i__ <= i__2; i__ += 6) { + dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], + abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ + + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = + dx[i__ + 5], abs(d__6)); +/* L50: */ + } +L60: + ret_val = dtemp; + return ret_val; +} /* dasum_ */ + +/* Subroutine */ int daxpy_(integer *n, double *da, double *dx, + integer *incx, double *dy, integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* constant times a vector plus a vector. */ +/* uses unrolled loops for increments equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*da == 0.) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[iy] += *da * dx[ix]; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 4; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] += *da * dx[i__]; +/* L30: */ + } + if (*n < 4) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 4) { + dy[i__] += *da * dx[i__]; + dy[i__ + 1] += *da * dx[i__ + 1]; + dy[i__ + 2] += *da * dx[i__ + 2]; + dy[i__ + 3] += *da * dx[i__ + 3]; +/* L50: */ + } + return 0; +} /* daxpy_ */ + +/* Subroutine */ int dcopy_(integer *n, double *dx, integer *incx, + double *dy, integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* copies a vector, x, to a vector, y. */ +/* uses unrolled loops for increments equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[iy] = dx[ix]; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 7; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dy[i__] = dx[i__]; +/* L30: */ + } + if (*n < 7) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 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]; +/* L50: */ + } + return 0; +} /* dcopy_ */ + +double ddot_(integer *n, double *dx, integer *incx, double *dy, + integer *incy) +{ + /* System generated locals */ + integer i__1; + double ret_val; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + double dtemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* forms the dot product of two vectors. */ +/* uses unrolled loops for increments equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + ret_val = 0.; + dtemp = 0.; + if (*n <= 0) { + return ret_val; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments */ +/* not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += dx[ix] * dy[iy]; + ix += *incx; + iy += *incy; +/* L10: */ + } + ret_val = dtemp; + return ret_val; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 5; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp += dx[i__] * dy[i__]; +/* L30: */ + } + if (*n < 5) { + goto L60; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 5) { + dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[ + i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + + 4] * dy[i__ + 4]; +/* L50: */ + } +L60: + ret_val = dtemp; + return ret_val; +} /* ddot_ */ + +/* Subroutine */ int dgbmv_(const char *trans, integer *m, integer *n, integer *kl, + integer *ku, double *alpha, double *a, integer *lda, + double *x, integer *incx, double *beta, double *y, + integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info; + double temp; + integer lenx, leny; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBMV 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 band matrix, with kl sub-diagonals and ku super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* 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. */ + +/* KL - INTEGER. */ +/* On entry, KL specifies the number of sub-diagonals of the */ +/* matrix A. KL must satisfy 0 .le. KL. */ +/* Unchanged on exit. */ + +/* KU - INTEGER. */ +/* On entry, KU specifies the number of super-diagonals of the */ +/* matrix A. KU must satisfy 0 .le. KU. */ +/* 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 ( kl + ku + 1 ) by n part of the */ +/* array A must contain the matrix of coefficients, supplied */ +/* column by column, with the leading diagonal of the matrix in */ +/* row ( ku + 1 ) of the array, the first super-diagonal */ +/* starting at position 2 in row ku, the first sub-diagonal */ +/* starting at position 1 in row ( ku + 2 ), and so on. */ +/* Elements in the array A that do not correspond to elements */ +/* in the band matrix (such as the top left ku by ku triangle) */ +/* are not referenced. */ +/* The following program segment will transfer a band matrix */ +/* from conventional full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* K = KU + 1 - J */ +/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */ +/* A( K + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* 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 */ +/* ( kl + ku + 1 ). */ +/* 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, 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*kl < 0) { + info = 4; + } else if (*ku < 0) { + info = 5; + } else if (*lda < *kl + *ku + 1) { + info = 8; + } else if (*incx == 0) { + info = 10; + } else if (*incy == 0) { + info = 13; + } + if (info != 0) { + xerbla_("DGBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* 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")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the band part of A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + kup1 = *ku + 1; + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + k = kup1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = std::min(i__5,i__6); + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + y[i__] += temp * a[k + i__ + j * a_dim1]; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + iy = ky; + k = kup1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = std::min(i__5,i__6); + for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { + y[iy] += temp * a[k + i__ + j * a_dim1]; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + if (j > *ku) { + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + k = kup1 - j; +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = std::min(i__5,i__6); + for (i__ = std::max(i__3,i__4); i__ <= i__2; ++i__) { + temp += a[k + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L100: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + ix = kx; + k = kup1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = std::min(i__5,i__6); + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + temp += a[k + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + y[jy] += *alpha * temp; + jy += *incy; + if (j > *ku) { + kx += *incx; + } +/* L120: */ + } + } + } + + return 0; + +/* End of DGBMV . */ + +} /* dgbmv_ */ + +/* Subroutine */ int dgemm_(const char *transa, const char *transb, integer *m, integer * + n, integer *k, double *alpha, double *a, integer *lda, + double *b, integer *ldb, double *beta, double *c__, + integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, l, info; + bool nota, notb; + double temp; + integer nrowa, nrowb; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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. */ + +/* Arguments */ +/* ========== */ + +/* 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 .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* 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. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + nota = lsame_(transa, "N"); + notb = lsame_(transb, "N"); + if (nota) { + nrowa = *m; + } else { + nrowa = *k; + } + if (notb) { + nrowb = *k; + } else { + nrowb = *n; + } + +/* Test the input parameters. */ + + info = 0; + if (! nota && ! lsame_(transa, "C") && ! lsame_( + transa, "T")) { + info = 1; + } else if (! notb && ! lsame_(transb, "C") && ! + lsame_(transb, "T")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < std::max(1_integer,nrowa)) { + info = 8; + } else if (*ldb < std::max(1_integer,nrowb)) { + info = 10; + } else if (*ldc < std::max(1_integer,*m)) { + info = 13; + } + if (info != 0) { + xerbla_("DGEMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + +/* And if alpha.eq.zero. */ + + if (*alpha == 0.) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (notb) { + if (nota) { + +/* Form C := alpha*A*B + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L50: */ + } + } else if (*beta != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L60: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (b[l + j * b_dim1] != 0.) { + temp = *alpha * b[l + j * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L70: */ + } + } +/* L80: */ + } +/* L90: */ + } + } else { + +/* Form C := alpha*A'*B + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; +/* L100: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L110: */ + } +/* L120: */ + } + } + } else { + if (nota) { + +/* Form C := alpha*A*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L130: */ + } + } else if (*beta != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L140: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (b[j + l * b_dim1] != 0.) { + temp = *alpha * b[j + l * b_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L150: */ + } + } +/* L160: */ + } +/* L170: */ + } + } else { + +/* Form C := alpha*A'*B' + beta*C */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; +/* L180: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L190: */ + } +/* L200: */ + } + } + } + + return 0; + +/* End of DGEMM . */ + +} /* dgemm_ */ + +/* Subroutine */ int dgemv_(const char *trans, integer *m, integer *n, double * + alpha, double *a, integer *lda, double *x, integer *incx, + double *beta, double *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + double temp; + integer lenx, leny; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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. */ + +/* Arguments */ +/* ========== */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") + ) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < std::max(1_integer,*m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("DGEMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* 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")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* 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 != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + if (lsame_(trans, "N")) { + +/* Form y := alpha*A*x + y. */ + + jx = kx; + if (*incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp * a[i__ + j * a_dim1]; +/* L50: */ + } + } + jx += *incx; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + iy = ky; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp * a[i__ + j * a_dim1]; + iy += *incy; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } else { + +/* Form y := alpha*A'*x + y. */ + + jy = ky; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L100: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = 0.; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + y[jy] += *alpha * temp; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of DGEMV . */ + +} /* dgemv_ */ + +/* Subroutine */ int dger_(integer *m, integer *n, double *alpha, + double *x, integer *incx, double *y, integer *incy, + double *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jy, kx, info; + double temp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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. */ + +/* Arguments */ +/* ========== */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (*m < 0) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < std::max(1_integer,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("DGER ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0.) { + return 0; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (*incy > 0) { + jy = 1; + } else { + jy = 1 - (*n - 1) * *incy; + } + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L10: */ + } + } + jy += *incy; +/* L20: */ + } + } else { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*m - 1) * *incx; + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (y[jy] != 0.) { + temp = *alpha * y[jy]; + ix = kx; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jy += *incy; +/* L40: */ + } + } + + return 0; + +/* End of DGER . */ + +} /* dger_ */ + +double dnrm2_(integer *n, double *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + double ret_val, d__1; + + /* Builtin functions + double sqrt(double);*/ + + /* Local variables */ + integer ix; + double ssq, norm, scale, absxi; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DNRM2 returns the euclidean norm of a vector via the function */ +/* name, so that */ + +/* DNRM2 := sqrt( x'*x ) */ + + +/* -- This version written on 25-October-1982. */ +/* Modified on 14-October-1993 to inline the call to DLASSQ. */ +/* Sven Hammarling, Nag Ltd. */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n < 1 || *incx < 1) { + norm = 0.; + } else if (*n == 1) { + norm = abs(x[1]); + } else { + scale = 0.; + ssq = 1.; +/* The following loop is equivalent to this call to the LAPACK */ +/* auxiliary routine: */ +/* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */ + + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + if (x[ix] != 0.) { + absxi = (d__1 = x[ix], abs(d__1)); + if (scale < absxi) { +/* Computing 2nd power */ + d__1 = scale / absxi; + ssq = ssq * (d__1 * d__1) + 1.; + scale = absxi; + } else { +/* Computing 2nd power */ + d__1 = absxi / scale; + ssq += d__1 * d__1; + } + } +/* L10: */ + } + norm = scale * sqrt(ssq); + } + + ret_val = norm; + return ret_val; + +/* End of DNRM2. */ + +} /* dnrm2_ */ + +/* Subroutine */ int drot_(integer *n, double *dx, integer *incx, + double *dy, integer *incy, double *c__, double *s) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, ix, iy; + double dtemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* applies a plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[ix] + *s * dy[iy]; + dy[iy] = *c__ * dy[iy] - *s * dx[ix]; + dx[ix] = dtemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[i__] + *s * dy[i__]; + dy[i__] = *c__ * dy[i__] - *s * dx[i__]; + dx[i__] = dtemp; +/* L30: */ + } + return 0; +} /* drot_ */ + +/* Subroutine */ int drotg_(double *da, double *db, double *c__, + double *s) +{ + /* Table of constant values */ + static double c_b4 = 1.; + + /* System generated locals */ + double d__1, d__2; + + /* Builtin functions + double sqrt(double), d_sign(double *, double *);*/ + + /* Local variables */ + double r__, z__, roe, scale; + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* construct givens plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + roe = *db; + if (abs(*da) > abs(*db)) { + roe = *da; + } + scale = abs(*da) + abs(*db); + if (scale != 0.) { + goto L10; + } + *c__ = 1.; + *s = 0.; + r__ = 0.; + z__ = 0.; + goto L20; +L10: +/* Computing 2nd power */ + d__1 = *da / scale; +/* Computing 2nd power */ + d__2 = *db / scale; + r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2); + r__ = d_sign(&c_b4, &roe) * r__; + *c__ = *da / r__; + *s = *db / r__; + z__ = 1.; + if (abs(*da) > abs(*db)) { + z__ = *s; + } + if (abs(*db) >= abs(*da) && *c__ != 0.) { + z__ = 1. / *c__; + } +L20: + *da = r__; + *db = z__; + return 0; +} /* drotg_ */ + +/* Subroutine */ int drotm_(integer *n, double *dx, integer *incx, + double *dy, integer *incy, double *dparam) +{ + /* Initialized data */ + + static double zero = 0.; + static double two = 2.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__; + double w, z__; + integer kx, ky; + double dh11, dh12, dh21, dh22, dflag; + integer nsteps; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ + +/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */ +/* (DY**T) */ + +/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ +/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */ +/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ + +/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ +/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* number of elements in input vector(s) */ + +/* DX (input/output) DOUBLE PRECISION array, dimension N */ +/* double precision vector with 5 elements */ + +/* INCX (input) INTEGER */ +/* storage spacing between elements of DX */ + +/* DY (input/output) DOUBLE PRECISION array, dimension N */ +/* double precision vector with N elements */ + +/* INCY (input) INTEGER */ +/* storage spacing between elements of DY */ + +/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ +/* DPARAM(1)=DFLAG */ +/* DPARAM(2)=DH11 */ +/* DPARAM(3)=DH21 */ +/* DPARAM(4)=DH12 */ +/* DPARAM(5)=DH22 */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --dparam; + --dy; + --dx; + + /* Function Body */ +/* .. */ + + dflag = dparam[1]; + if (*n <= 0 || dflag + two == zero) { + goto L140; + } + if (! (*incx == *incy && *incx > 0)) { + goto L70; + } + + nsteps = *n * *incx; + if (dflag < 0.) { + goto L50; + } else if (dflag == 0) { + goto L10; + } else { + goto L30; + } +L10: + dh12 = dparam[4]; + dh21 = dparam[3]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w + z__ * dh12; + dy[i__] = w * dh21 + z__; +/* L20: */ + } + goto L140; +L30: + dh11 = dparam[2]; + dh22 = dparam[5]; + i__2 = nsteps; + i__1 = *incx; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w * dh11 + z__; + dy[i__] = -w + dh22 * z__; +/* L40: */ + } + goto L140; +L50: + dh11 = dparam[2]; + dh12 = dparam[4]; + dh21 = dparam[3]; + dh22 = dparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w * dh11 + z__ * dh12; + dy[i__] = w * dh21 + z__ * dh22; +/* L60: */ + } + goto L140; +L70: + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + + if (dflag < 0.) { + goto L120; + } else if (dflag == 0) { + goto L80; + } else { + goto L100; + } +L80: + dh12 = dparam[4]; + dh21 = dparam[3]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w + z__ * dh12; + dy[ky] = w * dh21 + z__; + kx += *incx; + ky += *incy; +/* L90: */ + } + goto L140; +L100: + dh11 = dparam[2]; + dh22 = dparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w * dh11 + z__; + dy[ky] = -w + dh22 * z__; + kx += *incx; + ky += *incy; +/* L110: */ + } + goto L140; +L120: + dh11 = dparam[2]; + dh12 = dparam[4]; + dh21 = dparam[3]; + dh22 = dparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w * dh11 + z__ * dh12; + dy[ky] = w * dh21 + z__ * dh22; + kx += *incx; + ky += *incy; +/* L130: */ + } +L140: + return 0; +} /* drotm_ */ + +/* Subroutine */ int drotmg_(double *dd1, double *dd2, double * + dx1, double *dy1, double *dparam) +{ + /* Initialized data */ + + static double zero = 0.; + static double one = 1.; + static double two = 2.; + static double gam = 4096.; + static double gamsq = 16777216.; + static double rgamsq = 5.9604645e-8; + + /* System generated locals */ + double d__1; + + /* Local variables */ + double du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22; + integer igo; + double dflag, dtemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ +/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */ +/* DY2)**T. */ +/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ + +/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ +/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */ +/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */ +/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */ + +/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ +/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ +/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ + + +/* Arguments */ +/* ========= */ + +/* DD1 (input/output) DOUBLE PRECISION */ + +/* DD2 (input/output) DOUBLE PRECISION */ + +/* DX1 (input/output) DOUBLE PRECISION */ + +/* DY1 (input) DOUBLE PRECISION */ + +/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ +/* DPARAM(1)=DFLAG */ +/* DPARAM(2)=DH11 */ +/* DPARAM(3)=DH21 */ +/* DPARAM(4)=DH12 */ +/* DPARAM(5)=DH22 */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Data statements .. */ + + /* Parameter adjustments */ + --dparam; + + /* Function Body */ +/* .. */ + if (! (*dd1 < zero)) { + goto L10; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L10: +/* CASE-DD1-NONNEGATIVE */ + dp2 = *dd2 * *dy1; + if (! (dp2 == zero)) { + goto L20; + } + dflag = -two; + goto L260; +/* REGULAR-CASE.. */ +L20: + dp1 = *dd1 * *dx1; + dq2 = dp2 * *dy1; + dq1 = dp1 * *dx1; + + if (! (abs(dq1) > abs(dq2))) { + goto L40; + } + dh21 = -(*dy1) / *dx1; + dh12 = dp2 / dp1; + + du = one - dh12 * dh21; + + if (! (du <= zero)) { + goto L30; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L30: + dflag = zero; + *dd1 /= du; + *dd2 /= du; + *dx1 *= du; +/* GO SCALE-CHECK.. */ + goto L100; +L40: + if (! (dq2 < zero)) { + goto L50; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L50: + dflag = one; + dh11 = dp1 / dp2; + dh22 = *dx1 / *dy1; + du = one + dh11 * dh22; + dtemp = *dd2 / du; + *dd2 = *dd1 / du; + *dd1 = dtemp; + *dx1 = *dy1 * du; +/* GO SCALE-CHECK */ + goto L100; +/* PROCEDURE..ZERO-H-D-AND-DX1.. */ +L60: + dflag = -one; + dh11 = zero; + dh12 = zero; + dh21 = zero; + dh22 = zero; + + *dd1 = zero; + *dd2 = zero; + *dx1 = zero; +/* RETURN.. */ + goto L220; +/* PROCEDURE..FIX-H.. */ +L70: + if (! (dflag >= zero)) { + goto L90; + } + + if (! (dflag == zero)) { + goto L80; + } + dh11 = one; + dh22 = one; + dflag = -one; + goto L90; +L80: + dh21 = -one; + dh12 = one; + dflag = -one; +L90: + switch (igo) { + case 0: goto L120; + case 1: goto L150; + case 2: goto L180; + case 3: goto L210; + } +/* PROCEDURE..SCALE-CHECK */ +L100: +L110: + if (! (*dd1 <= rgamsq)) { + goto L130; + } + if (*dd1 == zero) { + goto L160; + } + igo = 0; +/* FIX-H.. */ + goto L70; +L120: +/* Computing 2nd power */ + d__1 = gam; + *dd1 *= d__1 * d__1; + *dx1 /= gam; + dh11 /= gam; + dh12 /= gam; + goto L110; +L130: +L140: + if (! (*dd1 >= gamsq)) { + goto L160; + } + igo = 1; +/* FIX-H.. */ + goto L70; +L150: +/* Computing 2nd power */ + d__1 = gam; + *dd1 /= d__1 * d__1; + *dx1 *= gam; + dh11 *= gam; + dh12 *= gam; + goto L140; +L160: +L170: + if (! (abs(*dd2) <= rgamsq)) { + goto L190; + } + if (*dd2 == zero) { + goto L220; + } + igo = 2; +/* FIX-H.. */ + goto L70; +L180: +/* Computing 2nd power */ + d__1 = gam; + *dd2 *= d__1 * d__1; + dh21 /= gam; + dh22 /= gam; + goto L170; +L190: +L200: + if (! (abs(*dd2) >= gamsq)) { + goto L220; + } + igo = 3; +/* FIX-H.. */ + goto L70; +L210: +/* Computing 2nd power */ + d__1 = gam; + *dd2 /= d__1 * d__1; + dh21 *= gam; + dh22 *= gam; + goto L200; +L220: + if (dflag < 0.) { + goto L250; + } else if (dflag == 0) { + goto L230; + } else { + goto L240; + } +L230: + dparam[3] = dh21; + dparam[4] = dh12; + goto L260; +L240: + dparam[2] = dh11; + dparam[5] = dh22; + goto L260; +L250: + dparam[2] = dh11; + dparam[3] = dh21; + dparam[4] = dh12; + dparam[5] = dh22; +L260: + dparam[1] = dflag; + return 0; +} /* drotmg_ */ + +/* Subroutine */ int dsbmv_(const char *uplo, integer *n, integer *k, double * + alpha, double *a, integer *lda, double *x, integer *incx, + double *beta, double *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, iy, jx, jy, kx, ky, info; + double temp1, temp2; + + integer kplus1; + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric band matrix, with k super-diagonals. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the band matrix A is being supplied as */ +/* follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* being supplied. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* being supplied. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix A. */ +/* N must be at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry, K specifies the number of super-diagonals of the */ +/* matrix A. K must satisfy 0 .le. K. */ +/* 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 with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the symmetric matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer the upper */ +/* triangular part of a symmetric band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the symmetric matrix, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer the lower */ +/* triangular part of a symmetric band matrix from conventional */ +/* full matrix storage to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* 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 */ +/* ( k + 1 ). */ +/* 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 */ +/* 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. */ +/* 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 */ +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*k < 0) { + info = 3; + } else if (*lda < *k + 1) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("DSBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array A */ +/* are accessed sequentially with one pass through A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when upper triangle of A is stored. */ + + kplus1 = *k + 1; + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + y[i__] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[i__]; +/* L50: */ + } + y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + ix = kx; + iy = ky; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { + y[iy] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * + temp2; + jx += *incx; + jy += *incy; + if (j > *k) { + kx += *incx; + ky += *incy; + } +/* L80: */ + } + } + } else { + +/* Form y when lower triangle of A is stored. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + y[j] += temp1 * a[j * a_dim1 + 1]; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = std::min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + y[i__] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[j] += *alpha * temp2; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + y[jy] += temp1 * a[j * a_dim1 + 1]; + l = 1 - j; + ix = jx; + iy = jy; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = std::min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * a[l + i__ + j * a_dim1]; + temp2 += a[l + i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of DSBMV . */ + +} /* dsbmv_ */ + +/* Subroutine */ int dscal_(integer *n, double *da, double *dx, + integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, m, mp1, nincx; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ +/* * */ +/* scales a vector by a constant. */ +/* uses unrolled loops for increment equal to one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dx; + + /* Function Body */ + if (*n <= 0 || *incx <= 0) { + return 0; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + dx[i__] = *da * dx[i__]; +/* L10: */ + } + return 0; + +/* code for increment equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 5; + if (m == 0) { + goto L40; + } + i__2 = m; + for (i__ = 1; i__ <= i__2; ++i__) { + dx[i__] = *da * dx[i__]; +/* L30: */ + } + if (*n < 5) { + return 0; + } +L40: + mp1 = m + 1; + i__2 = *n; + for (i__ = mp1; i__ <= i__2; i__ += 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]; +/* L50: */ + } + return 0; +} /* dscal_ */ + +double dsdot_(integer *n, float *sx, integer *incx, float *sy, integer * + incy) +{ + /* System generated locals */ + integer i__1, i__2; + double ret_val; + + /* Local variables */ + integer i__, ns, kx, ky; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* AUTHORS */ +/* ======= */ +/* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), */ +/* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) */ + +/* Purpose */ +/* ======= */ +/* Compute the inner product of two vectors with extended */ +/* precision accumulation and result. */ + +/* Returns D.P. dot product accumulated in D.P., for S.P. SX and SY */ +/* DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), */ +/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */ +/* defined in a similar way using INCY. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* number of elements in input vector(s) */ + +/* SX (input) REAL array, dimension(N) */ +/* single precision vector with N elements */ + +/* INCX (input) INTEGER */ +/* storage spacing between elements of SX */ + +/* SY (input) REAL array, dimension(N) */ +/* single precision vector with N elements */ + +/* INCY (input) INTEGER */ +/* storage spacing between elements of SY */ + +/* DSDOT (output) DOUBLE PRECISION */ +/* DSDOT double precision dot product (zero if N.LE.0) */ + +/* REFERENCES */ +/* ========== */ + +/* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */ +/* Krogh, Basic linear algebra subprograms for Fortran */ +/* usage, Algorithm No. 539, Transactions on Mathematical */ +/* Software 5, 3 (September 1979), pp. 308-323. */ + +/* REVISION HISTORY (YYMMDD) */ +/* ========================== */ + +/* 791001 DATE WRITTEN */ +/* 890831 Modified array declarations. (WRB) */ +/* 890831 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* 070118 Reformat to LAPACK style (JL) */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + ret_val = 0.; + if (*n <= 0) { + return ret_val; + } + if (*incx == *incy && *incx > 0) { + goto L20; + } + +/* Code for unequal or nonpositive increments. */ + + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ret_val += (double) sx[kx] * (double) sy[ky]; + kx += *incx; + ky += *incy; +/* L10: */ + } + return ret_val; + +/* Code for equal, positive, non-unit increments. */ + +L20: + ns = *n * *incx; + i__1 = ns; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + ret_val += (double) sx[i__] * (double) sy[i__]; +/* L30: */ + } + return ret_val; +} /* dsdot_ */ + +/* Subroutine */ int dspmv_(const char *uplo, integer *n, double *alpha, + double *ap, double *x, integer *incx, double *beta, + double *y, integer *incy) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + double temp1, temp2; + + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order 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. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. */ +/* 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. */ +/* 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 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --y; + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 6; + } else if (*incy == 0) { + info = 9; + } + if (info != 0) { + xerbla_("DSPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form y when AP contains the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * ap[k]; + temp2 += ap[k] * x[i__]; + ++k; +/* L50: */ + } + y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; + kk += j; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + ix = kx; + iy = ky; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + y[iy] += temp1 * ap[k]; + temp2 += ap[k] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; + jx += *incx; + jy += *incy; + kk += j; +/* L80: */ + } + } + } else { + +/* Form y when AP contains the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + y[j] += temp1 * ap[kk]; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * ap[k]; + temp2 += ap[k] * x[i__]; + ++k; +/* L90: */ + } + y[j] += *alpha * temp2; + kk += *n - j + 1; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + y[jy] += temp1 * ap[kk]; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * ap[k]; + temp2 += ap[k] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; + kk += *n - j + 1; +/* L120: */ + } + } + } + + return 0; + +/* End of DSPMV . */ + +} /* dspmv_ */ + +/* Subroutine */ int dspr_(const char *uplo, integer *n, double *alpha, + double *x, integer *incx, double *ap) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + double temp; + + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPR performs the symmetric rank 1 operation */ + +/* A := alpha*x*x' + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* 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. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ + + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } + if (info != 0) { + xerbla_("DSPR ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = *alpha * x[j]; + k = kk; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ap[k] += x[i__] * temp; + ++k; +/* L10: */ + } + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + ix = kx; + i__2 = kk + j - 1; + for (k = kk; k <= i__2; ++k) { + ap[k] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = *alpha * x[j]; + k = kk; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[k] += x[i__] * temp; + ++k; +/* L50: */ + } + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + ix = jx; + i__2 = kk + *n - j; + for (k = kk; k <= i__2; ++k) { + ap[k] += x[ix] * temp; + ix += *incx; +/* L70: */ + } + } + jx += *incx; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of DSPR . */ + +} /* dspr_ */ + +/* Subroutine */ int dspr2_(const char *uplo, integer *n, double *alpha, + double *x, integer *incx, double *y, integer *incy, + double *ap) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; + double temp1, temp2; + + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPR2 performs the symmetric rank 2 operation */ + +/* A := alpha*x*y' + alpha*y*x' + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an */ +/* n by n symmetric matrix, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the matrix A is supplied in the packed */ +/* array AP as follows: */ + +/* UPLO = 'U' or 'u' The upper triangular part of A is */ +/* supplied in AP. */ + +/* UPLO = 'L' or 'l' The lower triangular part of A is */ +/* supplied in AP. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* 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. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ +/* and a( 2, 2 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the upper triangular part of the */ +/* updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular part of the symmetric matrix */ +/* packed sequentially, column by column, so that AP( 1 ) */ +/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ +/* and a( 3, 1 ) respectively, and so on. On exit, the array */ +/* AP is overwritten by the lower triangular part of the */ +/* updated matrix. */ + + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --y; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } + if (info != 0) { + xerbla_("DSPR2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of the array AP */ +/* are accessed sequentially with one pass through AP. */ + + kk = 1; + if (lsame_(uplo, "U")) { + +/* Form A when upper triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + k = kk; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; + ++k; +/* L10: */ + } + } + kk += j; +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = kx; + iy = ky; + i__2 = kk + j - 1; + for (k = kk; k <= i__2; ++k) { + ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L30: */ + } + } + jx += *incx; + jy += *incy; + kk += j; +/* L40: */ + } + } + } else { + +/* Form A when lower triangle is stored in AP. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + k = kk; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; + ++k; +/* L50: */ + } + } + kk = kk + *n - j + 1; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = jx; + iy = jy; + i__2 = kk + *n - j; + for (k = kk; k <= i__2; ++k) { + ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + jy += *incy; + kk = kk + *n - j + 1; +/* L80: */ + } + } + } + + return 0; + +/* End of DSPR2 . */ + +} /* dspr2_ */ + +/* Subroutine */ int dswap_(integer *n, double *dx, integer *incx, + double *dy, integer *incy) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, m, ix, iy, mp1; + double dtemp; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* interchanges two vectors. */ +/* uses unrolled loops for increments equal one. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = dx[ix]; + dx[ix] = dy[iy]; + dy[iy] = dtemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + + +/* clean-up loop */ + +L20: + m = *n % 3; + if (m == 0) { + goto L40; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = dx[i__]; + dx[i__] = dy[i__]; + dy[i__] = dtemp; +/* L30: */ + } + if (*n < 3) { + return 0; + } +L40: + mp1 = m + 1; + i__1 = *n; + for (i__ = mp1; i__ <= i__1; i__ += 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; +/* L50: */ + } + return 0; +} /* dswap_ */ + +/* Subroutine */ int dsymm_(const char *side, const char *uplo, integer *m, integer *n, + double *alpha, double *a, integer *lda, double *b, + integer *ldb, double *beta, double *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, k, info; + double temp1, temp2; + + integer nrowa; + bool upper; + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYMM performs one of the matrix-matrix operations */ + +/* C := alpha*A*B + beta*C, */ + +/* or */ + +/* C := alpha*B*A + beta*C, */ + +/* where alpha and beta are scalars, A is a symmetric matrix and B and */ +/* C are m by n matrices. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether the symmetric matrix A */ +/* appears on the left or right in the operation as follows: */ + +/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */ + +/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */ + +/* Unchanged on exit. */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the symmetric matrix A is to be */ +/* referenced as follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of the */ +/* symmetric matrix is to be referenced. */ + +/* Unchanged on exit. */ + +/* M - INTEGER. */ +/* On entry, M specifies the number of rows 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 C. */ +/* 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, ka ), where ka is */ +/* m when SIDE = 'L' or 'l' and is n otherwise. */ +/* Before entry with SIDE = 'L' or 'l', the m by m part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading m by m upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading m by m lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* Before entry with SIDE = 'R' or 'r', the n by n part of */ +/* the array A must contain the symmetric matrix, such that */ +/* when UPLO = 'U' or 'u', the leading n by n upper triangular */ +/* part of the array A must contain the upper triangular part */ +/* of the symmetric matrix and the strictly lower triangular */ +/* part of A is not referenced, and when UPLO = 'L' or 'l', */ +/* the leading n by n lower triangular part of the array A */ +/* must contain the lower triangular part of the symmetric */ +/* matrix and the strictly upper triangular part of A is not */ +/* referenced. */ +/* 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 ), otherwise 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. */ +/* Unchanged on exit. */ + +/* 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. */ + +/* 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 updated */ +/* matrix. */ + +/* 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 .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Set NROWA as the number of rows of A. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(side, "L")) { + nrowa = *m; + } else { + nrowa = *n; + } + upper = lsame_(uplo, "U"); + +/* Test the input parameters. */ + + info = 0; + if (! lsame_(side, "L") && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (*m < 0) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < std::max(1_integer,nrowa)) { + info = 7; + } else if (*ldb < std::max(1_integer,*m)) { + info = 9; + } else if (*ldc < std::max(1_integer,*m)) { + info = 12; + } + if (info != 0) { + xerbla_("DSYMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(side, "L")) { + +/* Form C := alpha*A*B + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; +/* L50: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * + temp2; + } +/* L60: */ + } +/* L70: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp1 = *alpha * b[i__ + j * b_dim1]; + temp2 = 0.; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; + temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; +/* L80: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] + + *alpha * temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * a[i__ + i__ * a_dim1] + *alpha * + temp2; + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form C := alpha*B*A + beta*C. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * a[j + j * a_dim1]; + if (*beta == 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1]; +/* L110: */ + } + } else { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + temp1 * b[i__ + j * b_dim1]; +/* L120: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[k + j * a_dim1]; + } else { + temp1 = *alpha * a[j + k * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; +/* L130: */ + } +/* L140: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (upper) { + temp1 = *alpha * a[j + k * a_dim1]; + } else { + temp1 = *alpha * a[k + j * a_dim1]; + } + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + } + + return 0; + +/* End of DSYMM . */ + +} /* dsymm_ */ + +/* Subroutine */ int dsymv_(const char *uplo, integer *n, double *alpha, + double *a, integer *lda, double *x, integer *incx, double + *beta, double *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + double temp1, temp2; + + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYMV performs the matrix-vector operation */ + +/* y := alpha*A*x + beta*y, */ + +/* where alpha and beta are scalars, x and y are n element vectors and */ +/* A is an n by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order 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 with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the symmetric 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 part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. */ +/* 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. */ +/* 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 + ( n - 1 )*abs( INCY ) ). */ +/* Before entry, the incremented array Y must contain the n */ +/* element 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < std::max(1_integer,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("DSYMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + +/* First form y := beta*y. */ + + if (*beta != 1.) { + if (*incy == 1) { + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = *beta * y[i__]; +/* L20: */ + } + } + } else { + iy = ky; + if (*beta == 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = 0.; + iy += *incy; +/* L30: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[iy] = *beta * y[iy]; + iy += *incy; +/* L40: */ + } + } + } + } + if (*alpha == 0.) { + return 0; + } + if (lsame_(uplo, "U")) { + +/* Form y when A is stored in upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; +/* L50: */ + } + y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; +/* L60: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + ix = kx; + iy = ky; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; + ix += *incx; + iy += *incy; +/* L70: */ + } + y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } else { + +/* Form y when A is stored in lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[j]; + temp2 = 0.; + y[j] += temp1 * a[j + j * a_dim1]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + y[i__] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + y[j] += *alpha * temp2; +/* L100: */ + } + } else { + jx = kx; + jy = ky; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp1 = *alpha * x[jx]; + temp2 = 0.; + y[jy] += temp1 * a[j + j * a_dim1]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + iy += *incy; + y[iy] += temp1 * a[i__ + j * a_dim1]; + temp2 += a[i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + y[jy] += *alpha * temp2; + jx += *incx; + jy += *incy; +/* L120: */ + } + } + } + + return 0; + +/* End of DSYMV . */ + +} /* dsymv_ */ + +/* Subroutine */ int dsyr_(const char *uplo, integer *n, double *alpha, + double *x, integer *incx, double *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + double temp; + + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYR performs the symmetric rank 1 operation */ + +/* A := alpha*x*x' + A, */ + +/* where alpha is a real scalar, x is an n element vector and A is an */ +/* n by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* 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. */ + +/* 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 part of the symmetric matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of 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, n ). */ +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*lda < std::max(1_integer,*n)) { + info = 7; + } + if (info != 0) { + xerbla_("DSYR ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set the start point in X if the increment is not unity. */ + + if (*incx <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in upper triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = *alpha * x[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + ix = kx; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L30: */ + } + } + jx += *incx; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in lower triangle. */ + + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = *alpha * x[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[i__] * temp; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = *alpha * x[jx]; + ix = jx; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] += x[ix] * temp; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + + return 0; + +/* End of DSYR . */ + +} /* dsyr_ */ + +/* Subroutine */ int dsyr2_(const char *uplo, integer *n, double *alpha, + double *x, integer *incx, double *y, integer *incy, + double *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, iy, jx, jy, kx, ky, info; + double temp1, temp2; + + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYR2 performs the symmetric rank 2 operation */ + +/* A := alpha*x*y' + alpha*y*x' + A, */ + +/* where alpha is a scalar, x and y are n element vectors and A is an n */ +/* by n symmetric matrix. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array A is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of A */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of A */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ +/* Before entry, the incremented array X must contain the n */ +/* 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 with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array A must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of A is not referenced. On exit, the */ +/* upper triangular part of the array A is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array A must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of A is not referenced. On exit, the */ +/* lower triangular part of the array A is overwritten by the */ +/* lower triangular part of 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, n ). */ +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --y; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*incx == 0) { + info = 5; + } else if (*incy == 0) { + info = 7; + } else if (*lda < std::max(1_integer,*n)) { + info = 9; + } + if (info != 0) { + xerbla_("DSYR2 ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0.) { + return 0; + } + +/* Set up the start points in X and Y if the increments are not both */ +/* unity. */ + + if (*incx != 1 || *incy != 1) { + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + jx = kx; + jy = ky; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through the triangular part */ +/* of A. */ + + if (lsame_(uplo, "U")) { + +/* Form A when A is stored in the upper triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * + temp1 + y[i__] * temp2; +/* L10: */ + } + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = kx; + iy = ky; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * + temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L30: */ + } + } + jx += *incx; + jy += *incy; +/* L40: */ + } + } + } else { + +/* Form A when A is stored in the lower triangle. */ + + if (*incx == 1 && *incy == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0. || y[j] != 0.) { + temp1 = *alpha * y[j]; + temp2 = *alpha * x[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * + temp1 + y[i__] * temp2; +/* L50: */ + } + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0. || y[jy] != 0.) { + temp1 = *alpha * y[jy]; + temp2 = *alpha * x[jx]; + ix = jx; + iy = jy; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * + temp1 + y[iy] * temp2; + ix += *incx; + iy += *incy; +/* L70: */ + } + } + jx += *incx; + jy += *incy; +/* L80: */ + } + } + } + + return 0; + +/* End of DSYR2 . */ + +} /* dsyr2_ */ + +/* Subroutine */ int dsyr2k_(const char *uplo, const char *trans, integer *n, integer *k, + double *alpha, double *a, integer *lda, double *b, + integer *ldb, double *beta, double *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, j, l, info; + double temp1, temp2; + + integer nrowa; + bool upper; + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYR2K performs one of the symmetric rank 2k operations */ + +/* C := alpha*A*B' + alpha*B*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*B + alpha*B'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A and B are n by k matrices in the first case and k by n */ +/* matrices in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */ +/* beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */ +/* beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */ +/* beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrices A and B, and on entry with */ +/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ +/* of rows of the matrices A and 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 TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n 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 TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */ +/* k when TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array B must contain the matrix B, otherwise */ +/* the leading k by n 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 TRANS = 'N' or 'n' */ +/* then LDB must be at least max( 1, n ), otherwise LDB must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* 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, n ). */ +/* 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 .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < std::max(1_integer,nrowa)) { + info = 7; + } else if (*ldb < std::max(1_integer,nrowa)) { + info = 9; + } else if (*ldc < std::max(1_integer,*n)) { + info = 12; + } + if (info != 0) { + xerbla_("DSYR2K", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*B' + alpha*B*A' + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L90: */ + } + } else if (*beta != 1.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ + i__ + l * a_dim1] * temp1 + b[i__ + l * + b_dim1] * temp2; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L140: */ + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { + temp1 = *alpha * b[j + l * b_dim1]; + temp2 = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ + i__ + l * a_dim1] * temp1 + b[i__ + l * + b_dim1] * temp2; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*B + alpha*B'*A + C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp1 = 0.; + temp2 = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; +/* L190: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * + temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + *alpha * temp1 + *alpha * temp2; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp1 = 0.; + temp2 = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; + temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; +/* L220: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * + temp2; + } else { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + + *alpha * temp1 + *alpha * temp2; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of DSYR2K. */ + +} /* dsyr2k_ */ + +/* Subroutine */ int dsyrk_(const char *uplo, const char *trans, integer *n, integer *k, + double *alpha, double *a, integer *lda, double *beta, + double *c__, integer *ldc) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, l, info; + double temp; + + integer nrowa; + bool upper; + + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYRK performs one of the symmetric rank k operations */ + +/* C := alpha*A*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*A + beta*C, */ + +/* where alpha and beta are scalars, C is an n by n symmetric matrix */ +/* and A is an n by k matrix in the first case and a k by n matrix */ +/* in the second case. */ + +/* Arguments */ +/* ========== */ + +/* UPLO - CHARACTER*1. */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - CHARACTER*1. */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ + +/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */ + +/* Unchanged on exit. */ + +/* N - INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrix A, and on entry with */ +/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ +/* of rows of the matrix A. 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 TRANS = 'N' or 'n', and is n otherwise. */ +/* Before entry with TRANS = 'N' or 'n', the leading n by k */ +/* part of the array A must contain the matrix A, otherwise */ +/* the leading k by n 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 TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + +/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading n by n */ +/* upper triangular part of the array C must contain the upper */ +/* triangular part of the symmetric matrix and the strictly */ +/* lower triangular part of C is not referenced. On exit, the */ +/* upper triangular part of the array C is overwritten by the */ +/* upper triangular part of the updated matrix. */ +/* Before entry with UPLO = 'L' or 'l', the leading n by n */ +/* lower triangular part of the array C must contain the lower */ +/* triangular part of the symmetric matrix and the strictly */ +/* upper triangular part of C is not referenced. On exit, the */ +/* lower triangular part of the array C is overwritten by the */ +/* lower triangular part of the updated matrix. */ + +/* 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, n ). */ +/* 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 .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + if (lsame_(trans, "N")) { + nrowa = *n; + } else { + nrowa = *k; + } + upper = lsame_(uplo, "U"); + + info = 0; + if (! upper && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*k < 0) { + info = 4; + } else if (*lda < std::max(1_integer,nrowa)) { + info = 7; + } else if (*ldc < std::max(1_integer,*n)) { + info = 10; + } + if (info != 0) { + xerbla_("DSYRK ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + if (upper) { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else { + if (*beta == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L70: */ + } +/* L80: */ + } + } + } + return 0; + } + +/* Start the operations. */ + + if (lsame_(trans, "N")) { + +/* Form C := alpha*A*A' + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L90: */ + } + } else if (*beta != 1.) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L100: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = j; + for (i__ = 1; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L110: */ + } + } +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*beta == 0.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = 0.; +/* L140: */ + } + } else if (*beta != 1.) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; +/* L150: */ + } + } + i__2 = *k; + for (l = 1; l <= i__2; ++l) { + if (a[j + l * a_dim1] != 0.) { + temp = *alpha * a[j + l * a_dim1]; + i__3 = *n; + for (i__ = j; i__ <= i__3; ++i__) { + c__[i__ + j * c_dim1] += temp * a[i__ + l * + a_dim1]; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } + } else { + +/* Form C := alpha*A'*A + beta*C. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; +/* L190: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L200: */ + } +/* L210: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + temp = 0.; + i__3 = *k; + for (l = 1; l <= i__3; ++l) { + temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; +/* L220: */ + } + if (*beta == 0.) { + c__[i__ + j * c_dim1] = *alpha * temp; + } else { + c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ + i__ + j * c_dim1]; + } +/* L230: */ + } +/* L240: */ + } + } + } + + return 0; + +/* End of DSYRK . */ + +} /* dsyrk_ */ + +/* Subroutine */ int dtbmv_(const char *uplo, const char *trans, const char *diag, integer *n, + integer *k, double *a, integer *lda, double *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + double temp; + + integer kplus1; + + bool nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTBMV 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 band matrix, with ( k + 1 ) diagonals. */ + +/* Arguments */ +/* ========== */ + +/* 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. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, 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 */ +/* ( k + 1 ). */ +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("DTBMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + 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 <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = x[j]; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + x[i__] += temp * a[l + i__ + j * a_dim1]; +/* L10: */ + } + if (nounit) { + x[j] *= a[kplus1 + j * a_dim1]; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { + x[ix] += temp * a[l + i__ + j * a_dim1]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= a[kplus1 + j * a_dim1]; + } + } + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + temp = x[j]; + l = 1 - j; +/* Computing MIN */ + i__1 = *n, i__3 = j + *k; + i__4 = j + 1; + for (i__ = std::min(i__1,i__3); i__ >= i__4; --i__) { + x[i__] += temp * a[l + i__ + j * a_dim1]; +/* L50: */ + } + if (nounit) { + x[j] *= a[j * a_dim1 + 1]; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__1 = j + *k; + i__3 = j + 1; + for (i__ = std::min(i__4,i__1); i__ >= i__3; --i__) { + x[ix] += temp * a[l + i__ + j * a_dim1]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= a[j * a_dim1 + 1]; + } + } + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + l = kplus1 - j; + if (nounit) { + temp *= a[kplus1 + j * a_dim1]; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = std::max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + temp += a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + x[j] = temp; +/* L100: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + kx -= *incx; + ix = kx; + l = kplus1 - j; + if (nounit) { + temp *= a[kplus1 + j * a_dim1]; + } +/* Computing MAX */ + i__4 = 1, i__1 = j - *k; + i__3 = std::max(i__4,i__1); + for (i__ = j - 1; i__ >= i__3; --i__) { + temp += a[l + i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + temp = x[j]; + l = 1 - j; + if (nounit) { + temp *= a[j * a_dim1 + 1]; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = std::min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + temp += a[l + i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + x[j] = temp; +/* L140: */ + } + } else { + jx = kx; + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + temp = x[jx]; + kx += *incx; + ix = kx; + l = 1 - j; + if (nounit) { + temp *= a[j * a_dim1 + 1]; + } +/* Computing MIN */ + i__1 = *n, i__2 = j + *k; + i__4 = std::min(i__1,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + temp += a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L150: */ + } + x[jx] = temp; + jx += *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTBMV . */ + +} /* dtbmv_ */ + +/* Subroutine */ int dtbsv_(const char *uplo, const char *trans, const char *diag, integer *n, + integer *k, double *a, integer *lda, double *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ix, jx, kx, info; + double temp; + + integer kplus1; + + bool nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTBSV 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 band matrix, with ( k + 1 ) */ +/* diagonals. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* 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. */ + +/* K - INTEGER. */ +/* On entry with UPLO = 'U' or 'u', K specifies the number of */ +/* super-diagonals of the matrix A. */ +/* On entry with UPLO = 'L' or 'l', K specifies the number of */ +/* sub-diagonals of the matrix A. */ +/* K must satisfy 0 .le. K. */ +/* Unchanged on exit. */ + +/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ +/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ +/* by n part of the array A must contain the upper triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row */ +/* ( k + 1 ) of the array, the first super-diagonal starting at */ +/* position 2 in row k, and so on. The top left k by k triangle */ +/* of the array A is not referenced. */ +/* The following program segment will transfer an upper */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = K + 1 - J */ +/* DO 10, I = MAX( 1, J - K ), J */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ +/* by n part of the array A must contain the lower triangular */ +/* band part of the matrix of coefficients, supplied column by */ +/* column, with the leading diagonal of the matrix in row 1 of */ +/* the array, the first sub-diagonal starting at position 1 in */ +/* row 2, and so on. The bottom right k by k triangle of the */ +/* array A is not referenced. */ +/* The following program segment will transfer a lower */ +/* triangular band matrix from conventional full matrix storage */ +/* to band storage: */ + +/* DO 20, J = 1, N */ +/* M = 1 - J */ +/* DO 10, I = J, MIN( N, J + K ) */ +/* A( M + I, J ) = matrix( I, J ) */ +/* 10 CONTINUE */ +/* 20 CONTINUE */ + +/* Note that when DIAG = 'U' or 'u' the elements of the array A */ +/* corresponding to the diagonal elements of the matrix are not */ +/* referenced, 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 */ +/* ( k + 1 ). */ +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*k < 0) { + info = 5; + } else if (*lda < *k + 1) { + info = 7; + } else if (*incx == 0) { + info = 9; + } + if (info != 0) { + xerbla_("DTBSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + 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 <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed by sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + l = kplus1 - j; + if (nounit) { + x[j] /= a[kplus1 + j * a_dim1]; + } + temp = x[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = std::max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + x[i__] -= temp * a[l + i__ + j * a_dim1]; +/* L10: */ + } + } +/* L20: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + kx -= *incx; + if (x[jx] != 0.) { + ix = kx; + l = kplus1 - j; + if (nounit) { + x[jx] /= a[kplus1 + j * a_dim1]; + } + temp = x[jx]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__1 = std::max(i__2,i__3); + for (i__ = j - 1; i__ >= i__1; --i__) { + x[ix] -= temp * a[l + i__ + j * a_dim1]; + ix -= *incx; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + l = 1 - j; + if (nounit) { + x[j] /= a[j * a_dim1 + 1]; + } + temp = x[j]; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = std::min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * a[l + i__ + j * a_dim1]; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + kx += *incx; + if (x[jx] != 0.) { + ix = kx; + l = 1 - j; + if (nounit) { + x[jx] /= a[j * a_dim1 + 1]; + } + temp = x[jx]; +/* Computing MIN */ + i__3 = *n, i__4 = j + *k; + i__2 = std::min(i__3,i__4); + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[ix] -= temp * a[l + i__ + j * a_dim1]; + ix += *incx; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A')*x. */ + + if (lsame_(uplo, "U")) { + kplus1 = *k + 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + l = kplus1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + temp -= a[l + i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + if (nounit) { + temp /= a[kplus1 + j * a_dim1]; + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + l = kplus1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j - 1; + for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { + temp -= a[l + i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= a[kplus1 + j * a_dim1]; + } + x[jx] = temp; + jx += *incx; + if (j > *k) { + kx += *incx; + } +/* L120: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + l = 1 - j; +/* Computing MIN */ + i__1 = *n, i__3 = j + *k; + i__4 = j + 1; + for (i__ = std::min(i__1,i__3); i__ >= i__4; --i__) { + temp -= a[l + i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + if (nounit) { + temp /= a[j * a_dim1 + 1]; + } + x[j] = temp; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__1 = j + *k; + i__3 = j + 1; + for (i__ = std::min(i__4,i__1); i__ >= i__3; --i__) { + temp -= a[l + i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= a[j * a_dim1 + 1]; + } + x[jx] = temp; + jx -= *incx; + if (*n - j >= *k) { + kx -= *incx; + } +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTBSV . */ + +} /* dtbsv_ */ + +/* Subroutine */ int dtpmv_(const char *uplo, const char *trans, const char *diag, integer *n, + double *ap, double *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + double temp; + + + bool nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPMV 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, supplied in packed form. */ + +/* Arguments */ +/* ========== */ + +/* 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. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("DTPMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + 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 <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x:= A*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = x[j]; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__] += temp * ap[k]; + ++k; +/* L10: */ + } + if (nounit) { + x[j] *= ap[kk + j - 1]; + } + } + kk += j; +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + x[ix] += temp * ap[k]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= ap[kk + j - 1]; + } + } + jx += *incx; + kk += j; +/* L40: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + temp = x[j]; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[i__] += temp * ap[k]; + --k; +/* L50: */ + } + if (nounit) { + x[j] *= ap[kk - *n + j]; + } + } + kk -= *n - j + 1; +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + x[ix] += temp * ap[k]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= ap[kk - *n + j]; + } + } + jx -= *incx; + kk -= *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= ap[kk]; + } + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + temp += ap[k] * x[i__]; + --k; +/* L90: */ + } + x[j] = temp; + kk -= j; +/* L100: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= ap[kk]; + } + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + temp += ap[k] * x[ix]; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; + kk -= j; +/* L120: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= ap[kk]; + } + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += ap[k] * x[i__]; + ++k; +/* L130: */ + } + x[j] = temp; + kk += *n - j + 1; +/* L140: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= ap[kk]; + } + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + temp += ap[k] * x[ix]; +/* L150: */ + } + x[jx] = temp; + jx += *incx; + kk += *n - j + 1; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTPMV . */ + +} /* dtpmv_ */ + +/* Subroutine */ int dtpsv_(const char *uplo, const char *trans, const char *diag, integer *n, + double *ap, double *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, k, kk, ix, jx, kx, info; + double temp; + + + bool nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPSV 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, supplied in packed form. */ + +/* No test for singularity or near-singularity is included in this */ +/* routine. Such tests must be performed before calling this routine. */ + +/* Arguments */ +/* ========== */ + +/* 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. */ + +/* AP - DOUBLE PRECISION array of DIMENSION at least */ +/* ( ( n*( n + 1 ) )/2 ). */ +/* Before entry with UPLO = 'U' or 'u', the array AP must */ +/* contain the upper triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ +/* respectively, and so on. */ +/* Before entry with UPLO = 'L' or 'l', the array AP must */ +/* contain the lower triangular matrix packed sequentially, */ +/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ +/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ +/* respectively, and so on. */ +/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ +/* A are not referenced, but are assumed to be unity. */ +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --x; + --ap; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*incx == 0) { + info = 7; + } + if (info != 0) { + xerbla_("DTPSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + 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 <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of AP are */ +/* accessed sequentially with one pass through AP. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= ap[kk]; + } + temp = x[j]; + k = kk - 1; + for (i__ = j - 1; i__ >= 1; --i__) { + x[i__] -= temp * ap[k]; + --k; +/* L10: */ + } + } + kk -= j; +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= ap[kk]; + } + temp = x[jx]; + ix = jx; + i__1 = kk - j + 1; + for (k = kk - 1; k >= i__1; --k) { + ix -= *incx; + x[ix] -= temp * ap[k]; +/* L30: */ + } + } + jx -= *incx; + kk -= j; +/* L40: */ + } + } + } else { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= ap[kk]; + } + temp = x[j]; + k = kk + 1; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * ap[k]; + ++k; +/* L50: */ + } + } + kk += *n - j + 1; +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= ap[kk]; + } + temp = x[jx]; + ix = jx; + i__2 = kk + *n - j; + for (k = kk + 1; k <= i__2; ++k) { + ix += *incx; + x[ix] -= temp * ap[k]; +/* L70: */ + } + } + jx += *incx; + kk += *n - j + 1; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x. */ + + if (lsame_(uplo, "U")) { + kk = 1; + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + k = kk; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= ap[k] * x[i__]; + ++k; +/* L90: */ + } + if (nounit) { + temp /= ap[kk + j - 1]; + } + x[j] = temp; + kk += j; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + i__2 = kk + j - 2; + for (k = kk; k <= i__2; ++k) { + temp -= ap[k] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= ap[kk + j - 1]; + } + x[jx] = temp; + jx += *incx; + kk += j; +/* L120: */ + } + } + } else { + kk = *n * (*n + 1) / 2; + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + k = kk; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= ap[k] * x[i__]; + --k; +/* L130: */ + } + if (nounit) { + temp /= ap[kk - *n + j]; + } + x[j] = temp; + kk -= *n - j + 1; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + i__1 = kk - (*n - (j + 1)); + for (k = kk; k >= i__1; --k) { + temp -= ap[k] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= ap[kk - *n + j]; + } + x[jx] = temp; + jx -= *incx; + kk -= *n - j + 1; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTPSV . */ + +} /* dtpsv_ */ + +/* Subroutine */ int dtrmm_(const char *side, const char *uplo, const char *transa, const char *diag, + integer *m, integer *n, double *alpha, double *a, integer * + lda, double *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, info; + double temp; + bool lside; + + integer nrowa; + bool upper; + + bool nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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'. */ + +/* Arguments */ +/* ========== */ + +/* 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 .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < std::max(1_integer,nrowa)) { + info = 9; + } else if (*ldb < std::max(1_integer,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("DTRMM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { // changed in lapack 3.2.1 + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*A*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.) { + temp = *alpha * b[k + j * b_dim1]; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * + a_dim1]; +/* L30: */ + } + if (nounit) { + temp *= a[k + k * a_dim1]; + } + b[k + j * b_dim1] = temp; + } +/* L40: */ + } +/* L50: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.) { + temp = *alpha * b[k + j * b_dim1]; + b[k + j * b_dim1] = temp; + if (nounit) { + b[k + j * b_dim1] *= a[k + k * a_dim1]; + } + i__2 = *m; + for (i__ = k + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * a[i__ + k * + a_dim1]; +/* L60: */ + } + } +/* L70: */ + } +/* L80: */ + } + } + } else { + +/* Form B := alpha*A'*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__2 = i__ - 1; + for (k = 1; k <= i__2; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L90: */ + } + b[i__ + j * b_dim1] = *alpha * temp; +/* L100: */ + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = b[i__ + j * b_dim1]; + if (nounit) { + temp *= a[i__ + i__ * a_dim1]; + } + i__3 = *m; + for (k = i__ + 1; k <= i__3; ++k) { + temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L120: */ + } + b[i__ + j * b_dim1] = *alpha * temp; +/* L130: */ + } +/* L140: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*A. */ + + if (upper) { + for (j = *n; j >= 1; --j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L150: */ + } + i__1 = j - 1; + for (k = 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.) { + temp = *alpha * a[k + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L160: */ + } + } +/* L170: */ + } +/* L180: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = *alpha; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L190: */ + } + i__2 = *n; + for (k = j + 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.) { + temp = *alpha * a[k + j * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L200: */ + } + } +/* L210: */ + } +/* L220: */ + } + } + } else { + +/* Form B := alpha*B*A'. */ + + if (upper) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + for (j = 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L230: */ + } + } +/* L240: */ + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L250: */ + } + } +/* L260: */ + } + } else { + for (k = *n; k >= 1; --k) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = *alpha * a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] += temp * b[i__ + k * + b_dim1]; +/* L270: */ + } + } +/* L280: */ + } + temp = *alpha; + if (nounit) { + temp *= a[k + k * a_dim1]; + } + if (temp != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L290: */ + } + } +/* L300: */ + } + } + } + } + + return 0; + +/* End of DTRMM . */ + +} /* dtrmm_ */ + +/* Subroutine */ int dtrmv_(const char *uplo, const char *trans, const char *diag, integer *n, + double *a, integer *lda, double *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + double temp; + + + bool nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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. */ + +/* Arguments */ +/* ========== */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < std::max(1_integer,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("DTRMV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + 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 <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := A*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__] += temp * a[i__ + j * a_dim1]; +/* L10: */ + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } +/* L20: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix += *incx; +/* L30: */ + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx += *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[i__] += temp * a[i__ + j * a_dim1]; +/* L50: */ + } + if (nounit) { + x[j] *= a[j + j * a_dim1]; + } + } +/* L60: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + x[ix] += temp * a[i__ + j * a_dim1]; + ix -= *incx; +/* L70: */ + } + if (nounit) { + x[jx] *= a[j + j * a_dim1]; + } + } + jx -= *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := A'*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + temp += a[i__ + j * a_dim1] * x[ix]; +/* L110: */ + } + x[jx] = temp; + jx -= *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp += a[i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + x[j] = temp; +/* L140: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = jx; + if (nounit) { + temp *= a[j + j * a_dim1]; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + temp += a[i__ + j * a_dim1] * x[ix]; +/* L150: */ + } + x[jx] = temp; + jx += *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTRMV . */ + +} /* dtrmv_ */ + +/* Subroutine */ int dtrsm_(const char *side, const char *uplo, const char *transa, const char *diag, + integer *m, integer *n, double *alpha, double *a, integer * + lda, double *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, info; + double temp; + bool lside; + + integer nrowa; + bool upper; + + bool nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRSM solves one of the matrix equations */ + +/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ + +/* where alpha is a scalar, X and B are m by n matrices, 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'. */ + +/* The matrix X is overwritten on B. */ + +/* Arguments */ +/* ========== */ + +/* SIDE - CHARACTER*1. */ +/* On entry, SIDE specifies whether op( A ) appears on the left */ +/* or right of X as follows: */ + +/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ + +/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ + +/* 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 right-hand side matrix B, and on exit is */ +/* overwritten by the solution matrix X. */ + +/* 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 .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + lside = lsame_(side, "L"); + if (lside) { + nrowa = *m; + } else { + nrowa = *n; + } + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + + info = 0; + if (! lside && ! lsame_(side, "R")) { + info = 1; + } else if (! upper && ! lsame_(uplo, "L")) { + info = 2; + } else if (! lsame_(transa, "N") && ! lsame_(transa, + "T") && ! lsame_(transa, "C")) { + info = 3; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 4; + } else if (*m < 0) { + info = 5; + } else if (*n < 0) { + info = 6; + } else if (*lda < std::max(1_integer,nrowa)) { + info = 9; + } else if (*ldb < std::max(1_integer,*m)) { + info = 11; + } + if (info != 0) { + xerbla_("DTRSM ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { // changed in lapack 3.2.1 + return 0; + } + +/* And when alpha.eq.zero. */ + + if (*alpha == 0.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + return 0; + } + +/* Start the operations. */ + + if (lside) { + if (lsame_(transa, "N")) { + +/* Form B := alpha*inv( A )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L30: */ + } + } + for (k = *m; k >= 1; --k) { + if (b[k + j * b_dim1] != 0.) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__2 = k - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ + i__ + k * a_dim1]; +/* L40: */ + } + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L70: */ + } + } + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (b[k + j * b_dim1] != 0.) { + if (nounit) { + b[k + j * b_dim1] /= a[k + k * a_dim1]; + } + i__3 = *m; + for (i__ = k + 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ + i__ + k * a_dim1]; +/* L80: */ + } + } +/* L90: */ + } +/* L100: */ + } + } + } else { + +/* Form B := alpha*inv( A' )*B. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__3 = i__ - 1; + for (k = 1; k <= i__3; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L110: */ + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; +/* L120: */ + } +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + temp = *alpha * b[i__ + j * b_dim1]; + i__2 = *m; + for (k = i__ + 1; k <= i__2; ++k) { + temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; +/* L140: */ + } + if (nounit) { + temp /= a[i__ + i__ * a_dim1]; + } + b[i__ + j * b_dim1] = temp; +/* L150: */ + } +/* L160: */ + } + } + } + } else { + if (lsame_(transa, "N")) { + +/* Form B := alpha*B*inv( A ). */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L170: */ + } + } + i__2 = j - 1; + for (k = 1; k <= i__2; ++k) { + if (a[k + j * a_dim1] != 0.) { + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ + i__ + k * b_dim1]; +/* L180: */ + } + } +/* L190: */ + } + if (nounit) { + temp = 1. / a[j + j * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L200: */ + } + } +/* L210: */ + } + } else { + for (j = *n; j >= 1; --j) { + if (*alpha != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] + ; +/* L220: */ + } + } + i__1 = *n; + for (k = j + 1; k <= i__1; ++k) { + if (a[k + j * a_dim1] != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ + i__ + k * b_dim1]; +/* L230: */ + } + } +/* L240: */ + } + if (nounit) { + temp = 1. / a[j + j * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; +/* L250: */ + } + } +/* L260: */ + } + } + } else { + +/* Form B := alpha*B*inv( A' ). */ + + if (upper) { + for (k = *n; k >= 1; --k) { + if (nounit) { + temp = 1. / a[k + k * a_dim1]; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L270: */ + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = a[j + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * + b_dim1]; +/* L280: */ + } + } +/* L290: */ + } + if (*alpha != 1.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] + ; +/* L300: */ + } + } +/* L310: */ + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (nounit) { + temp = 1. / a[k + k * a_dim1]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; +/* L320: */ + } + } + i__2 = *n; + for (j = k + 1; j <= i__2; ++j) { + if (a[j + k * a_dim1] != 0.) { + temp = a[j + k * a_dim1]; + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + b[i__ + j * b_dim1] -= temp * b[i__ + k * + b_dim1]; +/* L330: */ + } + } +/* L340: */ + } + if (*alpha != 1.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] + ; +/* L350: */ + } + } +/* L360: */ + } + } + } + } + + return 0; + +/* End of DTRSM . */ + +} /* dtrsm_ */ + +/* Subroutine */ int dtrsv_(const char *uplo, const char *trans, const char *diag, integer *n, + double *a, integer *lda, double *x, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ix, jx, kx, info; + double temp; + + + bool nounit; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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. */ + +/* Arguments */ +/* ========== */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + + /* Function Body */ + info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + info = 1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + info = 2; + } else if (! lsame_(diag, "U") && ! lsame_(diag, + "N")) { + info = 3; + } else if (*n < 0) { + info = 4; + } else if (*lda < std::max(1_integer,*n)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } + if (info != 0) { + xerbla_("DTRSV ", &info); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + + 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 <= 0) { + kx = 1 - (*n - 1) * *incx; + } else if (*incx != 1) { + kx = 1; + } + +/* Start the operations. In this version the elements of A are */ +/* accessed sequentially with one pass through A. */ + + if (lsame_(trans, "N")) { + +/* Form x := inv( A )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + for (i__ = j - 1; i__ >= 1; --i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; +/* L10: */ + } + } +/* L20: */ + } + } else { + jx = kx + (*n - 1) * *incx; + for (j = *n; j >= 1; --j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + for (i__ = j - 1; i__ >= 1; --i__) { + ix -= *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; +/* L30: */ + } + } + jx -= *incx; +/* L40: */ + } + } + } else { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[j] != 0.) { + if (nounit) { + x[j] /= a[j + j * a_dim1]; + } + temp = x[j]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + x[i__] -= temp * a[i__ + j * a_dim1]; +/* L50: */ + } + } +/* L60: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (x[jx] != 0.) { + if (nounit) { + x[jx] /= a[j + j * a_dim1]; + } + temp = x[jx]; + ix = jx; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + ix += *incx; + x[ix] -= temp * a[i__ + j * a_dim1]; +/* L70: */ + } + } + jx += *incx; +/* L80: */ + } + } + } + } else { + +/* Form x := inv( A' )*x. */ + + if (lsame_(uplo, "U")) { + if (*incx == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; +/* L90: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; +/* L100: */ + } + } else { + jx = kx; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + temp = x[jx]; + ix = kx; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix += *incx; +/* L110: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx += *incx; +/* L120: */ + } + } + } else { + if (*incx == 1) { + for (j = *n; j >= 1; --j) { + temp = x[j]; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[i__]; +/* L130: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[j] = temp; +/* L140: */ + } + } else { + kx += (*n - 1) * *incx; + jx = kx; + for (j = *n; j >= 1; --j) { + temp = x[jx]; + ix = kx; + i__1 = j + 1; + for (i__ = *n; i__ >= i__1; --i__) { + temp -= a[i__ + j * a_dim1] * x[ix]; + ix -= *incx; +/* L150: */ + } + if (nounit) { + temp /= a[j + j * a_dim1]; + } + x[jx] = temp; + jx -= *incx; +/* L160: */ + } + } + } + } + + return 0; + +/* End of DTRSV . */ + +} /* dtrsv_ */ + +integer idamax_(integer *n, double *dx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + double d__1; + + /* Local variables */ + integer i__, ix; + double dmax__; + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* finds the index of element having max. absolute value. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ + /* Parameter adjustments */ + --dx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + dmax__ = abs(dx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[ix], abs(d__1)) <= dmax__) { + goto L5; + } + ret_val = i__; + dmax__ = (d__1 = dx[ix], abs(d__1)); +L5: + ix += *incx; +/* L10: */ + } + return ret_val; + +/* code for increment equal to 1 */ + +L20: + dmax__ = abs(dx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[i__], abs(d__1)) <= dmax__) { + goto L30; + } + ret_val = i__; + dmax__ = (d__1 = dx[i__], abs(d__1)); +L30: + ; + } + return ret_val; +} /* idamax_ */ diff --git a/external/clapack/blas/Makefile b/external/clapack/blas/Makefile deleted file mode 100644 index 35bc43a5..00000000 --- a/external/clapack/blas/Makefile +++ /dev/null @@ -1,39 +0,0 @@ -# Makefile of the library libblas.a -# David Weenink -# Generated on Thu Mar 12 14:16:43 2020 -# with the script "CLAPACK_copyFiles_to_Praat.praat". -# For CLAPACK version 3.1.1.1. - -include ../../../makefile.defs - -CPPFLAGS = -I ../../../melder -I .. - -OBJECTS = dasum.o daxpy.o dcopy.o \ - ddot.o dgbmv.o dgemm.o \ - dgemv.o dger.o dnrm2.o \ - drot.o drotg.o drotm.o \ - drotmg.o dsbmv.o dscal.o \ - dsdot.o dspmv.o dspr.o \ - dspr2.o dswap.o dsymm.o \ - dsymv.o dsyr.o dsyr2.o \ - dsyr2k.o dsyrk.o dtbmv.o \ - dtbsv.o dtpmv.o dtpsv.o \ - dtrmm.o dtrmv.o dtrsm.o \ - dtrsv.o idamax.o \ - sdot.o sgemm.o sgemv.o sscal.o ssyrk.o strsm.o - -.PHONY: all clean - -all: libblas.a - -clean: - $(RM) $(OBJECTS) - $(RM) libblas.a - -libblas.a: $(OBJECTS) - touch libblas.a - rm libblas.a - $(AR) cq libblas.a $(OBJECTS) - $(RANLIB) libblas.a - -$(OBJECTS): ../*.h ../../../melder/*.h diff --git a/external/clapack/blas/dasum.cpp b/external/clapack/blas/dasum.cpp deleted file mode 100644 index 3ffa3e13..00000000 --- a/external/clapack/blas/dasum.cpp +++ /dev/null @@ -1,89 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -double dasum_(integer *n, double *dx, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - double ret_val, d__1, d__2, d__3, d__4, d__5, d__6; - - /* Local variables */ - integer i__, m, mp1; - double dtemp; - integer nincx; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* takes the sum of the absolute values. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 3/93 to return if incx .le. 0. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --dx; - - /* Function Body */ - ret_val = 0.; - dtemp = 0.; - if (*n <= 0 || *incx <= 0) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - dtemp += (d__1 = dx[i__], abs(d__1)); -/* L10: */ - } - ret_val = dtemp; - return ret_val; - -/* code for increment equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 6; - if (m == 0) { - goto L40; - } - i__2 = m; - for (i__ = 1; i__ <= i__2; ++i__) { - dtemp += (d__1 = dx[i__], abs(d__1)); -/* L30: */ - } - if (*n < 6) { - goto L60; - } -L40: - mp1 = m + 1; - i__2 = *n; - for (i__ = mp1; i__ <= i__2; i__ += 6) { - dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], - abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ - + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = - dx[i__ + 5], abs(d__6)); -/* L50: */ - } -L60: - ret_val = dtemp; - return ret_val; -} /* dasum_ */ diff --git a/external/clapack/blas/daxpy.cpp b/external/clapack/blas/daxpy.cpp deleted file mode 100644 index 789a7777..00000000 --- a/external/clapack/blas/daxpy.cpp +++ /dev/null @@ -1,95 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int daxpy_(integer *n, double *da, double *dx, - integer *incx, double *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* constant times a vector plus a vector. */ -/* uses unrolled loops for increments equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --dy; - --dx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*da == 0.) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments */ -/* not equal to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[iy] += *da * dx[ix]; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 4; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[i__] += *da * dx[i__]; -/* L30: */ - } - if (*n < 4) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 4) { - dy[i__] += *da * dx[i__]; - dy[i__ + 1] += *da * dx[i__ + 1]; - dy[i__ + 2] += *da * dx[i__ + 2]; - dy[i__ + 3] += *da * dx[i__ + 3]; -/* L50: */ - } - return 0; -} /* daxpy_ */ diff --git a/external/clapack/blas/dcopy.cpp b/external/clapack/blas/dcopy.cpp deleted file mode 100644 index 4dd34d53..00000000 --- a/external/clapack/blas/dcopy.cpp +++ /dev/null @@ -1,95 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dcopy_(integer *n, double *dx, integer *incx, - double *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* copies a vector, x, to a vector, y. */ -/* uses unrolled loops for increments equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --dy; - --dx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments */ -/* not equal to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[iy] = dx[ix]; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 7; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[i__] = dx[i__]; -/* L30: */ - } - if (*n < 7) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 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]; -/* L50: */ - } - return 0; -} /* dcopy_ */ diff --git a/external/clapack/blas/ddot.cpp b/external/clapack/blas/ddot.cpp deleted file mode 100644 index 324fc0c7..00000000 --- a/external/clapack/blas/ddot.cpp +++ /dev/null @@ -1,98 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -double ddot_(integer *n, double *dx, integer *incx, double *dy, - integer *incy) -{ - /* System generated locals */ - integer i__1; - double ret_val; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - double dtemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* forms the dot product of two vectors. */ -/* uses unrolled loops for increments equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --dy; - --dx; - - /* Function Body */ - ret_val = 0.; - dtemp = 0.; - if (*n <= 0) { - return ret_val; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments */ -/* not equal to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += dx[ix] * dy[iy]; - ix += *incx; - iy += *incy; -/* L10: */ - } - ret_val = dtemp; - return ret_val; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += dx[i__] * dy[i__]; -/* L30: */ - } - if (*n < 5) { - goto L60; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 5) { - dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[ - i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + - 4] * dy[i__ + 4]; -/* L50: */ - } -L60: - ret_val = dtemp; - return ret_val; -} /* ddot_ */ diff --git a/external/clapack/blas/dgbmv.cpp b/external/clapack/blas/dgbmv.cpp deleted file mode 100644 index 699e09ec..00000000 --- a/external/clapack/blas/dgbmv.cpp +++ /dev/null @@ -1,355 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dgbmv_(const char *trans, integer *m, integer *n, integer *kl, - integer *ku, double *alpha, double *a, integer *lda, - double *x, integer *incx, double *beta, double *y, - integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; - - /* Local variables */ - integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info; - double temp; - integer lenx, leny; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBMV 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 band matrix, with kl sub-diagonals and ku super-diagonals. */ - -/* Arguments */ -/* ========== */ - -/* 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. */ - -/* KL - INTEGER. */ -/* On entry, KL specifies the number of sub-diagonals of the */ -/* matrix A. KL must satisfy 0 .le. KL. */ -/* Unchanged on exit. */ - -/* KU - INTEGER. */ -/* On entry, KU specifies the number of super-diagonals of the */ -/* matrix A. KU must satisfy 0 .le. KU. */ -/* 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 ( kl + ku + 1 ) by n part of the */ -/* array A must contain the matrix of coefficients, supplied */ -/* column by column, with the leading diagonal of the matrix in */ -/* row ( ku + 1 ) of the array, the first super-diagonal */ -/* starting at position 2 in row ku, the first sub-diagonal */ -/* starting at position 1 in row ( ku + 2 ), and so on. */ -/* Elements in the array A that do not correspond to elements */ -/* in the band matrix (such as the top left ku by ku triangle) */ -/* are not referenced. */ -/* The following program segment will transfer a band matrix */ -/* from conventional full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* K = KU + 1 - J */ -/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */ -/* A( K + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* 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 */ -/* ( kl + ku + 1 ). */ -/* 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, 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") - ) { - info = 1; - } else if (*m < 0) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*kl < 0) { - info = 4; - } else if (*ku < 0) { - info = 5; - } else if (*lda < *kl + *ku + 1) { - info = 8; - } else if (*incx == 0) { - info = 10; - } else if (*incy == 0) { - info = 13; - } - if (info != 0) { - xerbla_("DGBMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } - -/* 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")) { - lenx = *n; - leny = *m; - } else { - lenx = *m; - leny = *n; - } - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (lenx - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (leny - 1) * *incy; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the band part of A. */ - -/* First form y := beta*y. */ - - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - kup1 = *ku + 1; - if (lsame_(trans, "N")) { - -/* Form y := alpha*A*x + y. */ - - jx = kx; - if (*incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - k = kup1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__4 = std::min(i__5,i__6); - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - y[i__] += temp * a[k + i__ + j * a_dim1]; -/* L50: */ - } - } - jx += *incx; -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - iy = ky; - k = kup1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__3 = std::min(i__5,i__6); - for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { - y[iy] += temp * a[k + i__ + j * a_dim1]; - iy += *incy; -/* L70: */ - } - } - jx += *incx; - if (j > *ku) { - ky += *incy; - } -/* L80: */ - } - } - } else { - -/* Form y := alpha*A'*x + y. */ - - jy = ky; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - k = kup1 - j; -/* Computing MAX */ - i__3 = 1, i__4 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__2 = std::min(i__5,i__6); - for (i__ = std::max(i__3,i__4); i__ <= i__2; ++i__) { - temp += a[k + i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[jy] += *alpha * temp; - jy += *incy; -/* L100: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - ix = kx; - k = kup1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__4 = std::min(i__5,i__6); - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - temp += a[k + i__ + j * a_dim1] * x[ix]; - ix += *incx; -/* L110: */ - } - y[jy] += *alpha * temp; - jy += *incy; - if (j > *ku) { - kx += *incx; - } -/* L120: */ - } - } - } - - return 0; - -/* End of DGBMV . */ - -} /* dgbmv_ */ diff --git a/external/clapack/blas/dgemm.cpp b/external/clapack/blas/dgemm.cpp deleted file mode 100644 index df2da51f..00000000 --- a/external/clapack/blas/dgemm.cpp +++ /dev/null @@ -1,372 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dgemm_(const char *transa, const char *transb, integer *m, integer * - n, integer *k, double *alpha, double *a, integer *lda, - double *b, integer *ldb, double *beta, double *c__, - integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; - - /* Local variables */ - integer i__, j, l, info; - bool nota, notb; - double temp; - integer nrowa, nrowb; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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. */ - -/* Arguments */ -/* ========== */ - -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* 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. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - nota = lsame_(transa, "N"); - notb = lsame_(transb, "N"); - if (nota) { - nrowa = *m; - } else { - nrowa = *k; - } - if (notb) { - nrowb = *k; - } else { - nrowb = *n; - } - -/* Test the input parameters. */ - - info = 0; - if (! nota && ! lsame_(transa, "C") && ! lsame_( - transa, "T")) { - info = 1; - } else if (! notb && ! lsame_(transb, "C") && ! - lsame_(transb, "T")) { - info = 2; - } else if (*m < 0) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 8; - } else if (*ldb < std::max(1_integer,nrowb)) { - info = 10; - } else if (*ldc < std::max(1_integer,*m)) { - info = 13; - } - if (info != 0) { - xerbla_("DGEMM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } - -/* And if alpha.eq.zero. */ - - if (*alpha == 0.) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - return 0; - } - -/* Start the operations. */ - - if (notb) { - if (nota) { - -/* Form C := alpha*A*B + beta*C. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L50: */ - } - } else if (*beta != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L60: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (b[l + j * b_dim1] != 0.) { - temp = *alpha * b[l + j * b_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L70: */ - } - } -/* L80: */ - } -/* L90: */ - } - } else { - -/* Form C := alpha*A'*B + beta*C */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; -/* L100: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L110: */ - } -/* L120: */ - } - } - } else { - if (nota) { - -/* Form C := alpha*A*B' + beta*C */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L130: */ - } - } else if (*beta != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L140: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (b[j + l * b_dim1] != 0.) { - temp = *alpha * b[j + l * b_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L150: */ - } - } -/* L160: */ - } -/* L170: */ - } - } else { - -/* Form C := alpha*A'*B' + beta*C */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; -/* L180: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L190: */ - } -/* L200: */ - } - } - } - - return 0; - -/* End of DGEMM . */ - -} /* dgemm_ */ diff --git a/external/clapack/blas/dgemv.cpp b/external/clapack/blas/dgemv.cpp deleted file mode 100644 index 6880abaf..00000000 --- a/external/clapack/blas/dgemv.cpp +++ /dev/null @@ -1,298 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dgemv_(const char *trans, integer *m, integer *n, double * - alpha, double *a, integer *lda, double *x, integer *incx, - double *beta, double *y, integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, iy, jx, jy, kx, ky, info; - double temp; - integer lenx, leny; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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. */ - -/* Arguments */ -/* ========== */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") - ) { - info = 1; - } else if (*m < 0) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*lda < std::max(1_integer,*m)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("DGEMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } - -/* 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")) { - lenx = *n; - leny = *m; - } else { - lenx = *m; - leny = *n; - } - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (lenx - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (leny - 1) * *incy; - } - -/* 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 != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - if (lsame_(trans, "N")) { - -/* Form y := alpha*A*x + y. */ - - jx = kx; - if (*incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp * a[i__ + j * a_dim1]; -/* L50: */ - } - } - jx += *incx; -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - iy = ky; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp * a[i__ + j * a_dim1]; - iy += *incy; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } else { - -/* Form y := alpha*A'*x + y. */ - - jy = ky; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[jy] += *alpha * temp; - jy += *incy; -/* L100: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - ix = kx; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[ix]; - ix += *incx; -/* L110: */ - } - y[jy] += *alpha * temp; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of DGEMV . */ - -} /* dgemv_ */ diff --git a/external/clapack/blas/dger.cpp b/external/clapack/blas/dger.cpp deleted file mode 100644 index 9af99c29..00000000 --- a/external/clapack/blas/dger.cpp +++ /dev/null @@ -1,181 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dger_(integer *m, integer *n, double *alpha, - double *x, integer *incx, double *y, integer *incy, - double *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, jy, kx, info; - double temp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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. */ - -/* Arguments */ -/* ========== */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --x; - --y; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - info = 0; - if (*m < 0) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*incy == 0) { - info = 7; - } else if (*lda < std::max(1_integer,*m)) { - info = 9; - } - if (info != 0) { - xerbla_("DGER ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0 || *alpha == 0.) { - return 0; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (*incy > 0) { - jy = 1; - } else { - jy = 1 - (*n - 1) * *incy; - } - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (y[jy] != 0.) { - temp = *alpha * y[jy]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[i__] * temp; -/* L10: */ - } - } - jy += *incy; -/* L20: */ - } - } else { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*m - 1) * *incx; - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (y[jy] != 0.) { - temp = *alpha * y[jy]; - ix = kx; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[ix] * temp; - ix += *incx; -/* L30: */ - } - } - jy += *incy; -/* L40: */ - } - } - - return 0; - -/* End of DGER . */ - -} /* dger_ */ diff --git a/external/clapack/blas/dnrm2.cpp b/external/clapack/blas/dnrm2.cpp deleted file mode 100644 index 3ab464b5..00000000 --- a/external/clapack/blas/dnrm2.cpp +++ /dev/null @@ -1,83 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -double dnrm2_(integer *n, double *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - double ret_val, d__1; - - /* Builtin functions - double sqrt(double);*/ - - /* Local variables */ - integer ix; - double ssq, norm, scale, absxi; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DNRM2 returns the euclidean norm of a vector via the function */ -/* name, so that */ - -/* DNRM2 := sqrt( x'*x ) */ - - -/* -- This version written on 25-October-1982. */ -/* Modified on 14-October-1993 to inline the call to DLASSQ. */ -/* Sven Hammarling, Nag Ltd. */ - - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n < 1 || *incx < 1) { - norm = 0.; - } else if (*n == 1) { - norm = abs(x[1]); - } else { - scale = 0.; - ssq = 1.; -/* The following loop is equivalent to this call to the LAPACK */ -/* auxiliary routine: */ -/* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */ - - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.) { - absxi = (d__1 = x[ix], abs(d__1)); - if (scale < absxi) { -/* Computing 2nd power */ - d__1 = scale / absxi; - ssq = ssq * (d__1 * d__1) + 1.; - scale = absxi; - } else { -/* Computing 2nd power */ - d__1 = absxi / scale; - ssq += d__1 * d__1; - } - } -/* L10: */ - } - norm = scale * sqrt(ssq); - } - - ret_val = norm; - return ret_val; - -/* End of DNRM2. */ - -} /* dnrm2_ */ diff --git a/external/clapack/blas/drot.cpp b/external/clapack/blas/drot.cpp deleted file mode 100644 index ce6be0e8..00000000 --- a/external/clapack/blas/drot.cpp +++ /dev/null @@ -1,74 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int drot_(integer *n, double *dx, integer *incx, - double *dy, integer *incy, double *c__, double *s) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, ix, iy; - double dtemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* applies a plane rotation. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ - /* Parameter adjustments */ - --dy; - --dx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments not equal */ -/* to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = *c__ * dx[ix] + *s * dy[iy]; - dy[iy] = *c__ * dy[iy] - *s * dx[ix]; - dx[ix] = dtemp; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - -L20: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = *c__ * dx[i__] + *s * dy[i__]; - dy[i__] = *c__ * dy[i__] - *s * dx[i__]; - dx[i__] = dtemp; -/* L30: */ - } - return 0; -} /* drot_ */ diff --git a/external/clapack/blas/drotg.cpp b/external/clapack/blas/drotg.cpp deleted file mode 100644 index 7d88eaf4..00000000 --- a/external/clapack/blas/drotg.cpp +++ /dev/null @@ -1,67 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b4 = 1.; - -/* Subroutine */ int drotg_(double *da, double *db, double *c__, - double *s) -{ - /* System generated locals */ - double d__1, d__2; - - /* Builtin functions - double sqrt(double), d_sign(double *, double *);*/ - - /* Local variables */ - double r__, z__, roe, scale; - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* construct givens plane rotation. */ -/* jack dongarra, linpack, 3/11/78. */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - roe = *db; - if (abs(*da) > abs(*db)) { - roe = *da; - } - scale = abs(*da) + abs(*db); - if (scale != 0.) { - goto L10; - } - *c__ = 1.; - *s = 0.; - r__ = 0.; - z__ = 0.; - goto L20; -L10: -/* Computing 2nd power */ - d__1 = *da / scale; -/* Computing 2nd power */ - d__2 = *db / scale; - r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2); - r__ = d_sign(&c_b4, &roe) * r__; - *c__ = *da / r__; - *s = *db / r__; - z__ = 1.; - if (abs(*da) > abs(*db)) { - z__ = *s; - } - if (abs(*db) >= abs(*da) && *c__ != 0.) { - z__ = 1. / *c__; - } -L20: - *da = r__; - *db = z__; - return 0; -} /* drotg_ */ diff --git a/external/clapack/blas/drotm.cpp b/external/clapack/blas/drotm.cpp deleted file mode 100644 index 56898c3f..00000000 --- a/external/clapack/blas/drotm.cpp +++ /dev/null @@ -1,203 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int drotm_(integer *n, double *dx, integer *incx, - double *dy, integer *incy, double *dparam) -{ - /* Initialized data */ - - static double zero = 0.; - static double two = 2.; - - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__; - double w, z__; - integer kx, ky; - double dh11, dh12, dh21, dh22, dflag; - integer nsteps; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ - -/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */ -/* (DY**T) */ - -/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ -/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */ -/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ - -/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ - -/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ -/* H=( ) ( ) ( ) ( ) */ -/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ -/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* number of elements in input vector(s) */ - -/* DX (input/output) DOUBLE PRECISION array, dimension N */ -/* double precision vector with 5 elements */ - -/* INCX (input) INTEGER */ -/* storage spacing between elements of DX */ - -/* DY (input/output) DOUBLE PRECISION array, dimension N */ -/* double precision vector with N elements */ - -/* INCY (input) INTEGER */ -/* storage spacing between elements of DY */ - -/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ -/* DPARAM(1)=DFLAG */ -/* DPARAM(2)=DH11 */ -/* DPARAM(3)=DH21 */ -/* DPARAM(4)=DH12 */ -/* DPARAM(5)=DH22 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --dparam; - --dy; - --dx; - - /* Function Body */ -/* .. */ - - dflag = dparam[1]; - if (*n <= 0 || dflag + two == zero) { - goto L140; - } - if (! (*incx == *incy && *incx > 0)) { - goto L70; - } - - nsteps = *n * *incx; - if (dflag < 0.) { - goto L50; - } else if (dflag == 0) { - goto L10; - } else { - goto L30; - } -L10: - dh12 = dparam[4]; - dh21 = dparam[3]; - i__1 = nsteps; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w + z__ * dh12; - dy[i__] = w * dh21 + z__; -/* L20: */ - } - goto L140; -L30: - dh11 = dparam[2]; - dh22 = dparam[5]; - i__2 = nsteps; - i__1 = *incx; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w * dh11 + z__; - dy[i__] = -w + dh22 * z__; -/* L40: */ - } - goto L140; -L50: - dh11 = dparam[2]; - dh12 = dparam[4]; - dh21 = dparam[3]; - dh22 = dparam[5]; - i__1 = nsteps; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w * dh11 + z__ * dh12; - dy[i__] = w * dh21 + z__ * dh22; -/* L60: */ - } - goto L140; -L70: - kx = 1; - ky = 1; - if (*incx < 0) { - kx = (1 - *n) * *incx + 1; - } - if (*incy < 0) { - ky = (1 - *n) * *incy + 1; - } - - if (dflag < 0.) { - goto L120; - } else if (dflag == 0) { - goto L80; - } else { - goto L100; - } -L80: - dh12 = dparam[4]; - dh21 = dparam[3]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w + z__ * dh12; - dy[ky] = w * dh21 + z__; - kx += *incx; - ky += *incy; -/* L90: */ - } - goto L140; -L100: - dh11 = dparam[2]; - dh22 = dparam[5]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w * dh11 + z__; - dy[ky] = -w + dh22 * z__; - kx += *incx; - ky += *incy; -/* L110: */ - } - goto L140; -L120: - dh11 = dparam[2]; - dh12 = dparam[4]; - dh21 = dparam[3]; - dh22 = dparam[5]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w * dh11 + z__ * dh12; - dy[ky] = w * dh21 + z__ * dh22; - kx += *incx; - ky += *incy; -/* L130: */ - } -L140: - return 0; -} /* drotm_ */ diff --git a/external/clapack/blas/drotmg.cpp b/external/clapack/blas/drotmg.cpp deleted file mode 100644 index 9b1a2eab..00000000 --- a/external/clapack/blas/drotmg.cpp +++ /dev/null @@ -1,268 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int drotmg_(double *dd1, double *dd2, double * - dx1, double *dy1, double *dparam) -{ - /* Initialized data */ - - static double zero = 0.; - static double one = 1.; - static double two = 2.; - static double gam = 4096.; - static double gamsq = 16777216.; - static double rgamsq = 5.9604645e-8; - - /* System generated locals */ - double d__1; - - /* Local variables */ - double du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22; - integer igo; - double dflag, dtemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ -/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */ -/* DY2)**T. */ -/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ - -/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ - -/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ -/* H=( ) ( ) ( ) ( ) */ -/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ -/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */ -/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */ -/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */ - -/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ -/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ -/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ - - -/* Arguments */ -/* ========= */ - -/* DD1 (input/output) DOUBLE PRECISION */ - -/* DD2 (input/output) DOUBLE PRECISION */ - -/* DX1 (input/output) DOUBLE PRECISION */ - -/* DY1 (input) DOUBLE PRECISION */ - -/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ -/* DPARAM(1)=DFLAG */ -/* DPARAM(2)=DH11 */ -/* DPARAM(3)=DH21 */ -/* DPARAM(4)=DH12 */ -/* DPARAM(5)=DH22 */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Data statements .. */ - - /* Parameter adjustments */ - --dparam; - - /* Function Body */ -/* .. */ - if (! (*dd1 < zero)) { - goto L10; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L10: -/* CASE-DD1-NONNEGATIVE */ - dp2 = *dd2 * *dy1; - if (! (dp2 == zero)) { - goto L20; - } - dflag = -two; - goto L260; -/* REGULAR-CASE.. */ -L20: - dp1 = *dd1 * *dx1; - dq2 = dp2 * *dy1; - dq1 = dp1 * *dx1; - - if (! (abs(dq1) > abs(dq2))) { - goto L40; - } - dh21 = -(*dy1) / *dx1; - dh12 = dp2 / dp1; - - du = one - dh12 * dh21; - - if (! (du <= zero)) { - goto L30; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L30: - dflag = zero; - *dd1 /= du; - *dd2 /= du; - *dx1 *= du; -/* GO SCALE-CHECK.. */ - goto L100; -L40: - if (! (dq2 < zero)) { - goto L50; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L50: - dflag = one; - dh11 = dp1 / dp2; - dh22 = *dx1 / *dy1; - du = one + dh11 * dh22; - dtemp = *dd2 / du; - *dd2 = *dd1 / du; - *dd1 = dtemp; - *dx1 = *dy1 * du; -/* GO SCALE-CHECK */ - goto L100; -/* PROCEDURE..ZERO-H-D-AND-DX1.. */ -L60: - dflag = -one; - dh11 = zero; - dh12 = zero; - dh21 = zero; - dh22 = zero; - - *dd1 = zero; - *dd2 = zero; - *dx1 = zero; -/* RETURN.. */ - goto L220; -/* PROCEDURE..FIX-H.. */ -L70: - if (! (dflag >= zero)) { - goto L90; - } - - if (! (dflag == zero)) { - goto L80; - } - dh11 = one; - dh22 = one; - dflag = -one; - goto L90; -L80: - dh21 = -one; - dh12 = one; - dflag = -one; -L90: - switch (igo) { - case 0: goto L120; - case 1: goto L150; - case 2: goto L180; - case 3: goto L210; - } -/* PROCEDURE..SCALE-CHECK */ -L100: -L110: - if (! (*dd1 <= rgamsq)) { - goto L130; - } - if (*dd1 == zero) { - goto L160; - } - igo = 0; -/* FIX-H.. */ - goto L70; -L120: -/* Computing 2nd power */ - d__1 = gam; - *dd1 *= d__1 * d__1; - *dx1 /= gam; - dh11 /= gam; - dh12 /= gam; - goto L110; -L130: -L140: - if (! (*dd1 >= gamsq)) { - goto L160; - } - igo = 1; -/* FIX-H.. */ - goto L70; -L150: -/* Computing 2nd power */ - d__1 = gam; - *dd1 /= d__1 * d__1; - *dx1 *= gam; - dh11 *= gam; - dh12 *= gam; - goto L140; -L160: -L170: - if (! (abs(*dd2) <= rgamsq)) { - goto L190; - } - if (*dd2 == zero) { - goto L220; - } - igo = 2; -/* FIX-H.. */ - goto L70; -L180: -/* Computing 2nd power */ - d__1 = gam; - *dd2 *= d__1 * d__1; - dh21 /= gam; - dh22 /= gam; - goto L170; -L190: -L200: - if (! (abs(*dd2) >= gamsq)) { - goto L220; - } - igo = 3; -/* FIX-H.. */ - goto L70; -L210: -/* Computing 2nd power */ - d__1 = gam; - *dd2 /= d__1 * d__1; - dh21 *= gam; - dh22 *= gam; - goto L200; -L220: - if (dflag < 0.) { - goto L250; - } else if (dflag == 0) { - goto L230; - } else { - goto L240; - } -L230: - dparam[3] = dh21; - dparam[4] = dh12; - goto L260; -L240: - dparam[2] = dh11; - dparam[5] = dh22; - goto L260; -L250: - dparam[2] = dh11; - dparam[3] = dh21; - dparam[4] = dh12; - dparam[5] = dh22; -L260: - dparam[1] = dflag; - return 0; -} /* drotmg_ */ diff --git a/external/clapack/blas/dsbmv.cpp b/external/clapack/blas/dsbmv.cpp deleted file mode 100644 index eb8a2c81..00000000 --- a/external/clapack/blas/dsbmv.cpp +++ /dev/null @@ -1,352 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dsbmv_(const char *uplo, integer *n, integer *k, double * - alpha, double *a, integer *lda, double *x, integer *incx, - double *beta, double *y, integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ix, iy, jx, jy, kx, ky, info; - double temp1, temp2; - - integer kplus1; - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric band matrix, with k super-diagonals. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the band matrix A is being supplied as */ -/* follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* being supplied. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* being supplied. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix A. */ -/* N must be at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry, K specifies the number of super-diagonals of the */ -/* matrix A. K must satisfy 0 .le. K. */ -/* 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 with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the symmetric matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer the upper */ -/* triangular part of a symmetric band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the symmetric matrix, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer the lower */ -/* triangular part of a symmetric band matrix from conventional */ -/* full matrix storage to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* 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 */ -/* ( k + 1 ). */ -/* 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 */ -/* 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. */ -/* 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 */ -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*k < 0) { - info = 3; - } else if (*lda < *k + 1) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("DSBMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array A */ -/* are accessed sequentially with one pass through A. */ - -/* First form y := beta*y. */ - - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - if (lsame_(uplo, "U")) { - -/* Form y when upper triangle of A is stored. */ - - kplus1 = *k + 1; - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - y[i__] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[i__]; -/* L50: */ - } - y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { - y[iy] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * - temp2; - jx += *incx; - jy += *incy; - if (j > *k) { - kx += *incx; - ky += *incy; - } -/* L80: */ - } - } - } else { - -/* Form y when lower triangle of A is stored. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * a[j * a_dim1 + 1]; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = std::min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - y[i__] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[j] += *alpha * temp2; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * a[j * a_dim1 + 1]; - l = 1 - j; - ix = jx; - iy = jy; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = std::min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a[l + i__ + j * a_dim1]; - temp2 += a[l + i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of DSBMV . */ - -} /* dsbmv_ */ diff --git a/external/clapack/blas/dscal.cpp b/external/clapack/blas/dscal.cpp deleted file mode 100644 index 279e55cd..00000000 --- a/external/clapack/blas/dscal.cpp +++ /dev/null @@ -1,84 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dscal_(integer *n, double *da, double *dx, - integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, m, mp1, nincx; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ -/* * */ -/* scales a vector by a constant. */ -/* uses unrolled loops for increment equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 3/93 to return if incx .le. 0. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --dx; - - /* Function Body */ - if (*n <= 0 || *incx <= 0) { - return 0; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - dx[i__] = *da * dx[i__]; -/* L10: */ - } - return 0; - -/* code for increment equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__2 = m; - for (i__ = 1; i__ <= i__2; ++i__) { - dx[i__] = *da * dx[i__]; -/* L30: */ - } - if (*n < 5) { - return 0; - } -L40: - mp1 = m + 1; - i__2 = *n; - for (i__ = mp1; i__ <= i__2; i__ += 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]; -/* L50: */ - } - return 0; -} /* dscal_ */ diff --git a/external/clapack/blas/dsdot.cpp b/external/clapack/blas/dsdot.cpp deleted file mode 100644 index fd8996a5..00000000 --- a/external/clapack/blas/dsdot.cpp +++ /dev/null @@ -1,123 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -double dsdot_(integer *n, float *sx, integer *incx, float *sy, integer * - incy) -{ - /* System generated locals */ - integer i__1, i__2; - double ret_val; - - /* Local variables */ - integer i__, ns, kx, ky; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* AUTHORS */ -/* ======= */ -/* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), */ -/* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) */ - -/* Purpose */ -/* ======= */ -/* Compute the inner product of two vectors with extended */ -/* precision accumulation and result. */ - -/* Returns D.P. dot product accumulated in D.P., for S.P. SX and SY */ -/* DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), */ -/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */ -/* defined in a similar way using INCY. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* number of elements in input vector(s) */ - -/* SX (input) REAL array, dimension(N) */ -/* single precision vector with N elements */ - -/* INCX (input) INTEGER */ -/* storage spacing between elements of SX */ - -/* SY (input) REAL array, dimension(N) */ -/* single precision vector with N elements */ - -/* INCY (input) INTEGER */ -/* storage spacing between elements of SY */ - -/* DSDOT (output) DOUBLE PRECISION */ -/* DSDOT double precision dot product (zero if N.LE.0) */ - -/* REFERENCES */ -/* ========== */ - -/* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */ -/* Krogh, Basic linear algebra subprograms for Fortran */ -/* usage, Algorithm No. 539, Transactions on Mathematical */ -/* Software 5, 3 (September 1979), pp. 308-323. */ - -/* REVISION HISTORY (YYMMDD) */ -/* ========================== */ - -/* 791001 DATE WRITTEN */ -/* 890831 Modified array declarations. (WRB) */ -/* 890831 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* 070118 Reformat to LAPACK style (JL) */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --sy; - --sx; - - /* Function Body */ - ret_val = 0.; - if (*n <= 0) { - return ret_val; - } - if (*incx == *incy && *incx > 0) { - goto L20; - } - -/* Code for unequal or nonpositive increments. */ - - kx = 1; - ky = 1; - if (*incx < 0) { - kx = (1 - *n) * *incx + 1; - } - if (*incy < 0) { - ky = (1 - *n) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - ret_val += (double) sx[kx] * (double) sy[ky]; - kx += *incx; - ky += *incy; -/* L10: */ - } - return ret_val; - -/* Code for equal, positive, non-unit increments. */ - -L20: - ns = *n * *incx; - i__1 = ns; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - ret_val += (double) sx[i__] * (double) sy[i__]; -/* L30: */ - } - return ret_val; -} /* dsdot_ */ diff --git a/external/clapack/blas/dspmv.cpp b/external/clapack/blas/dspmv.cpp deleted file mode 100644 index 4edd632b..00000000 --- a/external/clapack/blas/dspmv.cpp +++ /dev/null @@ -1,300 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dspmv_(const char *uplo, integer *n, double *alpha, - double *ap, double *x, integer *incx, double *beta, - double *y, integer *incy) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; - double temp1, temp2; - - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric matrix, supplied in packed form. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the matrix A is supplied in the packed */ -/* array AP as follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* supplied in AP. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* supplied in AP. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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. */ - -/* AP - DOUBLE PRECISION array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ -/* and a( 2, 2 ) respectively, and so on. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ -/* and a( 3, 1 ) respectively, and so on. */ -/* 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. */ -/* 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 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the n */ -/* element 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --y; - --x; - --ap; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 6; - } else if (*incy == 0) { - info = 9; - } - if (info != 0) { - xerbla_("DSPMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of the array AP */ -/* are accessed sequentially with one pass through AP. */ - -/* First form y := beta*y. */ - - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - kk = 1; - if (lsame_(uplo, "U")) { - -/* Form y when AP contains the upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * ap[k]; - temp2 += ap[k] * x[i__]; - ++k; -/* L50: */ - } - y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; - kk += j; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - y[iy] += temp1 * ap[k]; - temp2 += ap[k] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; - jx += *incx; - jy += *incy; - kk += j; -/* L80: */ - } - } - } else { - -/* Form y when AP contains the lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * ap[kk]; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * ap[k]; - temp2 += ap[k] * x[i__]; - ++k; -/* L90: */ - } - y[j] += *alpha * temp2; - kk += *n - j + 1; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * ap[kk]; - ix = jx; - iy = jy; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * ap[k]; - temp2 += ap[k] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; - kk += *n - j + 1; -/* L120: */ - } - } - } - - return 0; - -/* End of DSPMV . */ - -} /* dspmv_ */ diff --git a/external/clapack/blas/dspr.cpp b/external/clapack/blas/dspr.cpp deleted file mode 100644 index 0df09c37..00000000 --- a/external/clapack/blas/dspr.cpp +++ /dev/null @@ -1,225 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dspr_(const char *uplo, integer *n, double *alpha, - double *x, integer *incx, double *ap) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j, k, kk, ix, jx, kx, info; - double temp; - - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPR performs the symmetric rank 1 operation */ - -/* A := alpha*x*x' + A, */ - -/* where alpha is a real scalar, x is an n element vector and A is an */ -/* n by n symmetric matrix, supplied in packed form. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the matrix A is supplied in the packed */ -/* array AP as follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* supplied in AP. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* supplied in AP. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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. */ - -/* AP - DOUBLE PRECISION array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ -/* and a( 2, 2 ) respectively, and so on. On exit, the array */ -/* AP is overwritten by the upper triangular part of the */ -/* updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ -/* and a( 3, 1 ) respectively, and so on. On exit, the array */ -/* AP is overwritten by the lower triangular part of the */ -/* updated matrix. */ - - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } - if (info != 0) { - xerbla_("DSPR ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0.) { - return 0; - } - -/* Set the start point in X if the increment is not unity. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of the array AP */ -/* are accessed sequentially with one pass through AP. */ - - kk = 1; - if (lsame_(uplo, "U")) { - -/* Form A when upper triangle is stored in AP. */ - - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - k = kk; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - ap[k] += x[i__] * temp; - ++k; -/* L10: */ - } - } - kk += j; -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = kx; - i__2 = kk + j - 1; - for (k = kk; k <= i__2; ++k) { - ap[k] += x[ix] * temp; - ix += *incx; -/* L30: */ - } - } - jx += *incx; - kk += j; -/* L40: */ - } - } - } else { - -/* Form A when lower triangle is stored in AP. */ - - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - k = kk; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - ap[k] += x[i__] * temp; - ++k; -/* L50: */ - } - } - kk = kk + *n - j + 1; -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = jx; - i__2 = kk + *n - j; - for (k = kk; k <= i__2; ++k) { - ap[k] += x[ix] * temp; - ix += *incx; -/* L70: */ - } - } - jx += *incx; - kk = kk + *n - j + 1; -/* L80: */ - } - } - } - - return 0; - -/* End of DSPR . */ - -} /* dspr_ */ diff --git a/external/clapack/blas/dspr2.cpp b/external/clapack/blas/dspr2.cpp deleted file mode 100644 index ba048413..00000000 --- a/external/clapack/blas/dspr2.cpp +++ /dev/null @@ -1,258 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dspr2_(const char *uplo, integer *n, double *alpha, - double *x, integer *incx, double *y, integer *incy, - double *ap) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; - double temp1, temp2; - - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPR2 performs the symmetric rank 2 operation */ - -/* A := alpha*x*y' + alpha*y*x' + A, */ - -/* where alpha is a scalar, x and y are n element vectors and A is an */ -/* n by n symmetric matrix, supplied in packed form. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the matrix A is supplied in the packed */ -/* array AP as follows: */ - -/* UPLO = 'U' or 'u' The upper triangular part of A is */ -/* supplied in AP. */ - -/* UPLO = 'L' or 'l' The lower triangular part of A is */ -/* supplied in AP. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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. */ - -/* AP - DOUBLE PRECISION array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ -/* and a( 2, 2 ) respectively, and so on. On exit, the array */ -/* AP is overwritten by the upper triangular part of the */ -/* updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular part of the symmetric matrix */ -/* packed sequentially, column by column, so that AP( 1 ) */ -/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ -/* and a( 3, 1 ) respectively, and so on. On exit, the array */ -/* AP is overwritten by the lower triangular part of the */ -/* updated matrix. */ - - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --y; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*incy == 0) { - info = 7; - } - if (info != 0) { - xerbla_("DSPR2 ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0.) { - return 0; - } - -/* Set up the start points in X and Y if the increments are not both */ -/* unity. */ - - if (*incx != 1 || *incy != 1) { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - jx = kx; - jy = ky; - } - -/* Start the operations. In this version the elements of the array AP */ -/* are accessed sequentially with one pass through AP. */ - - kk = 1; - if (lsame_(uplo, "U")) { - -/* Form A when upper triangle is stored in AP. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - k = kk; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; - ++k; -/* L10: */ - } - } - kk += j; -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = kx; - iy = ky; - i__2 = kk + j - 1; - for (k = kk; k <= i__2; ++k) { - ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L30: */ - } - } - jx += *incx; - jy += *incy; - kk += j; -/* L40: */ - } - } - } else { - -/* Form A when lower triangle is stored in AP. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - k = kk; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; - ++k; -/* L50: */ - } - } - kk = kk + *n - j + 1; -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = jx; - iy = jy; - i__2 = kk + *n - j; - for (k = kk; k <= i__2; ++k) { - ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L70: */ - } - } - jx += *incx; - jy += *incy; - kk = kk + *n - j + 1; -/* L80: */ - } - } - } - - return 0; - -/* End of DSPR2 . */ - -} /* dspr2_ */ diff --git a/external/clapack/blas/dswap.cpp b/external/clapack/blas/dswap.cpp deleted file mode 100644 index 7a3d2a65..00000000 --- a/external/clapack/blas/dswap.cpp +++ /dev/null @@ -1,102 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dswap_(integer *n, double *dx, integer *incx, - double *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - double dtemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* interchanges two vectors. */ -/* uses unrolled loops for increments equal one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --dy; - --dx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments not equal */ -/* to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = dx[ix]; - dx[ix] = dy[iy]; - dy[iy] = dtemp; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 3; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = dx[i__]; - dx[i__] = dy[i__]; - dy[i__] = dtemp; -/* L30: */ - } - if (*n < 3) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 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; -/* L50: */ - } - return 0; -} /* dswap_ */ diff --git a/external/clapack/blas/dsymm.cpp b/external/clapack/blas/dsymm.cpp deleted file mode 100644 index 5cde4cb4..00000000 --- a/external/clapack/blas/dsymm.cpp +++ /dev/null @@ -1,350 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dsymm_(const char *side, const char *uplo, integer *m, integer *n, - double *alpha, double *a, integer *lda, double *b, - integer *ldb, double *beta, double *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; - - /* Local variables */ - integer i__, j, k, info; - double temp1, temp2; - - integer nrowa; - bool upper; - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYMM performs one of the matrix-matrix operations */ - -/* C := alpha*A*B + beta*C, */ - -/* or */ - -/* C := alpha*B*A + beta*C, */ - -/* where alpha and beta are scalars, A is a symmetric matrix and B and */ -/* C are m by n matrices. */ - -/* Arguments */ -/* ========== */ - -/* SIDE - CHARACTER*1. */ -/* On entry, SIDE specifies whether the symmetric matrix A */ -/* appears on the left or right in the operation as follows: */ - -/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */ - -/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */ - -/* Unchanged on exit. */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the symmetric matrix A is to be */ -/* referenced as follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of the */ -/* symmetric matrix is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of the */ -/* symmetric matrix is to be referenced. */ - -/* Unchanged on exit. */ - -/* M - INTEGER. */ -/* On entry, M specifies the number of rows 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 C. */ -/* 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, ka ), where ka is */ -/* m when SIDE = 'L' or 'l' and is n otherwise. */ -/* Before entry with SIDE = 'L' or 'l', the m by m part of */ -/* the array A must contain the symmetric matrix, such that */ -/* when UPLO = 'U' or 'u', the leading m by m upper triangular */ -/* part of the array A must contain the upper triangular part */ -/* of the symmetric matrix and the strictly lower triangular */ -/* part of A is not referenced, and when UPLO = 'L' or 'l', */ -/* the leading m by m lower triangular part of the array A */ -/* must contain the lower triangular part of the symmetric */ -/* matrix and the strictly upper triangular part of A is not */ -/* referenced. */ -/* Before entry with SIDE = 'R' or 'r', the n by n part of */ -/* the array A must contain the symmetric matrix, such that */ -/* when UPLO = 'U' or 'u', the leading n by n upper triangular */ -/* part of the array A must contain the upper triangular part */ -/* of the symmetric matrix and the strictly lower triangular */ -/* part of A is not referenced, and when UPLO = 'L' or 'l', */ -/* the leading n by n lower triangular part of the array A */ -/* must contain the lower triangular part of the symmetric */ -/* matrix and the strictly upper triangular part of A is not */ -/* referenced. */ -/* 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 ), otherwise 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. */ -/* Unchanged on exit. */ - -/* 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. */ - -/* 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 updated */ -/* matrix. */ - -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* Set NROWA as the number of rows of A. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - if (lsame_(side, "L")) { - nrowa = *m; - } else { - nrowa = *n; - } - upper = lsame_(uplo, "U"); - -/* Test the input parameters. */ - - info = 0; - if (! lsame_(side, "L") && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (*m < 0) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 7; - } else if (*ldb < std::max(1_integer,*m)) { - info = 9; - } else if (*ldc < std::max(1_integer,*m)) { - info = 12; - } - if (info != 0) { - xerbla_("DSYMM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - return 0; - } - -/* Start the operations. */ - - if (lsame_(side, "L")) { - -/* Form C := alpha*A*B + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1 = *alpha * b[i__ + j * b_dim1]; - temp2 = 0.; - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; - temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; -/* L50: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] - + *alpha * temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + temp1 * a[i__ + i__ * a_dim1] + *alpha * - temp2; - } -/* L60: */ - } -/* L70: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp1 = *alpha * b[i__ + j * b_dim1]; - temp2 = 0.; - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1]; - temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1]; -/* L80: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] - + *alpha * temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + temp1 * a[i__ + i__ * a_dim1] + *alpha * - temp2; - } -/* L90: */ - } -/* L100: */ - } - } - } else { - -/* Form C := alpha*B*A + beta*C. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * a[j + j * a_dim1]; - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1]; -/* L110: */ - } - } else { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + - temp1 * b[i__ + j * b_dim1]; -/* L120: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (upper) { - temp1 = *alpha * a[k + j * a_dim1]; - } else { - temp1 = *alpha * a[j + k * a_dim1]; - } - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; -/* L130: */ - } -/* L140: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - if (upper) { - temp1 = *alpha * a[j + k * a_dim1]; - } else { - temp1 = *alpha * a[k + j * a_dim1]; - } - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1]; -/* L150: */ - } -/* L160: */ - } -/* L170: */ - } - } - - return 0; - -/* End of DSYMM . */ - -} /* dsymm_ */ diff --git a/external/clapack/blas/dsymv.cpp b/external/clapack/blas/dsymv.cpp deleted file mode 100644 index 67bae02d..00000000 --- a/external/clapack/blas/dsymv.cpp +++ /dev/null @@ -1,301 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dsymv_(const char *uplo, integer *n, double *alpha, - double *a, integer *lda, double *x, integer *incx, double - *beta, double *y, integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, iy, jx, jy, kx, ky, info; - double temp1, temp2; - - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYMV performs the matrix-vector operation */ - -/* y := alpha*A*x + beta*y, */ - -/* where alpha and beta are scalars, x and y are n element vectors and */ -/* A is an n by n symmetric matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array A is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of A */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of A */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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 with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular part of the symmetric 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 part of the symmetric matrix and the strictly */ -/* upper triangular part of A is not referenced. */ -/* 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. */ -/* 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 + ( n - 1 )*abs( INCY ) ). */ -/* Before entry, the incremented array Y must contain the n */ -/* element 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*lda < std::max(1_integer,*n)) { - info = 5; - } else if (*incx == 0) { - info = 7; - } else if (*incy == 0) { - info = 10; - } - if (info != 0) { - xerbla_("DSYMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } - -/* Set up the start points in X and Y. */ - - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the triangular part */ -/* of A. */ - -/* First form y := beta*y. */ - - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - if (lsame_(uplo, "U")) { - -/* Form y when A is stored in upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[i__]; -/* L50: */ - } - y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2; - jx += *incx; - jy += *incy; -/* L80: */ - } - } - } else { - -/* Form y when A is stored in lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * a[j + j * a_dim1]; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[j] += *alpha * temp2; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * a[j + j * a_dim1]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a[i__ + j * a_dim1]; - temp2 += a[i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of DSYMV . */ - -} /* dsymv_ */ diff --git a/external/clapack/blas/dsyr.cpp b/external/clapack/blas/dsyr.cpp deleted file mode 100644 index b53c1107..00000000 --- a/external/clapack/blas/dsyr.cpp +++ /dev/null @@ -1,226 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dsyr_(const char *uplo, integer *n, double *alpha, - double *x, integer *incx, double *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, jx, kx, info; - double temp; - - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYR performs the symmetric rank 1 operation */ - -/* A := alpha*x*x' + A, */ - -/* where alpha is a real scalar, x is an n element vector and A is an */ -/* n by n symmetric matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array A is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of A */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of A */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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. */ - -/* 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 part of the symmetric matrix and the strictly */ -/* lower triangular part of A is not referenced. On exit, the */ -/* upper triangular part of the array A is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of A is not referenced. On exit, the */ -/* lower triangular part of the array A is overwritten by the */ -/* lower triangular part of 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, n ). */ -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --x; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*lda < std::max(1_integer,*n)) { - info = 7; - } - if (info != 0) { - xerbla_("DSYR ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0.) { - return 0; - } - -/* Set the start point in X if the increment is not unity. */ - - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the triangular part */ -/* of A. */ - - if (lsame_(uplo, "U")) { - -/* Form A when A is stored in upper triangle. */ - - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[i__] * temp; -/* L10: */ - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = kx; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[ix] * temp; - ix += *incx; -/* L30: */ - } - } - jx += *incx; -/* L40: */ - } - } - } else { - -/* Form A when A is stored in lower triangle. */ - - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[i__] * temp; -/* L50: */ - } - } -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = jx; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] += x[ix] * temp; - ix += *incx; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } - - return 0; - -/* End of DSYR . */ - -} /* dsyr_ */ diff --git a/external/clapack/blas/dsyr2.cpp b/external/clapack/blas/dsyr2.cpp deleted file mode 100644 index 70a9dd0a..00000000 --- a/external/clapack/blas/dsyr2.cpp +++ /dev/null @@ -1,263 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dsyr2_(const char *uplo, integer *n, double *alpha, - double *x, integer *incx, double *y, integer *incy, - double *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, iy, jx, jy, kx, ky, info; - double temp1, temp2; - - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYR2 performs the symmetric rank 2 operation */ - -/* A := alpha*x*y' + alpha*y*x' + A, */ - -/* where alpha is a scalar, x and y are n element vectors and A is an n */ -/* by n symmetric matrix. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array A is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of A */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of A */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order 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 + ( n - 1 )*abs( INCX ) ). */ -/* Before entry, the incremented array X must contain the n */ -/* 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 with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array A must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of A is not referenced. On exit, the */ -/* upper triangular part of the array A is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array A must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of A is not referenced. On exit, the */ -/* lower triangular part of the array A is overwritten by the */ -/* lower triangular part of 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, n ). */ -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --x; - --y; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*incy == 0) { - info = 7; - } else if (*lda < std::max(1_integer,*n)) { - info = 9; - } - if (info != 0) { - xerbla_("DSYR2 ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *alpha == 0.) { - return 0; - } - -/* Set up the start points in X and Y if the increments are not both */ -/* unity. */ - - if (*incx != 1 || *incy != 1) { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - jx = kx; - jy = ky; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through the triangular part */ -/* of A. */ - - if (lsame_(uplo, "U")) { - -/* Form A when A is stored in the upper triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * - temp1 + y[i__] * temp2; -/* L10: */ - } - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = kx; - iy = ky; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * - temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L30: */ - } - } - jx += *incx; - jy += *incy; -/* L40: */ - } - } - } else { - -/* Form A when A is stored in the lower triangle. */ - - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * - temp1 + y[i__] * temp2; -/* L50: */ - } - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * - temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L70: */ - } - } - jx += *incx; - jy += *incy; -/* L80: */ - } - } - } - - return 0; - -/* End of DSYR2 . */ - -} /* dsyr2_ */ diff --git a/external/clapack/blas/dsyr2k.cpp b/external/clapack/blas/dsyr2k.cpp deleted file mode 100644 index cdae2320..00000000 --- a/external/clapack/blas/dsyr2k.cpp +++ /dev/null @@ -1,395 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dsyr2k_(const char *uplo, const char *trans, integer *n, integer *k, - double *alpha, double *a, integer *lda, double *b, - integer *ldb, double *beta, double *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; - - /* Local variables */ - integer i__, j, l, info; - double temp1, temp2; - - integer nrowa; - bool upper; - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYR2K performs one of the symmetric rank 2k operations */ - -/* C := alpha*A*B' + alpha*B*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*B + alpha*B'*A + beta*C, */ - -/* where alpha and beta are scalars, C is an n by n symmetric matrix */ -/* and A and B are n by k matrices in the first case and k by n */ -/* matrices in the second case. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */ -/* beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */ -/* beta*C. */ - -/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */ -/* beta*C. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrices A and B, and on entry with */ -/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ -/* of rows of the matrices A and 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 TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array A must contain the matrix A, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */ -/* k when TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array B must contain the matrix B, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDB must be at least max( 1, n ), otherwise LDB must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - DOUBLE PRECISION. */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array C must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of C is not referenced. On exit, the */ -/* upper triangular part of the array C is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array C must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of C is not referenced. On exit, the */ -/* lower triangular part of the array C is overwritten by the */ -/* lower triangular part of the updated matrix. */ - -/* 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, n ). */ -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 7; - } else if (*ldb < std::max(1_integer,nrowa)) { - info = 9; - } else if (*ldc < std::max(1_integer,*n)) { - info = 12; - } - if (info != 0) { - xerbla_("DSYR2K", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } - -/* Start the operations. */ - - if (lsame_(trans, "N")) { - -/* Form C := alpha*A*B' + alpha*B*A' + C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L90: */ - } - } else if (*beta != 1.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { - temp1 = *alpha * b[j + l * b_dim1]; - temp2 = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ - i__ + l * a_dim1] * temp1 + b[i__ + l * - b_dim1] * temp2; -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) { - temp1 = *alpha * b[j + l * b_dim1]; - temp2 = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[ - i__ + l * a_dim1] * temp1 + b[i__ + l * - b_dim1] * temp2; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { - -/* Form C := alpha*A'*B + alpha*B'*A + C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1 = 0.; - temp2 = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; - temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; -/* L190: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * - temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + *alpha * temp1 + *alpha * temp2; - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp1 = 0.; - temp2 = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1]; - temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1]; -/* L220: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * - temp2; - } else { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] - + *alpha * temp1 + *alpha * temp2; - } -/* L230: */ - } -/* L240: */ - } - } - } - - return 0; - -/* End of DSYR2K. */ - -} /* dsyr2k_ */ diff --git a/external/clapack/blas/dsyrk.cpp b/external/clapack/blas/dsyrk.cpp deleted file mode 100644 index bb938715..00000000 --- a/external/clapack/blas/dsyrk.cpp +++ /dev/null @@ -1,360 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dsyrk_(const char *uplo, const char *trans, integer *n, integer *k, - double *alpha, double *a, integer *lda, double *beta, - double *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, info; - double temp; - - integer nrowa; - bool upper; - - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYRK performs one of the symmetric rank k operations */ - -/* C := alpha*A*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*A + beta*C, */ - -/* where alpha and beta are scalars, C is an n by n symmetric matrix */ -/* and A is an n by k matrix in the first case and a k by n matrix */ -/* in the second case. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ - -/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrix A, and on entry with */ -/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ -/* of rows of the matrix A. 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 TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array A must contain the matrix A, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - DOUBLE PRECISION. */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array C must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of C is not referenced. On exit, the */ -/* upper triangular part of the array C is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array C must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of C is not referenced. On exit, the */ -/* lower triangular part of the array C is overwritten by the */ -/* lower triangular part of the updated matrix. */ - -/* 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, n ). */ -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 7; - } else if (*ldc < std::max(1_integer,*n)) { - info = 10; - } - if (info != 0) { - xerbla_("DSYRK ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } - -/* Start the operations. */ - - if (lsame_(trans, "N")) { - -/* Form C := alpha*A*A' + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L90: */ - } - } else if (*beta != 1.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.; -/* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { - -/* Form C := alpha*A'*A + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; -/* L190: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; -/* L220: */ - } - if (*beta == 0.) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L230: */ - } -/* L240: */ - } - } - } - - return 0; - -/* End of DSYRK . */ - -} /* dsyrk_ */ diff --git a/external/clapack/blas/dtbmv.cpp b/external/clapack/blas/dtbmv.cpp deleted file mode 100644 index e199dc50..00000000 --- a/external/clapack/blas/dtbmv.cpp +++ /dev/null @@ -1,410 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dtbmv_(const char *uplo, const char *trans, const char *diag, integer *n, - integer *k, double *a, integer *lda, double *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ix, jx, kx, info; - double temp; - - integer kplus1; - - bool nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTBMV 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 band matrix, with ( k + 1 ) diagonals. */ - -/* Arguments */ -/* ========== */ - -/* 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. */ - -/* K - INTEGER. */ -/* On entry with UPLO = 'U' or 'u', K specifies the number of */ -/* super-diagonals of the matrix A. */ -/* On entry with UPLO = 'L' or 'l', K specifies the number of */ -/* sub-diagonals of the matrix A. */ -/* K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer an upper */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer a lower */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Note that when DIAG = 'U' or 'u' the elements of the array A */ -/* corresponding to the diagonal elements of the matrix are not */ -/* referenced, 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 */ -/* ( k + 1 ). */ -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < *k + 1) { - info = 7; - } else if (*incx == 0) { - info = 9; - } - if (info != 0) { - xerbla_("DTBMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - 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 <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N")) { - -/* Form x := A*x. */ - - if (lsame_(uplo, "U")) { - kplus1 = *k + 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - x[i__] += temp * a[l + i__ + j * a_dim1]; -/* L10: */ - } - if (nounit) { - x[j] *= a[kplus1 + j * a_dim1]; - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { - x[ix] += temp * a[l + i__ + j * a_dim1]; - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= a[kplus1 + j * a_dim1]; - } - } - jx += *incx; - if (j > *k) { - kx += *incx; - } -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - l = 1 - j; -/* Computing MIN */ - i__1 = *n, i__3 = j + *k; - i__4 = j + 1; - for (i__ = std::min(i__1,i__3); i__ >= i__4; --i__) { - x[i__] += temp * a[l + i__ + j * a_dim1]; -/* L50: */ - } - if (nounit) { - x[j] *= a[j * a_dim1 + 1]; - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__1 = j + *k; - i__3 = j + 1; - for (i__ = std::min(i__4,i__1); i__ >= i__3; --i__) { - x[ix] += temp * a[l + i__ + j * a_dim1]; - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= a[j * a_dim1 + 1]; - } - } - jx -= *incx; - if (*n - j >= *k) { - kx -= *incx; - } -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x. */ - - if (lsame_(uplo, "U")) { - kplus1 = *k + 1; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - l = kplus1 - j; - if (nounit) { - temp *= a[kplus1 + j * a_dim1]; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = std::max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - temp += a[l + i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - x[j] = temp; -/* L100: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - kx -= *incx; - ix = kx; - l = kplus1 - j; - if (nounit) { - temp *= a[kplus1 + j * a_dim1]; - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = std::max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - temp += a[l + i__ + j * a_dim1] * x[ix]; - ix -= *incx; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - temp = x[j]; - l = 1 - j; - if (nounit) { - temp *= a[j * a_dim1 + 1]; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = std::min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - temp += a[l + i__ + j * a_dim1] * x[i__]; -/* L130: */ - } - x[j] = temp; -/* L140: */ - } - } else { - jx = kx; - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - temp = x[jx]; - kx += *incx; - ix = kx; - l = 1 - j; - if (nounit) { - temp *= a[j * a_dim1 + 1]; - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = std::min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - temp += a[l + i__ + j * a_dim1] * x[ix]; - ix += *incx; -/* L150: */ - } - x[jx] = temp; - jx += *incx; -/* L160: */ - } - } - } - } - - return 0; - -/* End of DTBMV . */ - -} /* dtbmv_ */ diff --git a/external/clapack/blas/dtbsv.cpp b/external/clapack/blas/dtbsv.cpp deleted file mode 100644 index ffde4a62..00000000 --- a/external/clapack/blas/dtbsv.cpp +++ /dev/null @@ -1,414 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dtbsv_(const char *uplo, const char *trans, const char *diag, integer *n, - integer *k, double *a, integer *lda, double *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ix, jx, kx, info; - double temp; - - integer kplus1; - - bool nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTBSV 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 band matrix, with ( k + 1 ) */ -/* diagonals. */ - -/* No test for singularity or near-singularity is included in this */ -/* routine. Such tests must be performed before calling this routine. */ - -/* Arguments */ -/* ========== */ - -/* 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. */ - -/* K - INTEGER. */ -/* On entry with UPLO = 'U' or 'u', K specifies the number of */ -/* super-diagonals of the matrix A. */ -/* On entry with UPLO = 'L' or 'l', K specifies the number of */ -/* sub-diagonals of the matrix A. */ -/* K must satisfy 0 .le. K. */ -/* Unchanged on exit. */ - -/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */ -/* by n part of the array A must contain the upper triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row */ -/* ( k + 1 ) of the array, the first super-diagonal starting at */ -/* position 2 in row k, and so on. The top left k by k triangle */ -/* of the array A is not referenced. */ -/* The following program segment will transfer an upper */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = K + 1 - J */ -/* DO 10, I = MAX( 1, J - K ), J */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */ -/* by n part of the array A must contain the lower triangular */ -/* band part of the matrix of coefficients, supplied column by */ -/* column, with the leading diagonal of the matrix in row 1 of */ -/* the array, the first sub-diagonal starting at position 1 in */ -/* row 2, and so on. The bottom right k by k triangle of the */ -/* array A is not referenced. */ -/* The following program segment will transfer a lower */ -/* triangular band matrix from conventional full matrix storage */ -/* to band storage: */ - -/* DO 20, J = 1, N */ -/* M = 1 - J */ -/* DO 10, I = J, MIN( N, J + K ) */ -/* A( M + I, J ) = matrix( I, J ) */ -/* 10 CONTINUE */ -/* 20 CONTINUE */ - -/* Note that when DIAG = 'U' or 'u' the elements of the array A */ -/* corresponding to the diagonal elements of the matrix are not */ -/* referenced, 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 */ -/* ( k + 1 ). */ -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < *k + 1) { - info = 7; - } else if (*incx == 0) { - info = 9; - } - if (info != 0) { - xerbla_("DTBSV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - 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 <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed by sequentially with one pass through A. */ - - if (lsame_(trans, "N")) { - -/* Form x := inv( A )*x. */ - - if (lsame_(uplo, "U")) { - kplus1 = *k + 1; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - l = kplus1 - j; - if (nounit) { - x[j] /= a[kplus1 + j * a_dim1]; - } - temp = x[j]; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__1 = std::max(i__2,i__3); - for (i__ = j - 1; i__ >= i__1; --i__) { - x[i__] -= temp * a[l + i__ + j * a_dim1]; -/* L10: */ - } - } -/* L20: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - kx -= *incx; - if (x[jx] != 0.) { - ix = kx; - l = kplus1 - j; - if (nounit) { - x[jx] /= a[kplus1 + j * a_dim1]; - } - temp = x[jx]; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__1 = std::max(i__2,i__3); - for (i__ = j - 1; i__ >= i__1; --i__) { - x[ix] -= temp * a[l + i__ + j * a_dim1]; - ix -= *incx; -/* L30: */ - } - } - jx -= *incx; -/* L40: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - l = 1 - j; - if (nounit) { - x[j] /= a[j * a_dim1 + 1]; - } - temp = x[j]; -/* Computing MIN */ - i__3 = *n, i__4 = j + *k; - i__2 = std::min(i__3,i__4); - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[i__] -= temp * a[l + i__ + j * a_dim1]; -/* L50: */ - } - } -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - kx += *incx; - if (x[jx] != 0.) { - ix = kx; - l = 1 - j; - if (nounit) { - x[jx] /= a[j * a_dim1 + 1]; - } - temp = x[jx]; -/* Computing MIN */ - i__3 = *n, i__4 = j + *k; - i__2 = std::min(i__3,i__4); - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[ix] -= temp * a[l + i__ + j * a_dim1]; - ix += *incx; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } - } else { - -/* Form x := inv( A')*x. */ - - if (lsame_(uplo, "U")) { - kplus1 = *k + 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - temp -= a[l + i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - if (nounit) { - temp /= a[kplus1 + j * a_dim1]; - } - x[j] = temp; -/* L100: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = kx; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { - temp -= a[l + i__ + j * a_dim1] * x[ix]; - ix += *incx; -/* L110: */ - } - if (nounit) { - temp /= a[kplus1 + j * a_dim1]; - } - x[jx] = temp; - jx += *incx; - if (j > *k) { - kx += *incx; - } -/* L120: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - l = 1 - j; -/* Computing MIN */ - i__1 = *n, i__3 = j + *k; - i__4 = j + 1; - for (i__ = std::min(i__1,i__3); i__ >= i__4; --i__) { - temp -= a[l + i__ + j * a_dim1] * x[i__]; -/* L130: */ - } - if (nounit) { - temp /= a[j * a_dim1 + 1]; - } - x[j] = temp; -/* L140: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = kx; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__1 = j + *k; - i__3 = j + 1; - for (i__ = std::min(i__4,i__1); i__ >= i__3; --i__) { - temp -= a[l + i__ + j * a_dim1] * x[ix]; - ix -= *incx; -/* L150: */ - } - if (nounit) { - temp /= a[j * a_dim1 + 1]; - } - x[jx] = temp; - jx -= *incx; - if (*n - j >= *k) { - kx -= *incx; - } -/* L160: */ - } - } - } - } - - return 0; - -/* End of DTBSV . */ - -} /* dtbsv_ */ diff --git a/external/clapack/blas/dtpmv.cpp b/external/clapack/blas/dtpmv.cpp deleted file mode 100644 index b6a37297..00000000 --- a/external/clapack/blas/dtpmv.cpp +++ /dev/null @@ -1,345 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dtpmv_(const char *uplo, const char *trans, const char *diag, integer *n, - double *ap, double *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j, k, kk, ix, jx, kx, info; - double temp; - - - bool nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTPMV 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, supplied in packed form. */ - -/* Arguments */ -/* ========== */ - -/* 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. */ - -/* AP - DOUBLE PRECISION array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular matrix packed sequentially, */ -/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ -/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ -/* respectively, and so on. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular matrix packed sequentially, */ -/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ -/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ -/* respectively, and so on. */ -/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ -/* A are not referenced, but are assumed to be unity. */ -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --x; - --ap; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*incx == 0) { - info = 7; - } - if (info != 0) { - xerbla_("DTPMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - 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 <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of AP are */ -/* accessed sequentially with one pass through AP. */ - - if (lsame_(trans, "N")) { - -/* Form x:= A*x. */ - - if (lsame_(uplo, "U")) { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__] += temp * ap[k]; - ++k; -/* L10: */ - } - if (nounit) { - x[j] *= ap[kk + j - 1]; - } - } - kk += j; -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - x[ix] += temp * ap[k]; - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= ap[kk + j - 1]; - } - } - jx += *incx; - kk += j; -/* L40: */ - } - } - } else { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - k = kk; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[i__] += temp * ap[k]; - --k; -/* L50: */ - } - if (nounit) { - x[j] *= ap[kk - *n + j]; - } - } - kk -= *n - j + 1; -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__1 = kk - (*n - (j + 1)); - for (k = kk; k >= i__1; --k) { - x[ix] += temp * ap[k]; - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= ap[kk - *n + j]; - } - } - jx -= *incx; - kk -= *n - j + 1; -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x. */ - - if (lsame_(uplo, "U")) { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - if (nounit) { - temp *= ap[kk]; - } - k = kk - 1; - for (i__ = j - 1; i__ >= 1; --i__) { - temp += ap[k] * x[i__]; - --k; -/* L90: */ - } - x[j] = temp; - kk -= j; -/* L100: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= ap[kk]; - } - i__1 = kk - j + 1; - for (k = kk - 1; k >= i__1; --k) { - ix -= *incx; - temp += ap[k] * x[ix]; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; - kk -= j; -/* L120: */ - } - } - } else { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - if (nounit) { - temp *= ap[kk]; - } - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - temp += ap[k] * x[i__]; - ++k; -/* L130: */ - } - x[j] = temp; - kk += *n - j + 1; -/* L140: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= ap[kk]; - } - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - temp += ap[k] * x[ix]; -/* L150: */ - } - x[jx] = temp; - jx += *incx; - kk += *n - j + 1; -/* L160: */ - } - } - } - } - - return 0; - -/* End of DTPMV . */ - -} /* dtpmv_ */ diff --git a/external/clapack/blas/dtpsv.cpp b/external/clapack/blas/dtpsv.cpp deleted file mode 100644 index c14c2347..00000000 --- a/external/clapack/blas/dtpsv.cpp +++ /dev/null @@ -1,348 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dtpsv_(const char *uplo, const char *trans, const char *diag, integer *n, - double *ap, double *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j, k, kk, ix, jx, kx, info; - double temp; - - - bool nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTPSV 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, supplied in packed form. */ - -/* No test for singularity or near-singularity is included in this */ -/* routine. Such tests must be performed before calling this routine. */ - -/* Arguments */ -/* ========== */ - -/* 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. */ - -/* AP - DOUBLE PRECISION array of DIMENSION at least */ -/* ( ( n*( n + 1 ) )/2 ). */ -/* Before entry with UPLO = 'U' or 'u', the array AP must */ -/* contain the upper triangular matrix packed sequentially, */ -/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ -/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */ -/* respectively, and so on. */ -/* Before entry with UPLO = 'L' or 'l', the array AP must */ -/* contain the lower triangular matrix packed sequentially, */ -/* column by column, so that AP( 1 ) contains a( 1, 1 ), */ -/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */ -/* respectively, and so on. */ -/* Note that when DIAG = 'U' or 'u', the diagonal elements of */ -/* A are not referenced, but are assumed to be unity. */ -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --x; - --ap; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*incx == 0) { - info = 7; - } - if (info != 0) { - xerbla_("DTPSV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - 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 <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of AP are */ -/* accessed sequentially with one pass through AP. */ - - if (lsame_(trans, "N")) { - -/* Form x := inv( A )*x. */ - - if (lsame_(uplo, "U")) { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= ap[kk]; - } - temp = x[j]; - k = kk - 1; - for (i__ = j - 1; i__ >= 1; --i__) { - x[i__] -= temp * ap[k]; - --k; -/* L10: */ - } - } - kk -= j; -/* L20: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= ap[kk]; - } - temp = x[jx]; - ix = jx; - i__1 = kk - j + 1; - for (k = kk - 1; k >= i__1; --k) { - ix -= *incx; - x[ix] -= temp * ap[k]; -/* L30: */ - } - } - jx -= *incx; - kk -= j; -/* L40: */ - } - } - } else { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= ap[kk]; - } - temp = x[j]; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[i__] -= temp * ap[k]; - ++k; -/* L50: */ - } - } - kk += *n - j + 1; -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= ap[kk]; - } - temp = x[jx]; - ix = jx; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - x[ix] -= temp * ap[k]; -/* L70: */ - } - } - jx += *incx; - kk += *n - j + 1; -/* L80: */ - } - } - } - } else { - -/* Form x := inv( A' )*x. */ - - if (lsame_(uplo, "U")) { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - temp -= ap[k] * x[i__]; - ++k; -/* L90: */ - } - if (nounit) { - temp /= ap[kk + j - 1]; - } - x[j] = temp; - kk += j; -/* L100: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = kx; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - temp -= ap[k] * x[ix]; - ix += *incx; -/* L110: */ - } - if (nounit) { - temp /= ap[kk + j - 1]; - } - x[jx] = temp; - jx += *incx; - kk += j; -/* L120: */ - } - } - } else { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - k = kk; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - temp -= ap[k] * x[i__]; - --k; -/* L130: */ - } - if (nounit) { - temp /= ap[kk - *n + j]; - } - x[j] = temp; - kk -= *n - j + 1; -/* L140: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = kx; - i__1 = kk - (*n - (j + 1)); - for (k = kk; k >= i__1; --k) { - temp -= ap[k] * x[ix]; - ix -= *incx; -/* L150: */ - } - if (nounit) { - temp /= ap[kk - *n + j]; - } - x[jx] = temp; - jx -= *incx; - kk -= *n - j + 1; -/* L160: */ - } - } - } - } - - return 0; - -/* End of DTPSV . */ - -} /* dtpsv_ */ diff --git a/external/clapack/blas/dtrmm.cpp b/external/clapack/blas/dtrmm.cpp deleted file mode 100644 index df3a90b9..00000000 --- a/external/clapack/blas/dtrmm.cpp +++ /dev/null @@ -1,441 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dtrmm_(const char *side, const char *uplo, const char *transa, const char *diag, - integer *m, integer *n, double *alpha, double *a, integer * - lda, double *b, integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, info; - double temp; - bool lside; - - integer nrowa; - bool upper; - - bool nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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'. */ - -/* Arguments */ -/* ========== */ - -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 9; - } else if (*ldb < std::max(1_integer,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("DTRMM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { // changed in lapack 3.2.1 - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - return 0; - } - -/* Start the operations. */ - - if (lside) { - if (lsame_(transa, "N")) { - -/* Form B := alpha*A*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.) { - temp = *alpha * b[k + j * b_dim1]; - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * a[i__ + k * - a_dim1]; -/* L30: */ - } - if (nounit) { - temp *= a[k + k * a_dim1]; - } - b[k + j * b_dim1] = temp; - } -/* L40: */ - } -/* L50: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.) { - temp = *alpha * b[k + j * b_dim1]; - b[k + j * b_dim1] = temp; - if (nounit) { - b[k + j * b_dim1] *= a[k + k * a_dim1]; - } - i__2 = *m; - for (i__ = k + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * a[i__ + k * - a_dim1]; -/* L60: */ - } - } -/* L70: */ - } -/* L80: */ - } - } - } else { - -/* Form B := alpha*A'*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = b[i__ + j * b_dim1]; - if (nounit) { - temp *= a[i__ + i__ * a_dim1]; - } - i__2 = i__ - 1; - for (k = 1; k <= i__2; ++k) { - temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L90: */ - } - b[i__ + j * b_dim1] = *alpha * temp; -/* L100: */ - } -/* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = b[i__ + j * b_dim1]; - if (nounit) { - temp *= a[i__ + i__ * a_dim1]; - } - i__3 = *m; - for (k = i__ + 1; k <= i__3; ++k) { - temp += a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L120: */ - } - b[i__ + j * b_dim1] = *alpha * temp; -/* L130: */ - } -/* L140: */ - } - } - } - } else { - if (lsame_(transa, "N")) { - -/* Form B := alpha*B*A. */ - - if (upper) { - for (j = *n; j >= 1; --j) { - temp = *alpha; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L150: */ - } - i__1 = j - 1; - for (k = 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.) { - temp = *alpha * a[k + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = *alpha; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L190: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.) { - temp = *alpha * a[k + j * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L200: */ - } - } -/* L210: */ - } -/* L220: */ - } - } - } else { - -/* Form B := alpha*B*A'. */ - - if (upper) { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - i__2 = k - 1; - for (j = 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = *alpha * a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L230: */ - } - } -/* L240: */ - } - temp = *alpha; - if (nounit) { - temp *= a[k + k * a_dim1]; - } - if (temp != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L250: */ - } - } -/* L260: */ - } - } else { - for (k = *n; k >= 1; --k) { - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = *alpha * a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] += temp * b[i__ + k * - b_dim1]; -/* L270: */ - } - } -/* L280: */ - } - temp = *alpha; - if (nounit) { - temp *= a[k + k * a_dim1]; - } - if (temp != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L290: */ - } - } -/* L300: */ - } - } - } - } - - return 0; - -/* End of DTRMM . */ - -} /* dtrmm_ */ diff --git a/external/clapack/blas/dtrmv.cpp b/external/clapack/blas/dtrmv.cpp deleted file mode 100644 index 6c889bc4..00000000 --- a/external/clapack/blas/dtrmv.cpp +++ /dev/null @@ -1,333 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dtrmv_(const char *uplo, const char *trans, const char *diag, integer *n, - double *a, integer *lda, double *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, jx, kx, info; - double temp; - - - bool nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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. */ - -/* Arguments */ -/* ========== */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*lda < std::max(1_integer,*n)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } - if (info != 0) { - xerbla_("DTRMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - 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 <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N")) { - -/* Form x := A*x. */ - - if (lsame_(uplo, "U")) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__] += temp * a[i__ + j * a_dim1]; -/* L10: */ - } - if (nounit) { - x[j] *= a[j + j * a_dim1]; - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[ix] += temp * a[i__ + j * a_dim1]; - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= a[j + j * a_dim1]; - } - } - jx += *incx; -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[i__] += temp * a[i__ + j * a_dim1]; -/* L50: */ - } - if (nounit) { - x[j] *= a[j + j * a_dim1]; - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[ix] += temp * a[i__ + j * a_dim1]; - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= a[j + j * a_dim1]; - } - } - jx -= *incx; -/* L80: */ - } - } - } - } else { - -/* Form x := A'*x. */ - - if (lsame_(uplo, "U")) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - for (i__ = j - 1; i__ >= 1; --i__) { - temp += a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - x[j] = temp; -/* L100: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - temp += a[i__ + j * a_dim1] * x[ix]; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[i__]; -/* L130: */ - } - x[j] = temp; -/* L140: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a[j + j * a_dim1]; - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - temp += a[i__ + j * a_dim1] * x[ix]; -/* L150: */ - } - x[jx] = temp; - jx += *incx; -/* L160: */ - } - } - } - } - - return 0; - -/* End of DTRMV . */ - -} /* dtrmv_ */ diff --git a/external/clapack/blas/dtrsm.cpp b/external/clapack/blas/dtrsm.cpp deleted file mode 100644 index 534436ae..00000000 --- a/external/clapack/blas/dtrsm.cpp +++ /dev/null @@ -1,478 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dtrsm_(const char *side, const char *uplo, const char *transa, const char *diag, - integer *m, integer *n, double *alpha, double *a, integer * - lda, double *b, integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, info; - double temp; - bool lside; - - integer nrowa; - bool upper; - - bool nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRSM solves one of the matrix equations */ - -/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ - -/* where alpha is a scalar, X and B are m by n matrices, 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'. */ - -/* The matrix X is overwritten on B. */ - -/* Arguments */ -/* ========== */ - -/* SIDE - CHARACTER*1. */ -/* On entry, SIDE specifies whether op( A ) appears on the left */ -/* or right of X as follows: */ - -/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ - -/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ - -/* 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 right-hand side matrix B, and on exit is */ -/* overwritten by the solution matrix X. */ - -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 9; - } else if (*ldb < std::max(1_integer,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("DTRSM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { // changed in lapack 3.2.1 - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - return 0; - } - -/* Start the operations. */ - - if (lside) { - if (lsame_(transa, "N")) { - -/* Form B := alpha*inv( A )*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L30: */ - } - } - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__2 = k - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; -/* L40: */ - } - } -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L70: */ - } - } - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__3 = *m; - for (i__ = k + 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; -/* L80: */ - } - } -/* L90: */ - } -/* L100: */ - } - } - } else { - -/* Form B := alpha*inv( A' )*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L110: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L140: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; -/* L150: */ - } -/* L160: */ - } - } - } - } else { - if (lsame_(transa, "N")) { - -/* Form B := alpha*B*inv( A ). */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L170: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; -/* L180: */ - } - } -/* L190: */ - } - if (nounit) { - temp = 1. / a[j + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L200: */ - } - } -/* L210: */ - } - } else { - for (j = *n; j >= 1; --j) { - if (*alpha != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L220: */ - } - } - i__1 = *n; - for (k = j + 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; -/* L230: */ - } - } -/* L240: */ - } - if (nounit) { - temp = 1. / a[j + j * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L250: */ - } - } -/* L260: */ - } - } - } else { - -/* Form B := alpha*B*inv( A' ). */ - - if (upper) { - for (k = *n; k >= 1; --k) { - if (nounit) { - temp = 1. / a[k + k * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L270: */ - } - } - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; -/* L280: */ - } - } -/* L290: */ - } - if (*alpha != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; -/* L300: */ - } - } -/* L310: */ - } - } else { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (nounit) { - temp = 1. / a[k + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L320: */ - } - } - i__2 = *n; - for (j = k + 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.) { - temp = a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; -/* L330: */ - } - } -/* L340: */ - } - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; -/* L350: */ - } - } -/* L360: */ - } - } - } - } - - return 0; - -/* End of DTRSM . */ - -} /* dtrsm_ */ diff --git a/external/clapack/blas/dtrsv.cpp b/external/clapack/blas/dtrsv.cpp deleted file mode 100644 index 32fb77a9..00000000 --- a/external/clapack/blas/dtrsv.cpp +++ /dev/null @@ -1,336 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -/* Subroutine */ int dtrsv_(const char *uplo, const char *trans, const char *diag, integer *n, - double *a, integer *lda, double *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, jx, kx, info; - double temp; - - - bool nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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. */ - -/* Arguments */ -/* ========== */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*lda < std::max(1_integer,*n)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } - if (info != 0) { - xerbla_("DTRSV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - - 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 <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } - -/* Start the operations. In this version the elements of A are */ -/* accessed sequentially with one pass through A. */ - - if (lsame_(trans, "N")) { - -/* Form x := inv( A )*x. */ - - if (lsame_(uplo, "U")) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= a[j + j * a_dim1]; - } - temp = x[j]; - for (i__ = j - 1; i__ >= 1; --i__) { - x[i__] -= temp * a[i__ + j * a_dim1]; -/* L10: */ - } - } -/* L20: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= a[j + j * a_dim1]; - } - temp = x[jx]; - ix = jx; - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - x[ix] -= temp * a[i__ + j * a_dim1]; -/* L30: */ - } - } - jx -= *incx; -/* L40: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= a[j + j * a_dim1]; - } - temp = x[j]; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[i__] -= temp * a[i__ + j * a_dim1]; -/* L50: */ - } - } -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= a[j + j * a_dim1]; - } - temp = x[jx]; - ix = jx; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - x[ix] -= temp * a[i__ + j * a_dim1]; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } - } else { - -/* Form x := inv( A' )*x. */ - - if (lsame_(uplo, "U")) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - temp -= a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - if (nounit) { - temp /= a[j + j * a_dim1]; - } - x[j] = temp; -/* L100: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - temp -= a[i__ + j * a_dim1] * x[ix]; - ix += *incx; -/* L110: */ - } - if (nounit) { - temp /= a[j + j * a_dim1]; - } - x[jx] = temp; - jx += *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - temp -= a[i__ + j * a_dim1] * x[i__]; -/* L130: */ - } - if (nounit) { - temp /= a[j + j * a_dim1]; - } - x[j] = temp; -/* L140: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - temp -= a[i__ + j * a_dim1] * x[ix]; - ix -= *incx; -/* L150: */ - } - if (nounit) { - temp /= a[j + j * a_dim1]; - } - x[jx] = temp; - jx -= *incx; -/* L160: */ - } - } - } - } - - return 0; - -/* End of DTRSV . */ - -} /* dtrsv_ */ diff --git a/external/clapack/blas/idamax.cpp b/external/clapack/blas/idamax.cpp deleted file mode 100644 index e9205a3f..00000000 --- a/external/clapack/blas/idamax.cpp +++ /dev/null @@ -1,81 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -integer idamax_(integer *n, double *dx, integer *incx) -{ - /* System generated locals */ - integer ret_val, i__1; - double d__1; - - /* Local variables */ - integer i__, ix; - double dmax__; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* finds the index of element having max. absolute value. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 3/93 to return if incx .le. 0. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --dx; - - /* Function Body */ - ret_val = 0; - if (*n < 1 || *incx <= 0) { - return ret_val; - } - ret_val = 1; - if (*n == 1) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - ix = 1; - dmax__ = abs(dx[1]); - ix += *incx; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((d__1 = dx[ix], abs(d__1)) <= dmax__) { - goto L5; - } - ret_val = i__; - dmax__ = (d__1 = dx[ix], abs(d__1)); -L5: - ix += *incx; -/* L10: */ - } - return ret_val; - -/* code for increment equal to 1 */ - -L20: - dmax__ = abs(dx[1]); - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((d__1 = dx[i__], abs(d__1)) <= dmax__) { - goto L30; - } - ret_val = i__; - dmax__ = (d__1 = dx[i__], abs(d__1)); -L30: - ; - } - return ret_val; -} /* idamax_ */ diff --git a/external/clapack/blas/sdot.cpp b/external/clapack/blas/sdot.cpp deleted file mode 100644 index 2a26add1..00000000 --- a/external/clapack/blas/sdot.cpp +++ /dev/null @@ -1,98 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - - -double sdot_(integer *n, float *sx, integer *incx, float *sy, integer *incy) -{ - /* System generated locals */ - integer i__1; - float ret_val; - - /* Local variables */ - integer i__, m, ix, iy, mp1; - float stemp; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* forms the dot product of two vectors. */ -/* uses unrolled loops for increments equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --sy; - --sx; - - /* Function Body */ - stemp = 0.f; - ret_val = 0.f; - if (*n <= 0) { - return ret_val; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments */ -/* not equal to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - stemp += sx[ix] * sy[iy]; - ix += *incx; - iy += *incy; -/* L10: */ - } - ret_val = stemp; - return ret_val; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - stemp += sx[i__] * sy[i__]; -/* L30: */ - } - if (*n < 5) { - goto L60; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 5) { - stemp = stemp + sx[i__] * sy[i__] + sx[i__ + 1] * sy[i__ + 1] + sx[ - i__ + 2] * sy[i__ + 2] + sx[i__ + 3] * sy[i__ + 3] + sx[i__ + - 4] * sy[i__ + 4]; -/* L50: */ - } -L60: - ret_val = stemp; - return ret_val; -} /* sdot_ */ diff --git a/external/clapack/blas/sgemm.cpp b/external/clapack/blas/sgemm.cpp deleted file mode 100644 index fc280c4c..00000000 --- a/external/clapack/blas/sgemm.cpp +++ /dev/null @@ -1,372 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - - -int sgemm_(const char *transa, const char *transb, integer *m, integer *n, integer *k, float *alpha, - float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, info; - bool nota, notb; - float temp; - integer ncola, nrowa, nrowb; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGEMM 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. */ - -/* Arguments */ -/* ========== */ - -/* 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 - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - REAL 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 - REAL 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 - REAL . */ -/* 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 - REAL 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* 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. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - nota = lsame_(transa, "N"); - notb = lsame_(transb, "N"); - if (nota) { - nrowa = *m; - ncola = *k; - } else { - nrowa = *k; - ncola = *m; - } - if (notb) { - nrowb = *k; - } else { - nrowb = *n; - } - -/* Test the input parameters. */ - - info = 0; - if (! nota && ! lsame_(transa, "C") && ! lsame_( - transa, "T")) { - info = 1; - } else if (! notb && ! lsame_(transb, "C") && ! - lsame_(transb, "T")) { - info = 2; - } else if (*m < 0) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 8; - } else if (*ldb < std::max(1_integer,nrowb)) { - info = 10; - } else if (*ldc < std::max(1_integer,*m)) { - info = 13; - } - if (info != 0) { - xerbla_("SGEMM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { - return 0; - } - -/* And if alpha.eq.zero. */ - - if (*alpha == 0.f) { - if (*beta == 0.f) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - return 0; - } - -/* Start the operations. */ - - if (notb) { - if (nota) { - -/* Form C := alpha*A*B + beta*C. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L50: */ - } - } else if (*beta != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L60: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (b[l + j * b_dim1] != 0.f) { - temp = *alpha * b[l + j * b_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L70: */ - } - } -/* L80: */ - } -/* L90: */ - } - } else { - -/* Form C := alpha*A'*B + beta*C */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.f; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * b[l + j * b_dim1]; -/* L100: */ - } - if (*beta == 0.f) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L110: */ - } -/* L120: */ - } - } - } else { - if (nota) { - -/* Form C := alpha*A*B' + beta*C */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L130: */ - } - } else if (*beta != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L140: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (b[j + l * b_dim1] != 0.f) { - temp = *alpha * b[j + l * b_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L150: */ - } - } -/* L160: */ - } -/* L170: */ - } - } else { - -/* Form C := alpha*A'*B' + beta*C */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.f; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * b[j + l * b_dim1]; -/* L180: */ - } - if (*beta == 0.f) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L190: */ - } -/* L200: */ - } - } - } - - return 0; - -/* End of SGEMM . */ - -} /* sgemm_ */ diff --git a/external/clapack/blas/sgemv.cpp b/external/clapack/blas/sgemv.cpp deleted file mode 100644 index dd18c66a..00000000 --- a/external/clapack/blas/sgemv.cpp +++ /dev/null @@ -1,298 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - - -int sgemv_(const char *trans, integer *m, integer *n, float *alpha, float *a, integer *lda, float *x, - integer *incx, float *beta, float *y, integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ix, iy, jx, jy, kx, ky, info; - float temp; - integer lenx, leny; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SGEMV 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. */ - -/* Arguments */ -/* ========== */ - -/* 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 - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - REAL 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 - REAL 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 - REAL . */ -/* 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 - REAL 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --y; - - /* Function Body */ - info = 0; - if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") - ) { - info = 1; - } else if (*m < 0) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*lda < std::max(1_integer,*m)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("SGEMV ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) { - return 0; - } - -/* 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")) { - lenx = *n; - leny = *m; - } else { - lenx = *m; - leny = *n; - } - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (lenx - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (leny - 1) * *incy; - } - -/* 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 != 1.f) { - if (*incy == 1) { - if (*beta == 0.f) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.f; -/* L10: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.f) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.f; - iy += *incy; -/* L30: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.f) { - return 0; - } - if (lsame_(trans, "N")) { - -/* Form y := alpha*A*x + y. */ - - jx = kx; - if (*incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.f) { - temp = *alpha * x[jx]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp * a[i__ + j * a_dim1]; -/* L50: */ - } - } - jx += *incx; -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.f) { - temp = *alpha * x[jx]; - iy = ky; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp * a[i__ + j * a_dim1]; - iy += *incy; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } else { - -/* Form y := alpha*A'*x + y. */ - - jy = ky; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.f; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[i__]; -/* L90: */ - } - y[jy] += *alpha * temp; - jy += *incy; -/* L100: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.f; - ix = kx; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += a[i__ + j * a_dim1] * x[ix]; - ix += *incx; -/* L110: */ - } - y[jy] += *alpha * temp; - jy += *incy; -/* L120: */ - } - } - } - - return 0; - -/* End of SGEMV . */ - -} /* sgemv_ */ diff --git a/external/clapack/blas/sscal.cpp b/external/clapack/blas/sscal.cpp deleted file mode 100644 index 93304ade..00000000 --- a/external/clapack/blas/sscal.cpp +++ /dev/null @@ -1,83 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -int sscal_(integer *n, float *sa, float *sx, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, m, mp1, nincx; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* scales a vector by a constant. */ -/* uses unrolled loops for increment equal to 1. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 3/93 to return if incx .le. 0. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ - /* Parameter adjustments */ - --sx; - - /* Function Body */ - if (*n <= 0 || *incx <= 0) { - return 0; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - sx[i__] = *sa * sx[i__]; -/* L10: */ - } - return 0; - -/* code for increment equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__2 = m; - for (i__ = 1; i__ <= i__2; ++i__) { - sx[i__] = *sa * sx[i__]; -/* L30: */ - } - if (*n < 5) { - return 0; - } -L40: - mp1 = m + 1; - i__2 = *n; - for (i__ = mp1; i__ <= i__2; i__ += 5) { - sx[i__] = *sa * sx[i__]; - sx[i__ + 1] = *sa * sx[i__ + 1]; - sx[i__ + 2] = *sa * sx[i__ + 2]; - sx[i__ + 3] = *sa * sx[i__ + 3]; - sx[i__ + 4] = *sa * sx[i__ + 4]; -/* L50: */ - } - return 0; -} /* sscal_ */ diff --git a/external/clapack/blas/ssyrk.cpp b/external/clapack/blas/ssyrk.cpp deleted file mode 100644 index 4336a5fa..00000000 --- a/external/clapack/blas/ssyrk.cpp +++ /dev/null @@ -1,358 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - - -int ssyrk_(const char *uplo, const char *trans, integer *n, integer *k, - float *alpha, float *a, integer *lda, float *beta, float *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, info; - float temp; - integer nrowa; - bool upper; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SSYRK performs one of the symmetric rank k operations */ - -/* C := alpha*A*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*A + beta*C, */ - -/* where alpha and beta are scalars, C is an n by n symmetric matrix */ -/* and A is an n by k matrix in the first case and a k by n matrix */ -/* in the second case. */ - -/* Arguments */ -/* ========== */ - -/* UPLO - CHARACTER*1. */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - CHARACTER*1. */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ - -/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */ - -/* Unchanged on exit. */ - -/* N - INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrix A, and on entry with */ -/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */ -/* of rows of the matrix A. K must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - REAL . */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */ -/* k when TRANS = 'N' or 'n', and is n otherwise. */ -/* Before entry with TRANS = 'N' or 'n', the leading n by k */ -/* part of the array A must contain the matrix A, otherwise */ -/* the leading k by n 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 TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - REAL . */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - -/* C - REAL array of DIMENSION ( LDC, n ). */ -/* Before entry with UPLO = 'U' or 'u', the leading n by n */ -/* upper triangular part of the array C must contain the upper */ -/* triangular part of the symmetric matrix and the strictly */ -/* lower triangular part of C is not referenced. On exit, the */ -/* upper triangular part of the array C is overwritten by the */ -/* upper triangular part of the updated matrix. */ -/* Before entry with UPLO = 'L' or 'l', the leading n by n */ -/* lower triangular part of the array C must contain the lower */ -/* triangular part of the symmetric matrix and the strictly */ -/* upper triangular part of C is not referenced. On exit, the */ -/* lower triangular part of the array C is overwritten by the */ -/* lower triangular part of the updated matrix. */ - -/* 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, n ). */ -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 7; - } else if (*ldc < std::max(1_integer,*n)) { - info = 10; - } - if (info != 0) { - xerbla_("SSYRK ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.f) { - if (upper) { - if (*beta == 0.f) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.f) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } - -/* Start the operations. */ - - if (lsame_(trans, "N")) { - -/* Form C := alpha*A*A' + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.f) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L90: */ - } - } else if (*beta != 1.f) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.f) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.f) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = 0.f; -/* L140: */ - } - } else if (*beta != 1.f) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]; -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a[j + l * a_dim1] != 0.f) { - temp = *alpha * a[j + l * a_dim1]; - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c__[i__ + j * c_dim1] += temp * a[i__ + l * - a_dim1]; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { - -/* Form C := alpha*A'*A + beta*C. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.f; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; -/* L190: */ - } - if (*beta == 0.f) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp = 0.f; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a[l + i__ * a_dim1] * a[l + j * a_dim1]; -/* L220: */ - } - if (*beta == 0.f) { - c__[i__ + j * c_dim1] = *alpha * temp; - } else { - c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[ - i__ + j * c_dim1]; - } -/* L230: */ - } -/* L240: */ - } - } - } - - return 0; - -/* End of SSYRK . */ - -} /* ssyrk_ */ diff --git a/external/clapack/blas/strsm.cpp b/external/clapack/blas/strsm.cpp deleted file mode 100644 index 10a55167..00000000 --- a/external/clapack/blas/strsm.cpp +++ /dev/null @@ -1,474 +0,0 @@ -#include "cblas.h" -#include "f2cP.h" - -int strsm_(const char *side, const char *uplo, const char *transa, const char *diag, - integer *m, integer *n, float *alpha, float *a, integer *lda, float *b, integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, info; - float temp; - bool lside; - integer nrowa; - bool upper, nounit; - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* STRSM solves one of the matrix equations */ - -/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */ - -/* where alpha is a scalar, X and B are m by n matrices, 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'. */ - -/* The matrix X is overwritten on B. */ - -/* Arguments */ -/* ========== */ - -/* SIDE - CHARACTER*1. */ -/* On entry, SIDE specifies whether op( A ) appears on the left */ -/* or right of X as follows: */ - -/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ - -/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ - -/* 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 - REAL . */ -/* 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 - REAL 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 - REAL array of DIMENSION ( LDB, n ). */ -/* Before entry, the leading m by n part of the array B must */ -/* contain the right-hand side matrix B, and on exit is */ -/* overwritten by the solution matrix X. */ - -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < std::max(1_integer,nrowa)) { - info = 9; - } else if (*ldb < std::max(1_integer,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("STRSM ", &info); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* And when alpha.eq.zero. */ - - if (*alpha == 0.f) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.f; -/* L10: */ - } -/* L20: */ - } - return 0; - } - -/* Start the operations. */ - - if (lside) { - if (lsame_(transa, "N")) { - -/* Form B := alpha*inv( A )*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L30: */ - } - } - for (k = *m; k >= 1; --k) { - if (b[k + j * b_dim1] != 0.f) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__2 = k - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; -/* L40: */ - } - } -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L70: */ - } - } - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b[k + j * b_dim1] != 0.f) { - if (nounit) { - b[k + j * b_dim1] /= a[k + k * a_dim1]; - } - i__3 = *m; - for (i__ = k + 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[ - i__ + k * a_dim1]; -/* L80: */ - } - } -/* L90: */ - } -/* L100: */ - } - } - } else { - -/* Form B := alpha*inv( A' )*B. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L110: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = *alpha * b[i__ + j * b_dim1]; - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1]; -/* L140: */ - } - if (nounit) { - temp /= a[i__ + i__ * a_dim1]; - } - b[i__ + j * b_dim1] = temp; -/* L150: */ - } -/* L160: */ - } - } - } - } else { - if (lsame_(transa, "N")) { - -/* Form B := alpha*B*inv( A ). */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L170: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (a[k + j * a_dim1] != 0.f) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; -/* L180: */ - } - } -/* L190: */ - } - if (nounit) { - temp = 1.f / a[j + j * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L200: */ - } - } -/* L210: */ - } - } else { - for (j = *n; j >= 1; --j) { - if (*alpha != 1.f) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1] - ; -/* L220: */ - } - } - i__1 = *n; - for (k = j + 1; k <= i__1; ++k) { - if (a[k + j * a_dim1] != 0.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[ - i__ + k * b_dim1]; -/* L230: */ - } - } -/* L240: */ - } - if (nounit) { - temp = 1.f / a[j + j * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1]; -/* L250: */ - } - } -/* L260: */ - } - } - } else { - -/* Form B := alpha*B*inv( A' ). */ - - if (upper) { - for (k = *n; k >= 1; --k) { - if (nounit) { - temp = 1.f / a[k + k * a_dim1]; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L270: */ - } - } - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - if (a[j + k * a_dim1] != 0.f) { - temp = a[j + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; -/* L280: */ - } - } -/* L290: */ - } - if (*alpha != 1.f) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; -/* L300: */ - } - } -/* L310: */ - } - } else { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (nounit) { - temp = 1.f / a[k + k * a_dim1]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1]; -/* L320: */ - } - } - i__2 = *n; - for (j = k + 1; j <= i__2; ++j) { - if (a[j + k * a_dim1] != 0.f) { - temp = a[j + k * a_dim1]; - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b[i__ + j * b_dim1] -= temp * b[i__ + k * - b_dim1]; -/* L330: */ - } - } -/* L340: */ - } - if (*alpha != 1.f) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1] - ; -/* L350: */ - } - } -/* L360: */ - } - } - } - } - - return 0; - -/* End of STRSM . */ - -} /* strsm_ */ diff --git a/external/clapack/cblas.h b/external/clapack/cblas.h index 96be74ef..5ee9c397 100644 --- a/external/clapack/cblas.h +++ b/external/clapack/cblas.h @@ -2,7 +2,7 @@ #define _cblas_h_ /* cblas.h * - * Copyright (C) 2020 David Weenink + * Copyright (C) 2020 David Weenink, Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -18,7 +18,7 @@ * along with this work. If not, see . */ -#include "melder.h" +#include "melder.h" // for integer double dasum_ (integer *n, double *dx, integer *incx); @@ -137,20 +137,4 @@ int dtrsv_ (const char *uplo, const char *trans, const char *diag, integer *n, integer idamax_ (integer *n, double *dx, integer *incx); -double sdot_(integer *n, float *sx, integer *incx, float *sy, integer *incy); - -int sgemm_(const char *transa, const char *transb, integer *m, integer *n, integer *k, float *alpha, - float *a, integer *lda, float *b, integer *ldb, float *beta, float *c__, integer *ldc); - -int sgemv_(const char *trans, integer *m, integer *n, float *alpha, float *a, integer *lda, float *x, - integer *incx, float *beta, float *y, integer *incy); - -int sscal_(integer *n, float *sa, float *sx, integer *incx); - -int ssyrk_(const char *uplo, const char *trans, integer *n, integer *k, - float *alpha, float *a, integer *lda, float *beta, float *c__, integer *ldc); - -int strsm_(const char *side, const char *uplo, const char *transa, const char *diag, - integer *m, integer *n, float *alpha, float *a, integer *lda, float *b, integer *ldb); - #endif /* _cblas_h_ */ diff --git a/external/clapack/clapack.h b/external/clapack/clapack.h index 48cbfd79..cc362ff2 100644 --- a/external/clapack/clapack.h +++ b/external/clapack/clapack.h @@ -1,5 +1,5 @@ -#ifndef __CLAPACK_H -#define __CLAPACK_H +#ifndef _clapack_h_ +#define _clapack_h_ #include "melder.h" @@ -12,39 +12,39 @@ int dbdsdc_(const char *uplo, const char *compq, integer *n, double * integer *ldvt, double *q, integer *iq, double *work, integer * iwork, integer *info); - int dbdsqr_(const char *uplo, integer *n, integer *ncvt, integer * +int dbdsqr_(const char *uplo, integer *n, integer *ncvt, integer * nru, integer *ncc, double *d__, double *e, double *vt, integer *ldvt, double *u, integer *ldu, double *c__, integer * ldc, double *work, integer *info); int ddisna_(const char *job, integer *m, integer *n, double *d__, double *sep, integer *info); - int dgbbrd_(const char *vect, integer *m, integer *n, integer *ncc, - integer *kl, integer *ku, double *ab, integer *ldab, double * +int dgbbrd_(const char *vect, integer *m, integer *n, integer *ncc, + integer *kl, integer *ku, double *ab, integer *ldab, double * d__, double *e, double *q, integer *ldq, double *pt, integer *ldpt, double *c__, integer *ldc, double *work, integer *info); - int dgbcon_(const char *norm, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, integer *ipiv, double *anorm, +int dgbcon_(const char *norm, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, integer *ipiv, double *anorm, double *rcond, double *work, integer *iwork, integer *info); - int dgbequ_(integer *m, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, double *r__, double *c__, +int dgbequ_(integer *m, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, double *r__, double *c__, double *rowcnd, double *colcnd, double *amax, integer * info); - int dgbequb_(integer *m, integer *n, integer *kl, integer * +int dgbequb_(integer *m, integer *n, integer *kl, integer * ku, double *ab, integer *ldab, double *r__, double *c__, double *rowcnd, double *colcnd, double *amax, integer *info); - int dgbrfs_(const char *trans, integer *n, integer *kl, integer * +int dgbrfs_(const char *trans, integer *n, integer *kl, integer * ku, integer *nrhs, double *ab, integer *ldab, double *afb, integer *ldafb, integer *ipiv, double *b, integer *ldb, double *x, integer *ldx, double *ferr, double *berr, double *work, integer *iwork, integer *info); - int dgbrfsx_(const char *trans, const char *equed, integer *n, integer * +int dgbrfsx_(const char *trans, const char *equed, integer *n, integer * kl, integer *ku, integer *nrhs, double *ab, integer *ldab, double *afb, integer *ldafb, integer *ipiv, double *r__, double *c__, double *b, integer *ldb, double *x, integer * @@ -55,7 +55,7 @@ int ddisna_(const char *job, integer *m, integer *n, double *d__, double *sep, i int dgbsv_(integer *n, integer *kl, integer *ku, integer *nrhs, double *ab, integer *ldab, integer *ipiv, double *b, integer *ldb, integer *info); - int dgbsvxx_(const char *fact, const char *trans, integer *n, integer * +int dgbsvxx_(const char *fact, const char *trans, integer *n, integer * kl, integer *ku, integer *nrhs, double *ab, integer *ldab, double *afb, integer *ldafb, integer *ipiv, char *equed, double *r__, double *c__, double *b, integer *ldb, @@ -64,169 +64,169 @@ int dgbsv_(integer *n, integer *kl, integer *ku, integer *nrhs, double *ab, inte double *err_bnds_comp__, integer *nparams, double *params, double *work, integer *iwork, integer *info); - int dgbsvx_(const char *fact, const char *trans, integer *n, integer *kl, - integer *ku, integer *nrhs, double *ab, integer *ldab, +int dgbsvx_(const char *fact, const char *trans, integer *n, integer *kl, + integer *ku, integer *nrhs, double *ab, integer *ldab, double *afb, integer *ldafb, integer *ipiv, char *equed, double *r__, double *c__, double *b, integer *ldb, double *x, integer *ldx, double *rcond, double *ferr, double *berr, double *work, integer *iwork, integer *info); - int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, integer *ipiv, integer *info); +int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, integer *ipiv, integer *info); - int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, integer *ipiv, integer *info); +int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, integer *ipiv, integer *info); - int dgbtrs_(const char *trans, integer *n, integer *kl, integer * +int dgbtrs_(const char *trans, integer *n, integer *kl, integer * ku, integer *nrhs, double *ab, integer *ldab, integer *ipiv, double *b, integer *ldb, integer *info); - int dgebak_(const char *job, const char *side, integer *n, integer *ilo, +int dgebak_(const char *job, const char *side, integer *n, integer *ilo, integer *ihi, double *scale, integer *m, double *v, integer * ldv, integer *info); - int dgebal_(const char *job, integer *n, double *a, integer * +int dgebal_(const char *job, integer *n, double *a, integer * lda, integer *ilo, integer *ihi, double *scale, integer *info); - int dgebd2_(integer *m, integer *n, double *a, integer * +int dgebd2_(integer *m, integer *n, double *a, integer * lda, double *d__, double *e, double *tauq, double * taup, double *work, integer *info); - int dgebrd_(integer *m, integer *n, double *a, integer * +int dgebrd_(integer *m, integer *n, double *a, integer * lda, double *d__, double *e, double *tauq, double * taup, double *work, integer *lwork, integer *info); - int dgecon_(const char *norm, integer *n, double *a, integer * +int dgecon_(const char *norm, integer *n, double *a, integer * lda, double *anorm, double *rcond, double *work, integer * iwork, integer *info); - int dgeequ_(integer *m, integer *n, double *a, integer * +int dgeequ_(integer *m, integer *n, double *a, integer * lda, double *r__, double *c__, double *rowcnd, double *colcnd, double *amax, integer *info); - int dgeequb_(integer *m, integer *n, double *a, integer *lda, double *r__, double *c__, +int dgeequb_(integer *m, integer *n, double *a, integer *lda, double *r__, double *c__, double *rowcnd, double *colcnd, double *amax, integer *info); - int dgees_(const char *jobvs, const char *sort, bool (*select)(const double *, const double *), +int dgees_(const char *jobvs, const char *sort, bool (*select)(const double *, const double *), integer *n, double *a, integer *lda, integer *sdim, double *wr, double *wi, double *vs, integer *ldvs, double *work, integer *lwork, bool *bwork, integer *info); - int dgeesx_(const char *jobvs, const char *sort, bool (*select)(const double *, const double *), +int dgeesx_(const char *jobvs, const char *sort, bool (*select)(const double *, const double *), const char *sense, integer *n, double *a, integer *lda, integer *sdim, double *wr, double *wi, double *vs, integer *ldvs, double *rconde, double *rcondv, double *work, integer * lwork, integer *iwork, integer *liwork, bool *bwork, integer *info); - int dgeev_(const char *jobvl, const char *jobvr, integer *n, double *a, integer *lda, +int dgeev_(const char *jobvl, const char *jobvr, integer *n, double *a, integer *lda, double *wr, double *wi, double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, integer *info); - int dgeevx_(const char *balanc, const char *jobvl, const char *jobvr, const char * +int dgeevx_(const char *balanc, const char *jobvl, const char *jobvr, const char * sense, integer *n, double *a, integer *lda, double *wr, double *wi, double *vl, integer *ldvl, double *vr, integer *ldvr, integer *ilo, integer *ihi, double *scale, double *abnrm, double *rconde, double *rcondv, double *work, integer *lwork, integer *iwork, integer *info); - int dgegs_(const char *jobvsl, const char *jobvsr, integer *n, +int dgegs_(const char *jobvsl, const char *jobvsr, integer *n, double *a, integer *lda, double *b, integer *ldb, double * alphar, double *alphai, double *beta, double *vsl, integer *ldvsl, double *vsr, integer *ldvsr, double *work, integer *lwork, integer *info); - int dgegv_(const char *jobvl, const char *jobvr, integer *n, double * +int dgegv_(const char *jobvl, const char *jobvr, integer *n, double * a, integer *lda, double *b, integer *ldb, double *alphar, double *alphai, double *beta, double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, integer *info); - int dgehd2_(integer *n, integer *ilo, integer *ihi, +int dgehd2_(integer *n, integer *ilo, integer *ihi, double *a, integer *lda, double *tau, double *work, integer *info); - int dgehrd_(integer *n, integer *ilo, integer *ihi, +int dgehrd_(integer *n, integer *ilo, integer *ihi, double *a, integer *lda, double *tau, double *work, integer *lwork, integer *info); - int dgelq2_(integer *m, integer *n, double *a, integer * +int dgelq2_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *info); - int dgelqf_(integer *m, integer *n, double *a, integer * +int dgelqf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); - int dgels_(const char *trans, integer *m, integer *n, integer * +int dgels_(const char *trans, integer *m, integer *n, integer * nrhs, double *a, integer *lda, double *b, integer *ldb, double *work, integer *lwork, integer *info); - int dgelsd_(integer *m, integer *n, integer *nrhs, +int dgelsd_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, double * s, double *rcond, integer *rank, double *work, integer *lwork, integer *iwork, integer *info); - int dgelss_(integer *m, integer *n, integer *nrhs, +int dgelss_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, double * s, double *rcond, integer *rank, double *work, integer *lwork, integer *info); - int dgelsx_(integer *m, integer *n, integer *nrhs, +int dgelsx_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, integer * jpvt, double *rcond, integer *rank, double *work, integer * info); - int dgelsy_(integer *m, integer *n, integer *nrhs, +int dgelsy_(integer *m, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, integer * jpvt, double *rcond, integer *rank, double *work, integer * lwork, integer *info); - int dgeql2_(integer *m, integer *n, double *a, integer * +int dgeql2_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *info); - int dgeqlf_(integer *m, integer *n, double *a, integer * +int dgeqlf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); - int dgeqp3_(integer *m, integer *n, double *a, integer * +int dgeqp3_(integer *m, integer *n, double *a, integer * lda, integer *jpvt, double *tau, double *work, integer *lwork, - integer *info); + integer *info); - int dgeqpf_(integer *m, integer *n, double *a, integer * +int dgeqpf_(integer *m, integer *n, double *a, integer * lda, integer *jpvt, double *tau, double *work, integer *info); - int dgeqr2_(integer *m, integer *n, double *a, integer * +int dgeqr2_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *info); - int dgeqrf_(integer *m, integer *n, double *a, integer * +int dgeqrf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); - int dgerfs_(const char *trans, integer *n, integer *nrhs, +int dgerfs_(const char *trans, integer *n, integer *nrhs, double *a, integer *lda, double *af, integer *ldaf, integer * ipiv, double *b, integer *ldb, double *x, integer *ldx, double *ferr, double *berr, double *work, integer *iwork, integer *info); - int dgerq2_(integer *m, integer *n, double *a, integer * +int dgerq2_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *info); - int dgerqf_(integer *m, integer *n, double *a, integer * +int dgerqf_(integer *m, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); - int dgesc2_(integer *n, double *a, integer *lda, +int dgesc2_(integer *n, double *a, integer *lda, double *rhs, integer *ipiv, integer *jpiv, double *scale); - int dgesdd_(const char *jobz, integer *m, integer *n, double * +int dgesdd_(const char *jobz, integer *m, integer *n, double * a, integer *lda, double *s, double *u, integer *ldu, double *vt, integer *ldvt, double *work, integer *lwork, integer *iwork, integer *info); - int dgesv_(integer *n, integer *nrhs, double *a, integer +int dgesv_(integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer *ldb, integer *info); - int dgesvd_(const char *jobu, const char *jobvt, integer *m, integer *n, +int dgesvd_(const char *jobu, const char *jobvt, integer *m, integer *n, double *a, integer *lda, double *s, double *u, integer * ldu, double *vt, integer *ldvt, double *work, integer *lwork, integer *info); - int dgesvx_(const char *fact, const char *trans, integer *n, integer * +int dgesvx_(const char *fact, const char *trans, integer *n, integer * nrhs, double *a, integer *lda, double *af, integer *ldaf, integer *ipiv, char *equed, double *r__, double *c__, double *b, integer *ldb, double *x, integer *ldx, double * @@ -241,20 +241,20 @@ int dgetrf_(integer *m, integer *n, double *a, integer *lda, integer *ipiv, inte int dgetri_(integer *n, double *a, integer *lda, integer *ipiv, double *work, integer *lwork, integer *info); - int dgetrs_(const char *trans, integer *n, integer *nrhs, +int dgetrs_(const char *trans, integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer * ldb, integer *info); - int dggbak_(const char *job, const char *side, integer *n, integer *ilo, +int dggbak_(const char *job, const char *side, integer *n, integer *ilo, integer *ihi, double *lscale, double *rscale, integer *m, double *v, integer *ldv, integer *info); - int dggbal_(const char *job, integer *n, double *a, integer * +int dggbal_(const char *job, integer *n, double *a, integer * lda, double *b, integer *ldb, integer *ilo, integer *ihi, double *lscale, double *rscale, double *work, integer * info); - int dgges_(const char *jobvsl, const char *jobvsr, const char *sort, +int dgges_(const char *jobvsl, const char *jobvsr, const char *sort, bool (*selctg)(const double *, const double *, const double *), integer *n, double *a, integer *lda, double *b, integer *ldb, integer *sdim, double *alphar, double *alphai, @@ -262,7 +262,7 @@ int dgetri_(integer *n, double *a, integer *lda, integer *ipiv, double *work, in integer *ldvsr, double *work, integer *lwork, bool *bwork, integer *info); - int dggesx_(const char *jobvsl, const char *jobvsr, const char *sort, +int dggesx_(const char *jobvsl, const char *jobvsr, const char *sort, bool (*selctg)(const double *, const double *, const double *), const char *sense, integer *n, double *a, integer *lda, double *b, integer *ldb, integer *sdim, double *alphar, @@ -271,13 +271,13 @@ int dgetri_(integer *n, double *a, integer *lda, integer *ipiv, double *work, in rcondv, double *work, integer *lwork, integer *iwork, integer * liwork, bool *bwork, integer *info); - int dggev_(const char *jobvl, const char *jobvr, integer *n, double * +int dggev_(const char *jobvl, const char *jobvr, integer *n, double * a, integer *lda, double *b, integer *ldb, double *alphar, double *alphai, double *beta, double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, integer *info); - int dggevx_(const char *balanc, const char *jobvl, const char *jobvr, const char * +int dggevx_(const char *balanc, const char *jobvl, const char *jobvr, const char * sense, integer *n, double *a, integer *lda, double *b, integer *ldb, double *alphar, double *alphai, double * beta, double *vl, integer *ldvl, double *vr, integer *ldvr, @@ -286,94 +286,96 @@ int dgetri_(integer *n, double *a, integer *lda, integer *ipiv, double *work, in rcondv, double *work, integer *lwork, integer *iwork, bool * bwork, integer *info); - int dggglm_(integer *n, integer *m, integer *p, double * +int dggglm_(integer *n, integer *m, integer *p, double * a, integer *lda, double *b, integer *ldb, double *d__, double *x, double *y, double *work, integer *lwork, integer *info); - int dgghrd_(const char *compq, const char *compz, integer *n, integer * +int dgghrd_(const char *compq, const char *compz, integer *n, integer * ilo, integer *ihi, double *a, integer *lda, double *b, integer *ldb, double *q, integer *ldq, double *z__, integer * ldz, integer *info); - int dgglse_(integer *m, integer *n, integer *p, double * +int dgglse_(integer *m, integer *n, integer *p, double * a, integer *lda, double *b, integer *ldb, double *c__, double *d__, double *x, double *work, integer *lwork, integer *info); - int dggqrf_(integer *n, integer *m, integer *p, double * +int dggqrf_(integer *n, integer *m, integer *p, double * a, integer *lda, double *taua, double *b, integer *ldb, double *taub, double *work, integer *lwork, integer *info); - int dggrqf_(integer *m, integer *p, integer *n, double * +int dggrqf_(integer *m, integer *p, integer *n, double * a, integer *lda, double *taua, double *b, integer *ldb, double *taub, double *work, integer *lwork, integer *info); - int dggsvd_(const char *jobu, const char *jobv, const char *jobq, integer *m, +int dggsvd_(const char *jobu, const char *jobv, const char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, double *a, integer *lda, double *b, integer *ldb, double *alpha, double *beta, double *u, integer *ldu, double *v, integer *ldv, double *q, integer *ldq, double *work, integer *iwork, integer *info); - int dggsvp_(const char *jobu, const char *jobv, const char *jobq, integer *m, +int dggsvp_(const char *jobu, const char *jobv, const char *jobq, integer *m, integer *p, integer *n, double *a, integer *lda, double *b, integer *ldb, double *tola, double *tolb, integer *k, integer *l, double *u, integer *ldu, double *v, integer *ldv, double *q, integer *ldq, integer *iwork, double *tau, double *work, integer *info); - int dgtcon_(const char *norm, integer *n, double *dl, +int dgtcon_(const char *norm, integer *n, double *dl, double *d__, double *du, double *du2, integer *ipiv, double *anorm, double *rcond, double *work, integer * iwork, integer *info); - int dgtrfs_(const char *trans, integer *n, integer *nrhs, +int dgtrfs_(const char *trans, integer *n, integer *nrhs, double *dl, double *d__, double *du, double *dlf, double *df, double *duf, double *du2, integer *ipiv, double *b, integer *ldb, double *x, integer *ldx, double * ferr, double *berr, double *work, integer *iwork, integer * info); - int dgtsv_(integer *n, integer *nrhs, double *dl, +int dgtsv_(integer *n, integer *nrhs, double *dl, double *d__, double *du, double *b, integer *ldb, integer *info); - int dgtsvx_(const char *fact, const char *trans, integer *n, integer * +int dgtsvx_(const char *fact, const char *trans, integer *n, integer * nrhs, double *dl, double *d__, double *du, double * dlf, double *df, double *duf, double *du2, integer *ipiv, double *b, integer *ldb, double *x, integer *ldx, double * rcond, double *ferr, double *berr, double *work, integer * iwork, integer *info); - int dgttrf_(integer *n, double *dl, double *d__, +int dgttrf_(integer *n, double *dl, double *d__, double *du, double *du2, integer *ipiv, integer *info); - int dgttrs_(const char *trans, integer *n, integer *nrhs, +int dgttrs_(const char *trans, integer *n, integer *nrhs, double *dl, double *d__, double *du, double *du2, integer *ipiv, double *b, integer *ldb, integer *info); - int dgtts2_(integer *itrans, integer *n, integer *nrhs, +int dgtts2_(integer *itrans, integer *n, integer *nrhs, double *dl, double *d__, double *du, double *du2, integer *ipiv, double *b, integer *ldb); - int dhgeqz_(const char *job, const char *compq, const char *compz, integer *n, +int dhgeqz_(const char *job, const char *compq, const char *compz, integer *n, integer *ilo, integer *ihi, double *h__, integer *ldh, double *t, integer *ldt, double *alphar, double *alphai, double * beta, double *q, integer *ldq, double *z__, integer *ldz, double *work, integer *lwork, integer *info); - int dhsein_(const char *side, const char *eigsrc, const char *initv, bool * +int dhsein_(const char *side, const char *eigsrc, const char *initv, bool * select, integer *n, double *h__, integer *ldh, double *wr, double *wi, double *vl, integer *ldvl, double *vr, integer *ldvr, integer *mm, integer *m, double *work, integer * ifaill, integer *ifailr, integer *info); - int dhseqr_(const char *job, const char *compz, integer *n, integer *ilo, integer *ihi, +int dhseqr_(const char *job, const char *compz, integer *n, integer *ilo, integer *ihi, double *h__, integer *ldh, double *wr, double *wi, double *z__, integer *ldz, double *work, integer *lwork, integer *info); -double dla_gbrcond__(const char *trans, integer *n, integer *kl, integer *ku, +bool disnan_(double *din); + +double dla_gbrcond__(const char *trans, integer *n, integer *kl, integer *ku, double *ab, integer *ldab, double *afb, integer *ldafb, integer *ipiv, integer *cmode, double *c__, integer *info, double *work, integer *iwork, integer trans_len); @@ -404,93 +406,93 @@ int dlabrd_(integer *m, integer *n, integer *nb, double * double *taup, double *x, integer *ldx, double *y, integer *ldy); - int dlacn2_(integer *n, double *v, double *x, +int dlacn2_(integer *n, double *v, double *x, integer *isgn, double *est, integer *kase, integer *isave); - int dlacon_(integer *n, double *v, double *x, +int dlacon_(integer *n, double *v, double *x, integer *isgn, double *est, integer *kase); - int dlacpy_(const char *uplo, integer *m, integer *n, double * +int dlacpy_(const char *uplo, integer *m, integer *n, double * a, integer *lda, double *b, integer *ldb); - int dladiv_(double *a, double *b, double *c__, +int dladiv_(double *a, double *b, double *c__, double *d__, double *p, double *q); - int dlae2_(double *a, double *b, double *c__, +int dlae2_(double *a, double *b, double *c__, double *rt1, double *rt2); - int dlaebz_(integer *ijob, integer *nitmax, integer *n, +int dlaebz_(integer *ijob, integer *nitmax, integer *n, integer *mmax, integer *minp, integer *nbmin, double *abstol, double *reltol, double *pivmin, double *d__, double * e, double *e2, integer *nval, double *ab, double *c__, integer *mout, integer *nab, double *work, integer *iwork, integer *info); - int dlaed0_(integer *icompq, integer *qsiz, integer *n, +int dlaed0_(integer *icompq, integer *qsiz, integer *n, double *d__, double *e, double *q, integer *ldq, double *qstore, integer *ldqs, double *work, integer *iwork, integer *info); - int dlaed1_(integer *n, double *d__, double *q, +int dlaed1_(integer *n, double *d__, double *q, integer *ldq, integer *indxq, double *rho, integer *cutpnt, double *work, integer *iwork, integer *info); - int dlaed2_(integer *k, integer *n, integer *n1, double * +int dlaed2_(integer *k, integer *n, integer *n1, double * d__, double *q, integer *ldq, integer *indxq, double *rho, double *z__, double *dlamda, double *w, double *q2, integer *indx, integer *indxc, integer *indxp, integer *coltyp, integer *info); - int dlaed3_(integer *k, integer *n, integer *n1, double * +int dlaed3_(integer *k, integer *n, integer *n1, double * d__, double *q, integer *ldq, double *rho, double *dlamda, - double *q2, integer *indx, integer *ctot, double *w, + double *q2, integer *indx, integer *ctot, double *w, double *s, integer *info); - int dlaed4_(integer *n, integer *i__, double *d__, +int dlaed4_(integer *n, integer *i__, double *d__, double *z__, double *delta, double *rho, double *dlam, - integer *info); + integer *info); - int dlaed5_(integer *i__, double *d__, double *z__, +int dlaed5_(integer *i__, double *d__, double *z__, double *delta, double *rho, double *dlam); - int dlaed6_(integer *kniter, bool *orgati, double * +int dlaed6_(integer *kniter, bool *orgati, double * rho, double *d__, double *z__, double *finit, double * tau, integer *info); - int dlaed7_(integer *icompq, integer *n, integer *qsiz, +int dlaed7_(integer *icompq, integer *n, integer *qsiz, integer *tlvls, integer *curlvl, integer *curpbm, double *d__, double *q, integer *ldq, integer *indxq, double *rho, integer *cutpnt, double *qstore, integer *qptr, integer *prmptr, integer * perm, integer *givptr, integer *givcol, double *givnum, double *work, integer *iwork, integer *info); - int dlaed8_(integer *icompq, integer *k, integer *n, integer +int dlaed8_(integer *icompq, integer *k, integer *n, integer *qsiz, double *d__, double *q, integer *ldq, integer *indxq, double *rho, integer *cutpnt, double *z__, double *dlamda, - double *q2, integer *ldq2, double *w, integer *perm, integer + double *q2, integer *ldq2, double *w, integer *perm, integer *givptr, integer *givcol, double *givnum, integer *indxp, integer *indx, integer *info); - int dlaed9_(integer *k, integer *kstart, integer *kstop, +int dlaed9_(integer *k, integer *kstart, integer *kstop, integer *n, double *d__, double *q, integer *ldq, double * rho, double *dlamda, double *w, double *s, integer *lds, integer *info); - int dlaeda_(integer *n, integer *tlvls, integer *curlvl, +int dlaeda_(integer *n, integer *tlvls, integer *curlvl, integer *curpbm, integer *prmptr, integer *perm, integer *givptr, integer *givcol, double *givnum, double *q, integer *qptr, double *z__, double *ztemp, integer *info); - int dlaein_(bool *rightv, bool *noinit, integer *n, +int dlaein_(bool *rightv, bool *noinit, integer *n, double *h__, integer *ldh, double *wr, double *wi, double *vr, double *vi, double *b, integer *ldb, double *work, double *eps3, double *smlnum, double * bignum, integer *info); - int dlaev2_(double *a, double *b, double *c__, +int dlaev2_(double *a, double *b, double *c__, double *rt1, double *rt2, double *cs1, double *sn1); - int dlaexc_(bool *wantq, integer *n, double *t, +int dlaexc_(bool *wantq, integer *n, double *t, integer *ldt, double *q, integer *ldq, integer *j1, integer *n1, integer *n2, double *work, integer *info); @@ -499,60 +501,62 @@ int dlag2_(double *a, integer *lda, double *b, integer *ldb, double *safmin, dou int dlag2s_(integer *m, integer *n, double *a, integer *lda, float *sa, integer *ldsa, integer *info); - int dlags2_(bool *upper, double *a1, double *a2, +int dlags2_(bool *upper, double *a1, double *a2, double *a3, double *b1, double *b2, double *b3, double *csu, double *snu, double *csv, double *snv, double *csq, double *snq); - int dlagtf_(integer *n, double *a, double *lambda, +int dlagtf_(integer *n, double *a, double *lambda, double *b, double *c__, double *tol, double *d__, integer *in, integer *info); - int dlagtm_(const char *trans, integer *n, integer *nrhs, +int dlagtm_(const char *trans, integer *n, integer *nrhs, double *alpha, double *dl, double *d__, double *du, double *x, integer *ldx, double *beta, double *b, integer *ldb); - int dlagts_(integer *job, integer *n, double *a, +int dlagts_(integer *job, integer *n, double *a, double *b, double *c__, double *d__, integer *in, double *y, double *tol, integer *info); - int dlagv2_(double *a, integer *lda, double *b, +int dlagv2_(double *a, integer *lda, double *b, integer *ldb, double *alphar, double *alphai, double * beta, double *csl, double *snl, double *csr, double * snr); - int dlahqr_(bool *wantt, bool *wantz, integer *n, +int dlahqr_(bool *wantt, bool *wantz, integer *n, integer *ilo, integer *ihi, double *h__, integer *ldh, double *wr, double *wi, integer *iloz, integer *ihiz, double *z__, integer *ldz, integer *info); - int dlahr2_(integer *n, integer *k, integer *nb, double * +int dlahr2_(integer *n, integer *k, integer *nb, double * a, integer *lda, double *tau, double *t, integer *ldt, double *y, integer *ldy); - int dlahrd_(integer *n, integer *k, integer *nb, double * +int dlahrd_(integer *n, integer *k, integer *nb, double * a, integer *lda, double *tau, double *t, integer *ldt, double *y, integer *ldy); - int dlaic1_(integer *job, integer *j, double *x, +int dlaic1_(integer *job, integer *j, double *x, double *sest, double *w, double *gamma, double * sestpr, double *s, double *c__); - int dlaln2_(bool *ltrans, integer *na, integer *nw, +bool dlaisnan_(double *din1, double *din2); + +int dlaln2_(bool *ltrans, integer *na, integer *nw, double *smin, double *ca, double *a, integer *lda, double *d1, double *d2, double *b, integer *ldb, double *wr, double *wi, double *x, integer *ldx, double *scale, double *xnorm, integer *info); - int dlals0_(integer *icompq, integer *nl, integer *nr, +int dlals0_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *nrhs, double *b, integer *ldb, double *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, double *givnum, integer *ldgnum, double * poles, double *difl, double *difr, double *z__, integer * k, double *c__, double *s, double *work, integer *info); - int dlalsa_(integer *icompq, integer *smlsiz, integer *n, +int dlalsa_(integer *icompq, integer *smlsiz, integer *n, integer *nrhs, double *b, integer *ldb, double *bx, integer * ldbx, double *u, integer *ldu, double *vt, integer *k, double *difl, double *difr, double *z__, double * @@ -560,57 +564,106 @@ int dlag2s_(integer *m, integer *n, double *a, integer *lda, float *sa, integer perm, double *givnum, double *c__, double *s, double * work, integer *iwork, integer *info); - int dlalsd_(const char *uplo, integer *smlsiz, integer *n, integer +int dlalsd_(const char *uplo, integer *smlsiz, integer *n, integer *nrhs, double *d__, double *e, double *b, integer *ldb, double *rcond, integer *rank, double *work, integer *iwork, integer *info); -double dlamch_ (const char *cmach); +int dlamc1_ (integer *beta, integer *t, bool *rnd, bool *ieee1); + +int dlamc2_ (integer *beta, integer *t, bool *rnd, + double *eps, integer *emin, double *rmin, integer *emax, double *rmax); + +double dlamc3_ (double *a, double *b); + +int dlamc4_ (integer *emin, double *start, integer *base); + +int dlamc5_ (integer *beta, integer *p, integer *emin, + bool *ieee, integer *emax, double *rmax); + +double dlamch_ (const char *cmach); int dlamrg_(integer *n1, integer *n2, double *a, integer *dtrd1, integer *dtrd2, integer *index); +integer dlaneg_(integer *n, double *d__, double *lld, double * + sigma, double *pivmin, integer *r__); + +double dlangb_(const char *norm, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, double *work); + +double dlange_(const char *norm, integer *m, integer *n, double *a, integer + *lda, double *work); + +double dlangt_(const char *norm, integer *n, double *dl, double *d__, + double *du); + +double dlanhs_ (const char *norm, integer *n, double *a, integer *lda, + double *work); + +double dlansb_(const char *norm, const char *uplo, integer *n, integer *k, double + *ab, integer *ldab, double *work); + +double dlansp_(const char *norm, const char *uplo, integer *n, double *ap, + double *work); + +double dlanst_(const char *norm, integer *n, double *d__, double *e); + +double dlansy_(const char *norm, const char *uplo, integer *n, double *a, integer + *lda, double *work); + +double dlantb_(const char *norm, const char *uplo, const char *diag, integer *n, integer *k, + double *ab, integer *ldab, double *work); + +double dlantp_(const char *norm, const char *uplo, const char *diag, integer *n, double *ap, double *work); + +double dlantr_(const char *norm, const char *uplo, const char *diag, integer *m, integer *n, + double *a, integer *lda, double *work); + double dlansf_(const char *norm, char *transr, char *uplo, integer *n, double *a, double *work); int dlanv2_(double *a, double *b, double *c__, double *d__, double *rt1r, double *rt1i, double *rt2r, double *rt2i, double *cs, double *sn); - int dlapll_(integer *n, double *x, integer *incx, +int dlapll_(integer *n, double *x, integer *incx, double *y, integer *incy, double *ssmin); - int dlapmt_(bool *forwrd, integer *m, integer *n, +int dlapmt_(bool *forwrd, integer *m, integer *n, double *x, integer *ldx, integer *k); - int dlaqgb_(integer *m, integer *n, integer *kl, integer *ku, +double dlapy2_(double *x, double *y); + +double dlapy3_(double *x, double *y, double *z__); + +int dlaqgb_(integer *m, integer *n, integer *kl, integer *ku, double *ab, integer *ldab, double *r__, double *c__, double *rowcnd, double *colcnd, double *amax, char *equed); - int dlaqge_(integer *m, integer *n, double *a, integer * +int dlaqge_(integer *m, integer *n, double *a, integer * lda, double *r__, double *c__, double *rowcnd, double *colcnd, double *amax, char *equed); - int dlaqp2_(integer *m, integer *n, integer *offset, +int dlaqp2_(integer *m, integer *n, integer *offset, double *a, integer *lda, integer *jpvt, double *tau, double *vn1, double *vn2, double *work); - int dlaqps_(integer *m, integer *n, integer *offset, integer +int dlaqps_(integer *m, integer *n, integer *offset, integer *nb, integer *kb, double *a, integer *lda, integer *jpvt, double *tau, double *vn1, double *vn2, double *auxv, double *f, integer *ldf); - int dlaqr0_(bool *wantt, bool *wantz, integer *n, integer *ilo, integer *ihi, double *h__, +int dlaqr0_(bool *wantt, bool *wantz, integer *n, integer *ilo, integer *ihi, double *h__, integer *ldh, double *wr, double *wi, integer *iloz, integer *ihiz, double *z__, integer *ldz, double *work, integer *lwork, integer *info); - int dlaqr1_(integer *n, double *h__, integer *ldh, double *sr1, double *si1, +int dlaqr1_(integer *n, double *h__, integer *ldh, double *sr1, double *si1, double *sr2, double *si2, double *v); - int dlaqr2_(bool *wantt, bool *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, +int dlaqr2_(bool *wantt, bool *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, double *h__, integer *ldh, integer *iloz, integer *ihiz, double *z__, integer *ldz, integer *ns, integer *nd, double *sr, double *si, double *v, integer *ldv, integer *nh, double *t, integer *ldt, integer *nv, double *wv, integer *ldwv, double *work, integer *lwork); - int dlaqr3_(bool *wantt, bool *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, double *h__, integer *ldh, integer *iloz, integer *ihiz, double *z__, integer *ldz, integer *ns, integer *nd, double *sr, double *si, double *v, integer *ldv, integer *nh, @@ -718,52 +771,52 @@ int dlarz_(const char *side, integer *m, integer *n, integer *l, double *v, integer *incv, double *tau, double *c__, integer *ldc, double *work); - int dlarzb_(const char *side, const char *trans, const char *direct, const char *storev, +int dlarzb_(const char *side, const char *trans, const char *direct, const char *storev, integer *m, integer *n, integer *k, integer *l, double *v, integer *ldv, double *t, integer *ldt, double *c__, integer *ldc, double *work, integer *ldwork); - int dlarzt_(const char *direct, const char *storev, integer *n, integer * +int dlarzt_(const char *direct, const char *storev, integer *n, integer * k, double *v, integer *ldv, double *tau, double *t, integer *ldt); - int dlas2_(double *f, double *g, double *h__, double *ssmin, double *ssmax); +int dlas2_(double *f, double *g, double *h__, double *ssmin, double *ssmax); - int dlascl_(const char *type__, integer *kl, integer *ku, double *cfrom, double *cto, +int dlascl_(const char *type__, integer *kl, integer *ku, double *cfrom, double *cto, integer *m, integer *n, double *a, integer *lda, integer *info); int dlascl2_(integer *m, integer *n, double *d__, double *x, integer *ldx); - int dlasd0_(integer *n, integer *sqre, double *d__, +int dlasd0_(integer *n, integer *sqre, double *d__, double *e, double *u, integer *ldu, double *vt, integer * ldvt, integer *smlsiz, integer *iwork, double *work, integer * info); - int dlasd1_(integer *nl, integer *nr, integer *sqre, +int dlasd1_(integer *nl, integer *nr, integer *sqre, double *d__, double *alpha, double *beta, double *u, integer *ldu, double *vt, integer *ldvt, integer *idxq, integer * iwork, double *work, integer *info); - int dlasd2_(integer *nl, integer *nr, integer *sqre, integer +int dlasd2_(integer *nl, integer *nr, integer *sqre, integer *k, double *d__, double *z__, double *alpha, double * beta, double *u, integer *ldu, double *vt, integer *ldvt, double *dsigma, double *u2, integer *ldu2, double *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer * idxq, integer *coltyp, integer *info); - int dlasd3_(integer *nl, integer *nr, integer *sqre, integer +int dlasd3_(integer *nl, integer *nr, integer *sqre, integer *k, double *d__, double *q, integer *ldq, double *dsigma, double *u, integer *ldu, double *u2, integer *ldu2, double *vt, integer *ldvt, double *vt2, integer *ldvt2, integer *idxc, integer *ctot, double *z__, integer *info); - int dlasd4_(integer *n, integer *i__, double *d__, +int dlasd4_(integer *n, integer *i__, double *d__, double *z__, double *delta, double *rho, double * sigma, double *work, integer *info); - int dlasd5_(integer *i__, double *d__, double *z__, +int dlasd5_(integer *i__, double *d__, double *z__, double *delta, double *rho, double *dsigma, double * work); - int dlasd6_(integer *icompq, integer *nl, integer *nr, +int dlasd6_(integer *icompq, integer *nl, integer *nr, integer *sqre, double *d__, double *vf, double *vl, double *alpha, double *beta, integer *idxq, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, double *givnum, @@ -771,7 +824,7 @@ int dlascl2_(integer *m, integer *n, double *d__, double *x, integer *ldx); difr, double *z__, integer *k, double *c__, double *s, double *work, integer *iwork, integer *info); - int dlasd7_(integer *icompq, integer *nl, integer *nr, +int dlasd7_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *k, double *d__, double *z__, double *zw, double *vf, double *vfw, double *vl, double *vlw, double *alpha, double *beta, double * @@ -779,30 +832,30 @@ int dlascl2_(integer *m, integer *n, double *d__, double *x, integer *ldx); integer *givptr, integer *givcol, integer *ldgcol, double *givnum, integer *ldgnum, double *c__, double *s, integer *info); - int dlasd8_(integer *icompq, integer *k, double *d__, +int dlasd8_(integer *icompq, integer *k, double *d__, double *z__, double *vf, double *vl, double *difl, double *difr, integer *lddifr, double *dsigma, double * work, integer *info); - int dlasda_(integer *icompq, integer *smlsiz, integer *n, +int dlasda_(integer *icompq, integer *smlsiz, integer *n, integer *sqre, double *d__, double *e, double *u, integer *ldu, double *vt, integer *k, double *difl, double *difr, double *z__, double *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm, double *givnum, double *c__, double *s, double *work, integer *iwork, integer *info); - int dlasdq_(const char *uplo, integer *sqre, integer *n, integer * +int dlasdq_(const char *uplo, integer *sqre, integer *n, integer * ncvt, integer *nru, integer *ncc, double *d__, double *e, double *vt, integer *ldvt, double *u, integer *ldu, double *c__, integer *ldc, double *work, integer *info); - int dlasdt_(integer *n, integer *lvl, integer *nd, integer * +int dlasdt_(integer *n, integer *lvl, integer *nd, integer * inode, integer *ndiml, integer *ndimr, integer *msub); - int dlaset_(const char *uplo, integer *m, integer *n, double * +int dlaset_(const char *uplo, integer *m, integer *n, double * alpha, double *beta, double *a, integer *lda); - int dlasq1_(integer *n, double *d__, double *e, +int dlasq1_(integer *n, double *d__, double *e, double *work, integer *info); int dlasq2_(integer *n, double *z__, integer *info); @@ -817,33 +870,33 @@ int dlasq4_(integer *i0, integer *n0, double *z__, double *dmin2, double *dn, double *dn1, double *dn2, double *tau, integer *ttype, double *g); - int dlasq5_(integer *i0, integer *n0, double *z__, +int dlasq5_(integer *i0, integer *n0, double *z__, integer *pp, double *tau, double *dmin__, double *dmin1, double *dmin2, double *dn, double *dnm1, double *dnm2, bool *ieee); - int dlasq6_(integer *i0, integer *n0, double *z__, +int dlasq6_(integer *i0, integer *n0, double *z__, integer *pp, double *dmin__, double *dmin1, double *dmin2, double *dn, double *dnm1, double *dnm2); - int dlasr_(const char *side, const char *pivot, const char *direct, integer *m, +int dlasr_(const char *side, const char *pivot, const char *direct, integer *m, integer *n, double *c__, double *s, double *a, integer * lda); - int dlasrt_(const char *id, integer *n, double *d__, integer * +int dlasrt_(const char *id, integer *n, double *d__, integer * info); - int dlassq_(integer *n, double *x, integer *incx, +int dlassq_(integer *n, double *x, integer *incx, double *scale, double *sumsq); - int dlasv2_(double *f, double *g, double *h__, +int dlasv2_(double *f, double *g, double *h__, double *ssmin, double *ssmax, double *snr, double * csr, double *snl, double *csl); - int dlaswp_(integer *n, double *a, integer *lda, integer +int dlaswp_(integer *n, double *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx); - int dlasy2_(bool *ltranl, bool *ltranr, integer *isgn, +int dlasy2_(bool *ltranl, bool *ltranr, integer *isgn, integer *n1, integer *n2, double *tl, integer *ldtl, double * tr, integer *ldtr, double *b, integer *ldb, double *scale, double *x, integer *ldx, double *xnorm, integer *info); @@ -856,36 +909,36 @@ int dlat2s_(const char *uplo, integer *n, double *a, integer *lda, float *sa, in int dlatbs_(const char *uplo, const char *trans, const char *diag,const char *normin, integer *n, integer *kd, double *ab, integer *ldab, double *x, double *scale, double *cnorm, integer *info); - int dlatdf_(integer *ijob, integer *n, double *z__, +int dlatdf_(integer *ijob, integer *n, double *z__, integer *ldz, double *rhs, double *rdsum, double *rdscal, integer *ipiv, integer *jpiv); - int dlatps_(const char *uplo, const char *trans, const char *diag, const char * +int dlatps_(const char *uplo, const char *trans, const char *diag, const char * normin, integer *n, double *ap, double *x, double *scale, double *cnorm, integer *info); - int dlatrd_(const char *uplo, integer *n, integer *nb, double * +int dlatrd_(const char *uplo, integer *n, integer *nb, double * a, integer *lda, double *e, double *tau, double *w, integer *ldw); - int dlatrs_(const char *uplo, const char *trans, const char *diag, const char * +int dlatrs_(const char *uplo, const char *trans, const char *diag, const char * normin, integer *n, double *a, integer *lda, double *x, double *scale, double *cnorm, integer *info); - int dlatrz_(integer *m, integer *n, integer *l, double * +int dlatrz_(integer *m, integer *n, integer *l, double * a, integer *lda, double *tau, double *work); - int dlatzm_(const char *side, integer *m, integer *n, double * +int dlatzm_(const char *side, integer *m, integer *n, double * v, integer *incv, double *tau, double *c1, double *c2, integer *ldc, double *work); - int dlauu2_(const char *uplo, integer *n, double *a, integer * +int dlauu2_(const char *uplo, integer *n, double *a, integer * lda, integer *info); - int dlauum_(const char *uplo, integer *n, double *a, integer * +int dlauum_(const char *uplo, integer *n, double *a, integer * lda, integer *info); - int dlazq3_(integer *i0, integer *n0, double *z__, +int dlazq3_(integer *i0, integer *n0, double *z__, integer *pp, double *dmin__, double *sigma, double *desig, double *qmax, integer *nfail, integer *iter, integer *ndiv, bool *ieee, integer *ttype, double *dmin1, double *dmin2, @@ -896,6 +949,8 @@ int dlazq4_(integer *i0, integer *n0, double *z__, integer *pp, integer *n0in, d integer dmaxloc_(double *a, integer *dimm); +double dnrm2_(integer *n, double *x, integer *incx); + int dopgtr_(const char *uplo, integer *n, double *ap, double *tau, double *q, integer *ldq, double *work, integer *info); int dopmtr_(const char *side, const char *uplo, const char *trans, integer *m, integer *n, @@ -905,122 +960,122 @@ int dorg2l_(integer *m, integer *n, integer *k, double *a, integer *lda, double int dorg2r_(integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double *work, integer *info); - int dorgbr_(const char *vect, integer *m, integer *n, integer *k, +int dorgbr_(const char *vect, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double *work, integer *lwork, integer *info); - int dorghr_(integer *n, integer *ilo, integer *ihi, +int dorghr_(integer *n, integer *ilo, integer *ihi, double *a, integer *lda, double *tau, double *work, integer *lwork, integer *info); - int dorgl2_(integer *m, integer *n, integer *k, double * +int dorgl2_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *info); - int dorglq_(integer *m, integer *n, integer *k, double * +int dorglq_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); - int dorgql_(integer *m, integer *n, integer *k, double * +int dorgql_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); - int dorgqr_(integer *m, integer *n, integer *k, double * +int dorgqr_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); - int dorgr2_(integer *m, integer *n, integer *k, double * +int dorgr2_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *info); - int dorgrq_(integer *m, integer *n, integer *k, double * +int dorgrq_(integer *m, integer *n, integer *k, double * a, integer *lda, double *tau, double *work, integer *lwork, integer *info); - int dorgtr_(const char *uplo, integer *n, double *a, integer * +int dorgtr_(const char *uplo, integer *n, double *a, integer * lda, double *tau, double *work, integer *lwork, integer *info); - int dorm2l_(const char *side, const char *trans, integer *m, integer *n, +int dorm2l_(const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *info); - int dorm2r_(const char *side, const char *trans, integer *m, integer *n, +int dorm2r_(const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *info); - int dormbr_(const char *vect, const char *side, const char *trans, integer *m, +int dormbr_(const char *vect, const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double *c__, integer *ldc, double *work, integer *lwork, integer *info); - int dormhr_(const char *side, const char *trans, integer *m, integer *n, +int dormhr_(const char *side, const char *trans, integer *m, integer *n, integer *ilo, integer *ihi, double *a, integer *lda, double * tau, double *c__, integer *ldc, double *work, integer *lwork, integer *info); - int dorml2_(const char *side, const char *trans, integer *m, integer *n, +int dorml2_(const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *info); - int dormlq_(const char *side, const char *trans, integer *m, integer *n, +int dormlq_(const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); - int dormql_(const char *side, const char *trans, integer *m, integer *n, +int dormql_(const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); - int dormqr_(const char *side, const char *trans, integer *m, integer *n, +int dormqr_(const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); - int dormr2_(const char *side, const char *trans, integer *m, integer *n, +int dormr2_(const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *info); - int dormr3_(const char *side, const char *trans, integer *m, integer *n, +int dormr3_(const char *side, const char *trans, integer *m, integer *n, integer *k, integer *l, double *a, integer *lda, double *tau, double *c__, integer *ldc, double *work, integer *info); - int dormrq_(const char *side, const char *trans, integer *m, integer *n, +int dormrq_(const char *side, const char *trans, integer *m, integer *n, integer *k, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); - int dormrz_(const char *side, const char *trans, integer *m, integer *n, +int dormrz_(const char *side, const char *trans, integer *m, integer *n, integer *k, integer *l, double *a, integer *lda, double *tau, double *c__, integer *ldc, double *work, integer *lwork, integer *info); - int dormtr_(const char *side, const char *uplo, const char *trans, integer *m, +int dormtr_(const char *side, const char *uplo, const char *trans, integer *m, integer *n, double *a, integer *lda, double *tau, double * c__, integer *ldc, double *work, integer *lwork, integer *info); - int dpbcon_(const char *uplo, integer *n, integer *kd, double * +int dpbcon_(const char *uplo, integer *n, integer *kd, double * ab, integer *ldab, double *anorm, double *rcond, double * work, integer *iwork, integer *info); - int dpbequ_(const char *uplo, integer *n, integer *kd, double * +int dpbequ_(const char *uplo, integer *n, integer *kd, double * ab, integer *ldab, double *s, double *scond, double *amax, integer *info); - int dpbrfs_(const char *uplo, integer *n, integer *kd, integer * +int dpbrfs_(const char *uplo, integer *n, integer *kd, integer * nrhs, double *ab, integer *ldab, double *afb, integer *ldafb, double *b, integer *ldb, double *x, integer *ldx, double * ferr, double *berr, double *work, integer *iwork, integer * info); - int dpbstf_(const char *uplo, integer *n, integer *kd, double * +int dpbstf_(const char *uplo, integer *n, integer *kd, double * ab, integer *ldab, integer *info); - int dpbsv_(const char *uplo, integer *n, integer *kd, integer * +int dpbsv_(const char *uplo, integer *n, integer *kd, integer * nrhs, double *ab, integer *ldab, double *b, integer *ldb, integer *info); - int dpbsvx_(const char *fact, const char *uplo, integer *n, integer *kd, +int dpbsvx_(const char *fact, const char *uplo, integer *n, integer *kd, integer *nrhs, double *ab, integer *ldab, double *afb, integer *ldafb, char *equed, double *s, double *b, integer * ldb, double *x, integer *ldx, double *rcond, double *ferr, - double *berr, double *work, integer *iwork, integer *info); + double *berr, double *work, integer *iwork, integer *info); - int dpbtf2_(const char *uplo, integer *n, integer *kd, double * +int dpbtf2_(const char *uplo, integer *n, integer *kd, double * ab, integer *ldab, integer *info); int dpbtrf_(const char *uplo, integer *n, integer *kd, double *ab, integer *ldab, integer *info); @@ -1307,17 +1362,17 @@ int dsyevr_(const char *jobz, const char *range, const char *uplo, integer *n, d double *w, double *z__, integer *ldz, integer *isuppz, double *work, integer *lwork, integer *iwork, integer *liwork, integer *info); - int dsyevx_(const char *jobz, const char *range, const char *uplo, integer *n, +int dsyevx_(const char *jobz, const char *range, const char *uplo, integer *n, double *a, integer *lda, double *vl, double *vu, integer * il, integer *iu, double *abstol, integer *m, double *w, double *z__, integer *ldz, double *work, integer *lwork, integer *iwork, integer *ifail, integer *info); - int dsygs2_(integer *itype, const char *uplo, integer *n, +int dsygs2_(integer *itype, const char *uplo, integer *n, double *a, integer *lda, double *b, integer *ldb, integer * info); - int dsygst_(integer *itype, const char *uplo, integer *n, +int dsygst_(integer *itype, const char *uplo, integer *n, double *a, integer *lda, double *b, integer *ldb, integer * info); @@ -1408,7 +1463,7 @@ int dtgexc_(bool *wantq, bool *wantz, integer *n, q, integer *ldq, double *z__, integer *ldz, integer *ifst, integer *ilst, double *work, integer *lwork, integer *info); - int dtgsen_(integer *ijob, bool *wantq, bool *wantz, +int dtgsen_(integer *ijob, bool *wantq, bool *wantz, bool *select, integer *n, double *a, integer *lda, double * b, integer *ldb, double *alphar, double *alphai, double * beta, double *q, integer *ldq, double *z__, integer *ldz, @@ -1416,34 +1471,34 @@ int dtgexc_(bool *wantq, bool *wantz, integer *n, double *work, integer *lwork, integer *iwork, integer *liwork, integer *info); - int dtgsja_(const char *jobu, const char *jobv, const char *jobq, integer *m, +int dtgsja_(const char *jobu, const char *jobv, const char *jobq, integer *m, integer *p, integer *n, integer *k, integer *l, double *a, integer *lda, double *b, integer *ldb, double *tola, double *tolb, double *alpha, double *beta, double *u, integer *ldu, double *v, integer *ldv, double *q, integer * ldq, double *work, integer *ncycle, integer *info); - int dtgsna_(const char *job, const char *howmny, bool *select, +int dtgsna_(const char *job, const char *howmny, bool *select, integer *n, double *a, integer *lda, double *b, integer *ldb, double *vl, integer *ldvl, double *vr, integer *ldvr, double *s, double *dif, integer *mm, integer *m, double * work, integer *lwork, integer *iwork, integer *info); - int dtgsy2_(const char *trans, integer *ijob, integer *m, integer * +int dtgsy2_(const char *trans, integer *ijob, integer *m, integer * n, double *a, integer *lda, double *b, integer *ldb, double *c__, integer *ldc, double *d__, integer *ldd, double *e, integer *lde, double *f, integer *ldf, double * scale, double *rdsum, double *rdscal, integer *iwork, integer *pq, integer *info); - int dtgsyl_(const char *trans, integer *ijob, integer *m, integer * +int dtgsyl_(const char *trans, integer *ijob, integer *m, integer * n, double *a, integer *lda, double *b, integer *ldb, double *c__, integer *ldc, double *d__, integer *ldd, double *e, integer *lde, double *f, integer *ldf, double * scale, double *dif, double *work, integer *lwork, integer * iwork, integer *info); - int dtpcon_(const char *norm, const char *uplo, const char *diag, integer *n, +int dtpcon_(const char *norm, const char *uplo, const char *diag, integer *n, double *ap, double *rcond, double *work, integer *iwork, integer *info); @@ -1475,7 +1530,7 @@ int dtrrfs_(const char *uplo, const char *trans, const char *diag, integer *n, i double *a, integer *lda, double *b, integer *ldb, double *x, integer *ldx, double *ferr, double *berr, double *work, integer *iwork, integer *info); - int dtrsen_(const char *job, const char *compq, bool *select, integer +int dtrsen_(const char *job, const char *compq, bool *select, integer *n, double *t, integer *ldt, double *q, integer *ldq, double *wr, double *wi, integer *m, double *s, double *sep, double *work, integer *lwork, integer *iwork, integer * @@ -1503,6 +1558,8 @@ int dtzrqf_(integer *m, integer *n, double *a, integer *lda, double *tau, intege int dtzrzf_(integer *m, integer *n, double *a, integer *lda, double *tau, double *work, integer *lwork, integer *info); +integer ieeeck_(integer *ispec, float *zero, float *one); + integer iladlc_(integer *m, integer *n, double *a, integer *lda); integer iladlr_(integer *m, integer *n, double *a, integer *lda); @@ -1516,6 +1573,9 @@ integer ilatrans_(const char *trans); int ilaver_(integer *vers_major__, integer *vers_minor__, integer *vers_patch__); +integer iparmq_ (integer *ispec, const char *name__, const char *opts, integer *n, integer + *ilo, integer *ihi, integer *lwork); + /* Some single precision routines needed in approximations */ int sgetrf_(integer *m, integer *n, float *a, integer *lda, integer *ipiv, integer *info); @@ -1523,21 +1583,8 @@ int sgetrf_(integer *m, integer *n, float *a, integer *lda, integer *ipiv, integ int sgetrs_(const char *trans, integer *n, integer *nrhs, float *a, integer *lda, integer *ipiv, float *b, integer *ldb, integer *info); -bool sisnan_(float *sin__); -bool slaisnan_(float *sin1, float *sin2); - int slag2d_(integer *m, integer *n, float *sa, integer *ldsa, double *a, integer *lda, integer *info); -integer smaxloc_(float *a, integer *dimm); - -int spotf2_(const char *uplo, integer *n, float *a, integer *lda, integer *info); - -int spotrf_(const char *uplo, integer *n, float *a, integer *lda, integer *info); - -int spotrs_(const char *uplo, integer *n, integer *nrhs, float *a, integer *lda, float *b, integer *ldb, integer *info); - -int ssfrk_(const char *transr, const char *uplo, const char *trans, integer *n, - integer *k, float *alpha, float *a, integer *lda, float *beta, float *c__); - +double slamch_(const char *cmach); -#endif /* __CLAPACK_H */ +#endif /* _clapack_h_ */ diff --git a/external/clapack/clapackP.h b/external/clapack/clapackP.h deleted file mode 100644 index 55546dab..00000000 --- a/external/clapack/clapackP.h +++ /dev/null @@ -1,91 +0,0 @@ -#ifndef _clapackP_h_ -#define _clapackP_h_ -/* clapackP.h - * - * Copyright (C) 2020 David Weenink - * - * This code is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or (at - * your option) any later version. - * - * This code is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this work. If not, see . - */ - -#include "melder.h" - -bool disnan_ (double *din); - -bool dlaisnan_ (double *din1, double *din2); - -integer dlaneg_ (integer *n, double *d__, double *lld, double * - sigma, double *pivmin, integer *r__); - -double dlangb_ (const char *norm, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, double *work); - -double dlange_ (const char *norm, integer *m, integer *n, double *a, integer - *lda, double *work); - -double dlangt_ (const char *norm, integer *n, double *dl, double *d__, - double *du); - -double dlanhs_ (const char *norm, integer *n, double *a, integer *lda, - double *work); - -double dlansb_ (const char *norm, const char *uplo, integer *n, integer *k, double - *ab, integer *ldab, double *work); - -double dlansp_ (const char *norm, const char *uplo, integer *n, double *ap, - double *work); - -double dlanst_ (const char *norm, integer *n, double *d__, double *e); - -double dlansy_ (const char *norm, const char *uplo, integer *n, double *a, integer - *lda, double *work); - -double dlantb_ (const char *norm, const char *uplo, const char *diag, integer *n, integer *k, - double *ab, integer *ldab, double *work); - -double dlantp_ (const char *norm, const char *uplo, const char *diag, integer *n, double *ap, double *work); - -double dlantr_ (const char *norm, const char *uplo, const char *diag, integer *m, integer *n, - double *a, integer *lda, double *work); - -double dlapy2_ (double *x, double *y); - -double dlapy3_ (double *x, double *y, double *z__); - -double dnrm2_ (integer *n, double *x, integer *incx); - -double slamch_ (const char *cmach); - -int dlamc1_ (integer *beta, integer *t, bool *rnd, bool *ieee1); - -int dlamc2_ (integer *beta, integer *t, bool *rnd, - double *eps, integer *emin, double *rmin, integer *emax, double *rmax); - -double dlamc3_ (double *a, double *b); - -int dlamc4_ (integer *emin, double *start, integer *base); - -int dlamc5_ (integer *beta, integer *p, integer *emin, - bool *ieee, integer *emax, double *rmax); - -//integer icmax1_ (integer *n, complex *cx, integer *incx); - -integer ieeeck_ (integer *ispec, float *zero, float *one); - -integer ilaenv_ (integer *ispec, const char *name__, const char *opts, integer *n1, - integer *n2, integer *n3, integer *n4); - -integer iparmq_ (integer *ispec, const char *name__, const char *opts, integer *n, integer - *ilo, integer *ihi, integer *lwork); - -#endif /* clapackP_h_ */ diff --git a/external/clapack/f2cP.h b/external/clapack/f2cP.h index 91231718..520cb3e1 100644 --- a/external/clapack/f2cP.h +++ b/external/clapack/f2cP.h @@ -20,7 +20,6 @@ #include "melder.h" #include "cblas.h" -#include "clapackP.h" static inline double d_abs (double *x) { return abs (*x); diff --git a/external/clapack/lapack.cpp b/external/clapack/lapack.cpp new file mode 100644 index 00000000..8132abe6 --- /dev/null +++ b/external/clapack/lapack.cpp @@ -0,0 +1,23331 @@ +#include "clapack.h" +#include "f2cP.h" + +#if 0 +void chla_transtype__(char *ret_val, integer ret_val_len, integer *trans) +{ + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* October 2008 */ +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This subroutine translates from a BLAST-specified integer constant to */ +/* the character string specifying a transposition operation. */ + +/* CHLA_TRANSTYPE returns an CHARACTER*1. If CHLA_TRANSTYPE is 'X', */ +/* then input is not an integer indicating a transposition operator. */ +/* Otherwise CHLA_TRANSTYPE returns the constant value corresponding to */ +/* TRANS. */ + +/* Arguments */ +/* ========= */ +/* TRANS (input) INTEGER */ +/* Specifies the form of the system of equations: */ +/* = BLAS_NO_TRANS = 111 : No Transpose */ +/* = BLAS_TRANS = 112 : Transpose */ +/* = BLAS_CONJ_TRANS = 113 : Conjugate Transpose */ +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Executable Statements .. */ + if (*trans == 111) { + *(unsigned char *)ret_val = 'N'; + } else if (*trans == 112) { + *(unsigned char *)ret_val = 'T'; + } else if (*trans == 113) { + *(unsigned char *)ret_val = 'C'; + } else { + *(unsigned char *)ret_val = 'X'; + } + return ; + +/* End of CHLA_TRANSTYPE */ + +} /* chla_transtype__ */ +#endif + +/* Subroutine */ int dbdsdc_(const char *uplo, const char *compq, integer *n, double * + d__, double *e, double *u, integer *ldu, double *vt, + integer *ldvt, double *q, integer *iq, double *work, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__9 = 9; + static integer c__0 = 0; + static double c_b15 = 1.; + static integer c__1 = 1; + static double c_b29 = 0.; + + /* System generated locals */ + integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j, k; + double p, r__; + integer z__, ic, ii, kk; + double cs; + integer is, iu; + double sn; + integer nm1; + double eps; + integer ivt, difl, difr, ierr, perm, mlvl, sqre; + integer poles, iuplo, nsize, start; + integer givcol; + integer icompq; + double orgnrm; + integer givnum, givptr, qstart, smlsiz, wstart, smlszp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DBDSDC computes the singular value decomposition (SVD) of a real */ +/* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */ +/* using a divide and conquer method, where S is a diagonal matrix */ +/* with non-negative diagonal elements (the singular values of B), and */ +/* U and VT are orthogonal matrices of left and right singular vectors, */ +/* respectively. DBDSDC can be used to compute all singular values, */ +/* and optionally, singular vectors or singular vectors in compact form. */ + +/* This code makes very mild assumptions about floating point */ +/* arithmetic. It will work on machines with a guard digit in */ +/* add/subtract, or on those binary machines without guard digits */ +/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ +/* It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. See DLASD3 for details. */ + +/* The code currently calls DLASDQ if singular values only are desired. */ +/* However, it can be slightly modified to compute singular values */ +/* using the divide and conquer method. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': B is upper bidiagonal. */ +/* = 'L': B is lower bidiagonal. */ + +/* COMPQ (input) CHARACTER*1 */ +/* Specifies whether singular vectors are to be computed */ +/* as follows: */ +/* = 'N': Compute singular values only; */ +/* = 'P': Compute singular values and compute singular */ +/* vectors in compact form; */ +/* = 'I': Compute singular values and singular vectors. */ + +/* N (input) INTEGER */ +/* The order of the matrix B. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the bidiagonal matrix B. */ +/* On exit, if INFO=0, the singular values of B. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the elements of E contain the offdiagonal */ +/* elements of the bidiagonal matrix whose SVD is desired. */ +/* On exit, E has been destroyed. */ + +/* U (output) DOUBLE PRECISION array, dimension (LDU,N) */ +/* If COMPQ = 'I', then: */ +/* On exit, if INFO = 0, U contains the left singular vectors */ +/* of the bidiagonal matrix. */ +/* For other values of COMPQ, U is not referenced. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= 1. */ +/* If singular vectors are desired, then LDU >= max( 1, N ). */ + +/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */ +/* If COMPQ = 'I', then: */ +/* On exit, if INFO = 0, VT' contains the right singular */ +/* vectors of the bidiagonal matrix. */ +/* For other values of COMPQ, VT is not referenced. */ + +/* LDVT (input) INTEGER */ +/* The leading dimension of the array VT. LDVT >= 1. */ +/* If singular vectors are desired, then LDVT >= max( 1, N ). */ + +/* Q (output) DOUBLE PRECISION array, dimension (LDQ) */ +/* If COMPQ = 'P', then: */ +/* On exit, if INFO = 0, Q and IQ contain the left */ +/* and right singular vectors in a compact form, */ +/* requiring O(N log N) space instead of 2*N**2. */ +/* In particular, Q contains all the DOUBLE PRECISION data in */ +/* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */ +/* words of memory, where SMLSIZ is returned by ILAENV and */ +/* is equal to the maximum size of the subproblems at the */ +/* bottom of the computation tree (usually about 25). */ +/* For other values of COMPQ, Q is not referenced. */ + +/* IQ (output) INTEGER array, dimension (LDIQ) */ +/* If COMPQ = 'P', then: */ +/* On exit, if INFO = 0, Q and IQ contain the left */ +/* and right singular vectors in a compact form, */ +/* requiring O(N log N) space instead of 2*N**2. */ +/* In particular, IQ contains all INTEGER data in */ +/* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */ +/* words of memory, where SMLSIZ is returned by ILAENV and */ +/* is equal to the maximum size of the subproblems at the */ +/* bottom of the computation tree (usually about 25). */ +/* For other values of COMPQ, IQ is not referenced. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* If COMPQ = 'N' then LWORK >= (4 * N). */ +/* If COMPQ = 'P' then LWORK >= (6 * N). */ +/* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */ + +/* IWORK (workspace) INTEGER array, dimension (8*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: The algorithm failed to compute an singular value. */ +/* The update process of divide and conquer failed. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ +/* Changed dimension statement in comment describing E from (N) to */ +/* (N-1). Sven, 17 Feb 05. */ +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + --q; + --iq; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + iuplo = 0; + if (lsame_(uplo, "U")) { + iuplo = 1; + } + if (lsame_(uplo, "L")) { + iuplo = 2; + } + if (lsame_(compq, "N")) { + icompq = 0; + } else if (lsame_(compq, "P")) { + icompq = 1; + } else if (lsame_(compq, "I")) { + icompq = 2; + } else { + icompq = -1; + } + if (iuplo == 0) { + *info = -1; + } else if (icompq < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldu < 1 || icompq == 2 && *ldu < *n) { + *info = -7; + } else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DBDSDC", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0); + if (*n == 1) { + if (icompq == 1) { + q[1] = d_sign(&c_b15, &d__[1]); + q[smlsiz * *n + 1] = 1.; + } else if (icompq == 2) { + u[u_dim1 + 1] = d_sign(&c_b15, &d__[1]); + vt[vt_dim1 + 1] = 1.; + } + d__[1] = abs(d__[1]); + return 0; + } + nm1 = *n - 1; + +/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ +/* by applying Givens rotations on the left */ + + wstart = 1; + qstart = 3; + if (icompq == 1) { + dcopy_(n, &d__[1], &c__1, &q[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1); + } + if (iuplo == 2) { + qstart = 5; + wstart = (*n << 1) - 1; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (icompq == 1) { + q[i__ + (*n << 1)] = cs; + q[i__ + *n * 3] = sn; + } else if (icompq == 2) { + work[i__] = cs; + work[nm1 + i__] = -sn; + } +/* L10: */ + } + } + +/* If ICOMPQ = 0, use DLASDQ to compute the singular values. */ + + if (icompq == 0) { + dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[ + wstart], info); + goto L40; + } + +/* If N is smaller than the minimum divide size SMLSIZ, then solve */ +/* the problem with another solver. */ + + if (*n <= smlsiz) { + if (icompq == 2) { + dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu); + dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt); + dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset] +, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[ + wstart], info); + } else if (icompq == 1) { + iu = 1; + ivt = iu + *n; + dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n); + dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n); + dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + ( + qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[ + iu + (qstart - 1) * *n], n, &work[wstart], info); + } + goto L40; + } + + if (icompq == 2) { + dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu); + dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt); + } + +/* Scale. */ + + orgnrm = dlanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.) { + return 0; + } + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, & + ierr); + + eps = dlamch_("Epsilon"); + + mlvl = (integer) (log((double) (*n) / (double) (smlsiz + 1)) / + log(2.)) + 1; + smlszp = smlsiz + 1; + + if (icompq == 1) { + iu = 1; + ivt = smlsiz + 1; + difl = ivt + smlszp; + difr = difl + mlvl; + z__ = difr + (mlvl << 1); + ic = z__ + mlvl; + is = ic + 1; + poles = is + 1; + givnum = poles + (mlvl << 1); + + k = 1; + givptr = 2; + perm = 3; + givcol = perm + mlvl; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) < eps) { + d__[i__] = d_sign(&eps, &d__[i__]); + } +/* L20: */ + } + + start = 1; + sqre = 0; + + i__1 = nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { + +/* Subproblem found. First determine its size and then */ +/* apply divide and conquer on it. */ + + if (i__ < nm1) { + +/* A subproblem with E(I) small for I < NM1. */ + + nsize = i__ - start + 1; + } else if ((d__1 = e[i__], abs(d__1)) >= eps) { + +/* A subproblem with E(NM1) not too small but I = NM1. */ + + nsize = *n - start + 1; + } else { + +/* A subproblem with E(NM1) small. This implies an */ +/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */ +/* first. */ + + nsize = i__ - start + 1; + if (icompq == 2) { + u[*n + *n * u_dim1] = d_sign(&c_b15, &d__[*n]); + vt[*n + *n * vt_dim1] = 1.; + } else if (icompq == 1) { + q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]); + q[*n + (smlsiz + qstart - 1) * *n] = 1.; + } + d__[*n] = (d__1 = d__[*n], abs(d__1)); + } + if (icompq == 2) { + dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start + + start * u_dim1], ldu, &vt[start + start * vt_dim1], + ldvt, &smlsiz, &iwork[1], &work[wstart], info); + } else { + dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[ + start], &q[start + (iu + qstart - 2) * *n], n, &q[ + start + (ivt + qstart - 2) * *n], &iq[start + k * *n], + &q[start + (difl + qstart - 2) * *n], &q[start + ( + difr + qstart - 2) * *n], &q[start + (z__ + qstart - + 2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[ + start + givptr * *n], &iq[start + givcol * *n], n, & + iq[start + perm * *n], &q[start + (givnum + qstart - + 2) * *n], &q[start + (ic + qstart - 2) * *n], &q[ + start + (is + qstart - 2) * *n], &work[wstart], & + iwork[1], info); + if (*info != 0) { + return 0; + } + } + start = i__ + 1; + } +/* L30: */ + } + +/* Unscale */ + + dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr); +L40: + +/* Use Selection Sort to minimize swaps of singular vectors */ + + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + kk = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] > p) { + kk = j; + p = d__[j]; + } +/* L50: */ + } + if (kk != i__) { + d__[kk] = d__[i__]; + d__[i__] = p; + if (icompq == 1) { + iq[i__] = kk; + } else if (icompq == 2) { + dswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], & + c__1); + dswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt); + } + } else if (icompq == 1) { + iq[i__] = i__; + } +/* L60: */ + } + +/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */ + + if (icompq == 1) { + if (iuplo == 1) { + iq[*n] = 1; + } else { + iq[*n] = 0; + } + } + +/* If B is lower bidiagonal, update U by those Givens rotations */ +/* which rotated B to be upper bidiagonal */ + + if (iuplo == 2 && icompq == 2) { + dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu); + } + + return 0; + +/* End of DBDSDC */ + +} /* dbdsdc_ */ + +/* Subroutine */ int dbdsqr_(const char *uplo, integer *n, integer *ncvt, integer * + nru, integer *ncc, double *d__, double *e, double *vt, + integer *ldvt, double *u, integer *ldu, double *c__, integer * + ldc, double *work, integer *info) +{ + /* Table of constant values */ + static double c_b15 = -.125; + static integer c__1 = 1; + static double c_b49 = 1.; + static double c_b72 = -1.; + + /* System generated locals */ + integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, + i__2; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + double f, g, h__; + integer i__, j, m; + double r__, cs; + integer ll; + double sn, mu; + integer nm1, nm12, nm13, lll; + double eps, sll, tol, abse; + integer idir; + double abss; + integer oldm; + double cosl; + integer isub, iter; + double unfl, sinl, cosr, smin, smax, sinr; + double oldcs; + integer oldll; + double shift, sigmn, oldsn; + integer maxit; + double sminl, sigmx; + bool lower; + double sminoa, thresh; + bool rotate; + double tolmul; + + +/* -- LAPACK routine (version 3.1.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* January 2007 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DBDSQR computes the singular values and, optionally, the right and/or */ +/* left singular vectors from the singular value decomposition (SVD) of */ +/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */ +/* zero-shift QR algorithm. The SVD of B has the form */ + +/* B = Q * S * P**T */ + +/* where S is the diagonal matrix of singular values, Q is an orthogonal */ +/* matrix of left singular vectors, and P is an orthogonal matrix of */ +/* right singular vectors. If left singular vectors are requested, this */ +/* subroutine actually returns U*Q instead of Q, and, if right singular */ +/* vectors are requested, this subroutine returns P**T*VT instead of */ +/* P**T, for given real input matrices U and VT. When U and VT are the */ +/* orthogonal matrices that reduce a general matrix A to bidiagonal */ +/* form: A = U*B*VT, as computed by DGEBRD, then */ + +/* A = (U*Q) * S * (P**T*VT) */ + +/* is the SVD of A. Optionally, the subroutine may also compute Q**T*C */ +/* for a given real input matrix C. */ + +/* See "Computing Small Singular Values of Bidiagonal Matrices With */ +/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */ +/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */ +/* no. 5, pp. 873-912, Sept 1990) and */ +/* "Accurate singular values and differential qd algorithms," by */ +/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */ +/* Department, University of California at Berkeley, July 1992 */ +/* for a detailed description of the algorithm. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': B is upper bidiagonal; */ +/* = 'L': B is lower bidiagonal. */ + +/* N (input) INTEGER */ +/* The order of the matrix B. N >= 0. */ + +/* NCVT (input) INTEGER */ +/* The number of columns of the matrix VT. NCVT >= 0. */ + +/* NRU (input) INTEGER */ +/* The number of rows of the matrix U. NRU >= 0. */ + +/* NCC (input) INTEGER */ +/* The number of columns of the matrix C. NCC >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the bidiagonal matrix B. */ +/* On exit, if INFO=0, the singular values of B in decreasing */ +/* order. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the N-1 offdiagonal elements of the bidiagonal */ +/* matrix B. */ +/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */ +/* will contain the diagonal and superdiagonal elements of a */ +/* bidiagonal matrix orthogonally equivalent to the one given */ +/* as input. */ + +/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */ +/* On entry, an N-by-NCVT matrix VT. */ +/* On exit, VT is overwritten by P**T * VT. */ +/* Not referenced if NCVT = 0. */ + +/* LDVT (input) INTEGER */ +/* The leading dimension of the array VT. */ +/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */ + +/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */ +/* On entry, an NRU-by-N matrix U. */ +/* On exit, U is overwritten by U * Q. */ +/* Not referenced if NRU = 0. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= max(1,NRU). */ + +/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */ +/* On entry, an N-by-NCC matrix C. */ +/* On exit, C is overwritten by Q**T * C. */ +/* Not referenced if NCC = 0. */ + +/* LDC (input) INTEGER */ +/* The leading dimension of the array C. */ +/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ +/* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > 0: the algorithm did not converge; D and E contain the */ +/* elements of a bidiagonal matrix which is orthogonally */ +/* similar to the input matrix B; if INFO = i, i */ +/* elements of E have not converged to zero. */ + +/* Internal Parameters */ +/* =================== */ + +/* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) */ +/* TOLMUL controls the convergence criterion of the QR loop. */ +/* If it is positive, TOLMUL*EPS is the desired relative */ +/* precision in the computed singular values. */ +/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */ +/* desired absolute accuracy in the computed singular */ +/* values (corresponds to relative accuracy */ +/* abs(TOLMUL*EPS) in the largest singular value. */ +/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */ +/* between 10 (for fast convergence) and .1/EPS */ +/* (for there to be some accuracy in the results). */ +/* Default is to lose at either one eighth or 2 of the */ +/* available decimal digits in each computed singular value */ +/* (whichever is smaller). */ + +/* MAXITR INTEGER, default = 6 */ +/* MAXITR controls the maximum number of passes of the */ +/* algorithm through its inner loop. The algorithms stops */ +/* (and so fails to converge) if the number of passes */ +/* through the inner loop exceeds MAXITR*N**2. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lsame_(uplo, "U") && ! lower) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ncvt < 0) { + *info = -3; + } else if (*nru < 0) { + *info = -4; + } else if (*ncc < 0) { + *info = -5; + } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldu < std::max(1_integer,*nru)) { + *info = -11; + } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < std::max(1_integer,*n)) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DBDSQR", &i__1); + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + goto L160; + } + +/* ROTATE is true if any singular vectors desired, false otherwise */ + + rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; + +/* If no singular vectors desired, use qd algorithm */ + + if (! rotate) { + dlasq1_(n, &d__[1], &e[1], &work[1], info); + return 0; + } + + nm1 = *n - 1; + nm12 = nm1 + nm1; + nm13 = nm12 + nm1; + idir = 0; + +/* Get machine constants */ + + eps = dlamch_("Epsilon"); + unfl = dlamch_("Safe minimum"); + +/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ +/* by applying Givens rotations on the left */ + + if (lower) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + work[i__] = cs; + work[nm1 + i__] = sn; +/* L10: */ + } + +/* Update singular vectors if desired */ + + if (*nru > 0) { + dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset], + ldu); + } + if (*ncc > 0) { + dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset], + ldc); + } + } + +/* Compute singular values to relative accuracy TOL */ +/* (By setting TOL to be negative, algorithm will compute */ +/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */ + +/* Computing MAX */ +/* Computing MIN */ + d__3 = 100., d__4 = pow_dd(&eps, &c_b15); + d__1 = 10., d__2 = std::min(d__3,d__4); + tolmul = std::max(d__1,d__2); + tol = tolmul * eps; + +/* Compute approximate maximum, minimum singular values */ + + smax = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1)); + smax = std::max(d__2,d__3); +/* L20: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1)); + smax = std::max(d__2,d__3); +/* L30: */ + } + sminl = 0.; + if (tol >= 0.) { + +/* Relative accuracy desired */ + + sminoa = abs(d__[1]); + if (sminoa == 0.) { + goto L50; + } + mu = sminoa; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1] + , abs(d__1)))); + sminoa = std::min(sminoa,mu); + if (sminoa == 0.) { + goto L50; + } +/* L40: */ + } +L50: + sminoa /= sqrt((double) (*n)); +/* Computing MAX */ + d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl; + thresh = std::max(d__1,d__2); + } else { + +/* Absolute accuracy desired */ + +/* Computing MAX */ + d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl; + thresh = std::max(d__1,d__2); + } + +/* Prepare for main iteration loop for the singular values */ +/* (MAXIT is the maximum number of passes through the inner */ +/* loop permitted before nonconvergence signalled.) */ + + maxit = *n * 6 * *n; + iter = 0; + oldll = -1; + oldm = -1; + +/* M points to last element of unconverged part of matrix */ + + m = *n; + +/* Begin main iteration loop */ + +L60: + +/* Check for convergence or exceeding iteration count */ + + if (m <= 1) { + goto L160; + } + if (iter > maxit) { + goto L200; + } + +/* Find diagonal block of matrix to work on */ + + if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) { + d__[m] = 0.; + } + smax = (d__1 = d__[m], abs(d__1)); + smin = smax; + i__1 = m - 1; + for (lll = 1; lll <= i__1; ++lll) { + ll = m - lll; + abss = (d__1 = d__[ll], abs(d__1)); + abse = (d__1 = e[ll], abs(d__1)); + if (tol < 0. && abss <= thresh) { + d__[ll] = 0.; + } + if (abse <= thresh) { + goto L80; + } + smin = std::min(smin,abss); +/* Computing MAX */ + d__1 = std::max(smax,abss); + smax = std::max(d__1,abse); +/* L70: */ + } + ll = 0; + goto L90; +L80: + e[ll] = 0.; + +/* Matrix splits since E(LL) = 0 */ + + if (ll == m - 1) { + +/* Convergence of bottom singular value, return to top of loop */ + + --m; + goto L60; + } +L90: + ++ll; + +/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */ + + if (ll == m - 1) { + +/* 2 by 2 block, handle separately */ + + dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, + &sinl, &cosl); + d__[m - 1] = sigmx; + e[m - 1] = 0.; + d__[m] = sigmn; + +/* Compute singular vectors, if desired */ + + if (*ncvt > 0) { + drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, & + cosr, &sinr); + } + if (*nru > 0) { + drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], & + c__1, &cosl, &sinl); + } + if (*ncc > 0) { + drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, & + cosl, &sinl); + } + m += -2; + goto L60; + } + +/* If working on new submatrix, choose shift direction */ +/* (from larger end diagonal element towards smaller) */ + + if (ll > oldm || m < oldll) { + if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) { + +/* Chase bulge from top (big end) to bottom (small end) */ + + idir = 1; + } else { + +/* Chase bulge from bottom (big end) to top (small end) */ + + idir = 2; + } + } + +/* Apply convergence tests */ + + if (idir == 1) { + +/* Run convergence test in forward direction */ +/* First apply standard test to bottom of matrix */ + + if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs( + d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) + { + e[m - 1] = 0.; + goto L60; + } + + if (tol >= 0.) { + +/* If relative accuracy desired, */ +/* apply convergence criterion forward */ + + mu = (d__1 = d__[ll], abs(d__1)); + sminl = mu; + i__1 = m - 1; + for (lll = ll; lll <= i__1; ++lll) { + if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { + e[lll] = 0.; + goto L60; + } + mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[ + lll], abs(d__1)))); + sminl = std::min(sminl,mu); +/* L100: */ + } + } + + } else { + +/* Run convergence test in backward direction */ +/* First apply standard test to top of matrix */ + + if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1) + ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) { + e[ll] = 0.; + goto L60; + } + + if (tol >= 0.) { + +/* If relative accuracy desired, */ +/* apply convergence criterion backward */ + + mu = (d__1 = d__[m], abs(d__1)); + sminl = mu; + i__1 = ll; + for (lll = m - 1; lll >= i__1; --lll) { + if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { + e[lll] = 0.; + goto L60; + } + mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll] + , abs(d__1)))); + sminl = std::min(sminl,mu); +/* L110: */ + } + } + } + oldll = ll; + oldm = m; + +/* Compute shift. First, test if shifting would ruin relative */ +/* accuracy, and if so set the shift to zero. */ + +/* Computing MAX */ + d__1 = eps, d__2 = tol * .01; + if (tol >= 0. && *n * tol * (sminl / smax) <= std::max(d__1,d__2)) { + +/* Use a zero shift to avoid loss of relative accuracy */ + + shift = 0.; + } else { + +/* Compute the shift from 2-by-2 block at end of matrix */ + + if (idir == 1) { + sll = (d__1 = d__[ll], abs(d__1)); + dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); + } else { + sll = (d__1 = d__[m], abs(d__1)); + dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); + } + +/* Test if shift negligible, and if so set to zero */ + + if (sll > 0.) { +/* Computing 2nd power */ + d__1 = shift / sll; + if (d__1 * d__1 < eps) { + shift = 0.; + } + } + } + +/* Increment iteration count */ + + iter = iter + m - ll; + +/* If SHIFT = 0, do simplified QR iteration */ + + if (shift == 0.) { + if (idir == 1) { + +/* Chase bulge from top to bottom */ +/* Save cosines and sines for later singular vector updates */ + + cs = 1.; + oldcs = 1.; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + d__1 = d__[i__] * cs; + dlartg_(&d__1, &e[i__], &cs, &sn, &r__); + if (i__ > ll) { + e[i__ - 1] = oldsn * r__; + } + d__1 = oldcs * r__; + d__2 = d__[i__ + 1] * sn; + dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); + work[i__ - ll + 1] = cs; + work[i__ - ll + 1 + nm1] = sn; + work[i__ - ll + 1 + nm12] = oldcs; + work[i__ - ll + 1 + nm13] = oldsn; +/* L120: */ + } + h__ = d__[m] * cs; + d__[m] = h__ * oldcs; + e[m - 1] = h__ * oldsn; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[ + ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 + + 1], &u[ll * u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 + + 1], &c__[ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { + e[m - 1] = 0.; + } + + } else { + +/* Chase bulge from bottom to top */ +/* Save cosines and sines for later singular vector updates */ + + cs = 1.; + oldcs = 1.; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + d__1 = d__[i__] * cs; + dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); + if (i__ < m) { + e[i__] = oldsn * r__; + } + d__1 = oldcs * r__; + d__2 = d__[i__ - 1] * sn; + dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); + work[i__ - ll] = cs; + work[i__ - ll + nm1] = -sn; + work[i__ - ll + nm12] = oldcs; + work[i__ - ll + nm13] = -oldsn; +/* L130: */ + } + h__ = d__[ll] * cs; + d__[ll] = h__ * oldcs; + e[ll] = h__ * oldsn; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[ + nm13 + 1], &vt[ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll * + u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[ + ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((d__1 = e[ll], abs(d__1)) <= thresh) { + e[ll] = 0.; + } + } + } else { + +/* Use nonzero shift */ + + if (idir == 1) { + +/* Chase bulge from top to bottom */ +/* Save cosines and sines for later singular vector updates */ + + f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[ + ll]) + shift / d__[ll]); + g = e[ll]; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + dlartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ > ll) { + e[i__ - 1] = r__; + } + f = cosr * d__[i__] + sinr * e[i__]; + e[i__] = cosr * e[i__] - sinr * d__[i__]; + g = sinr * d__[i__ + 1]; + d__[i__ + 1] = cosr * d__[i__ + 1]; + dlartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__] + sinl * d__[i__ + 1]; + d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; + if (i__ < m - 1) { + g = sinl * e[i__ + 1]; + e[i__ + 1] = cosl * e[i__ + 1]; + } + work[i__ - ll + 1] = cosr; + work[i__ - ll + 1 + nm1] = sinr; + work[i__ - ll + 1 + nm12] = cosl; + work[i__ - ll + 1 + nm13] = sinl; +/* L140: */ + } + e[m - 1] = f; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[ + ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 + + 1], &u[ll * u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 + + 1], &c__[ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { + e[m - 1] = 0.; + } + + } else { + +/* Chase bulge from bottom to top */ +/* Save cosines and sines for later singular vector updates */ + + f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m] + ) + shift / d__[m]); + g = e[m - 1]; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + dlartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ < m) { + e[i__] = r__; + } + f = cosr * d__[i__] + sinr * e[i__ - 1]; + e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; + g = sinr * d__[i__ - 1]; + d__[i__ - 1] = cosr * d__[i__ - 1]; + dlartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; + d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; + if (i__ > ll + 1) { + g = sinl * e[i__ - 2]; + e[i__ - 2] = cosl * e[i__ - 2]; + } + work[i__ - ll] = cosr; + work[i__ - ll + nm1] = -sinr; + work[i__ - ll + nm12] = cosl; + work[i__ - ll + nm13] = -sinl; +/* L150: */ + } + e[ll] = f; + +/* Test convergence */ + + if ((d__1 = e[ll], abs(d__1)) <= thresh) { + e[ll] = 0.; + } + +/* Update singular vectors if desired */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[ + nm13 + 1], &vt[ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll * + u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[ + ll + c_dim1], ldc); + } + } + } + +/* QR iteration finished, go back and check convergence */ + + goto L60; + +/* All singular values converged, so make them positive */ + +L160: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] < 0.) { + d__[i__] = -d__[i__]; + +/* Change sign of singular vectors, if desired */ + + if (*ncvt > 0) { + dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt); + } + } +/* L170: */ + } + +/* Sort the singular values into decreasing order (insertion sort on */ +/* singular values, but only one transposition per singular vector) */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for smallest D(I) */ + + isub = 1; + smin = d__[1]; + i__2 = *n + 1 - i__; + for (j = 2; j <= i__2; ++j) { + if (d__[j] <= smin) { + isub = j; + smin = d__[j]; + } +/* L180: */ + } + if (isub != *n + 1 - i__) { + +/* Swap singular values and vectors */ + + d__[isub] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = smin; + if (*ncvt > 0) { + dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + + vt_dim1], ldvt); + } + if (*nru > 0) { + dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * + u_dim1 + 1], &c__1); + } + if (*ncc > 0) { + dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + + c_dim1], ldc); + } + } +/* L190: */ + } + goto L220; + +/* Maximum number of iterations exceeded, failure to converge */ + +L200: + *info = 0; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } +/* L210: */ + } +L220: + return 0; + +/* End of DBDSQR */ + +} /* dbdsqr_ */ + +/* Subroutine */ int ddisna_(const char *job, integer *m, integer *n, double * + d__, double *sep, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, k; + double eps; + bool decr, left, incr, sing, eigen; + + double anorm; + bool right; + + double oldgap, safmin; + + double newgap, thresh; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DDISNA computes the reciprocal condition numbers for the eigenvectors */ +/* of a real symmetric or complex Hermitian matrix or for the left or */ +/* right singular vectors of a general m-by-n matrix. The reciprocal */ +/* condition number is the 'gap' between the corresponding eigenvalue or */ +/* singular value and the nearest other one. */ + +/* The bound on the error, measured by angle in radians, in the I-th */ +/* computed vector is given by */ + +/* DLAMCH( 'E' ) * ( ANORM / SEP( I ) ) */ + +/* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed */ +/* to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of */ +/* the error bound. */ + +/* DDISNA may also be used to compute error bounds for eigenvectors of */ +/* the generalized symmetric definite eigenproblem. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* Specifies for which problem the reciprocal condition numbers */ +/* should be computed: */ +/* = 'E': the eigenvectors of a symmetric/Hermitian matrix; */ +/* = 'L': the left singular vectors of a general matrix; */ +/* = 'R': the right singular vectors of a general matrix. */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix. M >= 0. */ + +/* N (input) INTEGER */ +/* If JOB = 'L' or 'R', the number of columns of the matrix, */ +/* in which case N >= 0. Ignored if JOB = 'E'. */ + +/* D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E' */ +/* dimension (min(M,N)) if JOB = 'L' or 'R' */ +/* The eigenvalues (if JOB = 'E') or singular values (if JOB = */ +/* 'L' or 'R') of the matrix, in either increasing or decreasing */ +/* order. If singular values, they must be non-negative. */ + +/* SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E' */ +/* dimension (min(M,N)) if JOB = 'L' or 'R' */ +/* The reciprocal condition numbers of the vectors. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + --sep; + --d__; + + /* Function Body */ + *info = 0; + eigen = lsame_(job, "E"); + left = lsame_(job, "L"); + right = lsame_(job, "R"); + sing = left || right; + if (eigen) { + k = *m; + } else if (sing) { + k = std::min(*m,*n); + } + if (! eigen && ! sing) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (k < 0) { + *info = -3; + } else { + incr = true; + decr = true; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (incr) { + incr = incr && d__[i__] <= d__[i__ + 1]; + } + if (decr) { + decr = decr && d__[i__] >= d__[i__ + 1]; + } +/* L10: */ + } + if (sing && k > 0) { + if (incr) { + incr = incr && 0. <= d__[1]; + } + if (decr) { + decr = decr && d__[k] >= 0.; + } + } + if (! (incr || decr)) { + *info = -4; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DDISNA", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (k == 0) { + return 0; + } + +/* Compute reciprocal condition numbers */ + + if (k == 1) { + sep[1] = dlamch_("O"); + } else { + oldgap = (d__1 = d__[2] - d__[1], abs(d__1)); + sep[1] = oldgap; + i__1 = k - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + newgap = (d__1 = d__[i__ + 1] - d__[i__], abs(d__1)); + sep[i__] = std::min(oldgap,newgap); + oldgap = newgap; +/* L20: */ + } + sep[k] = oldgap; + } + if (sing) { + if (left && *m > *n || right && *m < *n) { + if (incr) { + sep[1] = std::min(sep[1],d__[1]); + } + if (decr) { +/* Computing MIN */ + d__1 = sep[k], d__2 = d__[k]; + sep[k] = std::min(d__1,d__2); + } + } + } + +/* Ensure that reciprocal condition numbers are not less than */ +/* threshold, in order to limit the size of the error bound */ + + eps = dlamch_("E"); + safmin = dlamch_("S"); +/* Computing MAX */ + d__2 = abs(d__[1]), d__3 = (d__1 = d__[k], abs(d__1)); + anorm = std::max(d__2,d__3); + if (anorm == 0.) { + thresh = eps; + } else { +/* Computing MAX */ + d__1 = eps * anorm; + thresh = std::max(d__1,safmin); + } + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = sep[i__]; + sep[i__] = std::max(d__1,thresh); +/* L30: */ + } + + return 0; + +/* End of DDISNA */ + +} /* ddisna_ */ + +/* Subroutine */ int dhgeqz_(const char *job, const char *compq, const char *compz, integer *n, + integer *ilo, integer *ihi, double *h__, integer *ldh, double + *t, integer *ldt, double *alphar, double *alphai, double * + beta, double *q, integer *ldq, double *z__, integer *ldz, + double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static double c_b12 = 0.; + static double c_b13 = 1.; + static integer c__1 = 1; + static integer c__3 = 3; + + /* System generated locals */ + integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1, + z_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + double c__; + integer j; + double s, v[3], s1, s2, t1, u1, u2, a11, a12, a21, a22, b11, b22, c12, + c21; + integer jc; + double an, bn, cl, cq, cr; + integer in; + double u12, w11, w12, w21; + integer jr; + double cz, w22, sl, wi, sr, vs, wr, b1a, b2a, a1i, a2i, b1i, b2i, a1r, + a2r, b1r, b2r, wr2, ad11, ad12, ad21, ad22, c11i, c22i; + integer jch; + double c11r, c22r; + bool ilq; + double u12l, tau, sqi; + bool ilz; + double ulp, sqr, szi, szr, ad11l, ad12l, ad21l, ad22l, ad32l, wabs, + atol, btol, temp; + double temp2, s1inv, scale; + integer iiter, ilast, jiter; + double anorm, bnorm; + integer maxit; + double tempi, tempr; + bool ilazr2; + double ascale, bscale; + double safmin; + double safmax; + double eshift; + bool ilschr; + integer icompq, ilastm, ischur; + bool ilazro; + integer icompz, ifirst, ifrstm, istart; + bool ilpivt, lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), */ +/* where H is an upper Hessenberg matrix and T is upper triangular, */ +/* using the double-shift QZ method. */ +/* Matrix pairs of this type are produced by the reduction to */ +/* generalized upper Hessenberg form of a real matrix pair (A,B): */ + +/* A = Q1*H*Z1**T, B = Q1*T*Z1**T, */ + +/* as computed by DGGHRD. */ + +/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */ +/* also reduced to generalized Schur form, */ + +/* H = Q*S*Z**T, T = Q*P*Z**T, */ + +/* where Q and Z are orthogonal matrices, P is an upper triangular */ +/* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 */ +/* diagonal blocks. */ + +/* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair */ +/* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of */ +/* eigenvalues. */ + +/* Additionally, the 2-by-2 upper triangular diagonal blocks of P */ +/* corresponding to 2-by-2 blocks of S are reduced to positive diagonal */ +/* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, */ +/* P(j,j) > 0, and P(j+1,j+1) > 0. */ + +/* Optionally, the orthogonal matrix Q from the generalized Schur */ +/* factorization may be postmultiplied into an input matrix Q1, and the */ +/* orthogonal matrix Z may be postmultiplied into an input matrix Z1. */ +/* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced */ +/* the matrix pair (A,B) to generalized upper Hessenberg form, then the */ +/* output matrices Q1*Q and Z1*Z are the orthogonal factors from the */ +/* generalized Schur factorization of (A,B): */ + +/* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. */ + +/* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, */ +/* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is */ +/* complex and beta real. */ +/* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the */ +/* generalized nonsymmetric eigenvalue problem (GNEP) */ +/* A*x = lambda*B*x */ +/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */ +/* alternate form of the GNEP */ +/* mu*A*y = B*y. */ +/* Real eigenvalues can be read directly from the generalized Schur */ +/* form: */ +/* alpha = S(i,i), beta = P(i,i). */ + +/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */ +/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */ +/* pp. 241--256. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* = 'E': Compute eigenvalues only; */ +/* = 'S': Compute eigenvalues and the Schur form. */ + +/* COMPQ (input) CHARACTER*1 */ +/* = 'N': Left Schur vectors (Q) are not computed; */ +/* = 'I': Q is initialized to the unit matrix and the matrix Q */ +/* of left Schur vectors of (H,T) is returned; */ +/* = 'V': Q must contain an orthogonal matrix Q1 on entry and */ +/* the product Q1*Q is returned. */ + +/* COMPZ (input) CHARACTER*1 */ +/* = 'N': Right Schur vectors (Z) are not computed; */ +/* = 'I': Z is initialized to the unit matrix and the matrix Z */ +/* of right Schur vectors of (H,T) is returned; */ +/* = 'V': Z must contain an orthogonal matrix Z1 on entry and */ +/* the product Z1*Z is returned. */ + +/* N (input) INTEGER */ +/* The order of the matrices H, T, Q, and Z. N >= 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* ILO and IHI mark the rows and columns of H which are in */ +/* Hessenberg form. It is assumed that A is already upper */ +/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */ +/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */ + +/* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) */ +/* On entry, the N-by-N upper Hessenberg matrix H. */ +/* On exit, if JOB = 'S', H contains the upper quasi-triangular */ +/* matrix S from the generalized Schur factorization; */ +/* 2-by-2 diagonal blocks (corresponding to complex conjugate */ +/* pairs of eigenvalues) are returned in standard form, with */ +/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. */ +/* If JOB = 'E', the diagonal blocks of H match those of S, but */ +/* the rest of H is unspecified. */ + +/* LDH (input) INTEGER */ +/* The leading dimension of the array H. LDH >= max( 1, N ). */ + +/* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) */ +/* On entry, the N-by-N upper triangular matrix T. */ +/* On exit, if JOB = 'S', T contains the upper triangular */ +/* matrix P from the generalized Schur factorization; */ +/* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S */ +/* are reduced to positive diagonal form, i.e., if H(j+1,j) is */ +/* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and */ +/* T(j+1,j+1) > 0. */ +/* If JOB = 'E', the diagonal blocks of T match those of P, but */ +/* the rest of T is unspecified. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the array T. LDT >= max( 1, N ). */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ +/* The real parts of each scalar alpha defining an eigenvalue */ +/* of GNEP. */ + +/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ +/* The imaginary parts of each scalar alpha defining an */ +/* eigenvalue of GNEP. */ +/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* positive, then the j-th and (j+1)-st eigenvalues are a */ +/* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). */ + +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* The scalars beta that define the eigenvalues of GNEP. */ +/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ +/* beta = BETA(j) represent the j-th eigenvalue of the matrix */ +/* pair (A,B), in one of the forms lambda = alpha/beta or */ +/* mu = beta/alpha. Since either lambda or mu may overflow, */ +/* they should not, in general, be computed. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ +/* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in */ +/* the reduction of (A,B) to generalized Hessenberg form. */ +/* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur */ +/* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix */ +/* of left Schur vectors of (A,B). */ +/* Not referenced if COMPZ = 'N'. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= 1. */ +/* If COMPQ='V' or 'I', then LDQ >= N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in */ +/* the reduction of (A,B) to generalized Hessenberg form. */ +/* On exit, if COMPZ = 'I', the orthogonal matrix of */ +/* right Schur vectors of (H,T), and if COMPZ = 'V', the */ +/* orthogonal matrix of right Schur vectors of (A,B). */ +/* Not referenced if COMPZ = 'N'. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1. */ +/* If COMPZ='V' or 'I', then LDZ >= N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */ +/* in Schur form, but ALPHAR(i), ALPHAI(i), and */ +/* BETA(i), i=INFO+1,...,N should be correct. */ +/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */ +/* in Schur form, but ALPHAR(i), ALPHAI(i), and */ +/* BETA(i), i=INFO-N+1,...,N should be correct. */ + +/* Further Details */ +/* =============== */ + +/* Iteration counters: */ + +/* JITER -- counts iterations. */ +/* IITER -- counts iterations run since ILAST was last */ +/* changed. This is therefore reset only when a 1-by-1 or */ +/* 2-by-2 block deflates off the bottom. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* $ SAFETY = 1.0E+0 ) */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode JOB, COMPQ, COMPZ */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + --alphar; + --alphai; + --beta; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + if (lsame_(job, "E")) { + ilschr = false; + ischur = 1; + } else if (lsame_(job, "S")) { + ilschr = true; + ischur = 2; + } else { + ischur = 0; + } + + if (lsame_(compq, "N")) { + ilq = false; + icompq = 1; + } else if (lsame_(compq, "V")) { + ilq = true; + icompq = 2; + } else if (lsame_(compq, "I")) { + ilq = true; + icompq = 3; + } else { + icompq = 0; + } + + if (lsame_(compz, "N")) { + ilz = false; + icompz = 1; + } else if (lsame_(compz, "V")) { + ilz = true; + icompz = 2; + } else if (lsame_(compz, "I")) { + ilz = true; + icompz = 3; + } else { + icompz = 0; + } + +/* Check Argument Values */ + + *info = 0; + work[1] = (double) std::max(1_integer,*n); + lquery = *lwork == -1; + if (ischur == 0) { + *info = -1; + } else if (icompq == 0) { + *info = -2; + } else if (icompz == 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ilo < 1) { + *info = -5; + } else if (*ihi > *n || *ihi < *ilo - 1) { + *info = -6; + } else if (*ldh < *n) { + *info = -8; + } else if (*ldt < *n) { + *info = -10; + } else if (*ldq < 1 || ilq && *ldq < *n) { + *info = -15; + } else if (*ldz < 1 || ilz && *ldz < *n) { + *info = -17; + } else if (*lwork < std::max(1_integer,*n) && ! lquery) { + *info = -19; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DHGEQZ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + work[1] = 1.; + return 0; + } + +/* Initialize Q and Z */ + + if (icompq == 3) { + dlaset_("Full", n, n, &c_b12, &c_b13, &q[q_offset], ldq); + } + if (icompz == 3) { + dlaset_("Full", n, n, &c_b12, &c_b13, &z__[z_offset], ldz); + } + +/* Machine Constants */ + + in = *ihi + 1 - *ilo; + safmin = dlamch_("S"); + safmax = 1. / safmin; + ulp = dlamch_("E") * dlamch_("B"); + anorm = dlanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &work[1]); + bnorm = dlanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &work[1]); +/* Computing MAX */ + d__1 = safmin, d__2 = ulp * anorm; + atol = std::max(d__1,d__2); +/* Computing MAX */ + d__1 = safmin, d__2 = ulp * bnorm; + btol = std::max(d__1,d__2); + ascale = 1. / std::max(safmin,anorm); + bscale = 1. / std::max(safmin,bnorm); + +/* Set Eigenvalues IHI+1:N */ + + i__1 = *n; + for (j = *ihi + 1; j <= i__1; ++j) { + if (t[j + j * t_dim1] < 0.) { + if (ilschr) { + i__2 = j; + for (jr = 1; jr <= i__2; ++jr) { + h__[jr + j * h_dim1] = -h__[jr + j * h_dim1]; + t[jr + j * t_dim1] = -t[jr + j * t_dim1]; +/* L10: */ + } + } else { + h__[j + j * h_dim1] = -h__[j + j * h_dim1]; + t[j + j * t_dim1] = -t[j + j * t_dim1]; + } + if (ilz) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + z__[jr + j * z_dim1] = -z__[jr + j * z_dim1]; +/* L20: */ + } + } + } + alphar[j] = h__[j + j * h_dim1]; + alphai[j] = 0.; + beta[j] = t[j + j * t_dim1]; +/* L30: */ + } + +/* If IHI < ILO, skip QZ steps */ + + if (*ihi < *ilo) { + goto L380; + } + +/* MAIN QZ ITERATION LOOP */ + +/* Initialize dynamic indices */ + +/* Eigenvalues ILAST+1:N have been found. */ +/* Column operations modify rows IFRSTM:whatever. */ +/* Row operations modify columns whatever:ILASTM. */ + +/* If only eigenvalues are being computed, then */ +/* IFRSTM is the row of the last splitting row above row ILAST; */ +/* this is always at least ILO. */ +/* IITER counts iterations since the last eigenvalue was found, */ +/* to tell when to use an extraordinary shift. */ +/* MAXIT is the maximum number of QZ sweeps allowed. */ + + ilast = *ihi; + if (ilschr) { + ifrstm = 1; + ilastm = *n; + } else { + ifrstm = *ilo; + ilastm = *ihi; + } + iiter = 0; + eshift = 0.; + maxit = (*ihi - *ilo + 1) * 30; + + i__1 = maxit; + for (jiter = 1; jiter <= i__1; ++jiter) { + +/* Split the matrix if possible. */ + +/* Two tests: */ +/* 1: H(j,j-1)=0 or j=ILO */ +/* 2: T(j,j)=0 */ + + if (ilast == *ilo) { + +/* Special case: j=ILAST */ + + goto L80; + } else { + if ((d__1 = h__[ilast + (ilast - 1) * h_dim1], abs(d__1)) <= atol) + { + h__[ilast + (ilast - 1) * h_dim1] = 0.; + goto L80; + } + } + + if ((d__1 = t[ilast + ilast * t_dim1], abs(d__1)) <= btol) { + t[ilast + ilast * t_dim1] = 0.; + goto L70; + } + +/* General case: j= i__2; --j) { + +/* Test 1: for H(j,j-1)=0 or j=ILO */ + + if (j == *ilo) { + ilazro = true; + } else { + if ((d__1 = h__[j + (j - 1) * h_dim1], abs(d__1)) <= atol) { + h__[j + (j - 1) * h_dim1] = 0.; + ilazro = true; + } else { + ilazro = false; + } + } + +/* Test 2: for T(j,j)=0 */ + + if ((d__1 = t[j + j * t_dim1], abs(d__1)) < btol) { + t[j + j * t_dim1] = 0.; + +/* Test 1a: Check for 2 consecutive small subdiagonals in A */ + + ilazr2 = false; + if (! ilazro) { + temp = (d__1 = h__[j + (j - 1) * h_dim1], abs(d__1)); + temp2 = (d__1 = h__[j + j * h_dim1], abs(d__1)); + tempr = std::max(temp,temp2); + if (tempr < 1. && tempr != 0.) { + temp /= tempr; + temp2 /= tempr; + } + if (temp * (ascale * (d__1 = h__[j + 1 + j * h_dim1], abs( + d__1))) <= temp2 * (ascale * atol)) { + ilazr2 = true; + } + } + +/* If both tests pass (1 & 2), i.e., the leading diagonal */ +/* element of B in the block is zero, split a 1x1 block off */ +/* at the top. (I.e., at the J-th row/column) The leading */ +/* diagonal element of the remainder can also be zero, so */ +/* this may have to be done repeatedly. */ + + if (ilazro || ilazr2) { + i__3 = ilast - 1; + for (jch = j; jch <= i__3; ++jch) { + temp = h__[jch + jch * h_dim1]; + dlartg_(&temp, &h__[jch + 1 + jch * h_dim1], &c__, &s, + &h__[jch + jch * h_dim1]); + h__[jch + 1 + jch * h_dim1] = 0.; + i__4 = ilastm - jch; + drot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, & + h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__, + &s); + i__4 = ilastm - jch; + drot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[ + jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s); + if (ilq) { + drot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1) + * q_dim1 + 1], &c__1, &c__, &s); + } + if (ilazr2) { + h__[jch + (jch - 1) * h_dim1] *= c__; + } + ilazr2 = false; + if ((d__1 = t[jch + 1 + (jch + 1) * t_dim1], abs(d__1) + ) >= btol) { + if (jch + 1 >= ilast) { + goto L80; + } else { + ifirst = jch + 1; + goto L110; + } + } + t[jch + 1 + (jch + 1) * t_dim1] = 0.; +/* L40: */ + } + goto L70; + } else { + +/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */ +/* Then process as in the case T(ILAST,ILAST)=0 */ + + i__3 = ilast - 1; + for (jch = j; jch <= i__3; ++jch) { + temp = t[jch + (jch + 1) * t_dim1]; + dlartg_(&temp, &t[jch + 1 + (jch + 1) * t_dim1], &c__, + &s, &t[jch + (jch + 1) * t_dim1]); + t[jch + 1 + (jch + 1) * t_dim1] = 0.; + if (jch < ilastm - 1) { + i__4 = ilastm - jch - 1; + drot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, & + t[jch + 1 + (jch + 2) * t_dim1], ldt, & + c__, &s); + } + i__4 = ilastm - jch + 2; + drot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, & + h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__, + &s); + if (ilq) { + drot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1) + * q_dim1 + 1], &c__1, &c__, &s); + } + temp = h__[jch + 1 + jch * h_dim1]; + dlartg_(&temp, &h__[jch + 1 + (jch - 1) * h_dim1], & + c__, &s, &h__[jch + 1 + jch * h_dim1]); + h__[jch + 1 + (jch - 1) * h_dim1] = 0.; + i__4 = jch + 1 - ifrstm; + drot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[ + ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s) + ; + i__4 = jch - ifrstm; + drot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[ + ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s) + ; + if (ilz) { + drot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch + - 1) * z_dim1 + 1], &c__1, &c__, &s); + } +/* L50: */ + } + goto L70; + } + } else if (ilazro) { + +/* Only test 1 passed -- work on J:ILAST */ + + ifirst = j; + goto L110; + } + +/* Neither test passed -- try next J */ + +/* L60: */ + } + +/* (Drop-through is "impossible") */ + + *info = *n + 1; + goto L420; + +/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */ +/* 1x1 block. */ + +L70: + temp = h__[ilast + ilast * h_dim1]; + dlartg_(&temp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[ + ilast + ilast * h_dim1]); + h__[ilast + (ilast - 1) * h_dim1] = 0.; + i__2 = ilast - ifrstm; + drot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + ( + ilast - 1) * h_dim1], &c__1, &c__, &s); + i__2 = ilast - ifrstm; + drot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast - + 1) * t_dim1], &c__1, &c__, &s); + if (ilz) { + drot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) * + z_dim1 + 1], &c__1, &c__, &s); + } + +/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, */ +/* and BETA */ + +L80: + if (t[ilast + ilast * t_dim1] < 0.) { + if (ilschr) { + i__2 = ilast; + for (j = ifrstm; j <= i__2; ++j) { + h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1]; + t[j + ilast * t_dim1] = -t[j + ilast * t_dim1]; +/* L90: */ + } + } else { + h__[ilast + ilast * h_dim1] = -h__[ilast + ilast * h_dim1]; + t[ilast + ilast * t_dim1] = -t[ilast + ilast * t_dim1]; + } + if (ilz) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1]; +/* L100: */ + } + } + } + alphar[ilast] = h__[ilast + ilast * h_dim1]; + alphai[ilast] = 0.; + beta[ilast] = t[ilast + ilast * t_dim1]; + +/* Go to next block -- exit if finished. */ + + --ilast; + if (ilast < *ilo) { + goto L380; + } + +/* Reset counters */ + + iiter = 0; + eshift = 0.; + if (! ilschr) { + ilastm = ilast; + if (ifrstm > ilast) { + ifrstm = *ilo; + } + } + goto L350; + +/* QZ step */ + +/* This iteration only involves rows/columns IFIRST:ILAST. We */ +/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */ + +L110: + ++iiter; + if (! ilschr) { + ifrstm = ifirst; + } + +/* Compute single shifts. */ + +/* At this point, IFIRST < ILAST, and the diagonal elements of */ +/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */ +/* magnitude) */ + + if (iiter / 10 * 10 == iiter) { + +/* Exceptional shift. Chosen for no particularly good reason. */ +/* (Single shift only.) */ + + if ((double) maxit * safmin * (d__1 = h__[ilast - 1 + ilast * + h_dim1], abs(d__1)) < (d__2 = t[ilast - 1 + (ilast - 1) * + t_dim1], abs(d__2))) { + eshift += h__[ilast - 1 + ilast * h_dim1] / t[ilast - 1 + ( + ilast - 1) * t_dim1]; + } else { + eshift += 1. / (safmin * (double) maxit); + } + s1 = 1.; + wr = eshift; + + } else { + +/* Shifts based on the generalized eigenvalues of the */ +/* bottom-right 2x2 block of A and B. The first eigenvalue */ +/* returned by DLAG2 is the Wilkinson shift (AEP p.512), */ + + d__1 = safmin * 100.; + dlag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1 + + (ilast - 1) * t_dim1], ldt, &d__1, &s1, &s2, &wr, &wr2, + &wi); + +/* Computing MAX */ +/* Computing MAX */ + d__3 = 1., d__4 = abs(wr), d__3 = std::max(d__3,d__4), d__4 = abs(wi); + d__1 = s1, d__2 = safmin * std::max(d__3,d__4); + temp = std::max(d__1,d__2); + if (wi != 0.) { + goto L200; + } + } + +/* Fiddle with shift to avoid overflow */ + + temp = std::min(ascale,1.) * (safmax * .5); + if (s1 > temp) { + scale = temp / s1; + } else { + scale = 1.; + } + + temp = std::min(bscale,1.) * (safmax * .5); + if (abs(wr) > temp) { +/* Computing MIN */ + d__1 = scale, d__2 = temp / abs(wr); + scale = std::min(d__1,d__2); + } + s1 = scale * s1; + wr = scale * wr; + +/* Now check for two consecutive small subdiagonals. */ + + i__2 = ifirst + 1; + for (j = ilast - 1; j >= i__2; --j) { + istart = j; + temp = (d__1 = s1 * h__[j + (j - 1) * h_dim1], abs(d__1)); + temp2 = (d__1 = s1 * h__[j + j * h_dim1] - wr * t[j + j * t_dim1], + abs(d__1)); + tempr = std::max(temp,temp2); + if (tempr < 1. && tempr != 0.) { + temp /= tempr; + temp2 /= tempr; + } + if ((d__1 = ascale * h__[j + 1 + j * h_dim1] * temp, abs(d__1)) <= + ascale * atol * temp2) { + goto L130; + } +/* L120: */ + } + + istart = ifirst; +L130: + +/* Do an implicit single-shift QZ sweep. */ + +/* Initial Q */ + + temp = s1 * h__[istart + istart * h_dim1] - wr * t[istart + istart * + t_dim1]; + temp2 = s1 * h__[istart + 1 + istart * h_dim1]; + dlartg_(&temp, &temp2, &c__, &s, &tempr); + +/* Sweep */ + + i__2 = ilast - 1; + for (j = istart; j <= i__2; ++j) { + if (j > istart) { + temp = h__[j + (j - 1) * h_dim1]; + dlartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[ + j + (j - 1) * h_dim1]); + h__[j + 1 + (j - 1) * h_dim1] = 0.; + } + + i__3 = ilastm; + for (jc = j; jc <= i__3; ++jc) { + temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc * + h_dim1]; + h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ * + h__[j + 1 + jc * h_dim1]; + h__[j + jc * h_dim1] = temp; + temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1]; + t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j + + 1 + jc * t_dim1]; + t[j + jc * t_dim1] = temp2; +/* L140: */ + } + if (ilq) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) * + q_dim1]; + q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ * + q[jr + (j + 1) * q_dim1]; + q[jr + j * q_dim1] = temp; +/* L150: */ + } + } + + temp = t[j + 1 + (j + 1) * t_dim1]; + dlartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j + + 1) * t_dim1]); + t[j + 1 + j * t_dim1] = 0.; + +/* Computing MIN */ + i__4 = j + 2; + i__3 = std::min(i__4,ilast); + for (jr = ifrstm; jr <= i__3; ++jr) { + temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j * + h_dim1]; + h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ * + h__[jr + j * h_dim1]; + h__[jr + (j + 1) * h_dim1] = temp; +/* L160: */ + } + i__3 = j; + for (jr = ifrstm; jr <= i__3; ++jr) { + temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1] + ; + t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[ + jr + j * t_dim1]; + t[jr + (j + 1) * t_dim1] = temp; +/* L170: */ + } + if (ilz) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j * + z_dim1]; + z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] + + c__ * z__[jr + j * z_dim1]; + z__[jr + (j + 1) * z_dim1] = temp; +/* L180: */ + } + } +/* L190: */ + } + + goto L350; + +/* Use Francis double-shift */ + +/* Note: the Francis double-shift should work with real shifts, */ +/* but only if the block is at least 3x3. */ +/* This code may break if this point is reached with */ +/* a 2x2 block with real eigenvalues. */ + +L200: + if (ifirst + 1 == ilast) { + +/* Special case -- 2x2 block with complex eigenvectors */ + +/* Step 1: Standardize, that is, rotate so that */ + +/* ( B11 0 ) */ +/* B = ( ) with B11 non-negative. */ +/* ( 0 B22 ) */ + + dlasv2_(&t[ilast - 1 + (ilast - 1) * t_dim1], &t[ilast - 1 + + ilast * t_dim1], &t[ilast + ilast * t_dim1], &b22, &b11, & + sr, &cr, &sl, &cl); + + if (b11 < 0.) { + cr = -cr; + sr = -sr; + b11 = -b11; + b22 = -b22; + } + + i__2 = ilastm + 1 - ifirst; + drot_(&i__2, &h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &h__[ + ilast + (ilast - 1) * h_dim1], ldh, &cl, &sl); + i__2 = ilast + 1 - ifrstm; + drot_(&i__2, &h__[ifrstm + (ilast - 1) * h_dim1], &c__1, &h__[ + ifrstm + ilast * h_dim1], &c__1, &cr, &sr); + + if (ilast < ilastm) { + i__2 = ilastm - ilast; + drot_(&i__2, &t[ilast - 1 + (ilast + 1) * t_dim1], ldt, &t[ + ilast + (ilast + 1) * t_dim1], ldh, &cl, &sl); + } + if (ifrstm < ilast - 1) { + i__2 = ifirst - ifrstm; + drot_(&i__2, &t[ifrstm + (ilast - 1) * t_dim1], &c__1, &t[ + ifrstm + ilast * t_dim1], &c__1, &cr, &sr); + } + + if (ilq) { + drot_(n, &q[(ilast - 1) * q_dim1 + 1], &c__1, &q[ilast * + q_dim1 + 1], &c__1, &cl, &sl); + } + if (ilz) { + drot_(n, &z__[(ilast - 1) * z_dim1 + 1], &c__1, &z__[ilast * + z_dim1 + 1], &c__1, &cr, &sr); + } + + t[ilast - 1 + (ilast - 1) * t_dim1] = b11; + t[ilast - 1 + ilast * t_dim1] = 0.; + t[ilast + (ilast - 1) * t_dim1] = 0.; + t[ilast + ilast * t_dim1] = b22; + +/* If B22 is negative, negate column ILAST */ + + if (b22 < 0.) { + i__2 = ilast; + for (j = ifrstm; j <= i__2; ++j) { + h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1]; + t[j + ilast * t_dim1] = -t[j + ilast * t_dim1]; +/* L210: */ + } + + if (ilz) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1]; +/* L220: */ + } + } + } + +/* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.) */ + +/* Recompute shift */ + + d__1 = safmin * 100.; + dlag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1 + + (ilast - 1) * t_dim1], ldt, &d__1, &s1, &temp, &wr, & + temp2, &wi); + +/* If standardization has perturbed the shift onto real line, */ +/* do another (real single-shift) QR step. */ + + if (wi == 0.) { + goto L350; + } + s1inv = 1. / s1; + +/* Do EISPACK (QZVAL) computation of alpha and beta */ + + a11 = h__[ilast - 1 + (ilast - 1) * h_dim1]; + a21 = h__[ilast + (ilast - 1) * h_dim1]; + a12 = h__[ilast - 1 + ilast * h_dim1]; + a22 = h__[ilast + ilast * h_dim1]; + +/* Compute complex Givens rotation on right */ +/* (Assume some element of C = (sA - wB) > unfl ) */ +/* __ */ +/* (sA - wB) ( CZ -SZ ) */ +/* ( SZ CZ ) */ + + c11r = s1 * a11 - wr * b11; + c11i = -wi * b11; + c12 = s1 * a12; + c21 = s1 * a21; + c22r = s1 * a22 - wr * b22; + c22i = -wi * b22; + + if (abs(c11r) + abs(c11i) + abs(c12) > abs(c21) + abs(c22r) + abs( + c22i)) { + t1 = dlapy3_(&c12, &c11r, &c11i); + cz = c12 / t1; + szr = -c11r / t1; + szi = -c11i / t1; + } else { + cz = dlapy2_(&c22r, &c22i); + if (cz <= safmin) { + cz = 0.; + szr = 1.; + szi = 0.; + } else { + tempr = c22r / cz; + tempi = c22i / cz; + t1 = dlapy2_(&cz, &c21); + cz /= t1; + szr = -c21 * tempr / t1; + szi = c21 * tempi / t1; + } + } + +/* Compute Givens rotation on left */ + +/* ( CQ SQ ) */ +/* ( __ ) A or B */ +/* ( -SQ CQ ) */ + + an = abs(a11) + abs(a12) + abs(a21) + abs(a22); + bn = abs(b11) + abs(b22); + wabs = abs(wr) + abs(wi); + if (s1 * an > wabs * bn) { + cq = cz * b11; + sqr = szr * b22; + sqi = -szi * b22; + } else { + a1r = cz * a11 + szr * a12; + a1i = szi * a12; + a2r = cz * a21 + szr * a22; + a2i = szi * a22; + cq = dlapy2_(&a1r, &a1i); + if (cq <= safmin) { + cq = 0.; + sqr = 1.; + sqi = 0.; + } else { + tempr = a1r / cq; + tempi = a1i / cq; + sqr = tempr * a2r + tempi * a2i; + sqi = tempi * a2r - tempr * a2i; + } + } + t1 = dlapy3_(&cq, &sqr, &sqi); + cq /= t1; + sqr /= t1; + sqi /= t1; + +/* Compute diagonal elements of QBZ */ + + tempr = sqr * szr - sqi * szi; + tempi = sqr * szi + sqi * szr; + b1r = cq * cz * b11 + tempr * b22; + b1i = tempi * b22; + b1a = dlapy2_(&b1r, &b1i); + b2r = cq * cz * b22 + tempr * b11; + b2i = -tempi * b11; + b2a = dlapy2_(&b2r, &b2i); + +/* Normalize so beta > 0, and Im( alpha1 ) > 0 */ + + beta[ilast - 1] = b1a; + beta[ilast] = b2a; + alphar[ilast - 1] = wr * b1a * s1inv; + alphai[ilast - 1] = wi * b1a * s1inv; + alphar[ilast] = wr * b2a * s1inv; + alphai[ilast] = -(wi * b2a) * s1inv; + +/* Step 3: Go to next block -- exit if finished. */ + + ilast = ifirst - 1; + if (ilast < *ilo) { + goto L380; + } + +/* Reset counters */ + + iiter = 0; + eshift = 0.; + if (! ilschr) { + ilastm = ilast; + if (ifrstm > ilast) { + ifrstm = *ilo; + } + } + goto L350; + } else { + +/* Usual case: 3x3 or larger block, using Francis implicit */ +/* double-shift */ + +/* 2 */ +/* Eigenvalue equation is w - c w + d = 0, */ + +/* -1 2 -1 */ +/* so compute 1st column of (A B ) - c A B + d */ +/* using the formula in QZIT (from EISPACK) */ + +/* We assume that the block is at least 3x3 */ + + ad11 = ascale * h__[ilast - 1 + (ilast - 1) * h_dim1] / (bscale * + t[ilast - 1 + (ilast - 1) * t_dim1]); + ad21 = ascale * h__[ilast + (ilast - 1) * h_dim1] / (bscale * t[ + ilast - 1 + (ilast - 1) * t_dim1]); + ad12 = ascale * h__[ilast - 1 + ilast * h_dim1] / (bscale * t[ + ilast + ilast * t_dim1]); + ad22 = ascale * h__[ilast + ilast * h_dim1] / (bscale * t[ilast + + ilast * t_dim1]); + u12 = t[ilast - 1 + ilast * t_dim1] / t[ilast + ilast * t_dim1]; + ad11l = ascale * h__[ifirst + ifirst * h_dim1] / (bscale * t[ + ifirst + ifirst * t_dim1]); + ad21l = ascale * h__[ifirst + 1 + ifirst * h_dim1] / (bscale * t[ + ifirst + ifirst * t_dim1]); + ad12l = ascale * h__[ifirst + (ifirst + 1) * h_dim1] / (bscale * + t[ifirst + 1 + (ifirst + 1) * t_dim1]); + ad22l = ascale * h__[ifirst + 1 + (ifirst + 1) * h_dim1] / ( + bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]); + ad32l = ascale * h__[ifirst + 2 + (ifirst + 1) * h_dim1] / ( + bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]); + u12l = t[ifirst + (ifirst + 1) * t_dim1] / t[ifirst + 1 + (ifirst + + 1) * t_dim1]; + + v[0] = (ad11 - ad11l) * (ad22 - ad11l) - ad12 * ad21 + ad21 * u12 + * ad11l + (ad12l - ad11l * u12l) * ad21l; + v[1] = (ad22l - ad11l - ad21l * u12l - (ad11 - ad11l) - (ad22 - + ad11l) + ad21 * u12) * ad21l; + v[2] = ad32l * ad21l; + + istart = ifirst; + + dlarfg_(&c__3, v, &v[1], &c__1, &tau); + v[0] = 1.; + +/* Sweep */ + + i__2 = ilast - 2; + for (j = istart; j <= i__2; ++j) { + +/* All but last elements: use 3x3 Householder transforms. */ + +/* Zero (j-1)st column of A */ + + if (j > istart) { + v[0] = h__[j + (j - 1) * h_dim1]; + v[1] = h__[j + 1 + (j - 1) * h_dim1]; + v[2] = h__[j + 2 + (j - 1) * h_dim1]; + + dlarfg_(&c__3, &h__[j + (j - 1) * h_dim1], &v[1], &c__1, & + tau); + v[0] = 1.; + h__[j + 1 + (j - 1) * h_dim1] = 0.; + h__[j + 2 + (j - 1) * h_dim1] = 0.; + } + + i__3 = ilastm; + for (jc = j; jc <= i__3; ++jc) { + temp = tau * (h__[j + jc * h_dim1] + v[1] * h__[j + 1 + + jc * h_dim1] + v[2] * h__[j + 2 + jc * h_dim1]); + h__[j + jc * h_dim1] -= temp; + h__[j + 1 + jc * h_dim1] -= temp * v[1]; + h__[j + 2 + jc * h_dim1] -= temp * v[2]; + temp2 = tau * (t[j + jc * t_dim1] + v[1] * t[j + 1 + jc * + t_dim1] + v[2] * t[j + 2 + jc * t_dim1]); + t[j + jc * t_dim1] -= temp2; + t[j + 1 + jc * t_dim1] -= temp2 * v[1]; + t[j + 2 + jc * t_dim1] -= temp2 * v[2]; +/* L230: */ + } + if (ilq) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + temp = tau * (q[jr + j * q_dim1] + v[1] * q[jr + (j + + 1) * q_dim1] + v[2] * q[jr + (j + 2) * q_dim1] + ); + q[jr + j * q_dim1] -= temp; + q[jr + (j + 1) * q_dim1] -= temp * v[1]; + q[jr + (j + 2) * q_dim1] -= temp * v[2]; +/* L240: */ + } + } + +/* Zero j-th column of B (see DLAGBC for details) */ + +/* Swap rows to pivot */ + + ilpivt = false; +/* Computing MAX */ + d__3 = (d__1 = t[j + 1 + (j + 1) * t_dim1], abs(d__1)), d__4 = + (d__2 = t[j + 1 + (j + 2) * t_dim1], abs(d__2)); + temp = std::max(d__3,d__4); +/* Computing MAX */ + d__3 = (d__1 = t[j + 2 + (j + 1) * t_dim1], abs(d__1)), d__4 = + (d__2 = t[j + 2 + (j + 2) * t_dim1], abs(d__2)); + temp2 = std::max(d__3,d__4); + if (std::max(temp,temp2) < safmin) { + scale = 0.; + u1 = 1.; + u2 = 0.; + goto L250; + } else if (temp >= temp2) { + w11 = t[j + 1 + (j + 1) * t_dim1]; + w21 = t[j + 2 + (j + 1) * t_dim1]; + w12 = t[j + 1 + (j + 2) * t_dim1]; + w22 = t[j + 2 + (j + 2) * t_dim1]; + u1 = t[j + 1 + j * t_dim1]; + u2 = t[j + 2 + j * t_dim1]; + } else { + w21 = t[j + 1 + (j + 1) * t_dim1]; + w11 = t[j + 2 + (j + 1) * t_dim1]; + w22 = t[j + 1 + (j + 2) * t_dim1]; + w12 = t[j + 2 + (j + 2) * t_dim1]; + u2 = t[j + 1 + j * t_dim1]; + u1 = t[j + 2 + j * t_dim1]; + } + +/* Swap columns if nec. */ + + if (abs(w12) > abs(w11)) { + ilpivt = true; + temp = w12; + temp2 = w22; + w12 = w11; + w22 = w21; + w11 = temp; + w21 = temp2; + } + +/* LU-factor */ + + temp = w21 / w11; + u2 -= temp * u1; + w22 -= temp * w12; + w21 = 0.; + +/* Compute SCALE */ + + scale = 1.; + if (abs(w22) < safmin) { + scale = 0.; + u2 = 1.; + u1 = -w12 / w11; + goto L250; + } + if (abs(w22) < abs(u2)) { + scale = (d__1 = w22 / u2, abs(d__1)); + } + if (abs(w11) < abs(u1)) { +/* Computing MIN */ + d__2 = scale, d__3 = (d__1 = w11 / u1, abs(d__1)); + scale = std::min(d__2,d__3); + } + +/* Solve */ + + u2 = scale * u2 / w22; + u1 = (scale * u1 - w12 * u2) / w11; + +L250: + if (ilpivt) { + temp = u2; + u2 = u1; + u1 = temp; + } + +/* Compute Householder Vector */ + +/* Computing 2nd power */ + d__1 = scale; +/* Computing 2nd power */ + d__2 = u1; +/* Computing 2nd power */ + d__3 = u2; + t1 = sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); + tau = scale / t1 + 1.; + vs = -1. / (scale + t1); + v[0] = 1.; + v[1] = vs * u1; + v[2] = vs * u2; + +/* Apply transformations from the right. */ + +/* Computing MIN */ + i__4 = j + 3; + i__3 = std::min(i__4,ilast); + for (jr = ifrstm; jr <= i__3; ++jr) { + temp = tau * (h__[jr + j * h_dim1] + v[1] * h__[jr + (j + + 1) * h_dim1] + v[2] * h__[jr + (j + 2) * h_dim1]); + h__[jr + j * h_dim1] -= temp; + h__[jr + (j + 1) * h_dim1] -= temp * v[1]; + h__[jr + (j + 2) * h_dim1] -= temp * v[2]; +/* L260: */ + } + i__3 = j + 2; + for (jr = ifrstm; jr <= i__3; ++jr) { + temp = tau * (t[jr + j * t_dim1] + v[1] * t[jr + (j + 1) * + t_dim1] + v[2] * t[jr + (j + 2) * t_dim1]); + t[jr + j * t_dim1] -= temp; + t[jr + (j + 1) * t_dim1] -= temp * v[1]; + t[jr + (j + 2) * t_dim1] -= temp * v[2]; +/* L270: */ + } + if (ilz) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + temp = tau * (z__[jr + j * z_dim1] + v[1] * z__[jr + ( + j + 1) * z_dim1] + v[2] * z__[jr + (j + 2) * + z_dim1]); + z__[jr + j * z_dim1] -= temp; + z__[jr + (j + 1) * z_dim1] -= temp * v[1]; + z__[jr + (j + 2) * z_dim1] -= temp * v[2]; +/* L280: */ + } + } + t[j + 1 + j * t_dim1] = 0.; + t[j + 2 + j * t_dim1] = 0.; +/* L290: */ + } + +/* Last elements: Use Givens rotations */ + +/* Rotations from the left */ + + j = ilast - 1; + temp = h__[j + (j - 1) * h_dim1]; + dlartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[j + + (j - 1) * h_dim1]); + h__[j + 1 + (j - 1) * h_dim1] = 0.; + + i__2 = ilastm; + for (jc = j; jc <= i__2; ++jc) { + temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc * + h_dim1]; + h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ * + h__[j + 1 + jc * h_dim1]; + h__[j + jc * h_dim1] = temp; + temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1]; + t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j + + 1 + jc * t_dim1]; + t[j + jc * t_dim1] = temp2; +/* L300: */ + } + if (ilq) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) * + q_dim1]; + q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ * + q[jr + (j + 1) * q_dim1]; + q[jr + j * q_dim1] = temp; +/* L310: */ + } + } + +/* Rotations from the right. */ + + temp = t[j + 1 + (j + 1) * t_dim1]; + dlartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j + + 1) * t_dim1]); + t[j + 1 + j * t_dim1] = 0.; + + i__2 = ilast; + for (jr = ifrstm; jr <= i__2; ++jr) { + temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j * + h_dim1]; + h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ * + h__[jr + j * h_dim1]; + h__[jr + (j + 1) * h_dim1] = temp; +/* L320: */ + } + i__2 = ilast - 1; + for (jr = ifrstm; jr <= i__2; ++jr) { + temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1] + ; + t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[ + jr + j * t_dim1]; + t[jr + (j + 1) * t_dim1] = temp; +/* L330: */ + } + if (ilz) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j * + z_dim1]; + z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] + + c__ * z__[jr + j * z_dim1]; + z__[jr + (j + 1) * z_dim1] = temp; +/* L340: */ + } + } + +/* End of Double-Shift code */ + + } + + goto L350; + +/* End of iteration loop */ + +L350: +/* L360: */ + ; + } + +/* Drop-through = non-convergence */ + + *info = ilast; + goto L420; + +/* Successful completion of all QZ steps */ + +L380: + +/* Set Eigenvalues 1:ILO-1 */ + + i__1 = *ilo - 1; + for (j = 1; j <= i__1; ++j) { + if (t[j + j * t_dim1] < 0.) { + if (ilschr) { + i__2 = j; + for (jr = 1; jr <= i__2; ++jr) { + h__[jr + j * h_dim1] = -h__[jr + j * h_dim1]; + t[jr + j * t_dim1] = -t[jr + j * t_dim1]; +/* L390: */ + } + } else { + h__[j + j * h_dim1] = -h__[j + j * h_dim1]; + t[j + j * t_dim1] = -t[j + j * t_dim1]; + } + if (ilz) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + z__[jr + j * z_dim1] = -z__[jr + j * z_dim1]; +/* L400: */ + } + } + } + alphar[j] = h__[j + j * h_dim1]; + alphai[j] = 0.; + beta[j] = t[j + j * t_dim1]; +/* L410: */ + } + +/* Normal Termination */ + + *info = 0; + +/* Exit (other than argument error) -- return optimal workspace size */ + +L420: + work[1] = (double) (*n); + return 0; + +/* End of DHGEQZ */ + +} /* dhgeqz_ */ + +/* Subroutine */ int dhsein_(const char *side, const char *eigsrc, const char *initv, bool * + select, integer *n, double *h__, integer *ldh, double *wr, + double *wi, double *vl, integer *ldvl, double *vr, + integer *ldvr, integer *mm, integer *m, double *work, integer * + ifaill, integer *ifailr, integer *info) +{ + /* Table of constant values */ + static bool c_false = false; + static bool c_true = true; + + /* System generated locals */ + integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, k, kl, kr, kln, ksi; + double wki; + integer ksr; + double ulp, wkr, eps3; + bool pair; + double unfl; + integer iinfo; + bool leftv, bothv; + double hnorm; + double bignum; + bool noinit; + integer ldwork; + bool rightv, fromqr; + double smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DHSEIN uses inverse iteration to find specified right and/or left */ +/* eigenvectors of a real upper Hessenberg matrix H. */ + +/* The right eigenvector x and the left eigenvector y of the matrix H */ +/* corresponding to an eigenvalue w are defined by: */ + +/* H * x = w * x, y**h * H = w * y**h */ + +/* where y**h denotes the conjugate transpose of the vector y. */ + +/* Arguments */ +/* ========= */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'R': compute right eigenvectors only; */ +/* = 'L': compute left eigenvectors only; */ +/* = 'B': compute both right and left eigenvectors. */ + +/* EIGSRC (input) CHARACTER*1 */ +/* Specifies the source of eigenvalues supplied in (WR,WI): */ +/* = 'Q': the eigenvalues were found using DHSEQR; thus, if */ +/* H has zero subdiagonal elements, and so is */ +/* block-triangular, then the j-th eigenvalue can be */ +/* assumed to be an eigenvalue of the block containing */ +/* the j-th row/column. This property allows DHSEIN to */ +/* perform inverse iteration on just one diagonal block. */ +/* = 'N': no assumptions are made on the correspondence */ +/* between eigenvalues and diagonal blocks. In this */ +/* case, DHSEIN must always perform inverse iteration */ +/* using the whole matrix H. */ + +/* INITV (input) CHARACTER*1 */ +/* = 'N': no initial vectors are supplied; */ +/* = 'U': user-supplied initial vectors are stored in the arrays */ +/* VL and/or VR. */ + +/* SELECT (input/output) LOGICAL array, dimension (N) */ +/* Specifies the eigenvectors to be computed. To select the */ +/* real eigenvector corresponding to a real eigenvalue WR(j), */ +/* SELECT(j) must be set to .TRUE.. To select the complex */ +/* eigenvector corresponding to a complex eigenvalue */ +/* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)), */ +/* either SELECT(j) or SELECT(j+1) or both must be set to */ +/* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is */ +/* .FALSE.. */ + +/* N (input) INTEGER */ +/* The order of the matrix H. N >= 0. */ + +/* H (input) DOUBLE PRECISION array, dimension (LDH,N) */ +/* The upper Hessenberg matrix H. */ + +/* LDH (input) INTEGER */ +/* The leading dimension of the array H. LDH >= max(1,N). */ + +/* WR (input/output) DOUBLE PRECISION array, dimension (N) */ +/* WI (input) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the real and imaginary parts of the eigenvalues of */ +/* H; a complex conjugate pair of eigenvalues must be stored in */ +/* consecutive elements of WR and WI. */ +/* On exit, WR may have been altered since close eigenvalues */ +/* are perturbed slightly in searching for independent */ +/* eigenvectors. */ + +/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */ +/* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must */ +/* contain starting vectors for the inverse iteration for the */ +/* left eigenvectors; the starting vector for each eigenvector */ +/* must be in the same column(s) in which the eigenvector will */ +/* be stored. */ +/* On exit, if SIDE = 'L' or 'B', the left eigenvectors */ +/* specified by SELECT will be stored consecutively in the */ +/* columns of VL, in the same order as their eigenvalues. A */ +/* complex eigenvector corresponding to a complex eigenvalue is */ +/* stored in two consecutive columns, the first holding the real */ +/* part and the second the imaginary part. */ +/* If SIDE = 'R', VL is not referenced. */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the array VL. */ +/* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */ + +/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */ +/* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must */ +/* contain starting vectors for the inverse iteration for the */ +/* right eigenvectors; the starting vector for each eigenvector */ +/* must be in the same column(s) in which the eigenvector will */ +/* be stored. */ +/* On exit, if SIDE = 'R' or 'B', the right eigenvectors */ +/* specified by SELECT will be stored consecutively in the */ +/* columns of VR, in the same order as their eigenvalues. A */ +/* complex eigenvector corresponding to a complex eigenvalue is */ +/* stored in two consecutive columns, the first holding the real */ +/* part and the second the imaginary part. */ +/* If SIDE = 'L', VR is not referenced. */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the array VR. */ +/* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */ + +/* MM (input) INTEGER */ +/* The number of columns in the arrays VL and/or VR. MM >= M. */ + +/* M (output) INTEGER */ +/* The number of columns in the arrays VL and/or VR required to */ +/* store the eigenvectors; each selected real eigenvector */ +/* occupies one column and each selected complex eigenvector */ +/* occupies two columns. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N) */ + +/* IFAILL (output) INTEGER array, dimension (MM) */ +/* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left */ +/* eigenvector in the i-th column of VL (corresponding to the */ +/* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the */ +/* eigenvector converged satisfactorily. If the i-th and (i+1)th */ +/* columns of VL hold a complex eigenvector, then IFAILL(i) and */ +/* IFAILL(i+1) are set to the same value. */ +/* If SIDE = 'R', IFAILL is not referenced. */ + +/* IFAILR (output) INTEGER array, dimension (MM) */ +/* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right */ +/* eigenvector in the i-th column of VR (corresponding to the */ +/* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the */ +/* eigenvector converged satisfactorily. If the i-th and (i+1)th */ +/* columns of VR hold a complex eigenvector, then IFAILR(i) and */ +/* IFAILR(i+1) are set to the same value. */ +/* If SIDE = 'L', IFAILR is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, i is the number of eigenvectors which */ +/* failed to converge; see IFAILL and IFAILR for further */ +/* details. */ + +/* Further Details */ +/* =============== */ + +/* Each eigenvector is normalized so that the element of largest */ +/* magnitude has magnitude 1; here the magnitude of a complex number */ +/* (x,y) is taken to be |x|+|y|. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test the input parameters. */ + + /* Parameter adjustments */ + --select; + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --work; + --ifaill; + --ifailr; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + fromqr = lsame_(eigsrc, "Q"); + + noinit = lsame_(initv, "N"); + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors, and standardize the array SELECT. */ + + *m = 0; + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = false; + select[k] = false; + } else { + if (wi[k] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = true; + if (select[k] || select[k + 1]) { + select[k] = true; + *m += 2; + } + } + } +/* L10: */ + } + + *info = 0; + if (! rightv && ! leftv) { + *info = -1; + } else if (! fromqr && ! lsame_(eigsrc, "N")) { + *info = -2; + } else if (! noinit && ! lsame_(initv, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -5; + } else if (*ldh < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -11; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -13; + } else if (*mm < *m) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DHSEIN", &i__1); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Set machine-dependent constants. */ + + unfl = dlamch_("Safe minimum"); + ulp = dlamch_("Precision"); + smlnum = unfl * (*n / ulp); + bignum = (1. - ulp) / smlnum; + + ldwork = *n + 1; + + kl = 1; + kln = 0; + if (fromqr) { + kr = 0; + } else { + kr = *n; + } + ksr = 1; + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (select[k]) { + +/* Compute eigenvector(s) corresponding to W(K). */ + + if (fromqr) { + +/* If affiliation of eigenvalues is known, check whether */ +/* the matrix splits. */ + +/* Determine KL and KR such that 1 <= KL <= K <= KR <= N */ +/* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or */ +/* KR = N). */ + +/* Then inverse iteration can be performed with the */ +/* submatrix H(KL:N,KL:N) for a left eigenvector, and with */ +/* the submatrix H(1:KR,1:KR) for a right eigenvector. */ + + i__2 = kl + 1; + for (i__ = k; i__ >= i__2; --i__) { + if (h__[i__ + (i__ - 1) * h_dim1] == 0.) { + goto L30; + } +/* L20: */ + } +L30: + kl = i__; + if (k > kr) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + if (h__[i__ + 1 + i__ * h_dim1] == 0.) { + goto L50; + } +/* L40: */ + } +L50: + kr = i__; + } + } + + if (kl != kln) { + kln = kl; + +/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it */ +/* has not ben computed before. */ + + i__2 = kr - kl + 1; + hnorm = dlanhs_("I", &i__2, &h__[kl + kl * h_dim1], ldh, & + work[1]); + if (hnorm > 0.) { + eps3 = hnorm * ulp; + } else { + eps3 = smlnum; + } + } + +/* Perturb eigenvalue if it is close to any previous */ +/* selected eigenvalues affiliated to the submatrix */ +/* H(KL:KR,KL:KR). Close roots are modified by EPS3. */ + + wkr = wr[k]; + wki = wi[k]; +L60: + i__2 = kl; + for (i__ = k - 1; i__ >= i__2; --i__) { + if (select[i__] && (d__1 = wr[i__] - wkr, abs(d__1)) + (d__2 = + wi[i__] - wki, abs(d__2)) < eps3) { + wkr += eps3; + goto L60; + } +/* L70: */ + } + wr[k] = wkr; + + pair = wki != 0.; + if (pair) { + ksi = ksr + 1; + } else { + ksi = ksr; + } + if (leftv) { + +/* Compute left eigenvector. */ + + i__2 = *n - kl + 1; + dlaein_(&c_false, &noinit, &i__2, &h__[kl + kl * h_dim1], ldh, + &wkr, &wki, &vl[kl + ksr * vl_dim1], &vl[kl + ksi * + vl_dim1], &work[1], &ldwork, &work[*n * *n + *n + 1], + &eps3, &smlnum, &bignum, &iinfo); + if (iinfo > 0) { + if (pair) { + *info += 2; + } else { + ++(*info); + } + ifaill[ksr] = k; + ifaill[ksi] = k; + } else { + ifaill[ksr] = 0; + ifaill[ksi] = 0; + } + i__2 = kl - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + vl[i__ + ksr * vl_dim1] = 0.; +/* L80: */ + } + if (pair) { + i__2 = kl - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + vl[i__ + ksi * vl_dim1] = 0.; +/* L90: */ + } + } + } + if (rightv) { + +/* Compute right eigenvector. */ + + dlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wkr, & + wki, &vr[ksr * vr_dim1 + 1], &vr[ksi * vr_dim1 + 1], & + work[1], &ldwork, &work[*n * *n + *n + 1], &eps3, & + smlnum, &bignum, &iinfo); + if (iinfo > 0) { + if (pair) { + *info += 2; + } else { + ++(*info); + } + ifailr[ksr] = k; + ifailr[ksi] = k; + } else { + ifailr[ksr] = 0; + ifailr[ksi] = 0; + } + i__2 = *n; + for (i__ = kr + 1; i__ <= i__2; ++i__) { + vr[i__ + ksr * vr_dim1] = 0.; +/* L100: */ + } + if (pair) { + i__2 = *n; + for (i__ = kr + 1; i__ <= i__2; ++i__) { + vr[i__ + ksi * vr_dim1] = 0.; +/* L110: */ + } + } + } + + if (pair) { + ksr += 2; + } else { + ++ksr; + } + } +/* L120: */ + } + + return 0; + +/* End of DHSEIN */ + +} /* dhsein_ */ + +/* Subroutine */ int dhseqr_(const char *job, const char *compz, integer *n, integer *ilo, integer *ihi, double *h__, + integer *ldh, double *wr, double *wi, double *z__, integer *ldz, double *work, + integer *lwork, integer *info) +{ + /* Table of constant values */ + static double c_b11 = 0.; + static double c_b12 = 1.; + static integer c__12 = 12; + static integer c__2 = 2; + static integer c__49 = 49; + + /* System generated locals */ + char *a__1[2]; + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3; + double d__1; + char ch__1[3]; + + /* Local variables */ + integer i__; + double hl[2401] /* was [49][49] */; + integer kbot, nmin; + bool initz; + double workl[49]; + bool wantt, wantz; + bool lquery; + + +/* -- LAPACK driver routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ +/* Purpose */ +/* ======= */ + +/* DHSEQR computes the eigenvalues of a Hessenberg matrix H */ +/* and, optionally, the matrices T and Z from the Schur decomposition */ +/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ +/* Schur form), and Z is the orthogonal matrix of Schur vectors. */ + +/* Optionally Z may be postmultiplied into an input orthogonal */ +/* matrix Q so that this routine can give the Schur factorization */ +/* of a matrix A which has been reduced to the Hessenberg form H */ +/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* = 'E': compute eigenvalues only; */ +/* = 'S': compute eigenvalues and the Schur form T. */ + +/* COMPZ (input) CHARACTER*1 */ +/* = 'N': no Schur vectors are computed; */ +/* = 'I': Z is initialized to the unit matrix and the matrix Z */ +/* of Schur vectors of H is returned; */ +/* = 'V': Z must contain an orthogonal matrix Q on entry, and */ +/* the product Q*Z is returned. */ + +/* N (input) INTEGER */ +/* The order of the matrix H. N .GE. 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* It is assumed that H is already upper triangular in rows */ +/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ +/* set by a previous call to DGEBAL, and then passed to DGEHRD */ +/* when the matrix output by DGEBAL is reduced to Hessenberg */ +/* form. Otherwise ILO and IHI should be set to 1 and N */ +/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ +/* If N = 0, then ILO = 1 and IHI = 0. */ + +/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ +/* On entry, the upper Hessenberg matrix H. */ +/* On exit, if INFO = 0 and JOB = 'S', then H contains the */ +/* upper quasi-triangular matrix T from the Schur decomposition */ +/* (the Schur form); 2-by-2 diagonal blocks (corresponding to */ +/* complex conjugate pairs of eigenvalues) are returned in */ +/* standard form, with H(i,i) = H(i+1,i+1) and */ +/* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the */ +/* contents of H are unspecified on exit. (The output value of */ +/* H when INFO.GT.0 is given under the description of INFO */ +/* below.) */ + +/* Unlike earlier versions of DHSEQR, this subroutine may */ +/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */ +/* or j = IHI+1, IHI+2, ... N. */ + +/* LDH (input) INTEGER */ +/* The leading dimension of the array H. LDH .GE. max(1,N). */ + +/* WR (output) DOUBLE PRECISION array, dimension (N) */ +/* WI (output) DOUBLE PRECISION array, dimension (N) */ +/* The real and imaginary parts, respectively, of the computed */ +/* eigenvalues. If two eigenvalues are computed as a complex */ +/* conjugate pair, they are stored in consecutive elements of */ +/* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and */ +/* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in */ +/* the same order as on the diagonal of the Schur form returned */ +/* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */ +/* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ +/* WI(i+1) = -WI(i). */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* If COMPZ = 'N', Z is not referenced. */ +/* If COMPZ = 'I', on entry Z need not be set and on exit, */ +/* if INFO = 0, Z contains the orthogonal matrix Z of the Schur */ +/* vectors of H. If COMPZ = 'V', on entry Z must contain an */ +/* N-by-N matrix Q, which is assumed to be equal to the unit */ +/* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */ +/* if INFO = 0, Z contains Q*Z. */ +/* Normally Q is the orthogonal matrix generated by DORGHR */ +/* after the call to DGEHRD which formed the Hessenberg matrix */ +/* H. (The output value of Z when INFO.GT.0 is given under */ +/* the description of INFO below.) */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. if COMPZ = 'I' or */ +/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ +/* On exit, if INFO = 0, WORK(1) returns an estimate of */ +/* the optimal value for LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK .GE. max(1,N) */ +/* is sufficient and delivers very good and sometimes */ +/* optimal performance. However, LWORK as large as 11*N */ +/* may be required for optimal performance. A workspace */ +/* query is recommended to determine the optimal workspace */ +/* size. */ + +/* If LWORK = -1, then DHSEQR does a workspace query. */ +/* In this case, DHSEQR checks the input parameters and */ +/* estimates the optimal workspace size for the given */ +/* values of N, ILO and IHI. The estimate is returned */ +/* in WORK(1). No error message related to LWORK is */ +/* issued by XERBLA. Neither H nor Z are accessed. */ + + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* .LT. 0: if INFO = -i, the i-th argument had an illegal */ +/* value */ +/* .GT. 0: if INFO = i, DHSEQR failed to compute all of */ +/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ +/* and WI contain those eigenvalues which have been */ +/* successfully computed. (Failures are rare.) */ + +/* If INFO .GT. 0 and JOB = 'E', then on exit, the */ +/* remaining unconverged eigenvalues are the eigen- */ +/* values of the upper Hessenberg matrix rows and */ +/* columns ILO through INFO of the final, output */ +/* value of H. */ + +/* If INFO .GT. 0 and JOB = 'S', then on exit */ + +/* (*) (initial value of H)*U = U*(final value of H) */ + +/* where U is an orthogonal matrix. The final */ +/* value of H is upper Hessenberg and quasi-triangular */ +/* in rows and columns INFO+1 through IHI. */ + +/* If INFO .GT. 0 and COMPZ = 'V', then on exit */ + +/* (final value of Z) = (initial value of Z)*U */ + +/* where U is the orthogonal matrix in (*) (regard- */ +/* less of the value of JOB.) */ + +/* If INFO .GT. 0 and COMPZ = 'I', then on exit */ +/* (final value of Z) = U */ +/* where U is the orthogonal matrix in (*) (regard- */ +/* less of the value of JOB.) */ + +/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */ +/* accessed. */ + +/* ================================================================ */ +/* Default values supplied by */ +/* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */ +/* It is suggested that these defaults be adjusted in order */ +/* to attain best performance in each particular */ +/* computational environment. */ + +/* ISPEC=12: The DLAHQR vs DLAQR0 crossover point. */ +/* Default: 75. (Must be at least 11.) */ + +/* ISPEC=13: Recommended deflation window size. */ +/* This depends on ILO, IHI and NS. NS is the */ +/* number of simultaneous shifts returned */ +/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */ +/* The default for (IHI-ILO+1).LE.500 is NS. */ +/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */ + +/* ISPEC=14: Nibble crossover point. (See IPARMQ for */ +/* details.) Default: 14% of deflation window */ +/* size. */ + +/* ISPEC=15: Number of simultaneous shifts in a multishift */ +/* QR iteration. */ + +/* If IHI-ILO+1 is ... */ + +/* greater than ...but less ... the */ +/* or equal to ... than default is */ + +/* 1 30 NS = 2(+) */ +/* 30 60 NS = 4(+) */ +/* 60 150 NS = 10(+) */ +/* 150 590 NS = ** */ +/* 590 3000 NS = 64 */ +/* 3000 6000 NS = 128 */ +/* 6000 infinity NS = 256 */ + +/* (+) By default some or all matrices of this order */ +/* are passed to the implicit double shift routine */ +/* DLAHQR and this parameter is ignored. See */ +/* ISPEC=12 above and comments in IPARMQ for */ +/* details. */ + +/* (**) The asterisks (**) indicate an ad-hoc */ +/* function of N increasing from 10 to 64. */ + +/* ISPEC=16: Select structured matrix multiply. */ +/* If the number of simultaneous shifts (specified */ +/* by ISPEC=15) is less than 14, then the default */ +/* for ISPEC=16 is 0. Otherwise the default for */ +/* ISPEC=16 is 2. */ + +/* ================================================================ */ +/* Based on contributions by */ +/* Karen Braman and Ralph Byers, Department of Mathematics, */ +/* University of Kansas, USA */ + +/* ================================================================ */ +/* References: */ +/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* 929--947, 2002. */ + +/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* of Matrix Analysis, volume 23, pages 948--973, 2002. */ + +/* ================================================================ */ +/* .. Parameters .. */ + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . DLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== NL allocates some local workspace to help small matrices */ +/* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is */ +/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */ +/* . mended. (The default value of NMIN is 75.) Using NL = 49 */ +/* . allows up to six simultaneous shifts and a 16-by-16 */ +/* . deflation window. ==== */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* ==== Decode and check the input parameters. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantt = lsame_(job, "S"); + initz = lsame_(compz, "I"); + wantz = initz || lsame_(compz, "V"); + work[1] = (double)std::max(1_integer,*n); + lquery = *lwork == -1; + + *info = 0; + if (! lsame_(job, "E") && ! wantt) { + *info = -1; + } else if (! lsame_(compz, "N") && ! wantz) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1 || *ilo >std::max(1_integer,*n)) { + *info = -4; + } else if (*ihi *n) { + *info = -5; + } else if (*ldh (job); + i__2[1] = 1, a__1[1] = const_cast(compz); + s_cat(ch__1, a__1, i__2, &c__2, 2_integer); + ch__1 [2] = '\0'; + nmin = ilaenv_(&c__12, "DHSEQR", ch__1, n, ilo, ihi, lwork); + nmin =std::max(11_integer,nmin); + +/* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== */ + + if (*n > nmin) { + dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], + &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, + info); + } else { + +/* ==== Small matrix ==== */ + + dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], + &wi[1], ilo, ihi, &z__[z_offset], ldz, info); + + if (*info > 0) { + +/* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds */ +/* . when DLAHQR fails. ==== */ + + kbot = *info; + + if (*n >= 49) { + +/* ==== Larger matrices have enough subdiagonal scratch */ +/* . space to call DLAQR0 directly. ==== */ + + dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], + ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], + ldz, &work[1], lwork, info); + + } else { + +/* ==== Tiny matrices don't have enough subdiagonal */ +/* . scratch space to benefit from DLAQR0. Hence, */ +/* . tiny matrices must be copied into a larger */ +/* . array before calling DLAQR0. ==== */ + + dlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49); + hl[*n + 1 + *n * 49 - 50] = 0.; + i__1 = 49 - *n; + dlaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * + 49 - 49], &c__49); + dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, & + wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, + workl, &c__49, info); + if (wantt || *info != 0) { + dlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh); + } + } + } + } + +/* ==== Clear out the trash, if necessary. ==== */ + + if ((wantt || *info != 0) && *n > 2) { + i__1 = *n - 2; + i__3 = *n - 2; + dlaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh); + } + +/* ==== Ensure reported workspace size is backward-compatible with */ +/* . previous LAPACK versions. ==== */ + +/* Computing MAX */ + d__1 = (double)std::max(1_integer,*n); + work[1] =std::max(d__1,work[1]); + } + +/* ==== End of DHSEQR ==== */ + + return 0; +} /* dhseqr_ */ + +/* Subroutine */ bool disnan_(double *din) +{ + /* System generated locals */ + bool ret_val; + + /* Local variables */ + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DISNAN returns .TRUE. if its argument is NaN, and .FALSE. */ +/* otherwise. To be replaced by the Fortran 2003 intrinsic in the */ +/* future. */ + +/* Arguments */ +/* ========= */ + +/* DIN (input) DOUBLE PRECISION */ +/* Input to test for NaN. */ + +/* ===================================================================== */ + +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + ret_val = dlaisnan_(din, din); + return ret_val; +} /* disnan_ */ + +/* Subroutine */ int dopgtr_(const char *uplo, integer *n, double *ap, + double *tau, double *q, integer *ldq, double *work, + integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, ij; + integer iinfo; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DOPGTR generates a real orthogonal matrix Q which is defined as the */ +/* product of n-1 elementary reflectors H(i) of order n, as returned by */ +/* DSPTRD using packed storage: */ + +/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */ + +/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangular packed storage used in previous */ +/* call to DSPTRD; */ +/* = 'L': Lower triangular packed storage used in previous */ +/* call to DSPTRD. */ + +/* N (input) INTEGER */ +/* The order of the matrix Q. N >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The vectors which define the elementary reflectors, as */ +/* returned by DSPTRD. */ + +/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DSPTRD. */ + +/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* The N-by-N orthogonal matrix Q. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (N-1) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + --ap; + --tau; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldq < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DOPGTR", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Q was determined by a call to DSPTRD with UPLO = 'U' */ + +/* Unpack the vectors which define the elementary reflectors and */ +/* set the last row and column of Q equal to those of the unit */ +/* matrix */ + + ij = 2; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + q[i__ + j * q_dim1] = ap[ij]; + ++ij; +/* L10: */ + } + ij += 2; + q[*n + j * q_dim1] = 0.; +/* L20: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + q[i__ + *n * q_dim1] = 0.; +/* L30: */ + } + q[*n + *n * q_dim1] = 1.; + +/* Generate Q(1:n-1,1:n-1) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & + iinfo); + + } else { + +/* Q was determined by a call to DSPTRD with UPLO = 'L'. */ + +/* Unpack the vectors which define the elementary reflectors and */ +/* set the first row and column of Q equal to those of the unit */ +/* matrix */ + + q[q_dim1 + 1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + q[i__ + q_dim1] = 0.; +/* L40: */ + } + ij = 3; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + q[j * q_dim1 + 1] = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + q[i__ + j * q_dim1] = ap[ij]; + ++ij; +/* L50: */ + } + ij += 2; +/* L60: */ + } + if (*n > 1) { + +/* Generate Q(2:n,2:n) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorg2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], + &work[1], &iinfo); + } + } + return 0; + +/* End of DOPGTR */ + +} /* dopgtr_ */ + +/* Subroutine */ int dopmtr_(const char *side, const char *uplo, const char *trans, integer *m, + integer *n, double *ap, double *tau, double *c__, integer + *ldc, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer c_dim1, c_offset, i__1, i__2; + + /* Local variables */ + integer i__, i1, i2, i3, ic, jc, ii, mi, ni, nq; + double aii; + bool left; + bool upper; + bool notran, forwrd; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DOPMTR 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 of order nq, with nq = m if */ +/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ +/* nq-1 elementary reflectors, as returned by DSPTRD using packed */ +/* storage: */ + +/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ + +/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ + +/* Arguments */ +/* ========= */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'L': apply Q or Q**T from the Left; */ +/* = 'R': apply Q or Q**T from the Right. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangular packed storage used in previous */ +/* call to DSPTRD; */ +/* = 'L': Lower triangular packed storage used in previous */ +/* call to DSPTRD. */ + +/* 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. */ + +/* AP (input) DOUBLE PRECISION array, dimension */ +/* (M*(M+1)/2) if SIDE = 'L' */ +/* (N*(N+1)/2) if SIDE = 'R' */ +/* The vectors which define the elementary reflectors, as */ +/* returned by DSPTRD. AP is modified by the routine but */ +/* restored on exit. */ + +/* TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' */ +/* or (N-1) if SIDE = 'R' */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DSPTRD. */ + +/* 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 */ +/* (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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + --ap; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + upper = lsame_(uplo, "U"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DOPMTR", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + if (upper) { + +/* Q was determined by a call to DSPTRD with UPLO = 'U' */ + + forwrd = left && notran || ! left && ! notran; + + if (forwrd) { + i1 = 1; + i2 = nq - 1; + i3 = 1; + ii = 2; + } else { + i1 = nq - 1; + i2 = 1; + i3 = -1; + ii = nq * (nq + 1) / 2 - 1; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) is applied to C(1:i,1:n) */ + + mi = i__; + } else { + +/* H(i) is applied to C(1:m,1:i) */ + + ni = i__; + } + +/* Apply H(i) */ + + aii = ap[ii]; + ap[ii] = 1.; + dlarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &tau[i__], &c__[ + c_offset], ldc, &work[1]); + ap[ii] = aii; + + if (forwrd) { + ii = ii + i__ + 2; + } else { + ii = ii - i__ - 1; + } +/* L10: */ + } + } else { + +/* Q was determined by a call to DSPTRD with UPLO = 'L'. */ + + forwrd = left && ! notran || ! left && notran; + + if (forwrd) { + i1 = 1; + i2 = nq - 1; + i3 = 1; + ii = 2; + } else { + i1 = nq - 1; + i2 = 1; + i3 = -1; + ii = nq * (nq + 1) / 2 - 1; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__2 = i2; + i__1 = i3; + for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + aii = ap[ii]; + ap[ii] = 1.; + if (left) { + +/* H(i) is applied to C(i+1:m,1:n) */ + + mi = *m - i__; + ic = i__ + 1; + } else { + +/* H(i) is applied to C(1:m,i+1:n) */ + + ni = *n - i__; + jc = i__ + 1; + } + +/* Apply H(i) */ + + dlarf_(side, &mi, &ni, &ap[ii], &c__1, &tau[i__], &c__[ic + jc * + c_dim1], ldc, &work[1]); + ap[ii] = aii; + + if (forwrd) { + ii = ii + nq - i__ + 1; + } else { + ii = ii - nq + i__ - 2; + } +/* L20: */ + } + } + return 0; + +/* End of DOPMTR */ + +} /* dopmtr_ */ + +/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, double * + a, integer *lda, double *tau, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer i__, j, l, ii; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORG2L generates an m by n real matrix Q with orthonormal columns, */ +/* which is defined as the last n columns of a product of k elementary */ +/* reflectors of order m */ + +/* Q = H(k) . . . H(2) H(1) */ + +/* as returned by DGEQLF. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q. M >= N >= 0. */ + +/* K (input) INTEGER */ +/* The number of elementary reflectors whose product defines the */ +/* matrix Q. N >= K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the (n-k+i)-th column must contain the vector which */ +/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* returned by DGEQLF in the last k columns of its array */ +/* argument A. */ +/* On exit, the m by n matrix Q. */ + +/* LDA (input) INTEGER */ +/* The first dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGEQLF. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument has an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORG2L", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + +/* Initialise columns 1:n-k to columns of the unit matrix */ + + i__1 = *n - *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; +/* L10: */ + } + a[*m - *n + j + j * a_dim1] = 1.; +/* L20: */ + } + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + ii = *n - *k + i__; + +/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */ + + a[*m - *n + ii + ii * a_dim1] = 1.; + i__2 = *m - *n + ii; + i__3 = ii - 1; + dlarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & + a[a_offset], lda, &work[1]); + i__2 = *m - *n + ii - 1; + d__1 = -tau[i__]; + dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1); + a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__]; + +/* Set A(m-k+i+1:m,n-k+i) to zero */ + + i__2 = *m; + for (l = *m - *n + ii + 1; l <= i__2; ++l) { + a[l + ii * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + return 0; + +/* End of DORG2L */ + +} /* dorg2l_ */ + +/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, double * + a, integer *lda, double *tau, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j, l; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORG2R generates an m by n real matrix Q with orthonormal columns, */ +/* which is defined as the first n columns of a product of k elementary */ +/* reflectors of order m */ + +/* Q = H(1) H(2) . . . H(k) */ + +/* as returned by DGEQRF. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q. M >= N >= 0. */ + +/* K (input) INTEGER */ +/* The number of elementary reflectors whose product defines the */ +/* matrix Q. N >= K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, 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. */ +/* On exit, the m-by-n matrix Q. */ + +/* LDA (input) INTEGER */ +/* The first dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGEQRF. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument has an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORG2R", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + +/* Initialise columns k+1:n to columns of the unit matrix */ + + i__1 = *n; + for (j = *k + 1; j <= i__1; ++j) { + i__2 = *m; + for (l = 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; +/* L10: */ + } + a[j + j * a_dim1] = 1.; +/* L20: */ + } + + for (i__ = *k; i__ >= 1; --i__) { + +/* Apply H(i) to A(i:m,i:n) from the left */ + + if (i__ < *n) { + a[i__ + i__ * a_dim1] = 1.; + i__1 = *m - i__ + 1; + i__2 = *n - i__; + dlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ + i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); + } + if (i__ < *m) { + i__1 = *m - i__; + d__1 = -tau[i__]; + dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + } + a[i__ + i__ * a_dim1] = 1. - tau[i__]; + +/* Set A(1:i-1,i) to zero */ + + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + a[l + i__ * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + return 0; + +/* End of DORG2R */ + +} /* dorg2r_ */ + +/* Subroutine */ int dorgbr_(const char *vect, integer *m, integer *n, integer *k, + double *a, integer *lda, double *tau, double *work, + integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, nb, mn; + integer iinfo; + bool wantq; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGBR generates one of the real orthogonal matrices Q or P**T */ +/* determined by DGEBRD when reducing a real matrix A to bidiagonal */ +/* form: A = Q * B * P**T. Q and P**T are defined as products of */ +/* elementary reflectors H(i) or G(i) respectively. */ + +/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */ +/* is of order M: */ +/* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n */ +/* columns of Q, where m >= n >= k; */ +/* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an */ +/* M-by-M matrix. */ + +/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */ +/* is of order N: */ +/* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m */ +/* rows of P**T, where n >= m >= k; */ +/* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as */ +/* an N-by-N matrix. */ + +/* Arguments */ +/* ========= */ + +/* VECT (input) CHARACTER*1 */ +/* Specifies whether the matrix Q or the matrix P**T is */ +/* required, as defined in the transformation applied by DGEBRD: */ +/* = 'Q': generate Q; */ +/* = 'P': generate P**T. */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q or P**T to be returned. */ +/* M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q or P**T to be returned. */ +/* N >= 0. */ +/* If VECT = 'Q', M >= N >= min(M,K); */ +/* if VECT = 'P', N >= M >= min(N,K). */ + +/* K (input) INTEGER */ +/* If VECT = 'Q', the number of columns in the original M-by-K */ +/* matrix reduced by DGEBRD. */ +/* If VECT = 'P', the number of rows in the original K-by-N */ +/* matrix reduced by DGEBRD. */ +/* K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the vectors which define the elementary reflectors, */ +/* as returned by DGEBRD. */ +/* On exit, the M-by-N matrix Q or P**T. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension */ +/* (min(M,K)) if VECT = 'Q' */ +/* (min(N,K)) if VECT = 'P' */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i) or G(i), which determines Q or P**T, as */ +/* returned by DGEBRD in its array argument TAUQ or TAUP. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */ +/* For optimum performance LWORK >= min(M,N)*NB, where NB */ +/* is the optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + wantq = lsame_(vect, "Q"); + mn = std::min(*m,*n); + lquery = *lwork == -1; + if (! wantq && ! lsame_(vect, "P")) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0 || wantq && (*n > *m || *n < std::min(*m,*k)) || ! wantq && ( + *m > *n || *m < std::min(*n,*k))) { + *info = -3; + } else if (*k < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*m)) { + *info = -6; + } else if (*lwork < std::max(1_integer,mn) && ! lquery) { + *info = -9; + } + + if (*info == 0) { + if (wantq) { + nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1); + } else { + nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1); + } + lwkopt = std::max(1_integer,mn) * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGBR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + work[1] = 1.; + return 0; + } + + if (wantq) { + +/* Form Q, determined by a call to DGEBRD to reduce an m-by-k */ +/* matrix */ + + if (*m >= *k) { + +/* If m >= k, assume m >= n >= k */ + + dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); + + } else { + +/* If m < k, assume m = n */ + +/* Shift the vectors which define the elementary reflectors one */ +/* column to the right, and set the first row and column of Q */ +/* to those of the unit matrix */ + + for (j = *m; j >= 2; --j) { + a[j * a_dim1 + 1] = 0.; + i__1 = *m; + for (i__ = j + 1; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; +/* L10: */ + } +/* L20: */ + } + a[a_dim1 + 1] = 1.; + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; +/* L30: */ + } + if (*m > 1) { + +/* Form Q(2:m,2:m) */ + + i__1 = *m - 1; + i__2 = *m - 1; + i__3 = *m - 1; + dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ + 1], &work[1], lwork, &iinfo); + } + } + } else { + +/* Form P', determined by a call to DGEBRD to reduce a k-by-n */ +/* matrix */ + + if (*k < *n) { + +/* If k < n, assume k <= m <= n */ + + dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); + + } else { + +/* If k >= n, assume m = n */ + +/* Shift the vectors which define the elementary reflectors one */ +/* row downward, and set the first row and column of P' to */ +/* those of the unit matrix */ + + a[a_dim1 + 1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; +/* L40: */ + } + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + for (i__ = j - 1; i__ >= 2; --i__) { + a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1]; +/* L50: */ + } + a[j * a_dim1 + 1] = 0.; +/* L60: */ + } + if (*n > 1) { + +/* Form P'(2:n,2:n) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ + 1], &work[1], lwork, &iinfo); + } + } + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORGBR */ + +} /* dorgbr_ */ + +/* Subroutine */ int dorghr_(integer *n, integer *ilo, integer *ihi, + double *a, integer *lda, double *tau, double *work, + integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, nb, nh, iinfo; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGHR generates a real orthogonal matrix Q which is defined as the */ +/* product of IHI-ILO elementary reflectors of order N, as returned by */ +/* DGEHRD: */ + +/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix Q. N >= 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* ILO and IHI must have the same values as in the previous call */ +/* of DGEHRD. Q is equal to the unit matrix except in the */ +/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */ +/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the vectors which define the elementary reflectors, */ +/* as returned by DGEHRD. */ +/* On exit, the N-by-N orthogonal matrix Q. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGEHRD. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= IHI-ILO. */ +/* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */ +/* the optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nh = *ihi - *ilo; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > std::max(1_integer,*n)) { + *info = -2; + } else if (*ihi < std::min(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*lwork < std::max(1_integer,nh) && ! lquery) { + *info = -8; + } + + if (*info == 0) { + nb = ilaenv_(&c__1, "DORGQR", " ", &nh, &nh, &nh, &c_n1); + lwkopt = std::max(1_integer,nh) * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGHR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + work[1] = 1.; + return 0; + } + +/* Shift the vectors which define the elementary reflectors one */ +/* column to the right, and set the first ilo and the last n-ihi */ +/* rows and columns to those of the unit matrix */ + + i__1 = *ilo + 1; + for (j = *ihi; j >= i__1; --j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L10: */ + } + i__2 = *ihi; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; +/* L20: */ + } + i__2 = *n; + for (i__ = *ihi + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + i__1 = *ilo; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L50: */ + } + a[j + j * a_dim1] = 1.; +/* L60: */ + } + i__1 = *n; + for (j = *ihi + 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L70: */ + } + a[j + j * a_dim1] = 1.; +/* L80: */ + } + + if (nh > 0) { + +/* Generate Q(ilo+1:ihi,ilo+1:ihi) */ + + dorgqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[* + ilo], &work[1], lwork, &iinfo); + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORGHR */ + +} /* dorghr_ */ + +/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, double * + a, integer *lda, double *tau, double *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j, l; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGL2 generates an m by n real matrix Q with orthonormal rows, */ +/* which is defined as the first m rows of a product of k elementary */ +/* reflectors of order n */ + +/* Q = H(k) . . . H(2) H(1) */ + +/* as returned by DGELQF. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q. N >= M. */ + +/* K (input) INTEGER */ +/* The number of elementary reflectors whose product defines the */ +/* matrix Q. M >= K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the i-th row must contain the vector which defines */ +/* the elementary reflector H(i), for i = 1,2,...,k, as returned */ +/* by DGELQF in the first k rows of its array argument A. */ +/* On exit, the m-by-n matrix Q. */ + +/* LDA (input) INTEGER */ +/* The first dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGELQF. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument has an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGL2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m <= 0) { + return 0; + } + + if (*k < *m) { + +/* Initialise rows k+1:m to rows of the unit matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (l = *k + 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; +/* L10: */ + } + if (j > *k && j <= *m) { + a[j + j * a_dim1] = 1.; + } +/* L20: */ + } + } + + for (i__ = *k; i__ >= 1; --i__) { + +/* Apply H(i) to A(i:m,i:n) from the right */ + + if (i__ < *n) { + if (i__ < *m) { + a[i__ + i__ * a_dim1] = 1.; + i__1 = *m - i__; + i__2 = *n - i__ + 1; + dlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & + tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); + } + i__1 = *n - i__; + d__1 = -tau[i__]; + dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda); + } + a[i__ + i__ * a_dim1] = 1. - tau[i__]; + +/* Set A(i,1:i-1) to zero */ + + i__1 = i__ - 1; + for (l = 1; l <= i__1; ++l) { + a[i__ + l * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + return 0; + +/* End of DORGL2 */ + +} /* dorgl2_ */ + +/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, double * + a, integer *lda, double *tau, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGLQ generates an M-by-N real matrix Q with orthonormal rows, */ +/* which is defined as the first M rows of a product of K elementary */ +/* reflectors of order N */ + +/* Q = H(k) . . . H(2) H(1) */ + +/* as returned by DGELQF. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q. N >= M. */ + +/* K (input) INTEGER */ +/* The number of elementary reflectors whose product defines the */ +/* matrix Q. M >= K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the i-th row must contain the vector which defines */ +/* the elementary reflector H(i), for i = 1,2,...,k, as returned */ +/* by DGELQF in the first k rows of its array argument A. */ +/* On exit, the M-by-N matrix Q. */ + +/* LDA (input) INTEGER */ +/* The first dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGELQF. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,M). */ +/* For optimum performance LWORK >= M*NB, where NB is */ +/* the optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument has an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1); + lwkopt = std::max(1_integer,*m) * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else if (*lwork < std::max(1_integer,*m) && ! lquery) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGLQ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m <= 0) { + work[1] = 1.; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *m; + if (nb > 1 && nb < *k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DORGLQ", " ", m, n, k, &c_n1); + nx = std::max(i__1,i__2); + if (nx < *k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DORGLQ", " ", m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *k && nx < *k) { + +/* Use blocked code after the last block. */ +/* The first kk rows are handled by the block method. */ + + ki = (*k - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = *k, i__2 = ki + nb; + kk = std::min(i__1,i__2); + +/* Set A(kk+1:m,1:kk) to zero. */ + + i__1 = kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = kk + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + kk = 0; + } + +/* Use unblocked code for the last or only block. */ + + if (kk < *m) { + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & + tau[kk + 1], &work[1], &iinfo); + } + + if (kk > 0) { + +/* Use blocked code */ + + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = nb, i__3 = *k - i__ + 1; + ib = std::min(i__2,i__3); + if (i__ + ib <= *m) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__2 = *n - i__ + 1; + dlarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H' to A(i+ib:m,i:n) from the right */ + + i__2 = *m - i__ - ib + 1; + i__3 = *n - i__ + 1; + dlarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, & + i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & + ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + + 1], &ldwork); + } + +/* Apply H' to columns i:n of current block */ + + i__2 = *n - i__ + 1; + dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & + work[1], &iinfo); + +/* Set columns 1:i-1 of current block to zero */ + + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + ib - 1; + for (l = i__; l <= i__3; ++l) { + a[l + j * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + } + + work[1] = (double) iws; + return 0; + +/* End of DORGLQ */ + +} /* dorglq_ */ + +/* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, double * + a, integer *lda, double *tau, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGQL generates an M-by-N real matrix Q with orthonormal columns, */ +/* which is defined as the last N columns of a product of K elementary */ +/* reflectors of order M */ + +/* Q = H(k) . . . H(2) H(1) */ + +/* as returned by DGEQLF. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q. M >= N >= 0. */ + +/* K (input) INTEGER */ +/* The number of elementary reflectors whose product defines the */ +/* matrix Q. N >= K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the (n-k+i)-th column must contain the vector which */ +/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* returned by DGEQLF in the last k columns of its array */ +/* argument A. */ +/* On exit, the M-by-N matrix Q. */ + +/* LDA (input) INTEGER */ +/* The first dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGEQLF. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument has an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, "DORGQL", " ", m, n, k, &c_n1); + lwkopt = *n * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < std::max(1_integer,*n) && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGQL", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < *k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQL", " ", m, n, k, &c_n1); + nx = std::max(i__1,i__2); + if (nx < *k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQL", " ", m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *k && nx < *k) { + +/* Use blocked code after the first block. */ +/* The last kk columns are handled by the block method. */ + +/* Computing MIN */ + i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; + kk = std::min(i__1,i__2); + +/* Set A(m-kk+1:m,1:n-kk) to zero. */ + + i__1 = *n - kk; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + kk = 0; + } + +/* Use unblocked code for the first or only block. */ + + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) + ; + + if (kk > 0) { + +/* Use blocked code */ + + i__1 = *k; + i__2 = nb; + for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *k - i__ + 1; + ib = std::min(i__3,i__4); + if (*n - *k + i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *m - *k + i__ + ib - 1; + dlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - *k + + i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ + + i__3 = *m - *k + i__ + ib - 1; + i__4 = *n - *k + i__ - 1; + dlarfb_("Left", "No transpose", "Backward", "Columnwise", & + i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1], + lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib + + 1], &ldwork); + } + +/* Apply H to rows 1:m-k+i+ib-1 of current block */ + + i__3 = *m - *k + i__ + ib - 1; + dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, & + tau[i__], &work[1], &iinfo); + +/* Set rows m-k+i+ib:m of current block to zero */ + + i__3 = *n - *k + i__ + ib - 1; + for (j = *n - *k + i__; j <= i__3; ++j) { + i__4 = *m; + for (l = *m - *k + i__ + ib; l <= i__4; ++l) { + a[l + j * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + } + + work[1] = (double) iws; + return 0; + +/* End of DORGQL */ + +} /* dorgql_ */ + +/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, double * + a, integer *lda, double *tau, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGQR generates an M-by-N real matrix Q with orthonormal columns, */ +/* which is defined as the first N columns of a product of K elementary */ +/* reflectors of order M */ + +/* Q = H(1) H(2) . . . H(k) */ + +/* as returned by DGEQRF. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q. M >= N >= 0. */ + +/* K (input) INTEGER */ +/* The number of elementary reflectors whose product defines the */ +/* matrix Q. N >= K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, 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. */ +/* On exit, the M-by-N matrix Q. */ + +/* LDA (input) INTEGER */ +/* The first dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGEQRF. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument has an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1); + lwkopt = std::max(1_integer,*n) * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n > *m) { + *info = -2; + } else if (*k < 0 || *k > *n) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else if (*lwork < std::max(1_integer,*n) && ! lquery) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGQR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + work[1] = 1.; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < *k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQR", " ", m, n, k, &c_n1); + nx = std::max(i__1,i__2); + if (nx < *k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQR", " ", m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *k && nx < *k) { + +/* Use blocked code after the last block. */ +/* The first kk columns are handled by the block method. */ + + ki = (*k - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = *k, i__2 = ki + nb; + kk = std::min(i__1,i__2); + +/* Set A(1:kk,kk+1:n) to zero. */ + + i__1 = *n; + for (j = kk + 1; j <= i__1; ++j) { + i__2 = kk; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + kk = 0; + } + +/* Use unblocked code for the last or only block. */ + + if (kk < *n) { + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & + tau[kk + 1], &work[1], &iinfo); + } + + if (kk > 0) { + +/* Use blocked code */ + + i__1 = -nb; + for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = nb, i__3 = *k - i__ + 1; + ib = std::min(i__2,i__3); + if (i__ + ib <= *n) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__2 = *m - i__ + 1; + dlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(i:m,i+ib:n) from the left */ + + i__2 = *m - i__ + 1; + i__3 = *n - i__ - ib + 1; + dlarfb_("Left", "No transpose", "Forward", "Columnwise", & + i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & + work[ib + 1], &ldwork); + } + +/* Apply H to rows i:m of current block */ + + i__2 = *m - i__ + 1; + dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & + work[1], &iinfo); + +/* Set rows 1:i-1 of current block to zero */ + + i__2 = i__ + ib - 1; + for (j = i__; j <= i__2; ++j) { + i__3 = i__ - 1; + for (l = 1; l <= i__3; ++l) { + a[l + j * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + } + + work[1] = (double) iws; + return 0; + +/* End of DORGQR */ + +} /* dorgqr_ */ + +/* Subroutine */ int dorgr2_(integer *m, integer *n, integer *k, double * + a, integer *lda, double *tau, double *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer i__, j, l, ii; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGR2 generates an m by n real matrix Q with orthonormal rows, */ +/* which is defined as the last m rows of a product of k elementary */ +/* reflectors of order n */ + +/* Q = H(1) H(2) . . . H(k) */ + +/* as returned by DGERQF. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q. N >= M. */ + +/* K (input) INTEGER */ +/* The number of elementary reflectors whose product defines the */ +/* matrix Q. M >= K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the (m-k+i)-th row must contain the vector which */ +/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* returned by DGERQF in the last k rows of its array argument */ +/* A. */ +/* On exit, the m by n matrix Q. */ + +/* LDA (input) INTEGER */ +/* The first dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGERQF. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument has an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGR2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m <= 0) { + return 0; + } + + if (*k < *m) { + +/* Initialise rows 1:m-k to rows of the unit matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m - *k; + for (l = 1; l <= i__2; ++l) { + a[l + j * a_dim1] = 0.; +/* L10: */ + } + if (j > *n - *m && j <= *n - *k) { + a[*m - *n + j + j * a_dim1] = 1.; + } +/* L20: */ + } + } + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + ii = *m - *k + i__; + +/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right */ + + a[ii + (*n - *m + ii) * a_dim1] = 1.; + i__2 = ii - 1; + i__3 = *n - *m + ii; + dlarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &tau[i__], &a[ + a_offset], lda, &work[1]); + i__2 = *n - *m + ii - 1; + d__1 = -tau[i__]; + dscal_(&i__2, &d__1, &a[ii + a_dim1], lda); + a[ii + (*n - *m + ii) * a_dim1] = 1. - tau[i__]; + +/* Set A(m-k+i,n-k+i+1:n) to zero */ + + i__2 = *n; + for (l = *n - *m + ii + 1; l <= i__2; ++l) { + a[ii + l * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + return 0; + +/* End of DORGR2 */ + +} /* dorgr2_ */ + +/* Subroutine */ int dorgrq_(integer *m, integer *n, integer *k, double * + a, integer *lda, double *tau, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, l, ib, nb, ii, kk, nx, iws, nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGRQ generates an M-by-N real matrix Q with orthonormal rows, */ +/* which is defined as the last M rows of a product of K elementary */ +/* reflectors of order N */ + +/* Q = H(1) H(2) . . . H(k) */ + +/* as returned by DGERQF. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix Q. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Q. N >= M. */ + +/* K (input) INTEGER */ +/* The number of elementary reflectors whose product defines the */ +/* matrix Q. M >= K >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the (m-k+i)-th row must contain the vector which */ +/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ +/* returned by DGERQF in the last k rows of its array argument */ +/* A. */ +/* On exit, the M-by-N matrix Q. */ + +/* LDA (input) INTEGER */ +/* The first dimension of the array A. LDA >= max(1,M). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGERQF. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,M). */ +/* For optimum performance LWORK >= M*NB, where NB is the */ +/* optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument has an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*k < 0 || *k > *m) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } + + if (*info == 0) { + if (*m <= 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, "DORGRQ", " ", m, n, k, &c_n1); + lwkopt = *m * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < std::max(1_integer,*m) && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGRQ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m <= 0) { + return 0; + } + + nbmin = 2; + nx = 0; + iws = *m; + if (nb > 1 && nb < *k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DORGRQ", " ", m, n, k, &c_n1); + nx = std::max(i__1,i__2); + if (nx < *k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DORGRQ", " ", m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *k && nx < *k) { + +/* Use blocked code after the first block. */ +/* The last kk rows are handled by the block method. */ + +/* Computing MIN */ + i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; + kk = std::min(i__1,i__2); + +/* Set A(1:m-kk,n-kk+1:n) to zero. */ + + i__1 = *n; + for (j = *n - kk + 1; j <= i__1; ++j) { + i__2 = *m - kk; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else { + kk = 0; + } + +/* Use unblocked code for the first or only block. */ + + i__1 = *m - kk; + i__2 = *n - kk; + i__3 = *k - kk; + dorgr2_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) + ; + + if (kk > 0) { + +/* Use blocked code */ + + i__1 = *k; + i__2 = nb; + for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *k - i__ + 1; + ib = std::min(i__3,i__4); + ii = *m - *k + i__; + if (ii > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *n - *k + i__ + ib - 1; + dlarft_("Backward", "Rowwise", &i__3, &ib, &a[ii + a_dim1], + lda, &tau[i__], &work[1], &ldwork); + +/* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */ + + i__3 = ii - 1; + i__4 = *n - *k + i__ + ib - 1; + dlarfb_("Right", "Transpose", "Backward", "Rowwise", &i__3, & + i__4, &ib, &a[ii + a_dim1], lda, &work[1], &ldwork, & + a[a_offset], lda, &work[ib + 1], &ldwork); + } + +/* Apply H' to columns 1:n-k+i+ib-1 of current block */ + + i__3 = *n - *k + i__ + ib - 1; + dorgr2_(&ib, &i__3, &ib, &a[ii + a_dim1], lda, &tau[i__], &work[1] +, &iinfo); + +/* Set columns n-k+i+ib:n of current block to zero */ + + i__3 = *n; + for (l = *n - *k + i__ + ib; l <= i__3; ++l) { + i__4 = ii + ib - 1; + for (j = ii; j <= i__4; ++j) { + a[j + l * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + } + + work[1] = (double) iws; + return 0; + +/* End of DORGRQ */ + +} /* dorgrq_ */ + +/* Subroutine */ int dorgtr_(const char *uplo, integer *n, double *a, integer * + lda, double *tau, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, nb; + integer iinfo; + bool upper; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORGTR generates a real orthogonal matrix Q which is defined as the */ +/* product of n-1 elementary reflectors of order N, as returned by */ +/* DSYTRD: */ + +/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */ + +/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A contains elementary reflectors */ +/* from DSYTRD; */ +/* = 'L': Lower triangle of A contains elementary reflectors */ +/* from DSYTRD. */ + +/* N (input) INTEGER */ +/* The order of the matrix Q. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the vectors which define the elementary reflectors, */ +/* as returned by DSYTRD. */ +/* On exit, the N-by-N orthogonal matrix Q. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DSYTRD. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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-1). */ +/* For optimum performance LWORK >= (N-1)*NB, where NB is */ +/* the optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n - 1; + if (*lwork < std::max(i__1,i__2) && ! lquery) { + *info = -7; + } + } + + if (*info == 0) { + if (upper) { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, "DORGQL", " ", &i__1, &i__2, &i__3, &c_n1); + } else { + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, "DORGQR", " ", &i__1, &i__2, &i__3, &c_n1); + } +/* Computing MAX */ + i__1 = 1, i__2 = *n - 1; + lwkopt = std::max(i__1,i__2) * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORGTR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + work[1] = 1.; + return 0; + } + + if (upper) { + +/* Q was determined by a call to DSYTRD with UPLO = 'U' */ + +/* Shift the vectors which define the elementary reflectors one */ +/* column to the left, and set the last row and column of Q to */ +/* those of the unit matrix */ + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1]; +/* L10: */ + } + a[*n + j * a_dim1] = 0.; +/* L20: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + *n * a_dim1] = 0.; +/* L30: */ + } + a[*n + *n * a_dim1] = 1.; + +/* Generate Q(1:n-1,1:n-1) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], + lwork, &iinfo); + + } else { + +/* Q was determined by a call to DSYTRD with UPLO = 'L'. */ + +/* Shift the vectors which define the elementary reflectors one */ +/* column to the right, and set the first row and column of Q to */ +/* those of the unit matrix */ + + for (j = *n; j >= 2; --j) { + a[j * a_dim1 + 1] = 0.; + i__1 = *n; + for (i__ = j + 1; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; +/* L40: */ + } +/* L50: */ + } + a[a_dim1 + 1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] = 0.; +/* L60: */ + } + if (*n > 1) { + +/* Generate Q(2:n,2:n) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], + &work[1], lwork, &iinfo); + } + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORGTR */ + +} /* dorgtr_ */ + +/* Subroutine */ int dorm2l_(const char *side, const char *trans, integer *m, integer *n, + integer *k, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + + /* Local variables */ + integer i__, i1, i2, i3, mi, ni, nq; + double aii; + bool left; + bool notran; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORM2L 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(k) . . . H(2) H(1) */ + +/* as returned by DGEQLF. 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 */ +/* DGEQLF in the last 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 DGEQLF. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < std::max(1_integer,nq)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORM2L", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) is applied to C(1:m-k+i,1:n) */ + + mi = *m - *k + i__; + } else { + +/* H(i) is applied to C(1:m,1:n-k+i) */ + + ni = *n - *k + i__; + } + +/* Apply H(i) */ + + aii = a[nq - *k + i__ + i__ * a_dim1]; + a[nq - *k + i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[ + c_offset], ldc, &work[1]); + a[nq - *k + i__ + i__ * a_dim1] = aii; +/* L10: */ + } + return 0; + +/* End of DORM2L */ + +} /* dorm2l_ */ + +/* Subroutine */ int dorm2r_(const char *side, const char *trans, integer *m, integer *n, + integer *k, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + + /* Local variables */ + integer i__, i1, i2, i3, ic, jc, mi, ni, nq; + double aii; + bool left; + bool notran; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < std::max(1_integer,nq)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORM2R", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* 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__; + } + +/* Apply H(i) */ + + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ + ic + jc * c_dim1], ldc, &work[1]); + a[i__ + i__ * a_dim1] = aii; +/* L10: */ + } + return 0; + +/* End of DORM2R */ + +} /* dorm2r_ */ + +/* Subroutine */ int dormbr_(const char *vect, const char *side, const char *trans, integer *m, + integer *n, integer *k, double *a, integer *lda, double *tau, + double *c__, integer *ldc, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; + char ch__1[3]; + + /* Local variables */ + integer i1, i2, nb, mi, ni, nq, nw; + bool left; + integer iinfo; + bool notran; + bool applyq; + char transt[1]; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* If VECT = 'Q', DORMBR 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 */ + +/* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C */ +/* with */ +/* SIDE = 'L' SIDE = 'R' */ +/* TRANS = 'N': P * C C * P */ +/* TRANS = 'T': P**T * C C * P**T */ + +/* Here Q and P**T are the orthogonal matrices determined by DGEBRD when */ +/* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and */ +/* P**T are defined as products of elementary reflectors H(i) and G(i) */ +/* respectively. */ + +/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */ +/* order of the orthogonal matrix Q or P**T that is applied. */ + +/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */ +/* if nq >= k, Q = H(1) H(2) . . . H(k); */ +/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */ + +/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */ +/* if k < nq, P = G(1) G(2) . . . G(k); */ +/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */ + +/* Arguments */ +/* ========= */ + +/* VECT (input) CHARACTER*1 */ +/* = 'Q': apply Q or Q**T; */ +/* = 'P': apply P or P**T. */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'L': apply Q, Q**T, P or P**T from the Left; */ +/* = 'R': apply Q, Q**T, P or P**T from the Right. */ + +/* TRANS (input) CHARACTER*1 */ +/* = 'N': No transpose, apply Q or P; */ +/* = 'T': Transpose, apply Q**T or P**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 */ +/* If VECT = 'Q', the number of columns in the original */ +/* matrix reduced by DGEBRD. */ +/* If VECT = 'P', the number of rows in the original */ +/* matrix reduced by DGEBRD. */ +/* K >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension */ +/* (LDA,min(nq,K)) if VECT = 'Q' */ +/* (LDA,nq) if VECT = 'P' */ +/* The vectors which define the elementary reflectors H(i) and */ +/* G(i), whose products determine the matrices Q and P, as */ +/* returned by DGEBRD. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. */ +/* If VECT = 'Q', LDA >= max(1,nq); */ +/* if VECT = 'P', LDA >= max(1,min(nq,K)). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i) or G(i) which determines Q or P, as returned */ +/* by DGEBRD in the array argument TAUQ or TAUP. */ + +/* 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 */ +/* or P*C or P**T*C or C*P or C*P**T. */ + +/* LDC (input) INTEGER */ +/* The leading dimension of the array C. LDC >= max(1,M). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + applyq = lsame_(vect, "Q"); + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q or P and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! applyq && ! lsame_(vect, "P")) { + *info = -1; + } else if (! left && ! lsame_(side, "R")) { + *info = -2; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*k < 0) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = std::min(nq,*k); + if (applyq && *lda < std::max(1_integer,nq) || ! applyq && *lda < std::max(i__1,i__2)) { + *info = -8; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -11; + } else if (*lwork < std::max(1_integer,nw) && ! lquery) { + *info = -13; + } + } + + if (*info == 0) { + if (applyq) { + if (left) { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = *m - 1; + i__2 = *m - 1; + nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__1, n, &i__2, &c_n1); + } else { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = *n - 1; + i__2 = *n - 1; + nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__1, &i__2, &c_n1); + } + } else { + if (left) { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = *m - 1; + i__2 = *m - 1; + nb = ilaenv_(&c__1, "DORMLQ", ch__1, &i__1, n, &i__2, &c_n1); + } else { +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = *n - 1; + i__2 = *n - 1; + nb = ilaenv_(&c__1, "DORMLQ", ch__1, m, &i__1, &i__2, &c_n1); + } + } + lwkopt = std::max(1_integer,nw) * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORMBR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + work[1] = 1.; + if (*m == 0 || *n == 0) { + return 0; + } + + if (applyq) { + +/* Apply Q */ + + if (nq >= *k) { + +/* Q was determined by a call to DGEBRD with nq >= k */ + + dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], lwork, &iinfo); + } else if (nq > 1) { + +/* Q was determined by a call to DGEBRD with nq < k */ + + if (left) { + mi = *m - 1; + ni = *n; + i1 = 2; + i2 = 1; + } else { + mi = *m; + ni = *n - 1; + i1 = 1; + i2 = 2; + } + i__1 = nq - 1; + dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] +, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); + } + } else { + +/* Apply P */ + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + if (nq > *k) { + +/* P was determined by a call to DGEBRD with nq > k */ + + dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], lwork, &iinfo); + } else if (nq > 1) { + +/* P was determined by a call to DGEBRD with nq <= k */ + + if (left) { + mi = *m - 1; + ni = *n; + i1 = 2; + i2 = 1; + } else { + mi = *m; + ni = *n - 1; + i1 = 1; + i2 = 2; + } + i__1 = nq - 1; + dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, + &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & + iinfo); + } + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORMBR */ + +} /* dormbr_ */ + +/* Subroutine */ int dormhr_(const char *side, const char *trans, integer *m, integer *n, + integer *ilo, integer *ihi, double *a, integer *lda, double * + tau, double *c__, integer *ldc, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2; + char ch__1[3]; + + /* Local variables */ + integer i1, i2, nb, mi, nh, ni, nq, nw; + bool left; + integer iinfo; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORMHR 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 of order nq, with nq = m if */ +/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ +/* IHI-ILO elementary reflectors, as returned by DGEHRD: */ + +/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ + +/* 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. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* ILO and IHI must have the same values as in the previous call */ +/* of DGEHRD. Q is equal to the unit matrix except in the */ +/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */ +/* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and */ +/* ILO = 1 and IHI = 0, if M = 0; */ +/* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and */ +/* ILO = 1 and IHI = 0, if N = 0. */ + +/* A (input) DOUBLE PRECISION array, dimension */ +/* (LDA,M) if SIDE = 'L' */ +/* (LDA,N) if SIDE = 'R' */ +/* The vectors which define the elementary reflectors, as */ +/* returned by DGEHRD. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. */ +/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */ + +/* TAU (input) DOUBLE PRECISION array, dimension */ +/* (M-1) if SIDE = 'L' */ +/* (N-1) if SIDE = 'R' */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGEHRD. */ + +/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + nh = *ihi - *ilo; + left = lsame_(side, "L"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ilo < 1 || *ilo > std::max(1_integer,nq)) { + *info = -5; + } else if (*ihi < std::min(*ilo,nq) || *ihi > nq) { + *info = -6; + } else if (*lda < std::max(1_integer,nq)) { + *info = -8; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -11; + } else if (*lwork < std::max(1_integer,nw) && ! lquery) { + *info = -13; + } + + if (*info == 0) { + if (left) { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = const_cast (side); + i__1[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__1, &c__2, 2_integer); + ch__1 [2] = '\0'; + nb = ilaenv_(&c__1, "DORMQR", ch__1, &nh, n, &nh, &c_n1); + } else { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = const_cast (side); + i__1[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__1, &c__2, 2_integer); + ch__1 [2] = '\0'; + nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &nh, &nh, &c_n1); + } + lwkopt = std::max(1_integer,nw) * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__2 = -(*info); + xerbla_("DORMHR", &i__2); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || nh == 0) { + work[1] = 1.; + return 0; + } + + if (left) { + mi = nh; + ni = *n; + i1 = *ilo + 1; + i2 = 1; + } else { + mi = *m; + ni = nh; + i1 = 1; + i2 = *ilo + 1; + } + + dormqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, & + tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); + + work[1] = (double) lwkopt; + return 0; + +/* End of DORMHR */ + +} /* dormhr_ */ + +/* Subroutine */ int dorml2_(const char *side, const char *trans, integer *m, integer *n, + integer *k, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + + /* Local variables */ + integer i__, i1, i2, i3, ic, jc, mi, ni, nq; + double aii; + bool left; + bool notran; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORML2 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(k) . . . H(2) H(1) */ + +/* as returned by DGELQF. 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,M) if SIDE = 'L', */ +/* (LDA,N) if SIDE = 'R' */ +/* The i-th row must contain the vector which defines the */ +/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* DGELQF in the first k rows 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. LDA >= max(1,K). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGELQF. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < std::max(1_integer,*k)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORML2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* 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__; + } + +/* Apply H(i) */ + + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ + ic + jc * c_dim1], ldc, &work[1]); + a[i__ + i__ * a_dim1] = aii; +/* L10: */ + } + return 0; + +/* End of DORML2 */ + +} /* dorml2_ */ + +/* Subroutine */ int dormlq_(const char *side, const char *trans, integer *m, integer *n, + integer *k, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + static integer c__65 = 65; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[3]; + + /* Local variables */ + integer i__; + double t[4160] /* was [65][64] */; + integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; + bool left; + integer nbmin, iinfo; + bool notran; + integer ldwork; + char transt[1]; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORMLQ 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(k) . . . H(2) H(1) */ + +/* as returned by DGELQF. 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,M) if SIDE = 'L', */ +/* (LDA,N) if SIDE = 'R' */ +/* The i-th row must contain the vector which defines the */ +/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* DGELQF in the first k rows 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. LDA >= max(1,K). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGELQF. */ + +/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < std::max(1_integer,*k)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } else if (*lwork < std::max(1_integer,nw) && ! lquery) { + *info = -12; + } + + if (*info == 0) { + +/* Determine the block size. NB may be at most NBMAX, where NBMAX */ +/* is used to define the local array T. */ + +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1); + nb = std::min(i__1,i__2); + lwkopt = std::max(1_integer,nw) * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORMLQ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + work[1] = 1.; + return 0; + } + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + iws = nw * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } else { + iws = nw; + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = std::min(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__4 = nq - i__ + 1; + dlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], + lda, &tau[i__], t, &c__65); + if (left) { + +/* 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__; + } + +/* Apply H or H' */ + + dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ + + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], + ldc, &work[1], &ldwork); +/* L10: */ + } + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORMLQ */ + +} /* dormlq_ */ + +/* Subroutine */ int dormql_(const char *side, const char *trans, integer *m, integer *n, + integer *k, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + static integer c__65 = 65; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[3]; + + /* Local variables */ + integer i__; + double t[4160] /* was [65][64] */; + integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws; + bool left; + integer nbmin, iinfo; + bool notran; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORMQL 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(k) . . . H(2) H(1) */ + +/* as returned by DGEQLF. 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 */ +/* DGEQLF in the last 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 DGEQLF. */ + +/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = std::max(1_integer,*n); + } else { + nq = *n; + nw = std::max(1_integer,*m); + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < std::max(1_integer,nq)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } + + if (*info == 0) { + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { + +/* Determine the block size. NB may be at most NBMAX, where */ +/* NBMAX is used to define the local array T. */ + +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQL", ch__1, m, n, k, &c_n1); + nb = std::min(i__1,i__2); + lwkopt = nw * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < nw && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORMQL", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + iws = nw * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQL", ch__1, m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } else { + iws = nw; + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + if (left && notran || ! left && ! notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = std::min(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__4 = nq - *k + i__ + ib - 1; + dlarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] +, lda, &tau[i__], t, &c__65); + if (left) { + +/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */ + + mi = *m - *k + i__ + ib - 1; + } else { + +/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */ + + ni = *n - *k + i__ + ib - 1; + } + +/* Apply H or H' */ + + dlarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[ + i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, & + work[1], &ldwork); +/* L10: */ + } + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORMQL */ + +} /* dormql_ */ + +/* Subroutine */ int dormqr_(const char *side, const char *trans, integer *m, integer *n, + integer *k, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + static integer c__65 = 65; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[3]; + + /* Local variables */ + integer i__; + double t[4160] /* was [65][64] */; + integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; + bool left; + integer nbmin, iinfo; + bool notran; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < std::max(1_integer,nq)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } else if (*lwork < std::max(1_integer,nw) && ! lquery) { + *info = -12; + } + + if (*info == 0) { + +/* Determine the block size. NB may be at most NBMAX, where NBMAX */ +/* is used to define the local array T. */ + +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1); + nb = std::min(i__1,i__2); + lwkopt = std::max(1_integer,nw) * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORMQR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + work[1] = 1.; + return 0; + } + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + iws = nw * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } else { + iws = nw; + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = std::min(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__4 = nq - i__ + 1; + dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], t, &c__65) + ; + if (left) { + +/* 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__; + } + +/* Apply H or H' */ + + dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ + i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * + c_dim1], ldc, &work[1], &ldwork); +/* L10: */ + } + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORMQR */ + +} /* dormqr_ */ + +/* Subroutine */ int dormr2_(const char *side, const char *trans, integer *m, integer *n, + integer *k, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + + /* Local variables */ + integer i__, i1, i2, i3, mi, ni, nq; + double aii; + bool left; + bool notran; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORMR2 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 DGERQF. 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,M) if SIDE = 'L', */ +/* (LDA,N) if SIDE = 'R' */ +/* The i-th row must contain the vector which defines the */ +/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* DGERQF in the last k rows 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. LDA >= max(1,K). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGERQF. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < std::max(1_integer,*k)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORMR2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) is applied to C(1:m-k+i,1:n) */ + + mi = *m - *k + i__; + } else { + +/* H(i) is applied to C(1:m,1:n-k+i) */ + + ni = *n - *k + i__; + } + +/* Apply H(i) */ + + aii = a[i__ + (nq - *k + i__) * a_dim1]; + a[i__ + (nq - *k + i__) * a_dim1] = 1.; + dlarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &tau[i__], &c__[ + c_offset], ldc, &work[1]); + a[i__ + (nq - *k + i__) * a_dim1] = aii; +/* L10: */ + } + return 0; + +/* End of DORMR2 */ + +} /* dormr2_ */ + +/* Subroutine */ int dormr3_(const char *side, const char *trans, integer *m, integer *n, + integer *k, integer *l, double *a, integer *lda, double *tau, + double *c__, integer *ldc, double *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; + + /* Local variables */ + integer i__, i1, i2, i3, ja, ic, jc, mi, ni, nq; + bool left; + bool notran; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORMR3 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 DTZRZF. 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. */ + +/* L (input) INTEGER */ +/* The number of columns of the matrix A containing */ +/* the meaningful part of the Householder reflectors. */ +/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension */ +/* (LDA,M) if SIDE = 'L', */ +/* (LDA,N) if SIDE = 'R' */ +/* The i-th row must contain the vector which defines the */ +/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* DTZRZF in the last k rows 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. LDA >= max(1,K). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DTZRZF. */ + +/* 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 */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*l < 0 || left && *l > *m || ! left && *l > *n) { + *info = -6; + } else if (*lda < std::max(1_integer,*k)) { + *info = -8; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORMR3", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = 1; + } else { + i1 = *k; + i2 = 1; + i3 = -1; + } + + if (left) { + ni = *n; + ja = *m - *l + 1; + jc = 1; + } else { + mi = *m; + ja = *n - *l + 1; + ic = 1; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) or H(i)' is applied to C(i:m,1:n) */ + + mi = *m - i__ + 1; + ic = i__; + } else { + +/* H(i) or H(i)' is applied to C(1:m,i:n) */ + + ni = *n - i__ + 1; + jc = i__; + } + +/* Apply H(i) or H(i)' */ + + dlarz_(side, &mi, &ni, l, &a[i__ + ja * a_dim1], lda, &tau[i__], &c__[ + ic + jc * c_dim1], ldc, &work[1]); + +/* L10: */ + } + + return 0; + +/* End of DORMR3 */ + +} /* dormr3_ */ + +/* Subroutine */ int dormrq_(const char *side, const char *trans, integer *m, integer *n, + integer *k, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + static integer c__65 = 65; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[3]; + + /* Local variables */ + integer i__; + double t[4160] /* was [65][64] */; + integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws; + bool left; + integer nbmin, iinfo; + bool notran; + integer ldwork; + char transt[1]; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORMRQ 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 DGERQF. 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,M) if SIDE = 'L', */ +/* (LDA,N) if SIDE = 'R' */ +/* The i-th row must contain the vector which defines the */ +/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* DGERQF in the last k rows 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. LDA >= max(1,K). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DGERQF. */ + +/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = std::max(1_integer,*n); + } else { + nq = *n; + nw = std::max(1_integer,*m); + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*lda < std::max(1_integer,*k)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } + + if (*info == 0) { + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { + +/* Determine the block size. NB may be at most NBMAX, where */ +/* NBMAX is used to define the local array T. */ + +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 64, i__2 = ilaenv_(&c__1, "DORMRQ", ch__1, m, n, k, &c_n1); + nb = std::min(i__1,i__2); + lwkopt = nw * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < nw && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORMRQ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + iws = nw * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 2, i__2 = ilaenv_(&c__2, "DORMRQ", ch__1, m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } else { + iws = nw; + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + dormr2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = std::min(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__4 = nq - *k + i__ + ib - 1; + dlarft_("Backward", "Rowwise", &i__4, &ib, &a[i__ + a_dim1], lda, + &tau[i__], t, &c__65); + if (left) { + +/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */ + + mi = *m - *k + i__ + ib - 1; + } else { + +/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */ + + ni = *n - *k + i__ + ib - 1; + } + +/* Apply H or H' */ + + dlarfb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, &a[ + i__ + a_dim1], lda, t, &c__65, &c__[c_offset], ldc, &work[ + 1], &ldwork); +/* L10: */ + } + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORMRQ */ + +} /* dormrq_ */ + +/* Subroutine */ int dormrz_(const char *side, const char *trans, integer *m, integer *n, + integer *k, integer *l, double *a, integer *lda, double *tau, + double *c__, integer *ldc, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + static integer c__65 = 65; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, + i__5; + char ch__1[3]; + + /* Local variables */ + integer i__; + double t[4160] /* was [65][64] */; + integer i1, i2, i3, ib, ic, ja, jc, nb, mi, ni, nq, nw, iws; + bool left; + integer nbmin, iinfo; + bool notran; + integer ldwork; + char transt[1]; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* January 2007 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORMRZ 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 DTZRZF. 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. */ + +/* L (input) INTEGER */ +/* The number of columns of the matrix A containing */ +/* the meaningful part of the Householder reflectors. */ +/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension */ +/* (LDA,M) if SIDE = 'L', */ +/* (LDA,N) if SIDE = 'R' */ +/* The i-th row must contain the vector which defines the */ +/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* DTZRZF in the last k rows 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. LDA >= max(1,K). */ + +/* TAU (input) DOUBLE PRECISION array, dimension (K) */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DTZRZF. */ + +/* 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**H*C or C*Q**H or C*Q. */ + +/* LDC (input) INTEGER */ +/* The leading dimension of the array C. LDC >= max(1,M). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = std::max(1_integer,*n); + } else { + nq = *n; + nw = std::max(1_integer,*m); + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0 || *k > nq) { + *info = -5; + } else if (*l < 0 || left && *l > *m || ! left && *l > *n) { + *info = -6; + } else if (*lda < std::max(1_integer,*k)) { + *info = -8; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -11; + } + + if (*info == 0) { + if (*m == 0 || *n == 0) { + lwkopt = 1; + } else { + +/* Determine the block size. NB may be at most NBMAX, where */ +/* NBMAX is used to define the local array T. */ + +/* Computing MIN */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 64, i__2 = ilaenv_(&c__1, "DORMRQ", ch__1, m, n, k, &c_n1); + nb = std::min(i__1,i__2); + lwkopt = nw * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < std::max(1_integer,nw) && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DORMRZ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + work[1] = 1.; + return 0; + } + + nbmin = 2; + ldwork = nw; + if (nb > 1 && nb < *k) { + iws = nw * nb; + if (*lwork < iws) { + nb = *lwork / ldwork; +/* Computing MAX */ +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = const_cast (side); + i__3[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__3, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__1 = 2, i__2 = ilaenv_(&c__2, "DORMRQ", ch__1, m, n, k, &c_n1); + nbmin = std::max(i__1,i__2); + } + } else { + iws = nw; + } + + if (nb < nbmin || nb >= *k) { + +/* Use unblocked code */ + + dormr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[ + c_offset], ldc, &work[1], &iinfo); + } else { + +/* Use blocked code */ + + if (left && ! notran || ! left && notran) { + i1 = 1; + i2 = *k; + i3 = nb; + } else { + i1 = (*k - 1) / nb * nb + 1; + i2 = 1; + i3 = -nb; + } + + if (left) { + ni = *n; + jc = 1; + ja = *m - *l + 1; + } else { + mi = *m; + ic = 1; + ja = *n - *l + 1; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__4 = nb, i__5 = *k - i__ + 1; + ib = std::min(i__4,i__5); + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + dlarzt_("Backward", "Rowwise", l, &ib, &a[i__ + ja * a_dim1], lda, + &tau[i__], t, &c__65); + + if (left) { + +/* 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__; + } + +/* Apply H or H' */ + + dlarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, &a[ + i__ + ja * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1] +, ldc, &work[1], &ldwork); +/* L10: */ + } + + } + + work[1] = (double) lwkopt; + + return 0; + +/* End of DORMRZ */ + +} /* dormrz_ */ + +/* Subroutine */ int dormtr_(const char *side, const char *uplo, const char *trans, integer *m, + integer *n, double *a, integer *lda, double *tau, double * + c__, integer *ldc, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3; + char ch__1[3]; + + /* Local variables */ + integer i1, i2, nb, mi, ni, nq, nw; + bool left; + integer iinfo; + bool upper; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DORMTR 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 of order nq, with nq = m if */ +/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ +/* nq-1 elementary reflectors, as returned by DSYTRD: */ + +/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ + +/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ + +/* Arguments */ +/* ========= */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'L': apply Q or Q**T from the Left; */ +/* = 'R': apply Q or Q**T from the Right. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A contains elementary reflectors */ +/* from DSYTRD; */ +/* = 'L': Lower triangle of A contains elementary reflectors */ +/* from DSYTRD. */ + +/* 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. */ + +/* A (input) DOUBLE PRECISION array, dimension */ +/* (LDA,M) if SIDE = 'L' */ +/* (LDA,N) if SIDE = 'R' */ +/* The vectors which define the elementary reflectors, as */ +/* returned by DSYTRD. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. */ +/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */ + +/* TAU (input) DOUBLE PRECISION array, dimension */ +/* (M-1) if SIDE = 'L' */ +/* (N-1) if SIDE = 'R' */ +/* TAU(i) must contain the scalar factor of the elementary */ +/* reflector H(i), as returned by DSYTRD. */ + +/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + +/* NQ is the order of Q and NW is the minimum dimension of WORK */ + + if (left) { + nq = *m; + nw = *n; + } else { + nq = *n; + nw = *m; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T")) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,nq)) { + *info = -7; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } else if (*lwork < std::max(1_integer,nw) && ! lquery) { + *info = -12; + } + + if (*info == 0) { + if (upper) { + if (left) { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = const_cast (side); + i__1[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__1, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, "DORMQL", ch__1, &i__2, n, &i__3, &c_n1); + } else { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = const_cast (side); + i__1[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__1, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, "DORMQL", ch__1, m, &i__2, &i__3, &c_n1); + } + } else { + if (left) { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = const_cast (side); + i__1[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__1, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__2 = *m - 1; + i__3 = *m - 1; + nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__2, n, &i__3, &c_n1); + } else { +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = const_cast (side); + i__1[1] = 1, a__1[1] = const_cast (trans); + s_cat(ch__1, a__1, i__1, &c__2, 2_integer); + ch__1 [2] = '\0'; + i__2 = *n - 1; + i__3 = *n - 1; + nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__2, &i__3, &c_n1); + } + } + lwkopt = std::max(1_integer,nw) * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__2 = -(*info); + xerbla_("DORMTR", &i__2); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0 || nq == 1) { + work[1] = 1.; + return 0; + } + + if (left) { + mi = *m - 1; + ni = *n; + } else { + mi = *m; + ni = *n - 1; + } + + if (upper) { + +/* Q was determined by a call to DSYTRD with UPLO = 'U' */ + + i__2 = nq - 1; + dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & + tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo); + } else { + +/* Q was determined by a call to DSYTRD with UPLO = 'L' */ + + if (left) { + i1 = 2; + i2 = 1; + } else { + i1 = 1; + i2 = 2; + } + i__2 = nq - 1; + dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & + c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); + } + work[1] = (double) lwkopt; + return 0; + +/* End of DORMTR */ + +} /* dormtr_ */ + +/* Subroutine */ int dpbcon_(const char *uplo, integer *n, integer *kd, double * + ab, integer *ldab, double *anorm, double *rcond, double * + work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1; + double d__1; + + /* Local variables */ + integer ix, kase; + double scale; + integer isave[3]; + bool upper; + double scalel; + double scaleu; + double ainvnm; + char normin[1]; + double smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBCON estimates the reciprocal of the condition number (in the */ +/* 1-norm) of a real symmetric positive definite band matrix using the */ +/* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF. */ + +/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangular factor stored in AB; */ +/* = 'L': Lower triangular factor stored in AB. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T of the band matrix A, stored in the */ +/* first KD+1 rows of the array. The j-th column of U or L is */ +/* stored in the j-th column of the array AB as follows: */ +/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* ANORM (input) DOUBLE PRECISION */ +/* The 1-norm (or infinity-norm) of the symmetric band matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* estimate of the 1-norm of inv(A) computed in this routine. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } else if (*anorm < 0.) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + + smlnum = dlamch_("Safe minimum"); + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; + *(unsigned char *)normin = 'N'; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (upper) { + +/* Multiply by inv(U'). */ + + dlatbs_("Upper", "Transpose", "Non-unit", normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1], + info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(U). */ + + dlatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1], + info); + } else { + +/* Multiply by inv(L). */ + + dlatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1], + info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(L'). */ + + dlatbs_("Lower", "Transpose", "Non-unit", normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1], + info); + } + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + scale = scalel * scaleu; + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) + { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + +L20: + + return 0; + +/* End of DPBCON */ + +} /* dpbcon_ */ + +/* Subroutine */ int dpbequ_(const char *uplo, integer *n, integer *kd, double * + ab, integer *ldab, double *s, double *scond, double *amax, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double smin; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBEQU computes row and column scalings intended to equilibrate a */ +/* symmetric positive definite band matrix A and reduce its condition */ +/* number (with respect to the two-norm). S contains the scale factors, */ +/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ +/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ +/* choice of S puts the condition number of B within a factor N of the */ +/* smallest possible condition number over all possible diagonal */ +/* scalings. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangular of A is stored; */ +/* = 'L': Lower triangular of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The upper or lower triangle of the symmetric band matrix A, */ +/* stored in the first KD+1 rows of the array. The j-th column */ +/* of A is stored in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array A. LDAB >= KD+1. */ + +/* S (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, S contains the scale factors for A. */ + +/* SCOND (output) DOUBLE PRECISION */ +/* If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* large nor too small, it is not worth scaling by S. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --s; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBEQU", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *scond = 1.; + *amax = 0.; + return 0; + } + + if (upper) { + j = *kd + 1; + } else { + j = 1; + } + +/* Initialize SMIN and AMAX. */ + + s[1] = ab[j + ab_dim1]; + smin = s[1]; + *amax = s[1]; + +/* Find the minimum and maximum diagonal elements. */ + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + s[i__] = ab[j + i__ * ab_dim1]; +/* Computing MIN */ + d__1 = smin, d__2 = s[i__]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = *amax, d__2 = s[i__]; + *amax = std::max(d__1,d__2); +/* L10: */ + } + + if (smin <= 0.) { + +/* Find the first non-positive diagonal element and return. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] <= 0.) { + *info = i__; + return 0; + } +/* L20: */ + } + } else { + +/* Set the scale factors to the reciprocals */ +/* of the diagonal elements. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 1. / sqrt(s[i__]); +/* L30: */ + } + +/* Compute SCOND = min(S(I)) / max(S(I)) */ + + *scond = sqrt(smin) / sqrt(*amax); + } + return 0; + +/* End of DPBEQU */ + +} /* dpbequ_ */ + +/* Subroutine */ int dpbrfs_(const char *uplo, integer *n, integer *kd, integer * + nrhs, double *ab, integer *ldab, double *afb, integer *ldafb, + double *b, integer *ldb, double *x, integer *ldx, double * + ferr, double *berr, double *work, integer *iwork, integer * + info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b12 = -1.; + static double c_b14 = 1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k, l; + double s, xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + integer count; + bool upper; + double safmin; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBRFS improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive definite */ +/* and banded, and provides error bounds and backward error estimates */ +/* for the solution. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The upper or lower triangle of the symmetric band matrix A, */ +/* stored in the first KD+1 rows of the array. The j-th column */ +/* of A is stored in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T of the band matrix A as computed by */ +/* DPBTRF, in the same storage format as A (see AB). */ + +/* LDAFB (input) INTEGER */ +/* The leading dimension of the array AFB. LDAFB >= KD+1. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DPBTRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldafb < *kd + 1) { + *info = -8; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -10; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + +/* Computing MIN */ + i__1 = *n + 1, i__2 = (*kd << 1) + 2; + nz = std::min(i__1,i__2); + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dsbmv_(uplo, n, kd, &c_b12, &ab[ab_offset], ldab, &x[j * x_dim1 + 1], + &c__1, &c_b14, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + l = *kd + 1 - k; +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k - 1; + for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) { + work[i__] += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) + * xk; + s += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L40: */ + } + work[k] = work[k] + (d__1 = ab[*kd + 1 + k * ab_dim1], abs( + d__1)) * xk + s; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + work[k] += (d__1 = ab[k * ab_dim1 + 1], abs(d__1)) * xk; + l = 1 - k; +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = std::min(i__3,i__4); + for (i__ = k + 1; i__ <= i__5; ++i__) { + work[i__] += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) + * xk; + s += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L60: */ + } + work[k] += s; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + 1] +, n, info); + daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A'). */ + + dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] *= work[i__]; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] *= work[i__]; +/* L120: */ + } + dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + + 1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DPBRFS */ + +} /* dpbrfs_ */ + +/* Subroutine */ int dpbstf_(const char *uplo, integer *n, integer *kd, double * + ab, integer *ldab, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b9 = -1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer j, m, km; + double ajj; + integer kld; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBSTF computes a split Cholesky factorization of a real */ +/* symmetric positive definite band matrix A. */ + +/* This routine is designed to be used in conjunction with DSBGST. */ + +/* The factorization has the form A = S**T*S where S is a band matrix */ +/* of the same bandwidth as A and the following structure: */ + +/* S = ( U ) */ +/* ( M L ) */ + +/* where U is upper triangular of order m = (n+kd)/2, and L is lower */ +/* triangular of order n-m. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first kd+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* On exit, if INFO = 0, the factor S from the split Cholesky */ +/* factorization A = S**T*S. See Further Details. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the factorization could not be completed, */ +/* because the updated element a(i,i) was negative; the */ +/* matrix A is not positive definite. */ + +/* Further Details */ +/* =============== */ + +/* The band storage scheme is illustrated by the following example, when */ +/* N = 7, KD = 2: */ + +/* S = ( s11 s12 s13 ) */ +/* ( s22 s23 s24 ) */ +/* ( s33 s34 ) */ +/* ( s44 ) */ +/* ( s53 s54 s55 ) */ +/* ( s64 s65 s66 ) */ +/* ( s75 s76 s77 ) */ + +/* If UPLO = 'U', the array AB holds: */ + +/* on entry: on exit: */ + +/* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 */ +/* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 */ +/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */ + +/* If UPLO = 'L', the array AB holds: */ + +/* on entry: on exit: */ + +/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */ +/* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * */ +/* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * */ + +/* Array elements marked * are not used by the routine. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBSTF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Computing MAX */ + i__1 = 1, i__2 = *ldab - 1; + kld = std::max(i__1,i__2); + +/* Set the splitting point m. */ + + m = (*n + *kd) / 2; + + if (upper) { + +/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */ + + i__1 = m + 1; + for (j = *n; j >= i__1; --j) { + +/* Compute s(j,j) and test for non-positive-definiteness. */ + + ajj = ab[*kd + 1 + j * ab_dim1]; + if (ajj <= 0.) { + goto L50; + } + ajj = sqrt(ajj); + ab[*kd + 1 + j * ab_dim1] = ajj; +/* Computing MIN */ + i__2 = j - 1; + km = std::min(i__2,*kd); + +/* Compute elements j-km:j-1 of the j-th column and update the */ +/* the leading submatrix within the band. */ + + d__1 = 1. / ajj; + dscal_(&km, &d__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1); + dsyr_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1, + &ab[*kd + 1 + (j - km) * ab_dim1], &kld); +/* L10: */ + } + +/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */ + + i__1 = m; + for (j = 1; j <= i__1; ++j) { + +/* Compute s(j,j) and test for non-positive-definiteness. */ + + ajj = ab[*kd + 1 + j * ab_dim1]; + if (ajj <= 0.) { + goto L50; + } + ajj = sqrt(ajj); + ab[*kd + 1 + j * ab_dim1] = ajj; +/* Computing MIN */ + i__2 = *kd, i__3 = m - j; + km = std::min(i__2,i__3); + +/* Compute elements j+1:j+km of the j-th row and update the */ +/* trailing submatrix within the band. */ + + if (km > 0) { + d__1 = 1. / ajj; + dscal_(&km, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld); + dsyr_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld, + &ab[*kd + 1 + (j + 1) * ab_dim1], &kld); + } +/* L20: */ + } + } else { + +/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */ + + i__1 = m + 1; + for (j = *n; j >= i__1; --j) { + +/* Compute s(j,j) and test for non-positive-definiteness. */ + + ajj = ab[j * ab_dim1 + 1]; + if (ajj <= 0.) { + goto L50; + } + ajj = sqrt(ajj); + ab[j * ab_dim1 + 1] = ajj; +/* Computing MIN */ + i__2 = j - 1; + km = std::min(i__2,*kd); + +/* Compute elements j-km:j-1 of the j-th row and update the */ +/* trailing submatrix within the band. */ + + d__1 = 1. / ajj; + dscal_(&km, &d__1, &ab[km + 1 + (j - km) * ab_dim1], &kld); + dsyr_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld, + &ab[(j - km) * ab_dim1 + 1], &kld); +/* L30: */ + } + +/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */ + + i__1 = m; + for (j = 1; j <= i__1; ++j) { + +/* Compute s(j,j) and test for non-positive-definiteness. */ + + ajj = ab[j * ab_dim1 + 1]; + if (ajj <= 0.) { + goto L50; + } + ajj = sqrt(ajj); + ab[j * ab_dim1 + 1] = ajj; +/* Computing MIN */ + i__2 = *kd, i__3 = m - j; + km = std::min(i__2,i__3); + +/* Compute elements j+1:j+km of the j-th column and update the */ +/* trailing submatrix within the band. */ + + if (km > 0) { + d__1 = 1. / ajj; + dscal_(&km, &d__1, &ab[j * ab_dim1 + 2], &c__1); + dsyr_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[( + j + 1) * ab_dim1 + 1], &kld); + } +/* L40: */ + } + } + return 0; + +L50: + *info = j; + return 0; + +/* End of DPBSTF */ + +} /* dpbstf_ */ + +/* Subroutine */ int dpbsv_(const char *uplo, integer *n, integer *kd, integer * + nrhs, double *ab, integer *ldab, double *b, integer *ldb, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBSV computes the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N symmetric positive definite band matrix and X */ +/* and B are N-by-NRHS matrices. */ + +/* The Cholesky decomposition is used to factor A as */ +/* A = U**T * U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular band matrix, and L is a lower */ +/* triangular band matrix, with the same number of superdiagonals or */ +/* subdiagonals as A. The factored form of A is then used to solve the */ +/* system of equations A * X = B. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */ +/* See below for further details. */ + +/* On exit, if INFO = 0, the triangular factor U or L from the */ +/* Cholesky factorization A = U**T*U or A = L*L**T of the band */ +/* matrix A, in the same storage format as A. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the leading minor of order i of A is not */ +/* positive definite, so the factorization could not be */ +/* completed, and the solution has not been computed. */ + +/* Further Details */ +/* =============== */ + +/* The band storage scheme is illustrated by the following example, when */ +/* N = 6, KD = 2, and UPLO = 'U': */ + +/* On entry: On exit: */ + +/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ +/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ + +/* Similarly, if UPLO = 'L' the format of A is as follows: */ + +/* On entry: On exit: */ + +/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ +/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ +/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ + +/* Array elements marked * are not used by the routine. */ + +/* ===================================================================== */ + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBSV ", &i__1); + return 0; + } + +/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ + + dpbtrf_(uplo, n, kd, &ab[ab_offset], ldab, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dpbtrs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &b[b_offset], ldb, + info); + + } + return 0; + +/* End of DPBSV */ + +} /* dpbsv_ */ + +/* Subroutine */ int dpbsvx_(const char *fact, const char *uplo, integer *n, integer *kd, + integer *nrhs, double *ab, integer *ldab, double *afb, + integer *ldafb, char *equed, double *s, double *b, integer * + ldb, double *x, integer *ldx, double *rcond, double *ferr, + double *berr, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, j1, j2; + double amax, smin, smax; + double scond, anorm; + bool equil, rcequ, upper; + bool nofact; + double bignum; + integer infequ; + double smlnum; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */ +/* compute the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N symmetric positive definite band matrix and X */ +/* and B are N-by-NRHS matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* the system: */ +/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ +/* Whether or not the system will be equilibrated depends on the */ +/* scaling of the matrix A, but if equilibration is used, A is */ +/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ + +/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ +/* factor the matrix A (after equilibration if FACT = 'E') as */ +/* A = U**T * U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular band matrix, and L is a lower */ +/* triangular band matrix. */ + +/* 3. If the leading i-by-i principal minor is not positive definite, */ +/* then the routine returns with INFO = i. Otherwise, the factored */ +/* form of A is used to estimate the condition number of the matrix */ +/* A. If the reciprocal of the condition number is less than machine */ +/* precision, INFO = N+1 is returned as a warning, but the routine */ +/* still goes on to solve for X and compute error bounds as */ +/* described below. */ + +/* 4. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 5. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* 6. If equilibration was used, the matrix X is premultiplied by */ +/* diag(S) so that it solves the original system before */ +/* equilibration. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of the matrix A is */ +/* supplied on entry, and if not, whether the matrix A should be */ +/* equilibrated before it is factored. */ +/* = 'F': On entry, AFB contains the factored form of A. */ +/* If EQUED = 'Y', the matrix A has been equilibrated */ +/* with scaling factors given by S. AB and AFB will not */ +/* be modified. */ +/* = 'N': The matrix A will be copied to AFB and factored. */ +/* = 'E': The matrix A will be equilibrated if necessary, then */ +/* copied to AFB and factored. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right-hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array, except */ +/* if FACT = 'F' and EQUED = 'Y', then A must contain the */ +/* equilibrated matrix diag(S)*A*diag(S). The j-th column of A */ +/* is stored in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */ +/* See below for further details. */ + +/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* diag(S)*A*diag(S). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array A. LDAB >= KD+1. */ + +/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* If FACT = 'F', then AFB is an input argument and on entry */ +/* contains the triangular factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T of the band matrix */ +/* A, in the same storage format as A (see AB). If EQUED = 'Y', */ +/* then AFB is the factored form of the equilibrated matrix A. */ + +/* If FACT = 'N', then AFB is an output argument and on exit */ +/* returns the triangular factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T. */ + +/* If FACT = 'E', then AFB is an output argument and on exit */ +/* returns the triangular factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T of the equilibrated */ +/* matrix A (see the description of A for the form of the */ +/* equilibrated matrix). */ + +/* LDAFB (input) INTEGER */ +/* The leading dimension of the array AFB. LDAFB >= KD+1. */ + +/* EQUED (input or output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration (always true if FACT = 'N'). */ +/* = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* diag(S) * A * diag(S). */ +/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* output argument. */ + +/* S (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A; not accessed if EQUED = 'N'. S is */ +/* an input argument if FACT = 'F'; otherwise, S is an output */ +/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */ +/* must be positive. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ +/* B is overwritten by diag(S) * B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ +/* the original system of equations. Note that if EQUED = 'Y', */ +/* A and B are modified on exit, and the solution to the */ +/* equilibrated system is inv(diag(S))*X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The estimate of the reciprocal condition number of the matrix */ +/* A after equilibration (if done). If RCOND is less than the */ +/* machine precision (in particular, if RCOND = 0), the matrix */ +/* is singular to working precision. This condition is */ +/* indicated by a return code of INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= N: the leading minor of order i of A is */ +/* not positive definite, so the factorization */ +/* could not be completed, and the solution has not */ +/* been computed. RCOND = 0 is returned. */ +/* = N+1: U is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* Further Details */ +/* =============== */ + +/* The band storage scheme is illustrated by the following example, when */ +/* N = 6, KD = 2, and UPLO = 'U': */ + +/* Two-dimensional storage of the symmetric matrix A: */ + +/* a11 a12 a13 */ +/* a22 a23 a24 */ +/* a33 a34 a35 */ +/* a44 a45 a46 */ +/* a55 a56 */ +/* (aij=conjg(aji)) a66 */ + +/* Band storage of the upper triangle of A: */ + +/* * * a13 a24 a35 a46 */ +/* * a12 a23 a34 a45 a56 */ +/* a11 a22 a33 a44 a55 a66 */ + +/* Similarly, if UPLO = 'L' the format of A is as follows: */ + +/* a11 a22 a33 a44 a55 a66 */ +/* a21 a32 a43 a54 a65 * */ +/* a31 a42 a53 a64 * * */ + +/* Array elements marked * are not used by the routine. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + upper = lsame_(uplo, "U"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = false; + } else { + rcequ = lsame_(equed, "Y"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } else if (*ldafb < *kd + 1) { + *info = -9; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -10; + } else { + if (rcequ) { + smin = bignum; + smax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = smin, d__2 = s[j]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = smax, d__2 = s[j]; + smax = std::max(d__1,d__2); +/* L10: */ + } + if (smin <= 0.) { + *info = -11; + } else if (*n > 0) { + scond = std::max(smin,smlnum) / std::min(smax,bignum); + } else { + scond = 1.; + } + } + if (*info == 0) { + if (*ldb < std::max(1_integer,*n)) { + *info = -13; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -15; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBSVX", &i__1); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dpbequ_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, & + infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqsb_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, + equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right-hand side. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1]; +/* L20: */ + } +/* L30: */ + } + } + + if (nofact || equil) { + +/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *kd; + j1 = std::max(i__2,1_integer); + i__2 = j - j1 + 1; + dcopy_(&i__2, &ab[*kd + 1 - j + j1 + j * ab_dim1], &c__1, & + afb[*kd + 1 - j + j1 + j * afb_dim1], &c__1); +/* L40: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + *kd; + j2 = std::min(i__2,*n); + i__2 = j2 - j + 1; + dcopy_(&i__2, &ab[j * ab_dim1 + 1], &c__1, &afb[j * afb_dim1 + + 1], &c__1); +/* L50: */ + } + } + + dpbtrf_(uplo, n, kd, &afb[afb_offset], ldafb, info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlansb_("1", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dpbcon_(uplo, n, kd, &afb[afb_offset], ldafb, &anorm, rcond, &work[1], & + iwork[1], info); + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dpbtrs_(uplo, n, kd, nrhs, &afb[afb_offset], ldafb, &x[x_offset], ldx, + info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dpbrfs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, + &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] +, &iwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1]; +/* L60: */ + } +/* L70: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= scond; +/* L80: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of DPBSVX */ + +} /* dpbsvx_ */ + +/* Subroutine */ int dpbtf2_(const char *uplo, integer *n, integer *kd, double * + ab, integer *ldab, integer *info) +{ + /* Table of constant values */ + static double c_b8 = -1.; + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer j, kn; + double ajj; + integer kld; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBTF2 computes the Cholesky factorization of a real symmetric */ +/* positive definite band matrix A. */ + +/* The factorization has the form */ +/* A = U' * U , if UPLO = 'U', or */ +/* A = L * L', if UPLO = 'L', */ +/* where U is an upper triangular matrix, U' is the transpose of U, and */ +/* L is lower triangular. */ + +/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored: */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* On exit, if INFO = 0, the triangular factor U or L from the */ +/* Cholesky factorization A = U'*U or A = L*L' of the band */ +/* matrix A, in the same storage format as A. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > 0: if INFO = k, the leading minor of order k is not */ +/* positive definite, and the factorization could not be */ +/* completed. */ + +/* Further Details */ +/* =============== */ + +/* The band storage scheme is illustrated by the following example, when */ +/* N = 6, KD = 2, and UPLO = 'U': */ + +/* On entry: On exit: */ + +/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ +/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ + +/* Similarly, if UPLO = 'L' the format of A is as follows: */ + +/* On entry: On exit: */ + +/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ +/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ +/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ + +/* Array elements marked * are not used by the routine. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBTF2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Computing MAX */ + i__1 = 1, i__2 = *ldab - 1; + kld = std::max(i__1,i__2); + + if (upper) { + +/* Compute the Cholesky factorization A = U'*U. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute U(J,J) and test for non-positive-definiteness. */ + + ajj = ab[*kd + 1 + j * ab_dim1]; + if (ajj <= 0.) { + goto L30; + } + ajj = sqrt(ajj); + ab[*kd + 1 + j * ab_dim1] = ajj; + +/* Compute elements J+1:J+KN of row J and update the */ +/* trailing submatrix within the band. */ + +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + kn = std::min(i__2,i__3); + if (kn > 0) { + d__1 = 1. / ajj; + dscal_(&kn, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld); + dsyr_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld, + &ab[*kd + 1 + (j + 1) * ab_dim1], &kld); + } +/* L10: */ + } + } else { + +/* Compute the Cholesky factorization A = L*L'. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute L(J,J) and test for non-positive-definiteness. */ + + ajj = ab[j * ab_dim1 + 1]; + if (ajj <= 0.) { + goto L30; + } + ajj = sqrt(ajj); + ab[j * ab_dim1 + 1] = ajj; + +/* Compute elements J+1:J+KN of column J and update the */ +/* trailing submatrix within the band. */ + +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + kn = std::min(i__2,i__3); + if (kn > 0) { + d__1 = 1. / ajj; + dscal_(&kn, &d__1, &ab[j * ab_dim1 + 2], &c__1); + dsyr_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[( + j + 1) * ab_dim1 + 1], &kld); + } +/* L20: */ + } + } + return 0; + +L30: + *info = j; + return 0; + +/* End of DPBTF2 */ + +} /* dpbtf2_ */ + +/* Subroutine */ int dpbtrf_(const char *uplo, integer *n, integer *kd, double * + ab, integer *ldab, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b18 = 1.; + static double c_b21 = -1.; + static integer c__33 = 33; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, i2, i3, ib, nb, ii, jj; + double work[1056] /* was [33][32] */; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBTRF computes the Cholesky factorization of a real symmetric */ +/* positive definite band matrix A. */ + +/* The factorization has the form */ +/* A = U**T * U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is lower triangular. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* On exit, if INFO = 0, the triangular factor U or L from the */ +/* Cholesky factorization A = U**T*U or A = L*L**T of the band */ +/* matrix A, in the same storage format as A. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the leading minor of order i is not */ +/* positive definite, and the factorization could not be */ +/* completed. */ + +/* Further Details */ +/* =============== */ + +/* The band storage scheme is illustrated by the following example, when */ +/* N = 6, KD = 2, and UPLO = 'U': */ + +/* On entry: On exit: */ + +/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ +/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ + +/* Similarly, if UPLO = 'L' the format of A is as follows: */ + +/* On entry: On exit: */ + +/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ +/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ +/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ + +/* Array elements marked * are not used by the routine. */ + +/* Contributed by */ +/* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*ldab < *kd + 1) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBTRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment */ + + nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1); + +/* The block size must not exceed the semi-bandwidth KD, and must not */ +/* exceed the limit set by the size of the local array WORK. */ + + nb = std::min(nb,32_integer); + + if (nb <= 1 || nb > *kd) { + +/* Use unblocked code */ + + dpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info); + } else { + +/* Use blocked code */ + + if (lsame_(uplo, "U")) { + +/* Compute the Cholesky factorization of a symmetric band */ +/* matrix, given the upper triangle of the matrix in band */ +/* storage. */ + +/* Zero the upper triangle of the work array. */ + + i__1 = nb; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * 33 - 34] = 0.; +/* L10: */ + } +/* L20: */ + } + +/* Process the band matrix one diagonal block at a time. */ + + i__1 = *n; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = std::min(i__3,i__4); + +/* Factorize the diagonal block */ + + i__3 = *ldab - 1; + dpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii); + if (ii != 0) { + *info = i__ + ii - 1; + goto L150; + } + if (i__ + ib <= *n) { + +/* Update the relevant part of the trailing submatrix. */ +/* If A11 denotes the diagonal block which has just been */ +/* factorized, then we need to update the remaining */ +/* blocks in the diagram: */ + +/* A11 A12 A13 */ +/* A22 A23 */ +/* A33 */ + +/* The numbers of rows and columns in the partitioning */ +/* are IB, I2, I3 respectively. The blocks A12, A22 and */ +/* A23 are empty if IB = KD. The upper triangle of A13 */ +/* lies outside the band. */ + +/* Computing MIN */ + i__3 = *kd - ib, i__4 = *n - i__ - ib + 1; + i2 = std::min(i__3,i__4); +/* Computing MIN */ + i__3 = ib, i__4 = *n - i__ - *kd + 1; + i3 = std::min(i__3,i__4); + + if (i2 > 0) { + +/* Update A12 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, + &i2, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], & + i__3, &ab[*kd + 1 - ib + (i__ + ib) * ab_dim1] +, &i__4); + +/* Update A22 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &ab[* + kd + 1 - ib + (i__ + ib) * ab_dim1], &i__3, & + c_b18, &ab[*kd + 1 + (i__ + ib) * ab_dim1], & + i__4); + } + + if (i3 > 0) { + +/* Copy the lower triangle of A13 into the work array. */ + + i__3 = i3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = ib; + for (ii = jj; ii <= i__4; ++ii) { + work[ii + jj * 33 - 34] = ab[ii - jj + 1 + ( + jj + i__ + *kd - 1) * ab_dim1]; +/* L30: */ + } +/* L40: */ + } + +/* Update A13 (in the work array). */ + + i__3 = *ldab - 1; + dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, + &i3, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], & + i__3, work, &c__33); + +/* Update A23 */ + + if (i2 > 0) { + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dgemm_("Transpose", "No Transpose", &i2, &i3, &ib, + &c_b21, &ab[*kd + 1 - ib + (i__ + ib) * + ab_dim1], &i__3, work, &c__33, &c_b18, & + ab[ib + 1 + (i__ + *kd) * ab_dim1], &i__4); + } + +/* Update A33 */ + + i__3 = *ldab - 1; + dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, & + c__33, &c_b18, &ab[*kd + 1 + (i__ + *kd) * + ab_dim1], &i__3); + +/* Copy the lower triangle of A13 back into place. */ + + i__3 = i3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = ib; + for (ii = jj; ii <= i__4; ++ii) { + ab[ii - jj + 1 + (jj + i__ + *kd - 1) * + ab_dim1] = work[ii + jj * 33 - 34]; +/* L50: */ + } +/* L60: */ + } + } + } +/* L70: */ + } + } else { + +/* Compute the Cholesky factorization of a symmetric band */ +/* matrix, given the lower triangle of the matrix in band */ +/* storage. */ + +/* Zero the lower triangle of the work array. */ + + i__2 = nb; + for (j = 1; j <= i__2; ++j) { + i__1 = nb; + for (i__ = j + 1; i__ <= i__1; ++i__) { + work[i__ + j * 33 - 34] = 0.; +/* L80: */ + } +/* L90: */ + } + +/* Process the band matrix one diagonal block at a time. */ + + i__2 = *n; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = std::min(i__3,i__4); + +/* Factorize the diagonal block */ + + i__3 = *ldab - 1; + dpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii); + if (ii != 0) { + *info = i__ + ii - 1; + goto L150; + } + if (i__ + ib <= *n) { + +/* Update the relevant part of the trailing submatrix. */ +/* If A11 denotes the diagonal block which has just been */ +/* factorized, then we need to update the remaining */ +/* blocks in the diagram: */ + +/* A11 */ +/* A21 A22 */ +/* A31 A32 A33 */ + +/* The numbers of rows and columns in the partitioning */ +/* are IB, I2, I3 respectively. The blocks A21, A22 and */ +/* A32 are empty if IB = KD. The lower triangle of A31 */ +/* lies outside the band. */ + +/* Computing MIN */ + i__3 = *kd - ib, i__4 = *n - i__ - ib + 1; + i2 = std::min(i__3,i__4); +/* Computing MIN */ + i__3 = ib, i__4 = *n - i__ - *kd + 1; + i3 = std::min(i__3,i__4); + + if (i2 > 0) { + +/* Update A21 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i2, + &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, & + ab[ib + 1 + i__ * ab_dim1], &i__4); + +/* Update A22 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dsyrk_("Lower", "No Transpose", &i2, &ib, &c_b21, &ab[ + ib + 1 + i__ * ab_dim1], &i__3, &c_b18, &ab[( + i__ + ib) * ab_dim1 + 1], &i__4); + } + + if (i3 > 0) { + +/* Copy the upper triangle of A31 into the work array. */ + + i__3 = ib; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = std::min(jj,i3); + for (ii = 1; ii <= i__4; ++ii) { + work[ii + jj * 33 - 34] = ab[*kd + 1 - jj + + ii + (jj + i__ - 1) * ab_dim1]; +/* L100: */ + } +/* L110: */ + } + +/* Update A31 (in the work array). */ + + i__3 = *ldab - 1; + dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i3, + &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, + work, &c__33); + +/* Update A32 */ + + if (i2 > 0) { + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dgemm_("No transpose", "Transpose", &i3, &i2, &ib, + &c_b21, work, &c__33, &ab[ib + 1 + i__ * + ab_dim1], &i__3, &c_b18, &ab[*kd + 1 - ib + + (i__ + ib) * ab_dim1], &i__4); + } + +/* Update A33 */ + + i__3 = *ldab - 1; + dsyrk_("Lower", "No Transpose", &i3, &ib, &c_b21, + work, &c__33, &c_b18, &ab[(i__ + *kd) * + ab_dim1 + 1], &i__3); + +/* Copy the upper triangle of A31 back into place. */ + + i__3 = ib; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = std::min(jj,i3); + for (ii = 1; ii <= i__4; ++ii) { + ab[*kd + 1 - jj + ii + (jj + i__ - 1) * + ab_dim1] = work[ii + jj * 33 - 34]; +/* L120: */ + } +/* L130: */ + } + } + } +/* L140: */ + } + } + } + return 0; + +L150: + return 0; + +/* End of DPBTRF */ + +} /* dpbtrf_ */ + +/* Subroutine */ int dpbtrs_(const char *uplo, integer *n, integer *kd, integer * + nrhs, double *ab, integer *ldab, double *b, integer *ldb, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer j; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPBTRS solves a system of linear equations A*X = B with a symmetric */ +/* positive definite band matrix A using the Cholesky factorization */ +/* A = U**T*U or A = L*L**T computed by DPBTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangular factor stored in AB; */ +/* = 'L': Lower triangular factor stored in AB. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T of the band matrix A, stored in the */ +/* first KD+1 rows of the array. The j-th column of U or L is */ +/* stored in the j-th column of the array AB as follows: */ +/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kd < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPBTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B where A = U'*U. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve U'*X = B, overwriting B with X. */ + + dtbsv_("Upper", "Transpose", "Non-unit", n, kd, &ab[ab_offset], + ldab, &b[j * b_dim1 + 1], &c__1); + +/* Solve U*X = B, overwriting B with X. */ + + dtbsv_("Upper", "No transpose", "Non-unit", n, kd, &ab[ab_offset], + ldab, &b[j * b_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Solve A*X = B where A = L*L'. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve L*X = B, overwriting B with X. */ + + dtbsv_("Lower", "No transpose", "Non-unit", n, kd, &ab[ab_offset], + ldab, &b[j * b_dim1 + 1], &c__1); + +/* Solve L'*X = B, overwriting B with X. */ + + dtbsv_("Lower", "Transpose", "Non-unit", n, kd, &ab[ab_offset], + ldab, &b[j * b_dim1 + 1], &c__1); +/* L20: */ + } + } + + return 0; + +/* End of DPBTRS */ + +} /* dpbtrs_ */ + +int dpftrf_(const char *transr, const char *uplo, integer *n, double *a, integer *info) +{ + /* Table of constant values */ + static double c_b12 = 1.; + static double c_b15 = -1.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer k, n1, n2; + bool normaltransr; + bool lower; + bool nisodd; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ + +/* Purpose */ +/* ======= */ + +/* DPFTRF computes the Cholesky factorization of a real symmetric */ +/* positive definite matrix A. */ + +/* The factorization has the form */ +/* A = U**T * U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is lower triangular. */ + +/* This is the block version of the algorithm, calling Level 3 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': The Normal TRANSR of RFP A is stored; */ +/* = 'T': The Transpose TRANSR of RFP A is stored. */ + +/* UPLO (input) CHARACTER */ +/* = 'U': Upper triangle of RFP A is stored; */ +/* = 'L': Lower triangle of RFP A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); */ +/* On entry, the symmetric matrix A in RFP format. RFP format is */ +/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ +/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ +/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */ +/* the transpose of RFP A as defined when */ +/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ +/* follows: If UPLO = 'U' the RFP A contains the NT elements of */ +/* upper packed A. If UPLO = 'L' the RFP A contains the elements */ +/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */ +/* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N */ +/* is odd. See the Note below for more details. */ + +/* On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* factorization RFP A = U**T*U or RFP A = L*L**T. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the leading minor of order i is not */ +/* positive definite, and the factorization could not be */ +/* completed. */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPFTRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = false; + } else { + nisodd = true; + } + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(n1) */ + + dpotrf_("L", &n1, a, n, info); + if (*info > 0) { + return 0; + } + dtrsm_("R", "L", "T", "N", &n2, &n1, &c_b12, a, n, &a[n1], n); + dsyrk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b12, &a[*n], + n); + dpotrf_("U", &n2, &a[*n], n, info); + if (*info > 0) { + *info += n1; + } + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ +/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ +/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ + + dpotrf_("L", &n1, &a[n2], n, info); + if (*info > 0) { + return 0; + } + dtrsm_("L", "L", "N", "N", &n1, &n2, &c_b12, &a[n2], n, a, n); + dsyrk_("U", "T", &n2, &n1, &c_b15, a, n, &c_b12, &a[n1], n); + dpotrf_("U", &n2, &a[n1], n, info); + if (*info > 0) { + *info += n1; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is odd */ +/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */ +/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */ + + dpotrf_("U", &n1, a, &n1, info); + if (*info > 0) { + return 0; + } + dtrsm_("L", "U", "T", "N", &n1, &n2, &c_b12, a, &n1, &a[n1 * + n1], &n1); + dsyrk_("L", "T", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b12, & + a[1], &n1); + dpotrf_("L", &n2, &a[1], &n1, info); + if (*info > 0) { + *info += n1; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */ +/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */ + + dpotrf_("U", &n1, &a[n2 * n2], &n2, info); + if (*info > 0) { + return 0; + } + dtrsm_("R", "U", "N", "N", &n2, &n1, &c_b12, &a[n2 * n2], &n2, + a, &n2); + dsyrk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b12, &a[n1 * n2] +, &n2); + dpotrf_("L", &n2, &a[n1 * n2], &n2, info); + if (*info > 0) { + *info += n1; + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + i__1 = *n + 1; + dpotrf_("L", &k, &a[1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrsm_("R", "L", "T", "N", &k, &k, &c_b12, &a[1], &i__1, &a[k + + 1], &i__2); + i__1 = *n + 1; + i__2 = *n + 1; + dsyrk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b12, a, + &i__2); + i__1 = *n + 1; + dpotrf_("U", &k, a, &i__1, info); + if (*info > 0) { + *info += k; + } + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + i__1 = *n + 1; + dpotrf_("L", &k, &a[k + 1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrsm_("L", "L", "N", "N", &k, &k, &c_b12, &a[k + 1], &i__1, + a, &i__2); + i__1 = *n + 1; + i__2 = *n + 1; + dsyrk_("U", "T", &k, &k, &c_b15, a, &i__1, &c_b12, &a[k], & + i__2); + i__1 = *n + 1; + dpotrf_("U", &k, &a[k], &i__1, info); + if (*info > 0) { + *info += k; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + dpotrf_("U", &k, &a[k], &k, info); + if (*info > 0) { + return 0; + } + dtrsm_("L", "U", "T", "N", &k, &k, &c_b12, &a[k], &n1, &a[k * + (k + 1)], &k); + dsyrk_("L", "T", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b12, + a, &k); + dpotrf_("L", &k, a, &k, info); + if (*info > 0) { + *info += k; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + dpotrf_("U", &k, &a[k * (k + 1)], &k, info); + if (*info > 0) { + return 0; + } + dtrsm_("R", "U", "N", "N", &k, &k, &c_b12, &a[k * (k + 1)], & + k, a, &k); + dsyrk_("L", "N", &k, &k, &c_b15, a, &k, &c_b12, &a[k * k], &k); + dpotrf_("L", &k, &a[k * k], &k, info); + if (*info > 0) { + *info += k; + } + + } + + } + + } + + return 0; + +/* End of DPFTRF */ + +} /* dpftrf_ */ + +int dpftri_(const char *transr, const char *uplo, integer *n, double *a, integer *info) +{ + /* Table of constant values */ + static double c_b11 = 1.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer k, n1, n2; + bool normaltransr, lower, nisodd; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPFTRI computes the inverse of a (real) symmetric positive definite */ +/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ +/* computed by DPFTRF. */ + +/* Arguments */ +/* ========= */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': The Normal TRANSR of RFP A is stored; */ +/* = 'T': The Transpose TRANSR of RFP A is stored. */ + +/* UPLO (input) CHARACTER */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ) */ +/* On entry, the symmetric matrix A in RFP format. RFP format is */ +/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ +/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ +/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */ +/* the transpose of RFP A as defined when */ +/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ +/* follows: If UPLO = 'U' the RFP A contains the nt elements of */ +/* upper packed A. If UPLO = 'L' the RFP A contains the elements */ +/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */ +/* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N */ +/* is odd. See the Note below for more details. */ + +/* On exit, the symmetric inverse of the original matrix, in the */ +/* same storage format. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the (i,i) element of the factor U or L is */ +/* zero, and the inverse could not be computed. */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPFTRI", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Invert the triangular Cholesky factor U or L. */ + + dtftri_(transr, uplo, "N", n, a, info); + if (*info > 0) { + return 0; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = false; + } else { + nisodd = true; + } + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */ +/* inv(L)^C*inv(L). There are eight cases. */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(N1) */ + + dlauum_("L", &n1, a, n, info); + dsyrk_("L", "T", &n1, &n2, &c_b11, &a[n1], n, &c_b11, a, n); + dtrmm_("L", "U", "N", "N", &n2, &n1, &c_b11, &a[*n], n, &a[n1] +, n); + dlauum_("U", &n2, &a[*n], n, info); + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */ +/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */ +/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */ + + dlauum_("L", &n1, &a[n2], n, info); + dsyrk_("L", "N", &n1, &n2, &c_b11, a, n, &c_b11, &a[n2], n); + dtrmm_("R", "U", "T", "N", &n1, &n2, &c_b11, &a[n1], n, a, n); + dlauum_("U", &n2, &a[n1], n, info); + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE, and N is odd */ +/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */ + + dlauum_("U", &n1, a, &n1, info); + dsyrk_("U", "N", &n1, &n2, &c_b11, &a[n1 * n1], &n1, &c_b11, + a, &n1); + dtrmm_("R", "L", "N", "N", &n1, &n2, &c_b11, &a[1], &n1, &a[ + n1 * n1], &n1); + dlauum_("L", &n2, &a[1], &n1, info); + + } else { + +/* SRPA for UPPER, TRANSPOSE, and N is odd */ +/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */ + + dlauum_("U", &n1, &a[n2 * n2], &n2, info); + dsyrk_("U", "T", &n1, &n2, &c_b11, a, &n2, &c_b11, &a[n2 * n2] +, &n2); + dtrmm_("L", "L", "T", "N", &n2, &n1, &c_b11, &a[n1 * n2], &n2, + a, &n2); + dlauum_("L", &n2, &a[n1 * n2], &n2, info); + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + i__1 = *n + 1; + dlauum_("L", &k, &a[1], &i__1, info); + i__1 = *n + 1; + i__2 = *n + 1; + dsyrk_("L", "T", &k, &k, &c_b11, &a[k + 1], &i__1, &c_b11, &a[ + 1], &i__2); + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("L", "U", "N", "N", &k, &k, &c_b11, a, &i__1, &a[k + 1] +, &i__2); + i__1 = *n + 1; + dlauum_("U", &k, a, &i__1, info); + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + i__1 = *n + 1; + dlauum_("L", &k, &a[k + 1], &i__1, info); + i__1 = *n + 1; + i__2 = *n + 1; + dsyrk_("L", "N", &k, &k, &c_b11, a, &i__1, &c_b11, &a[k + 1], + &i__2); + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("R", "U", "T", "N", &k, &k, &c_b11, &a[k], &i__1, a, & + i__2); + i__1 = *n + 1; + dlauum_("U", &k, &a[k], &i__1, info); + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + dlauum_("U", &k, &a[k], &k, info); + dsyrk_("U", "N", &k, &k, &c_b11, &a[k * (k + 1)], &k, &c_b11, + &a[k], &k); + dtrmm_("R", "L", "N", "N", &k, &k, &c_b11, a, &k, &a[k * (k + + 1)], &k); + dlauum_("L", &k, a, &k, info); + + } else { + +/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + dlauum_("U", &k, &a[k * (k + 1)], &k, info); + dsyrk_("U", "T", &k, &k, &c_b11, a, &k, &c_b11, &a[k * (k + 1) + ], &k); + dtrmm_("L", "L", "T", "N", &k, &k, &c_b11, &a[k * k], &k, a, & + k); + dlauum_("L", &k, &a[k * k], &k, info); + + } + + } + + } + + return 0; + +/* End of DPFTRI */ + +} /* dpftri_ */ + +int dpftrs_(char *transr, char *uplo, integer *n, integer *nrhs, double *a, double *b, integer *ldb, integer *info) +{ + /* Table of constant values */ + static double c_b10 = 1.; + + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + bool normaltransr, lower; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPFTRS solves a system of linear equations A*X = B with a symmetric */ +/* positive definite matrix A using the Cholesky factorization */ +/* A = U**T*U or A = L*L**T computed by DPFTRF. */ + +/* Arguments */ +/* ========= */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': The Normal TRANSR of RFP A is stored; */ +/* = 'T': The Transpose TRANSR of RFP A is stored. */ + +/* UPLO (input) CHARACTER */ +/* = 'U': Upper triangle of RFP A is stored; */ +/* = 'L': Lower triangle of RFP A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ). */ +/* The triangular factor U or L from the Cholesky factorization */ +/* of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF. */ +/* See note below for more details about RFP A. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPFTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* start execution: there are two triangular solves */ + + if (lower) { + dtfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b10, a, &b[b_offset], + ldb); + dtfsm_(transr, "L", uplo, "T", "N", n, nrhs, &c_b10, a, &b[b_offset], + ldb); + } else { + dtfsm_(transr, "L", uplo, "T", "N", n, nrhs, &c_b10, a, &b[b_offset], + ldb); + dtfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b10, a, &b[b_offset], + ldb); + } + + return 0; + +/* End of DPFTRS */ + +} /* dpftrs_ */ + +/* Subroutine */ int dpocon_(const char *uplo, integer *n, double *a, integer * + lda, double *anorm, double *rcond, double *work, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1; + double d__1; + + /* Local variables */ + integer ix, kase; + double scale; + integer isave[3]; + bool upper; + double scalel; + double scaleu; + double ainvnm; + char normin[1]; + double smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOCON estimates the reciprocal of the condition number (in the */ +/* 1-norm) of a real symmetric positive definite matrix using the */ +/* Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF. */ + +/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* ANORM (input) DOUBLE PRECISION */ +/* The 1-norm (or infinity-norm) of the symmetric matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* estimate of the 1-norm of inv(A) computed in this routine. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else if (*anorm < 0.) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + + smlnum = dlamch_("Safe minimum"); + +/* Estimate the 1-norm of inv(A). */ + + kase = 0; + *(unsigned char *)normin = 'N'; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (upper) { + +/* Multiply by inv(U'). */ + + dlatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset], + lda, &work[1], &scalel, &work[(*n << 1) + 1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(U). */ + + dlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &scaleu, &work[(*n << 1) + 1], + info); + } else { + +/* Multiply by inv(L). */ + + dlatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &scalel, &work[(*n << 1) + 1], + info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(L'). */ + + dlatrs_("Lower", "Transpose", "Non-unit", normin, n, &a[a_offset], + lda, &work[1], &scaleu, &work[(*n << 1) + 1], info); + } + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + scale = scalel * scaleu; + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) + { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + +L20: + return 0; + +/* End of DPOCON */ + +} /* dpocon_ */ + +/* Subroutine */ int dpoequ_(integer *n, double *a, integer *lda, + double *s, double *scond, double *amax, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + double d__1, d__2; + + /* Local variables */ + integer i__; + double smin; + + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOEQU computes row and column scalings intended to equilibrate a */ +/* symmetric positive definite matrix A and reduce its condition number */ +/* (with respect to the two-norm). S contains the scale factors, */ +/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ +/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ +/* choice of S puts the condition number of B within a factor N of the */ +/* smallest possible condition number over all possible diagonal */ +/* scalings. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The N-by-N symmetric positive definite matrix whose scaling */ +/* factors are to be computed. Only the diagonal elements of A */ +/* are referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* S (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, S contains the scale factors for A. */ + +/* SCOND (output) DOUBLE PRECISION */ +/* If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* large nor too small, it is not worth scaling by S. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --s; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*lda < std::max(1_integer,*n)) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOEQU", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *scond = 1.; + *amax = 0.; + return 0; + } + +/* Find the minimum and maximum diagonal elements. */ + + s[1] = a[a_dim1 + 1]; + smin = s[1]; + *amax = s[1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + s[i__] = a[i__ + i__ * a_dim1]; +/* Computing MIN */ + d__1 = smin, d__2 = s[i__]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = *amax, d__2 = s[i__]; + *amax = std::max(d__1,d__2); +/* L10: */ + } + + if (smin <= 0.) { + +/* Find the first non-positive diagonal element and return. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] <= 0.) { + *info = i__; + return 0; + } +/* L20: */ + } + } else { + +/* Set the scale factors to the reciprocals */ +/* of the diagonal elements. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 1. / sqrt(s[i__]); +/* L30: */ + } + +/* Compute SCOND = min(S(I)) / max(S(I)) */ + + *scond = sqrt(smin) / sqrt(*amax); + } + return 0; + +/* End of DPOEQU */ + +} /* dpoequ_ */ + +int dpoequb_(integer *n, double *a, integer *lda, double *s, double *scond, double *amax, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__; + double tmp, base, smin; + +/* -- LAPACK routine (version 3.2) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOEQU computes row and column scalings intended to equilibrate a */ +/* symmetric positive definite matrix A and reduce its condition number */ +/* (with respect to the two-norm). S contains the scale factors, */ +/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ +/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ +/* choice of S puts the condition number of B within a factor N of the */ +/* smallest possible condition number over all possible diagonal */ +/* scalings. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The N-by-N symmetric positive definite matrix whose scaling */ +/* factors are to be computed. Only the diagonal elements of A */ +/* are referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* S (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, S contains the scale factors for A. */ + +/* SCOND (output) DOUBLE PRECISION */ +/* If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* large nor too small, it is not worth scaling by S. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + +/* Positive definite only performs 1 pass of equilibration. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --s; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*lda < std::max(1_integer,*n)) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOEQUB", &i__1); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + *scond = 1.; + *amax = 0.; + return 0; + } + base = dlamch_("B"); + tmp = -.5 / log(base); + +/* Find the minimum and maximum diagonal elements. */ + + s[1] = a[a_dim1 + 1]; + smin = s[1]; + *amax = s[1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + s[i__] = a[i__ + i__ * a_dim1]; +/* Computing MIN */ + d__1 = smin, d__2 = s[i__]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = *amax, d__2 = s[i__]; + *amax = std::max(d__1,d__2); +/* L10: */ + } + + if (smin <= 0.) { + +/* Find the first non-positive diagonal element and return. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] <= 0.) { + *info = i__; + return 0; + } +/* L20: */ + } + } else { + +/* Set the scale factors to the reciprocals */ +/* of the diagonal elements. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = (integer) (tmp * log(s[i__])); + s[i__] = pow_di(&base, &i__2); +/* L30: */ + } + +/* Compute SCOND = min(S(I)) / max(S(I)). */ + + *scond = sqrt(smin) / sqrt(*amax); + } + + return 0; + +/* End of DPOEQUB */ + +} /* dpoequb_ */ + +/* Subroutine */ int dporfs_(const char *uplo, integer *n, integer *nrhs, + double *a, integer *lda, double *af, integer *ldaf, + double *b, integer *ldb, double *x, integer *ldx, double * + ferr, double *berr, double *work, integer *iwork, integer * + info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b12 = -1.; + static double c_b14 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s, xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + integer count; + bool upper; + double safmin; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPORFS improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive definite, */ +/* and provides error bounds and backward error estimates for the */ +/* solution. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of A contains the upper triangular part */ +/* of the matrix A, and the strictly lower triangular part of A */ +/* is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* triangular part of A contains the lower triangular part of */ +/* the matrix A, and the strictly upper triangular part of A is */ +/* not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DPOTRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPORFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, + &c_b14, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ + i__ + j * x_dim1], abs(d__2)); +/* L40: */ + } + work[k] = work[k] + (d__1 = a[k + k * a_dim1], abs(d__1)) * + xk + s; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + work[k] += (d__1 = a[k + k * a_dim1], abs(d__1)) * xk; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ + i__ + j * x_dim1], abs(d__2)); +/* L60: */ + } + work[k] += s; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1], n, + info); + daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A'). */ + + dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1], + n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L120: */ + } + dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1], + n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DPORFS */ + +} /* dporfs_ */ + +#if 0 +int dporfsx_(const char *uplo, const char *equed, integer *n, integer *nrhs, double *a, integer *lda, + double *af, integer *ldaf, double *s, double *b, integer *ldb, double *x, integer * + ldx, double *rcond, double *berr, integer *n_err_bnds__, double *err_bnds_norm__, double *err_bnds_comp__, + integer *nparams, double *params, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c_n1 = -1; + static integer c__0 = 0; + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + double d__1, d__2; + + /* Builtin functions */ + double sqrt(double); + + /* Local variables */ + double illrcond_thresh__, unstable_thresh__, err_lbnd__; + integer ref_type__, j; + double rcond_tmp__; + integer prec_type__; + double cwise_wrong__; + char norm[1]; + bool ignore_cwise__; + double anorm; + bool rcequ; + integer ithresh, n_norms__; + double rthresh; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPORFSX improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive */ +/* definite, and provides error bounds and backward error estimates */ +/* for the solution. In addition to normwise error bound, the code */ +/* provides maximum componentwise error bound if possible. See */ +/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */ +/* error bounds. */ + +/* The original system of linear equations may have been equilibrated */ +/* before calling this routine, as described by arguments EQUED and S */ +/* below. In this case, the solution and error bounds returned are */ +/* for the original unequilibrated system. */ + +/* Arguments */ +/* ========= */ + +/* Some optional parameters are bundled in the PARAMS array. These */ +/* settings determine how refinement is performed, but often the */ +/* defaults are acceptable. If the defaults are acceptable, users */ +/* can pass NPARAMS = 0 which prevents the source code from accessing */ +/* the PARAMS argument. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* EQUED (input) CHARACTER*1 */ +/* Specifies the form of equilibration that was done to A */ +/* before calling this routine. This is needed to compute */ +/* the solution and error bounds correctly. */ +/* = 'N': No equilibration */ +/* = 'Y': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(S) * A * diag(S). */ +/* The right hand side B has been changed accordingly. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of A contains the upper triangular part */ +/* of the matrix A, and the strictly lower triangular part of A */ +/* is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* triangular part of A contains the lower triangular part of */ +/* the matrix A, and the strictly upper triangular part of A is */ +/* not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* S (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */ +/* the left and right by diag(S). S is an input argument if FACT = */ +/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ +/* = 'Y', each element of S must be positive. If S is output, each */ +/* element of S is a power of the radix. If S is input, each element */ +/* of S should be a power of the radix to ensure a reliable solution */ +/* and error estimates. Scaling by powers of the radix does not cause */ +/* rounding errors unless the result underflows or overflows. */ +/* Rounding errors during scaling lead to refining with a matrix that */ +/* is not equivalent to the input matrix, producing error estimates */ +/* that may not be reliable. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DGETRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* Reciprocal scaled condition number. This is an estimate of the */ +/* reciprocal Skeel condition number of the matrix A after */ +/* equilibration (if done). If this is less than the machine */ +/* precision (in particular, if it is zero), the matrix is singular */ +/* to working precision. Note that the error may still be small even */ +/* if this number is very small and the matrix appears ill- */ +/* conditioned. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* Componentwise relative backward error. This is the */ +/* componentwise relative backward error of each solution vector X(j) */ +/* (i.e., the smallest relative change in any element of A or B that */ +/* makes X(j) an exact solution). */ + +/* N_ERR_BNDS (input) INTEGER */ +/* Number of error bounds to return for each right hand side */ +/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* ERR_BNDS_COMP below. */ + +/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* For each right-hand side, this array contains information about */ +/* various error bounds and condition numbers corresponding to the */ +/* normwise relative error, which is defined as follows: */ + +/* Normwise relative error in the ith solution vector: */ +/* max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* ------------------------------ */ +/* max_j abs(X(j,i)) */ + +/* The array is indexed by the type of error information as described */ +/* below. There currently are up to three pieces of information */ +/* returned. */ + +/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* right-hand side. */ + +/* The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* three fields: */ +/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* reciprocal condition number is less than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). */ + +/* err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* almost certainly within a factor of 10 of the true error */ +/* so long as the next entry is greater than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* be trusted if the previous boolean is true. */ + +/* err = 3 Reciprocal condition number: Estimated normwise */ +/* reciprocal condition number. Compared with the threshold */ +/* sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* estimate is "guaranteed". These reciprocal condition */ +/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* appropriately scaled matrix Z. */ +/* Let Z = S*A, where S scales each row by a power of the */ +/* radix so all absolute row sums of Z are approximately 1. */ + +/* See Lapack Working Note 165 for further details and extra */ +/* cautions. */ + +/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* For each right-hand side, this array contains information about */ +/* various error bounds and condition numbers corresponding to the */ +/* componentwise relative error, which is defined as follows: */ + +/* Componentwise relative error in the ith solution vector: */ +/* abs(XTRUE(j,i) - X(j,i)) */ +/* max_j ---------------------- */ +/* abs(X(j,i)) */ + +/* The array is indexed by the right-hand side i (on which the */ +/* componentwise relative error depends), and the type of error */ +/* information as described below. There currently are up to three */ +/* pieces of information returned for each right-hand side. If */ +/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ +/* the first (:,N_ERR_BNDS) entries are returned. */ + +/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* right-hand side. */ + +/* The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* three fields: */ +/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* reciprocal condition number is less than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). */ + +/* err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* almost certainly within a factor of 10 of the true error */ +/* so long as the next entry is greater than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* be trusted if the previous boolean is true. */ + +/* err = 3 Reciprocal condition number: Estimated componentwise */ +/* reciprocal condition number. Compared with the threshold */ +/* sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* estimate is "guaranteed". These reciprocal condition */ +/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* appropriately scaled matrix Z. */ +/* Let Z = S*(A*diag(x)), where x is the solution for the */ +/* current right-hand side and S scales each row of */ +/* A*diag(x) by a power of the radix so all absolute row */ +/* sums of Z are approximately 1. */ + +/* See Lapack Working Note 165 for further details and extra */ +/* cautions. */ + +/* NPARAMS (input) INTEGER */ +/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */ +/* PARAMS array is never referenced and default values are used. */ + +/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */ +/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */ +/* that entry will be filled with default value used for that */ +/* parameter. Only positions up to NPARAMS are accessed; defaults */ +/* are used for higher-numbered parameters. */ + +/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* refinement or not. */ +/* Default: 1.0D+0 */ +/* = 0.0 : No refinement is performed, and no error bounds are */ +/* computed. */ +/* = 1.0 : Use the double-precision refinement algorithm, */ +/* possibly with doubled-single computations if the */ +/* compilation environment does not support DOUBLE */ +/* PRECISION. */ +/* (other values are reserved for future use) */ + +/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* computations allowed for refinement. */ +/* Default: 10 */ +/* Aggressive: Set to 100 to permit convergence using approximate */ +/* factorizations or factorizations other than LU. If */ +/* the factorization uses a technique other than */ +/* Gaussian elimination, the guarantees in */ +/* err_bnds_norm and err_bnds_comp may no longer be */ +/* trustworthy. */ + +/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* will attempt to find a solution with small componentwise */ +/* relative error in the double-precision algorithm. Positive */ +/* is true, 0.0 is false. */ +/* Default: 1.0 (attempt componentwise convergence) */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: Successful exit. The solution to every right-hand side is */ +/* guaranteed. */ +/* < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly singular, so */ +/* the solution and error bounds could not be computed. RCOND = 0 */ +/* is returned. */ +/* = N+J: The solution corresponding to the Jth right-hand side is */ +/* not guaranteed. The solutions corresponding to other right- */ +/* hand sides K with K > J may not be guaranteed as well, but */ +/* only the first such right-hand side is reported. If a small */ +/* componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* the Jth right-hand side is the first with a normwise error */ +/* bound that is not guaranteed (the smallest J such */ +/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* the Jth right-hand side is the first with either a normwise or */ +/* componentwise error bound that is not guaranteed (the smallest */ +/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* about all of the right-hand sides check ERR_BNDS_NORM or */ +/* ERR_BNDS_COMP. */ + +/* ================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Check the input parameters. */ + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + ref_type__ = 1; + if (*nparams >= 1) { + if (params[1] < 0.) { + params[1] = 1.; + } else { + ref_type__ = (integer) params[1]; + } + } + +/* Set default parameters. */ + + illrcond_thresh__ = (double) (*n) * dlamch_("Epsilon"); + ithresh = 10; + rthresh = .5; + unstable_thresh__ = .25; + ignore_cwise__ = false; + + if (*nparams >= 2) { + if (params[2] < 0.) { + params[2] = (double) ithresh; + } else { + ithresh = (integer) params[2]; + } + } + if (*nparams >= 3) { + if (params[3] < 0.) { + if (ignore_cwise__) { + params[3] = 0.; + } else { + params[3] = 1.; + } + } else { + ignore_cwise__ = params[3] == 0.; + } + } + if (ref_type__ == 0 || *n_err_bnds__ == 0) { + n_norms__ = 0; + } else if (ignore_cwise__) { + n_norms__ = 1; + } else { + n_norms__ = 2; + } + + rcequ = lsame_(equed, "Y"); + +/* Test input parameters. */ + + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! rcequ && ! lsame_(equed, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -11; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPORFSX", &i__1); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *nrhs == 0) { + *rcond = 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 0.; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } else if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.; + } else if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.; + } + } + return 0; + } + +/* Default to failure. */ + + *rcond = 0.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 1.; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } else if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + } else if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.; + } + } + +/* Compute the norm of A and the reciprocal of the condition */ +/* number of A. */ + + *(unsigned char *)norm = 'I'; + anorm = dlansy_(norm, uplo, n, &a[a_offset], lda, &work[1]); + dpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1], + info); + +/* Perform refinement on each right-hand side */ + + if (ref_type__ != 0) { + prec_type__ = ilaprec_("E"); + dla_porfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda, + &af[af_offset], ldaf, &rcequ, &s[1], &b[b_offset], ldb, &x[ + x_offset], ldx, &berr[1], &n_norms__, &err_bnds_norm__[ + err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset], + &work[*n + 1], &work[1], &work[(*n << 1) + 1], &work[1], + rcond, &ithresh, &rthresh, &unstable_thresh__, & + ignore_cwise__, info, 1_integer); + } +/* Computing MAX */ + d__1 = 10., d__2 = sqrt((double) (*n)); + err_lbnd__ = std::max(d__1,d__2) * dlamch_("Epsilon"); + if (*n_err_bnds__ >= 1 && n_norms__ >= 1) { + +/* Compute scaled normwise condition number cond(A*C). */ + + if (rcequ) { + rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &c_n1, &s[1], info, &work[1], &iwork[1], 1_integer); + } else { + rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &c__0, &s[1], info, &work[1], &iwork[1], 1_integer); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 + << 1)] > 1.) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + err_bnds_norm__[j + err_bnds_norm_dim1] = 0.; + if (*info <= *n) { + *info = *n + j; + } + } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < + err_lbnd__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__; + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__; + } + } + } + if (*n_err_bnds__ >= 1 && n_norms__ >= 2) { + +/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */ +/* each right-hand side using the current solution as an estimate of */ +/* the true solution. If the componentwise error estimate is too */ +/* large, then the solution is a lousy estimate of truth and the */ +/* estimated RCOND may be too optimistic. To avoid misleading users, */ +/* the inverse condition number is set to 0.0 when the estimated */ +/* cwise error is at least CWISE_WRONG. */ + + cwise_wrong__ = sqrt(dlamch_("Epsilon")); + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + cwise_wrong__) { + rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &c__1, &x[j * x_dim1 + 1], info, & + work[1], &iwork[1], 1_integer); + } else { + rcond_tmp__ = 0.; + } + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 + << 1)] > 1.) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 0.; + if (params[3] == 1. && *info < *n + j) { + *info = *n + j; + } + } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + err_lbnd__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__; + } + } + } + + return 0; + +/* End of DPORFSX */ + +} /* dporfsx_ */ +#endif + +/* Subroutine */ int dposv_(const char *uplo, integer *n, integer *nrhs, double + *a, integer *lda, double *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOSV computes the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N symmetric positive definite matrix and X and B */ +/* are N-by-NRHS matrices. */ + +/* The Cholesky decomposition is used to factor A as */ +/* A = U**T* U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is a lower triangular */ +/* matrix. The factored form of A is then used to solve the system of */ +/* equations A * X = B. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the leading minor of order i of A is not */ +/* positive definite, so the factorization could not be */ +/* completed, and the solution has not been computed. */ + +/* ===================================================================== */ + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOSV ", &i__1); + return 0; + } + +/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ + + dpotrf_(uplo, n, &a[a_offset], lda, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info); + + } + return 0; + +/* End of DPOSV */ + +} /* dposv_ */ + +/* Subroutine */ int dposvx_(const char *fact, const char *uplo, integer *n, integer * + nrhs, double *a, integer *lda, double *af, integer *ldaf, + char *equed, double *s, double *b, integer *ldb, double * + x, integer *ldx, double *rcond, double *ferr, double * + berr, double *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double amax, smin, smax; + double scond, anorm; + bool equil, rcequ; + bool nofact; + double bignum; + integer infequ; + double smlnum; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */ +/* compute the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N symmetric positive definite matrix and X and B */ +/* are N-by-NRHS matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* the system: */ +/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ +/* Whether or not the system will be equilibrated depends on the */ +/* scaling of the matrix A, but if equilibration is used, A is */ +/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ + +/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ +/* factor the matrix A (after equilibration if FACT = 'E') as */ +/* A = U**T* U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is a lower triangular */ +/* matrix. */ + +/* 3. If the leading i-by-i principal minor is not positive definite, */ +/* then the routine returns with INFO = i. Otherwise, the factored */ +/* form of A is used to estimate the condition number of the matrix */ +/* A. If the reciprocal of the condition number is less than machine */ +/* precision, INFO = N+1 is returned as a warning, but the routine */ +/* still goes on to solve for X and compute error bounds as */ +/* described below. */ + +/* 4. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 5. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* 6. If equilibration was used, the matrix X is premultiplied by */ +/* diag(S) so that it solves the original system before */ +/* equilibration. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of the matrix A is */ +/* supplied on entry, and if not, whether the matrix A should be */ +/* equilibrated before it is factored. */ +/* = 'F': On entry, AF contains the factored form of A. */ +/* If EQUED = 'Y', the matrix A has been equilibrated */ +/* with scaling factors given by S. A and AF will not */ +/* be modified. */ +/* = 'N': The matrix A will be copied to AF and factored. */ +/* = 'E': The matrix A will be equilibrated if necessary, then */ +/* copied to AF and factored. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A, except if FACT = 'F' and */ +/* EQUED = 'Y', then A must contain the equilibrated matrix */ +/* diag(S)*A*diag(S). If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. A is not modified if */ +/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ + +/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* diag(S)*A*diag(S). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* If FACT = 'F', then AF is an input argument and on entry */ +/* contains the triangular factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T, in the same storage */ +/* format as A. If EQUED .ne. 'N', then AF is the factored form */ +/* of the equilibrated matrix diag(S)*A*diag(S). */ + +/* If FACT = 'N', then AF is an output argument and on exit */ +/* returns the triangular factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T of the original */ +/* matrix A. */ + +/* If FACT = 'E', then AF is an output argument and on exit */ +/* returns the triangular factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T of the equilibrated */ +/* matrix A (see the description of A for the form of the */ +/* equilibrated matrix). */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* EQUED (input or output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration (always true if FACT = 'N'). */ +/* = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* diag(S) * A * diag(S). */ +/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* output argument. */ + +/* S (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A; not accessed if EQUED = 'N'. S is */ +/* an input argument if FACT = 'F'; otherwise, S is an output */ +/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */ +/* must be positive. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ +/* B is overwritten by diag(S) * B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ +/* the original system of equations. Note that if EQUED = 'Y', */ +/* A and B are modified on exit, and the solution to the */ +/* equilibrated system is inv(diag(S))*X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The estimate of the reciprocal condition number of the matrix */ +/* A after equilibration (if done). If RCOND is less than the */ +/* machine precision (in particular, if RCOND = 0), the matrix */ +/* is singular to working precision. This condition is */ +/* indicated by a return code of INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= N: the leading minor of order i of A is */ +/* not positive definite, so the factorization */ +/* could not be completed, and the solution has not */ +/* been computed. RCOND = 0 is returned. */ +/* = N+1: U is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = false; + } else { + rcequ = lsame_(equed, "Y"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -8; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -9; + } else { + if (rcequ) { + smin = bignum; + smax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = smin, d__2 = s[j]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = smax, d__2 = s[j]; + smax = std::max(d__1,d__2); +/* L10: */ + } + if (smin <= 0.) { + *info = -10; + } else if (*n > 0) { + scond = std::max(smin,smlnum) / std::min(smax,bignum); + } else { + scond = 1.; + } + } + if (*info == 0) { + if (*ldb < std::max(1_integer,*n)) { + *info = -12; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -14; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOSVX", &i__1); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right hand side. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1]; +/* L20: */ + } +/* L30: */ + } + } + + if (nofact || equil) { + +/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ + + dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + dpotrf_(uplo, n, &af[af_offset], ldaf, info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &work[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1], + info); + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &b[ + b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], & + iwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1]; +/* L40: */ + } +/* L50: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= scond; +/* L60: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of DPOSVX */ + +} /* dposvx_ */ + +/* Subroutine */ int dpotf2_(const char *uplo, integer *n, double *a, integer *lda, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b10 = -1.; + static double c_b12 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer j; + double ajj; + bool upper; + + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOTF2 computes the Cholesky factorization of a real symmetric */ +/* positive definite matrix A. */ + +/* The factorization has the form */ +/* A = U' * U , if UPLO = 'U', or */ +/* A = L * L', if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is lower triangular. */ + +/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n by n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n by n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* factorization A = U'*U or A = L*L'. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > 0: if INFO = k, the leading minor of order k is not */ +/* positive definite, and the factorization could not be */ +/* completed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOTF2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Compute the Cholesky factorization A = U'*U. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute U(J,J) and test for non-positive-definiteness. */ + + i__2 = j - 1; + ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1, + &a[j * a_dim1 + 1], &c__1); + if (ajj <= 0. || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L30; + } + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of row J. */ + + if (j < *n) { + i__2 = j - 1; + i__3 = *n - j; + dgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 + + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( + j + 1) * a_dim1], lda); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the Cholesky factorization A = L*L'. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute L(J,J) and test for non-positive-definiteness. */ + + i__2 = j - 1; + ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j + + a_dim1], lda); + if (ajj <= 0. || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L30; + } + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of column J. */ + + if (j < *n) { + i__2 = *n - j; + i__3 = j - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + + a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + + j * a_dim1], &c__1); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } +/* L20: */ + } + } + goto L40; + +L30: + *info = j; + +L40: + return 0; + +/* End of DPOTF2 */ + +} /* dpotf2_ */ + +/* Subroutine */ int dpotrf_(const char *uplo, integer *n, double *a, integer * + lda, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b13 = -1.; + static double c_b14 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer j, jb, nb; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOTRF computes the Cholesky factorization of a real symmetric */ +/* positive definite matrix A. */ + +/* The factorization has the form */ +/* A = U**T * U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is lower triangular. */ + +/* This is the block version of the algorithm, calling Level 3 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the leading minor of order i is not */ +/* positive definite, and the factorization could not be */ +/* completed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOTRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code. */ + + dpotf2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code. */ + + if (upper) { + +/* Compute the Cholesky factorization A = U'*U. */ + + i__1 = *n; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Update and factorize the current diagonal block and test */ +/* for non-positive-definiteness. */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - j + 1; + jb = std::min(i__3,i__4); + i__3 = j - 1; + dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j * + a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda); + dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info); + if (*info != 0) { + goto L30; + } + if (j + jb <= *n) { + +/* Compute the current block row. */ + + i__3 = *n - j - jb + 1; + i__4 = j - 1; + dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, & + c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) * + a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) * + a_dim1], lda); + i__3 = *n - j - jb + 1; + dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, & + i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j + + jb) * a_dim1], lda); + } +/* L10: */ + } + + } else { + +/* Compute the Cholesky factorization A = L*L'. */ + + i__2 = *n; + i__1 = nb; + for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Update and factorize the current diagonal block and test */ +/* for non-positive-definiteness. */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - j + 1; + jb = std::min(i__3,i__4); + i__3 = j - 1; + dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j + + a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda); + dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info); + if (*info != 0) { + goto L30; + } + if (j + jb <= *n) { + +/* Compute the current block column. */ + + i__3 = *n - j - jb + 1; + i__4 = j - 1; + dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, & + c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1], + lda, &c_b14, &a[j + jb + j * a_dim1], lda); + i__3 = *n - j - jb + 1; + dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, & + jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb + + j * a_dim1], lda); + } +/* L20: */ + } + } + } + goto L40; + +L30: + *info = *info + j - 1; + +L40: + return 0; + +/* End of DPOTRF */ + +} /* dpotrf_ */ + +/* Subroutine */ int dpotri_(const char *uplo, integer *n, double *a, integer * + lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOTRI computes the inverse of a real symmetric positive definite */ +/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ +/* computed by DPOTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the triangular factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T, as computed by */ +/* DPOTRF. */ +/* On exit, the upper or lower triangle of the (symmetric) */ +/* inverse of A, overwriting the input factor U or L. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the (i,i) element of the factor U or L is */ +/* zero, and the inverse could not be computed. */ + +/* ===================================================================== */ + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOTRI", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Invert the triangular Cholesky factor U or L. */ + + dtrtri_(uplo, "Non-unit", n, &a[a_offset], lda, info); + if (*info > 0) { + return 0; + } + +/* Form inv(U)*inv(U)' or inv(L)'*inv(L). */ + + dlauum_(uplo, n, &a[a_offset], lda, info); + + return 0; + +/* End of DPOTRI */ + +} /* dpotri_ */ + +/* Subroutine */ int dpotrs_(const char *uplo, integer *n, integer *nrhs, + double *a, integer *lda, double *b, integer *ldb, integer * + info) +{ + /* Table of constant values */ + + static double c_b9 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + bool upper; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPOTRS solves a system of linear equations A*X = B with a symmetric */ +/* positive definite matrix A using the Cholesky factorization */ +/* A = U**T*U or A = L*L**T computed by DPOTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPOTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B where A = U'*U. */ + +/* Solve U'*X = B, overwriting B with X. */ + + dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ + a_offset], lda, &b[b_offset], ldb); + +/* Solve U*X = B, overwriting B with X. */ + + dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, & + a[a_offset], lda, &b[b_offset], ldb); + } else { + +/* Solve A*X = B where A = L*L'. */ + +/* Solve L*X = B, overwriting B with X. */ + + dtrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, & + a[a_offset], lda, &b[b_offset], ldb); + +/* Solve L'*X = B, overwriting B with X. */ + + dtrsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ + a_offset], lda, &b[b_offset], ldb); + } + + return 0; + +/* End of DPOTRS */ + +} /* dpotrs_ */ + +/* Subroutine */ int dppcon_(const char *uplo, integer *n, double *ap, + double *anorm, double *rcond, double *work, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer ix, kase; + double scale; + integer isave[3]; + bool upper; + double scalel; + double scaleu; + double ainvnm; + char normin[1]; + double smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPPCON estimates the reciprocal of the condition number (in the */ +/* 1-norm) of a real symmetric positive definite packed matrix using */ +/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */ +/* DPPTRF. */ + +/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T, packed columnwise in a linear */ +/* array. The j-th column of U or L is stored in the array AP */ +/* as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ + +/* ANORM (input) DOUBLE PRECISION */ +/* The 1-norm (or infinity-norm) of the symmetric matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* estimate of the 1-norm of inv(A) computed in this routine. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --iwork; + --work; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*anorm < 0.) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + + smlnum = dlamch_("Safe minimum"); + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; + *(unsigned char *)normin = 'N'; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (upper) { + +/* Multiply by inv(U'). */ + + dlatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], & + work[1], &scalel, &work[(*n << 1) + 1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(U). */ + + dlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], & + work[1], &scaleu, &work[(*n << 1) + 1], info); + } else { + +/* Multiply by inv(L). */ + + dlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], & + work[1], &scalel, &work[(*n << 1) + 1], info); + *(unsigned char *)normin = 'Y'; + +/* Multiply by inv(L'). */ + + dlatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], & + work[1], &scaleu, &work[(*n << 1) + 1], info); + } + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + scale = scalel * scaleu; + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) + { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + +L20: + return 0; + +/* End of DPPCON */ + +} /* dppcon_ */ + +/* Subroutine */ int dppequ_(const char *uplo, integer *n, double *ap, + double *s, double *scond, double *amax, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + integer i__, jj; + double smin; + + bool upper; + + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPPEQU computes row and column scalings intended to equilibrate a */ +/* symmetric positive definite matrix A in packed storage and reduce */ +/* its condition number (with respect to the two-norm). S contains the */ +/* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix */ +/* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. */ +/* This choice of S puts the condition number of B within a factor N of */ +/* the smallest possible condition number over all possible diagonal */ +/* scalings. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangle of the symmetric matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* S (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, S contains the scale factors for A. */ + +/* SCOND (output) DOUBLE PRECISION */ +/* If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* large nor too small, it is not worth scaling by S. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --s; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPEQU", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *scond = 1.; + *amax = 0.; + return 0; + } + +/* Initialize SMIN and AMAX. */ + + s[1] = ap[1]; + smin = s[1]; + *amax = s[1]; + + if (upper) { + +/* UPLO = 'U': Upper triangle of A is stored. */ +/* Find the minimum and maximum diagonal elements. */ + + jj = 1; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + jj += i__; + s[i__] = ap[jj]; +/* Computing MIN */ + d__1 = smin, d__2 = s[i__]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = *amax, d__2 = s[i__]; + *amax = std::max(d__1,d__2); +/* L10: */ + } + + } else { + +/* UPLO = 'L': Lower triangle of A is stored. */ +/* Find the minimum and maximum diagonal elements. */ + + jj = 1; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + jj = jj + *n - i__ + 2; + s[i__] = ap[jj]; +/* Computing MIN */ + d__1 = smin, d__2 = s[i__]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = *amax, d__2 = s[i__]; + *amax = std::max(d__1,d__2); +/* L20: */ + } + } + + if (smin <= 0.) { + +/* Find the first non-positive diagonal element and return. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] <= 0.) { + *info = i__; + return 0; + } +/* L30: */ + } + } else { + +/* Set the scale factors to the reciprocals */ +/* of the diagonal elements. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 1. / sqrt(s[i__]); +/* L40: */ + } + +/* Compute SCOND = min(S(I)) / max(S(I)) */ + + *scond = sqrt(smin) / sqrt(*amax); + } + return 0; + +/* End of DPPEQU */ + +} /* dppequ_ */ + +/* Subroutine */ int dpprfs_(const char *uplo, integer *n, integer *nrhs, + double *ap, double *afp, double *b, integer *ldb, + double *x, integer *ldx, double *ferr, double *berr, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b12 = -1.; + static double c_b14 = 1.; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s; + integer ik, kk; + double xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + integer count; + bool upper; + double safmin; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPPRFS improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive definite */ +/* and packed, and provides error bounds and backward error estimates */ +/* for the solution. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangle of the symmetric matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF, */ +/* packed columnwise in a linear array in the same format as A */ +/* (see AP). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DPPTRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --afp; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, & + work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + kk = 1; + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + ik = kk; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; + s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * + x_dim1], abs(d__2)); + ++ik; +/* L40: */ + } + work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk + + s; + kk += k; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + work[k] += (d__1 = ap[kk], abs(d__1)) * xk; + ik = kk + 1; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; + s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * + x_dim1], abs(d__2)); + ++ik; +/* L60: */ + } + work[k] += s; + kk += *n - k + 1; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); + daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A'). */ + + dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L120: */ + } + dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DPPRFS */ + +} /* dpprfs_ */ + +/* Subroutine */ int dppsv_(const char *uplo, integer *n, integer *nrhs, double + *ap, double *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPPSV computes the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N symmetric positive definite matrix stored in */ +/* packed format and X and B are N-by-NRHS matrices. */ + +/* The Cholesky decomposition is used to factor A as */ +/* A = U**T* U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is a lower triangular */ +/* matrix. The factored form of A is then used to solve the system of */ +/* equations A * X = B. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* See below for further details. */ + +/* On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T, in the same storage */ +/* format as A. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the leading minor of order i of A is not */ +/* positive definite, so the factorization could not be */ +/* completed, and the solution has not been computed. */ + +/* Further Details */ +/* =============== */ + +/* The packed storage scheme is illustrated by the following example */ +/* when N = 4, UPLO = 'U': */ + +/* Two-dimensional storage of the symmetric matrix A: */ + +/* a11 a12 a13 a14 */ +/* a22 a23 a24 */ +/* a33 a34 (aij = conjg(aji)) */ +/* a44 */ + +/* Packed storage of the upper triangle of A: */ + +/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ + +/* ===================================================================== */ + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPSV ", &i__1); + return 0; + } + +/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ + + dpptrf_(uplo, n, &ap[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dpptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info); + + } + return 0; + +/* End of DPPSV */ + +} /* dppsv_ */ + +/* Subroutine */ int dppsvx_(const char *fact, const char *uplo, integer *n, integer * + nrhs, double *ap, double *afp, char *equed, double *s, + double *b, integer *ldb, double *x, integer *ldx, double * + rcond, double *ferr, double *berr, double *work, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double amax, smin, smax; + double scond, anorm; + bool equil, rcequ; + bool nofact; + double bignum; + integer infequ; + double smlnum; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */ +/* compute the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N symmetric positive definite matrix stored in */ +/* packed format and X and B are N-by-NRHS matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* the system: */ +/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ +/* Whether or not the system will be equilibrated depends on the */ +/* scaling of the matrix A, but if equilibration is used, A is */ +/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ + +/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ +/* factor the matrix A (after equilibration if FACT = 'E') as */ +/* A = U**T* U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is a lower triangular */ +/* matrix. */ + +/* 3. If the leading i-by-i principal minor is not positive definite, */ +/* then the routine returns with INFO = i. Otherwise, the factored */ +/* form of A is used to estimate the condition number of the matrix */ +/* A. If the reciprocal of the condition number is less than machine */ +/* precision, INFO = N+1 is returned as a warning, but the routine */ +/* still goes on to solve for X and compute error bounds as */ +/* described below. */ + +/* 4. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 5. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* 6. If equilibration was used, the matrix X is premultiplied by */ +/* diag(S) so that it solves the original system before */ +/* equilibration. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of the matrix A is */ +/* supplied on entry, and if not, whether the matrix A should be */ +/* equilibrated before it is factored. */ +/* = 'F': On entry, AFP contains the factored form of A. */ +/* If EQUED = 'Y', the matrix A has been equilibrated */ +/* with scaling factors given by S. AP and AFP will not */ +/* be modified. */ +/* = 'N': The matrix A will be copied to AFP and factored. */ +/* = 'E': The matrix A will be equilibrated if necessary, then */ +/* copied to AFP and factored. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array, except if FACT = 'F' */ +/* and EQUED = 'Y', then A must contain the equilibrated matrix */ +/* diag(S)*A*diag(S). The j-th column of A is stored in the */ +/* array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* See below for further details. A is not modified if */ +/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ + +/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* diag(S)*A*diag(S). */ + +/* AFP (input or output) DOUBLE PRECISION array, dimension */ +/* (N*(N+1)/2) */ +/* If FACT = 'F', then AFP is an input argument and on entry */ +/* contains the triangular factor U or L from the Cholesky */ +/* factorization A = U'*U or A = L*L', in the same storage */ +/* format as A. If EQUED .ne. 'N', then AFP is the factored */ +/* form of the equilibrated matrix A. */ + +/* If FACT = 'N', then AFP is an output argument and on exit */ +/* returns the triangular factor U or L from the Cholesky */ +/* factorization A = U'*U or A = L*L' of the original matrix A. */ + +/* If FACT = 'E', then AFP is an output argument and on exit */ +/* returns the triangular factor U or L from the Cholesky */ +/* factorization A = U'*U or A = L*L' of the equilibrated */ +/* matrix A (see the description of AP for the form of the */ +/* equilibrated matrix). */ + +/* EQUED (input or output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration (always true if FACT = 'N'). */ +/* = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* diag(S) * A * diag(S). */ +/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* output argument. */ + +/* S (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A; not accessed if EQUED = 'N'. S is */ +/* an input argument if FACT = 'F'; otherwise, S is an output */ +/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */ +/* must be positive. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ +/* B is overwritten by diag(S) * B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ +/* the original system of equations. Note that if EQUED = 'Y', */ +/* A and B are modified on exit, and the solution to the */ +/* equilibrated system is inv(diag(S))*X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The estimate of the reciprocal condition number of the matrix */ +/* A after equilibration (if done). If RCOND is less than the */ +/* machine precision (in particular, if RCOND = 0), the matrix */ +/* is singular to working precision. This condition is */ +/* indicated by a return code of INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= N: the leading minor of order i of A is */ +/* not positive definite, so the factorization */ +/* could not be completed, and the solution has not */ +/* been computed. RCOND = 0 is returned. */ +/* = N+1: U is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* Further Details */ +/* =============== */ + +/* The packed storage scheme is illustrated by the following example */ +/* when N = 4, UPLO = 'U': */ + +/* Two-dimensional storage of the symmetric matrix A: */ + +/* a11 a12 a13 a14 */ +/* a22 a23 a24 */ +/* a33 a34 (aij = conjg(aji)) */ +/* a44 */ + +/* Packed storage of the upper triangle of A: */ + +/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ap; + --afp; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = false; + } else { + rcequ = lsame_(equed, "Y"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -7; + } else { + if (rcequ) { + smin = bignum; + smax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = smin, d__2 = s[j]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = smax, d__2 = s[j]; + smax = std::max(d__1,d__2); +/* L10: */ + } + if (smin <= 0.) { + *info = -8; + } else if (*n > 0) { + scond = std::max(smin,smlnum) / std::min(smax,bignum); + } else { + scond = 1.; + } + } + if (*info == 0) { + if (*ldb < std::max(1_integer,*n)) { + *info = -10; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -12; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPSVX", &i__1); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqsp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right-hand side. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1]; +/* L20: */ + } +/* L30: */ + } + } + + if (nofact || equil) { + +/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ + + i__1 = *n * (*n + 1) / 2; + dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); + dpptrf_(uplo, n, &afp[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlansp_("I", uplo, n, &ap[1], &work[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info); + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset], + ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (rcequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1]; +/* L40: */ + } +/* L50: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= scond; +/* L60: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of DPPSVX */ + +} /* dppsvx_ */ + +/* Subroutine */ int dpptrf_(const char *uplo, integer *n, double *ap, integer * + info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b16 = -1.; + + /* System generated locals */ + integer i__1, i__2; + double d__1; + + /* Local variables */ + integer j, jc, jj; + double ajj; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPPTRF computes the Cholesky factorization of a real symmetric */ +/* positive definite matrix A stored in packed format. */ + +/* The factorization has the form */ +/* A = U**T * U, if UPLO = 'U', or */ +/* A = L * L**T, if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is lower triangular. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* See below for further details. */ + +/* On exit, if INFO = 0, the triangular factor U or L from the */ +/* Cholesky factorization A = U**T*U or A = L*L**T, in the same */ +/* storage format as A. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the leading minor of order i is not */ +/* positive definite, and the factorization could not be */ +/* completed. */ + +/* Further Details */ +/* ======= ======= */ + +/* The packed storage scheme is illustrated by the following example */ +/* when N = 4, UPLO = 'U': */ + +/* Two-dimensional storage of the symmetric matrix A: */ + +/* a11 a12 a13 a14 */ +/* a22 a23 a24 */ +/* a33 a34 (aij = aji) */ +/* a44 */ + +/* Packed storage of the upper triangle of A: */ + +/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPTRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Compute the Cholesky factorization A = U'*U. */ + + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + +/* Compute elements 1:J-1 of column J. */ + + if (j > 1) { + i__2 = j - 1; + dtpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[ + jc], &c__1); + } + +/* Compute U(J,J) and test for non-positive-definiteness. */ + + i__2 = j - 1; + ajj = ap[jj] - ddot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1); + if (ajj <= 0.) { + ap[jj] = ajj; + goto L30; + } + ap[jj] = sqrt(ajj); +/* L10: */ + } + } else { + +/* Compute the Cholesky factorization A = L*L'. */ + + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Compute L(J,J) and test for non-positive-definiteness. */ + + ajj = ap[jj]; + if (ajj <= 0.) { + ap[jj] = ajj; + goto L30; + } + ajj = sqrt(ajj); + ap[jj] = ajj; + +/* Compute elements J+1:N of column J and update the trailing */ +/* submatrix. */ + + if (j < *n) { + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &ap[jj + 1], &c__1); + i__2 = *n - j; + dspr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n + - j + 1]); + jj = jj + *n - j + 1; + } +/* L20: */ + } + } + goto L40; + +L30: + *info = j; + +L40: + return 0; + +/* End of DPPTRF */ + +} /* dpptrf_ */ + +/* Subroutine */ int dpptri_(const char *uplo, integer *n, double *ap, integer * + info) +{ + /* Table of constant values */ + static double c_b8 = 1.; + static integer c__1 = 1; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer j, jc, jj; + double ajj; + integer jjn; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPPTRI computes the inverse of a real symmetric positive definite */ +/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ +/* computed by DPPTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangular factor is stored in AP; */ +/* = 'L': Lower triangular factor is stored in AP. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the triangular factor U or L from the Cholesky */ +/* factorization A = U**T*U or A = L*L**T, packed columnwise as */ +/* a linear array. The j-th column of U or L is stored in the */ +/* array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ + +/* On exit, the upper or lower triangle of the (symmetric) */ +/* inverse of A, overwriting the input factor U or L. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the (i,i) element of the factor U or L is */ +/* zero, and the inverse could not be computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPTRI", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Invert the triangular Cholesky factor U or L. */ + + dtptri_(uplo, "Non-unit", n, &ap[1], info); + if (*info > 0) { + return 0; + } + + if (upper) { + +/* Compute the product inv(U) * inv(U)'. */ + + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jc = jj + 1; + jj += j; + if (j > 1) { + i__2 = j - 1; + dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]); + } + ajj = ap[jj]; + dscal_(&j, &ajj, &ap[jc], &c__1); +/* L10: */ + } + + } else { + +/* Compute the product inv(L)' * inv(L). */ + + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jjn = jj + *n - j + 1; + i__2 = *n - j + 1; + ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1); + if (j < *n) { + i__2 = *n - j; + dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ + jj + 1], &c__1); + } + jj = jjn; +/* L20: */ + } + } + + return 0; + +/* End of DPPTRI */ + +} /* dpptri_ */ + +/* Subroutine */ int dpptrs_(const char *uplo, integer *n, integer *nrhs, + double *ap, double *b, integer *ldb, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + integer i__; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPPTRS solves a system of linear equations A*X = B with a symmetric */ +/* positive definite matrix A in packed storage using the Cholesky */ +/* factorization A = U**T*U or A = L*L**T computed by DPPTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T, packed columnwise in a linear */ +/* array. The j-th column of U or L is stored in the array AP */ +/* as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPPTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B where A = U'*U. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve U'*X = B, overwriting B with X. */ + + dtpsv_("Upper", "Transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); + +/* Solve U*X = B, overwriting B with X. */ + + dtpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Solve A*X = B where A = L*L'. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve L*Y = B, overwriting B with X. */ + + dtpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); + +/* Solve L'*X = Y, overwriting B with X. */ + + dtpsv_("Lower", "Transpose", "Non-unit", n, &ap[1], &b[i__ * + b_dim1 + 1], &c__1); +/* L20: */ + } + } + + return 0; + +/* End of DPPTRS */ + +} /* dpptrs_ */ + +#if 0 +int dpstf2_(const char *uplo, integer *n, double *a, integer *lda, integer *piv, integer *rank, + double *tol, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b16 = -1.; + static double c_b18 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer i__, j, maxlocval; + double ajj; + integer pvt; + double dtemp; + integer itemp; + double dstop; + bool upper; + + +/* -- LAPACK PROTOTYPE routine (version 3.2) -- */ +/* Craig Lucas, University of Manchester / NAG Ltd. */ +/* October, 2008 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPSTF2 computes the Cholesky factorization with complete */ +/* pivoting of a real symmetric positive semidefinite matrix A. */ + +/* The factorization has the form */ +/* P' * A * P = U' * U , if UPLO = 'U', */ +/* P' * A * P = L * L', if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is lower triangular, and */ +/* P is stored as vector PIV. */ + +/* This algorithm does not attempt to check that A is positive */ +/* semidefinite. This version of the algorithm calls level 2 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n by n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n by n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* factorization as above. */ + +/* PIV (output) INTEGER array, dimension (N) */ +/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ + +/* RANK (output) INTEGER */ +/* The rank of A given by the number of steps the algorithm */ +/* completed. */ + +/* TOL (input) DOUBLE PRECISION */ +/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */ +/* will be used. The algorithm terminates at the (K-1)st step */ +/* if the pivot <= TOL. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* WORK DOUBLE PRECISION array, dimension (2*N) */ +/* Work space. */ + +/* INFO (output) INTEGER */ +/* < 0: If INFO = -K, the K-th argument had an illegal value, */ +/* = 0: algorithm completed successfully, and */ +/* > 0: the matrix A is either rank deficient with computed rank */ +/* as returned in RANK, or is indefinite. See Section 7 of */ +/* LAPACK Working Note #161 for further information. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + --work; + --piv; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPSTF2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Initialize PIV */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + piv[i__] = i__; +/* L100: */ + } + +/* Compute stopping value */ + + pvt = 1; + ajj = a[pvt + pvt * a_dim1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (a[i__ + i__ * a_dim1] > ajj) { + pvt = i__; + ajj = a[pvt + pvt * a_dim1]; + } + } + if (ajj == 0. || disnan_(&ajj)) { + *rank = 0; + *info = 1; + goto L170; + } + +/* Compute stopping value if not supplied */ + + if (*tol < 0.) { + dstop = *n * dlamch_("Epsilon") * ajj; + } else { + dstop = *tol; + } + +/* Set first half of WORK to zero, holds dot products */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L110: */ + } + + if (upper) { + +/* Compute the Cholesky factorization P' * A * P = U' * U */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + + if (j > 1) { +/* Computing 2nd power */ + d__1 = a[j - 1 + i__ * a_dim1]; + work[i__] += d__1 * d__1; + } + work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; + +/* L120: */ + } + + if (j > 1) { + maxlocval = (*n << 1) - (*n + j) + 1; + itemp = dmaxloc_(&work[*n + j], &maxlocval); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= dstop || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L160; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; + i__2 = j - 1; + dswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1], + &c__1); + if (pvt < *n) { + i__2 = *n - pvt; + dswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + ( + pvt + 1) * a_dim1], lda); + } + i__2 = pvt - j - 1; + dswap_(&i__2, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + pvt * + a_dim1], &c__1); + +/* Swap dot products and PIV */ + + dtemp = work[j]; + work[j] = work[pvt]; + work[pvt] = dtemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of row J */ + + if (j < *n) { + i__2 = j - 1; + i__3 = *n - j; + dgemv_("Trans", &i__2, &i__3, &c_b16, &a[(j + 1) * a_dim1 + 1] +, lda, &a[j * a_dim1 + 1], &c__1, &c_b18, &a[j + (j + + 1) * a_dim1], lda); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); + } + +/* L130: */ + } + + } else { + +/* Compute the Cholesky factorization P' * A * P = L * L' */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + + if (j > 1) { +/* Computing 2nd power */ + d__1 = a[i__ + (j - 1) * a_dim1]; + work[i__] += d__1 * d__1; + } + work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; + +/* L140: */ + } + + if (j > 1) { + maxlocval = (*n << 1) - (*n + j) + 1; + itemp = dmaxloc_(&work[*n + j], &maxlocval); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= dstop || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L160; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; + i__2 = j - 1; + dswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda); + if (pvt < *n) { + i__2 = *n - pvt; + dswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1 + + pvt * a_dim1], &c__1); + } + i__2 = pvt - j - 1; + dswap_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + (j + 1) + * a_dim1], lda); + +/* Swap dot products and PIV */ + + dtemp = work[j]; + work[j] = work[pvt]; + work[pvt] = dtemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of column J */ + + if (j < *n) { + i__2 = *n - j; + i__3 = j - 1; + dgemv_("No Trans", &i__2, &i__3, &c_b16, &a[j + 1 + a_dim1], + lda, &a[j + a_dim1], lda, &c_b18, &a[j + 1 + j * + a_dim1], &c__1); + i__2 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } + +/* L150: */ + } + + } + +/* Ran to completion, A has full rank */ + + *rank = *n; + + goto L170; +L160: + +/* Rank is number of steps completed. Set INFO = 1 to signal */ +/* that the factorization cannot be used to solve a system. */ + + *rank = j - 1; + *info = 1; + +L170: + return 0; + +/* End of DPSTF2 */ + +} /* dpstf2_ */ +#endif + +#if 0 +int dpstrf_(const char *uplo, integer *n, double *a, integer *lda, integer *piv, integer *rank, + double *tol, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b22 = -1.; + static double c_b24 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + double d__1; + + /* Local variables */ + integer i__, j, k, maxlocvar, jb, nb; + double ajj; + integer pvt; + double dtemp; + integer itemp; + double dstop; + bool upper; + + +/* -- LAPACK routine (version 3.2) -- */ +/* Craig Lucas, University of Manchester / NAG Ltd. */ +/* October, 2008 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPSTRF computes the Cholesky factorization with complete */ +/* pivoting of a real symmetric positive semidefinite matrix A. */ + +/* The factorization has the form */ +/* P' * A * P = U' * U , if UPLO = 'U', */ +/* P' * A * P = L * L', if UPLO = 'L', */ +/* where U is an upper triangular matrix and L is lower triangular, and */ +/* P is stored as vector PIV. */ + +/* This algorithm does not attempt to check that A is positive */ +/* semidefinite. This version of the algorithm calls level 3 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n by n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n by n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if INFO = 0, the factor U or L from the Cholesky */ +/* factorization as above. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* PIV (output) INTEGER array, dimension (N) */ +/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ + +/* RANK (output) INTEGER */ +/* The rank of A given by the number of steps the algorithm */ +/* completed. */ + +/* TOL (input) DOUBLE PRECISION */ +/* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */ +/* will be used. The algorithm terminates at the (K-1)st step */ +/* if the pivot <= TOL. */ + +/* WORK DOUBLE PRECISION array, dimension (2*N) */ +/* Work space. */ + +/* INFO (output) INTEGER */ +/* < 0: If INFO = -K, the K-th argument had an illegal value, */ +/* = 0: algorithm completed successfully, and */ +/* > 0: the matrix A is either rank deficient with computed rank */ +/* as returned in RANK, or is indefinite. See Section 7 of */ +/* LAPACK Working Note #161 for further information. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --work; + --piv; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPSTRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get block size */ + + nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dpstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1], + info); + goto L200; + + } else { + +/* Initialize PIV */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + piv[i__] = i__; +/* L100: */ + } + +/* Compute stopping value */ + + pvt = 1; + ajj = a[pvt + pvt * a_dim1]; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (a[i__ + i__ * a_dim1] > ajj) { + pvt = i__; + ajj = a[pvt + pvt * a_dim1]; + } + } + if (ajj == 0. || disnan_(&ajj)) { + *rank = 0; + *info = 1; + goto L200; + } + +/* Compute stopping value if not supplied */ + + if (*tol < 0.) { + dstop = *n * dlamch_("Epsilon") * ajj; + } else { + dstop = *tol; + } + + + if (upper) { + +/* Compute the Cholesky factorization P' * A * P = U' * U */ + + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + +/* Account for last block not being NB wide */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - k + 1; + jb = std::min(i__3,i__4); + +/* Set relevant part of first half of WORK to zero, */ +/* holds dot products */ + + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] = 0.; +/* L110: */ + } + + i__3 = k + jb - 1; + for (j = k; j <= i__3; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__4 = *n; + for (i__ = j; i__ <= i__4; ++i__) { + + if (j > k) { +/* Computing 2nd power */ + d__1 = a[j - 1 + i__ * a_dim1]; + work[i__] += d__1 * d__1; + } + work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; + +/* L120: */ + } + + if (j > 1) { + maxlocvar = (*n << 1) - (*n + j) + 1; + itemp = dmaxloc_(&work[*n + j], &maxlocvar); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= dstop || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L190; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; + i__4 = j - 1; + dswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt * + a_dim1 + 1], &c__1); + if (pvt < *n) { + i__4 = *n - pvt; + dswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[ + pvt + (pvt + 1) * a_dim1], lda); + } + i__4 = pvt - j - 1; + dswap_(&i__4, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + + pvt * a_dim1], &c__1); + +/* Swap dot products and PIV */ + + dtemp = work[j]; + work[j] = work[pvt]; + work[pvt] = dtemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of row J. */ + + if (j < *n) { + i__4 = j - k; + i__5 = *n - j; + dgemv_("Trans", &i__4, &i__5, &c_b22, &a[k + (j + 1) * + a_dim1], lda, &a[k + j * a_dim1], &c__1, & + c_b24, &a[j + (j + 1) * a_dim1], lda); + i__4 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__4, &d__1, &a[j + (j + 1) * a_dim1], lda); + } + +/* L130: */ + } + +/* Update trailing matrix, J already incremented */ + + if (k + jb <= *n) { + i__3 = *n - j + 1; + dsyrk_("Upper", "Trans", &i__3, &jb, &c_b22, &a[k + j * + a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda); + } + +/* L140: */ + } + + } else { + +/* Compute the Cholesky factorization P' * A * P = L * L' */ + + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + +/* Account for last block not being NB wide */ + +/* Computing MIN */ + i__3 = nb, i__4 = *n - k + 1; + jb = std::min(i__3,i__4); + +/* Set relevant part of first half of WORK to zero, */ +/* holds dot products */ + + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] = 0.; +/* L150: */ + } + + i__3 = k + jb - 1; + for (j = k; j <= i__3; ++j) { + +/* Find pivot, test for exit, else swap rows and columns */ +/* Update dot products, compute possible pivots which are */ +/* stored in the second half of WORK */ + + i__4 = *n; + for (i__ = j; i__ <= i__4; ++i__) { + + if (j > k) { +/* Computing 2nd power */ + d__1 = a[i__ + (j - 1) * a_dim1]; + work[i__] += d__1 * d__1; + } + work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; + +/* L160: */ + } + + if (j > 1) { + maxlocvar = (*n << 1) - (*n + j) + 1; + itemp = dmaxloc_(&work[*n + j], &maxlocvar); + pvt = itemp + j - 1; + ajj = work[*n + pvt]; + if (ajj <= dstop || disnan_(&ajj)) { + a[j + j * a_dim1] = ajj; + goto L190; + } + } + + if (j != pvt) { + +/* Pivot OK, so can now swap pivot rows and columns */ + + a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; + i__4 = j - 1; + dswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1], + lda); + if (pvt < *n) { + i__4 = *n - pvt; + dswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[ + pvt + 1 + pvt * a_dim1], &c__1); + } + i__4 = pvt - j - 1; + dswap_(&i__4, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + + (j + 1) * a_dim1], lda); + +/* Swap dot products and PIV */ + + dtemp = work[j]; + work[j] = work[pvt]; + work[pvt] = dtemp; + itemp = piv[pvt]; + piv[pvt] = piv[j]; + piv[j] = itemp; + } + + ajj = sqrt(ajj); + a[j + j * a_dim1] = ajj; + +/* Compute elements J+1:N of column J. */ + + if (j < *n) { + i__4 = *n - j; + i__5 = j - k; + dgemv_("No Trans", &i__4, &i__5, &c_b22, &a[j + 1 + k + * a_dim1], lda, &a[j + k * a_dim1], lda, & + c_b24, &a[j + 1 + j * a_dim1], &c__1); + i__4 = *n - j; + d__1 = 1. / ajj; + dscal_(&i__4, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } + +/* L170: */ + } + +/* Update trailing matrix, J already incremented */ + + if (k + jb <= *n) { + i__3 = *n - j + 1; + dsyrk_("Lower", "No Trans", &i__3, &jb, &c_b22, &a[j + k * + a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda); + } + +/* L180: */ + } + + } + } + +/* Ran to completion, A has full rank */ + + *rank = *n; + + goto L200; +L190: + +/* Rank is the number of steps completed. Set INFO = 1 to signal */ +/* that the factorization cannot be used to solve a system. */ + + *rank = j - 1; + *info = 1; + +L200: + return 0; + +/* End of DPSTRF */ + +} /* dpstrf_ */ +#endif + +/* Subroutine */ int dptcon_(integer *n, double *d__, double *e, + double *anorm, double *rcond, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer i__, ix; + + + double ainvnm; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPTCON computes the reciprocal of the condition number (in the */ +/* 1-norm) of a real symmetric positive definite tridiagonal matrix */ +/* using the factorization A = L*D*L**T or A = U**T*D*U computed by */ +/* DPTTRF. */ + +/* Norm(inv(A)) is computed by a direct method, and the reciprocal of */ +/* the condition number is computed as */ +/* RCOND = 1 / (ANORM * norm(inv(A))). */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the diagonal matrix D from the */ +/* factorization of A, as computed by DPTTRF. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) off-diagonal elements of the unit bidiagonal factor */ +/* U or L from the factorization of A, as computed by DPTTRF. */ + +/* ANORM (input) DOUBLE PRECISION */ +/* The 1-norm of the original matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the */ +/* 1-norm of inv(A) computed in this routine. */ + +/* 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 method used is described in Nicholas J. Higham, "Efficient */ +/* Algorithms for Computing the Condition Number of a Tridiagonal */ +/* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments. */ + + /* Parameter adjustments */ + --work; + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*anorm < 0.) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + +/* Check that D(1:N) is positive. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= 0.) { + return 0; + } +/* L10: */ + } + +/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */ + +/* m(i,j) = abs(A(i,j)), i = j, */ +/* m(i,j) = -abs(A(i,j)), i .ne. j, */ + +/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */ + +/* Solve M(L) * x = e. */ + + work[1] = 1.; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + work[i__] = work[i__ - 1] * (d__1 = e[i__ - 1], abs(d__1)) + 1.; +/* L20: */ + } + +/* Solve D * M(L)' * x = b. */ + + work[*n] /= d__[*n]; + for (i__ = *n - 1; i__ >= 1; --i__) { + work[i__] = work[i__] / d__[i__] + work[i__ + 1] * (d__1 = e[i__], + abs(d__1)); +/* L30: */ + } + +/* Compute AINVNM = max(x(i)), 1<=i<=n. */ + + ix = idamax_(n, &work[1], &c__1); + ainvnm = (d__1 = work[ix], abs(d__1)); + +/* Compute the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + + return 0; + +/* End of DPTCON */ + +} /* dptcon_ */ + +/* Subroutine */ int dpteqr_(const char *compz, integer *n, double *d__, + double *e, double *z__, integer *ldz, double *work, + integer *info) +{ + /* Table of constant values */ + static double c_b7 = 0.; + static double c_b8 = 1.; + static integer c__0 = 0; + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1; + + /* Local variables */ + double c__[1] /* was [1][1] */; + integer i__; + double vt[1] /* was [1][1] */; + integer nru; + integer icompz; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a */ +/* symmetric positive definite tridiagonal matrix by first factoring the */ +/* matrix using DPTTRF, and then calling DBDSQR to compute the singular */ +/* values of the bidiagonal factor. */ + +/* This routine computes the eigenvalues of the positive definite */ +/* tridiagonal matrix to high relative accuracy. This means that if the */ +/* eigenvalues range over many orders of magnitude in size, then the */ +/* small eigenvalues and corresponding eigenvectors will be computed */ +/* more accurately than, for example, with the standard QR method. */ + +/* The eigenvectors of a full or band symmetric positive definite matrix */ +/* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to */ +/* reduce this matrix to tridiagonal form. (The reduction to tridiagonal */ +/* form, however, may preclude the possibility of obtaining high */ +/* relative accuracy in the small eigenvalues of the original matrix, if */ +/* these eigenvalues range over many orders of magnitude.) */ + +/* Arguments */ +/* ========= */ + +/* COMPZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only. */ +/* = 'V': Compute eigenvectors of original symmetric */ +/* matrix also. Array Z contains the orthogonal */ +/* matrix used to reduce the original matrix to */ +/* tridiagonal form. */ +/* = 'I': Compute eigenvectors of tridiagonal matrix also. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the tridiagonal */ +/* matrix. */ +/* On normal exit, D contains the eigenvalues, in descending */ +/* order. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix. */ +/* On exit, E has been destroyed. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* On entry, if COMPZ = 'V', the orthogonal matrix used in the */ +/* reduction to tridiagonal form. */ +/* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */ +/* original symmetric matrix; */ +/* if COMPZ = 'I', the orthonormal eigenvectors of the */ +/* tridiagonal matrix. */ +/* If INFO > 0 on exit, Z contains the eigenvectors associated */ +/* with only the stored eigenvalues. */ +/* If COMPZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* COMPZ = 'V' or 'I', LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = i, and i is: */ +/* <= N the Cholesky factorization of the matrix could */ +/* not be performed because the i-th principal minor */ +/* was not positive definite. */ +/* > N the SVD algorithm failed to converge; */ +/* if INFO = N+i, i off-diagonal elements of the */ +/* bidiagonal factor did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTEQR", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (icompz > 0) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + if (icompz == 2) { + dlaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz); + } + +/* Call DPTTRF to factor the matrix. */ + + dpttrf_(n, &d__[1], &e[1], info); + if (*info != 0) { + return 0; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(d__[i__]); +/* L10: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] *= d__[i__]; +/* L20: */ + } + +/* Call DBDSQR to compute the singular values/vectors of the */ +/* bidiagonal factor. */ + + if (icompz > 0) { + nru = *n; + } else { + nru = 0; + } + dbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[ + z_offset], ldz, c__, &c__1, &work[1], info); + +/* Square the singular values. */ + + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] *= d__[i__]; +/* L30: */ + } + } else { + *info = *n + *info; + } + + return 0; + +/* End of DPTEQR */ + +} /* dpteqr_ */ + +/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, double *d__, + double *e, double *df, double *ef, double *b, integer + *ldb, double *x, integer *ldx, double *ferr, double *berr, + double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b11 = 1.; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j; + double s, bi, cx, dx, ex; + integer ix, nz; + double eps, safe1, safe2; + integer count; + double safmin; + double lstres; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPTRFS improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric positive definite */ +/* and tridiagonal, and provides error bounds and backward error */ +/* estimates for the solution. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the tridiagonal matrix A. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */ + +/* DF (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the diagonal matrix D from the */ +/* factorization computed by DPTTRF. */ + +/* EF (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of the unit bidiagonal factor */ +/* L from the factorization computed by DPTTRF. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DPTTRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --df; + --ef; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = 4; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X. Also compute */ +/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */ + + if (*n == 1) { + bi = b[j * b_dim1 + 1]; + dx = d__[1] * x[j * x_dim1 + 1]; + work[*n + 1] = bi - dx; + work[1] = abs(bi) + abs(dx); + } else { + bi = b[j * b_dim1 + 1]; + dx = d__[1] * x[j * x_dim1 + 1]; + ex = e[1] * x[j * x_dim1 + 2]; + work[*n + 1] = bi - dx - ex; + work[1] = abs(bi) + abs(dx) + abs(ex); + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + bi = b[i__ + j * b_dim1]; + cx = e[i__ - 1] * x[i__ - 1 + j * x_dim1]; + dx = d__[i__] * x[i__ + j * x_dim1]; + ex = e[i__] * x[i__ + 1 + j * x_dim1]; + work[*n + i__] = bi - cx - dx - ex; + work[i__] = abs(bi) + abs(cx) + abs(dx) + abs(ex); +/* L30: */ + } + bi = b[*n + j * b_dim1]; + cx = e[*n - 1] * x[*n - 1 + j * x_dim1]; + dx = d__[*n] * x[*n + j * x_dim1]; + work[*n + *n] = bi - cx - dx; + work[*n] = abs(bi) + abs(cx) + abs(dx); + } + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L40: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dpttrs_(n, &c__1, &df[1], &ef[1], &work[*n + 1], n, info); + daxpy_(n, &c_b11, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L50: */ + } + ix = idamax_(n, &work[1], &c__1); + ferr[j] = work[ix]; + +/* Estimate the norm of inv(A). */ + +/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */ + +/* m(i,j) = abs(A(i,j)), i = j, */ +/* m(i,j) = -abs(A(i,j)), i .ne. j, */ + +/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */ + +/* Solve M(L) * x = e. */ + + work[1] = 1.; + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__] = work[i__ - 1] * (d__1 = ef[i__ - 1], abs(d__1)) + 1.; +/* L60: */ + } + +/* Solve D * M(L)' * x = b. */ + + work[*n] /= df[*n]; + for (i__ = *n - 1; i__ >= 1; --i__) { + work[i__] = work[i__] / df[i__] + work[i__ + 1] * (d__1 = ef[i__], + abs(d__1)); +/* L70: */ + } + +/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */ + + ix = idamax_(n, &work[1], &c__1); + ferr[j] *= (d__1 = work[ix], abs(d__1)); + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L80: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L90: */ + } + + return 0; + +/* End of DPTRFS */ + +} /* dptrfs_ */ + +/* Subroutine */ int dptsv_(integer *n, integer *nrhs, double *d__, + double *e, double *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPTSV computes the solution to a real system of linear equations */ +/* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal */ +/* matrix, and X and B are N-by-NRHS matrices. */ + +/* A is factored as A = L*D*L**T, and the factored form of A is then */ +/* used to solve the system of equations. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the tridiagonal matrix */ +/* A. On exit, the n diagonal elements of the diagonal matrix */ +/* D from the factorization A = L*D*L**T. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix A. On exit, the (n-1) subdiagonal elements of the */ +/* unit bidiagonal factor L from the L*D*L**T factorization of */ +/* A. (E can also be regarded as the superdiagonal of the unit */ +/* bidiagonal factor U from the U**T*D*U factorization of A.) */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the leading minor of order i is not */ +/* positive definite, and the solution has not been */ +/* computed. The factorization has not been completed */ +/* unless i = N. */ + +/* ===================================================================== */ + +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTSV ", &i__1); + return 0; + } + +/* Compute the L*D*L' (or U'*D*U) factorization of A. */ + + dpttrf_(n, &d__[1], &e[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dpttrs_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info); + } + return 0; + +/* End of DPTSV */ + +} /* dptsv_ */ + +/* Subroutine */ int dptsvx_(const char *fact, integer *n, integer *nrhs, + double *d__, double *e, double *df, double *ef, + double *b, integer *ldb, double *x, integer *ldx, double * + rcond, double *ferr, double *berr, double *work, integer * + info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1; + + /* Local variables */ + double anorm; + bool nofact; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPTSVX uses the factorization A = L*D*L**T to compute the solution */ +/* to a real system of linear equations A*X = B, where A is an N-by-N */ +/* symmetric positive definite tridiagonal matrix and X and B are */ +/* N-by-NRHS matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L */ +/* is a unit lower bidiagonal matrix and D is diagonal. The */ +/* factorization can also be regarded as having the form */ +/* A = U**T*D*U. */ + +/* 2. If the leading i-by-i principal minor is not positive definite, */ +/* then the routine returns with INFO = i. Otherwise, the factored */ +/* form of A is used to estimate the condition number of the matrix */ +/* A. If the reciprocal of the condition number is less than machine */ +/* precision, INFO = N+1 is returned as a warning, but the routine */ +/* still goes on to solve for X and compute error bounds as */ +/* described below. */ + +/* 3. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 4. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of A has been */ +/* supplied on entry. */ +/* = 'F': On entry, DF and EF contain the factored form of A. */ +/* D, E, DF, and EF will not be modified. */ +/* = 'N': The matrix A will be copied to DF and EF and */ +/* factored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the tridiagonal matrix A. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */ + +/* DF (input or output) DOUBLE PRECISION array, dimension (N) */ +/* If FACT = 'F', then DF is an input argument and on entry */ +/* contains the n diagonal elements of the diagonal matrix D */ +/* from the L*D*L**T factorization of A. */ +/* If FACT = 'N', then DF is an output argument and on exit */ +/* contains the n diagonal elements of the diagonal matrix D */ +/* from the L*D*L**T factorization of A. */ + +/* EF (input or output) DOUBLE PRECISION array, dimension (N-1) */ +/* If FACT = 'F', then EF is an input argument and on entry */ +/* contains the (n-1) subdiagonal elements of the unit */ +/* bidiagonal factor L from the L*D*L**T factorization of A. */ +/* If FACT = 'N', then EF is an output argument and on exit */ +/* contains the (n-1) subdiagonal elements of the unit */ +/* bidiagonal factor L from the L*D*L**T factorization of A. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The N-by-NRHS right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal condition number of the matrix A. If RCOND */ +/* is less than the machine precision (in particular, if */ +/* RCOND = 0), the matrix is singular to working precision. */ +/* This condition is indicated by a return code of INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in any */ +/* element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= N: the leading minor of order i of A is */ +/* not positive definite, so the factorization */ +/* could not be completed, and the solution has not */ +/* been computed. RCOND = 0 is returned. */ +/* = N+1: U is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --df; + --ef; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTSVX", &i__1); + return 0; + } + + if (nofact) { + +/* Compute the L*D*L' (or U'*D*U) factorization of A. */ + + dcopy_(n, &d__[1], &c__1, &df[1], &c__1); + if (*n > 1) { + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &ef[1], &c__1); + } + dpttrf_(n, &df[1], &ef[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlanst_("1", n, &d__[1], &e[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info); + +/* Compute the solution vectors X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dpttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + dptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[ + x_offset], ldx, &ferr[1], &berr[1], &work[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of DPTSVX */ + +} /* dptsvx_ */ + +/* Subroutine */ int dpttrf_(integer *n, double *d__, double *e, + integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, i4; + double ei; + + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPTTRF computes the L*D*L' factorization of a real symmetric */ +/* positive definite tridiagonal matrix A. The factorization may also */ +/* be regarded as having the form A = U'*D*U. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the tridiagonal matrix */ +/* A. On exit, the n diagonal elements of the diagonal matrix */ +/* D from the L*D*L' factorization of A. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix A. On exit, the (n-1) subdiagonal elements of the */ +/* unit bidiagonal factor L from the L*D*L' factorization of A. */ +/* E can also be regarded as the superdiagonal of the unit */ +/* bidiagonal factor U from the U'*D*U factorization of A. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > 0: if INFO = k, the leading minor of order k is not */ +/* positive definite; if k < N, the factorization could not */ +/* be completed, while if k = N, the factorization was */ +/* completed, but D(N) <= 0. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("DPTTRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Compute the L*D*L' (or U'*D*U) factorization of A. */ + + i4 = (*n - 1) % 4; + i__1 = i4; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= 0.) { + *info = i__; + goto L30; + } + ei = e[i__]; + e[i__] = ei / d__[i__]; + d__[i__ + 1] -= e[i__] * ei; +/* L10: */ + } + + i__1 = *n - 4; + for (i__ = i4 + 1; i__ <= i__1; i__ += 4) { + +/* Drop out of the loop if d(i) <= 0: the matrix is not positive */ +/* definite. */ + + if (d__[i__] <= 0.) { + *info = i__; + goto L30; + } + +/* Solve for e(i) and d(i+1). */ + + ei = e[i__]; + e[i__] = ei / d__[i__]; + d__[i__ + 1] -= e[i__] * ei; + + if (d__[i__ + 1] <= 0.) { + *info = i__ + 1; + goto L30; + } + +/* Solve for e(i+1) and d(i+2). */ + + ei = e[i__ + 1]; + e[i__ + 1] = ei / d__[i__ + 1]; + d__[i__ + 2] -= e[i__ + 1] * ei; + + if (d__[i__ + 2] <= 0.) { + *info = i__ + 2; + goto L30; + } + +/* Solve for e(i+2) and d(i+3). */ + + ei = e[i__ + 2]; + e[i__ + 2] = ei / d__[i__ + 2]; + d__[i__ + 3] -= e[i__ + 2] * ei; + + if (d__[i__ + 3] <= 0.) { + *info = i__ + 3; + goto L30; + } + +/* Solve for e(i+3) and d(i+4). */ + + ei = e[i__ + 3]; + e[i__ + 3] = ei / d__[i__ + 3]; + d__[i__ + 4] -= e[i__ + 3] * ei; +/* L20: */ + } + +/* Check d(n) for positive definiteness. */ + + if (d__[*n] <= 0.) { + *info = *n; + } + +L30: + return 0; + +/* End of DPTTRF */ + +} /* dpttrf_ */ + +/* Subroutine */ int dpttrs_(integer *n, integer *nrhs, double *d__, + double *e, double *b, integer *ldb, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer j, jb, nb; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPTTRS solves a tridiagonal system of the form */ +/* A * X = B */ +/* using the L*D*L' factorization of A computed by DPTTRF. D is a */ +/* diagonal matrix specified in the vector D, L is a unit bidiagonal */ +/* matrix whose subdiagonal is specified in the vector E, and X and B */ +/* are N by NRHS matrices. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the tridiagonal matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the diagonal matrix D from the */ +/* L*D*L' factorization of A. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of the unit bidiagonal factor */ +/* L from the L*D*L' factorization of A. E can also be regarded */ +/* as the superdiagonal of the unit bidiagonal factor U from the */ +/* factorization A = U'*D*U. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side vectors B for the system of */ +/* linear equations. */ +/* On exit, the solution vectors, X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments. */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DPTTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Determine the number of right-hand sides to solve at a time. */ + + if (*nrhs == 1) { + nb = 1; + } else { +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "DPTTRS", " ", n, nrhs, &c_n1, &c_n1); + nb = std::max(i__1,i__2); + } + + if (nb >= *nrhs) { + dptts2_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb); + } else { + i__1 = *nrhs; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nrhs - j + 1; + jb = std::min(i__3,nb); + dptts2_(n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb); +/* L10: */ + } + } + + return 0; + +/* End of DPTTRS */ + +} /* dpttrs_ */ + +/* Subroutine */ int dptts2_(integer *n, integer *nrhs, double *d__, + double *e, double *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DPTTS2 solves a tridiagonal system of the form */ +/* A * X = B */ +/* using the L*D*L' factorization of A computed by DPTTRF. D is a */ +/* diagonal matrix specified in the vector D, L is a unit bidiagonal */ +/* matrix whose subdiagonal is specified in the vector E, and X and B */ +/* are N by NRHS matrices. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the tridiagonal matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the diagonal matrix D from the */ +/* L*D*L' factorization of A. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of the unit bidiagonal factor */ +/* L from the L*D*L' factorization of A. E can also be regarded */ +/* as the superdiagonal of the unit bidiagonal factor U from the */ +/* factorization A = U'*D*U. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side vectors B for the system of */ +/* linear equations. */ +/* On exit, the solution vectors, X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + if (*n <= 1) { + if (*n == 1) { + d__1 = 1. / d__[1]; + dscal_(nrhs, &d__1, &b[b_offset], ldb); + } + return 0; + } + +/* Solve A * X = B using the factorization A = L*D*L', */ +/* overwriting each right hand side vector with its solution. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve L * x = b. */ + + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= b[i__ - 1 + j * b_dim1] * e[i__ - 1]; +/* L10: */ + } + +/* Solve D * L' * x = b. */ + + b[*n + j * b_dim1] /= d__[*n]; + for (i__ = *n - 1; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] / d__[i__] - b[i__ + 1 + + j * b_dim1] * e[i__]; +/* L20: */ + } +/* L30: */ + } + + return 0; + +/* End of DPTTS2 */ + +} /* dptts2_ */ + +/* Subroutine */ int drscl_(integer *n, double *sa, double *sx, + integer *incx) +{ + double mul, cden; + bool done; + double cnum, cden1, cnum1; + double bignum, smlnum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DRSCL multiplies an n-element real vector x by the real scalar 1/a. */ +/* This is done without overflow or underflow as long as */ +/* the final result x/a does not overflow or underflow. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of components of the vector x. */ + +/* SA (input) DOUBLE PRECISION */ +/* The scalar a which is used to divide each component of x. */ +/* SA must be >= 0, or the subroutine will divide by zero. */ + +/* SX (input/output) DOUBLE PRECISION array, dimension */ +/* (1+(N-1)*abs(INCX)) */ +/* The n-element vector x. */ + +/* INCX (input) INTEGER */ +/* The increment between successive values of the vector SX. */ +/* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Initialize the denominator to SA and the numerator to 1. */ + + cden = *sa; + cnum = 1.; + +L10: + cden1 = cden * smlnum; + cnum1 = cnum / bignum; + if (abs(cden1) > abs(cnum) && cnum != 0.) { + +/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ + + mul = smlnum; + done = false; + cden = cden1; + } else if (abs(cnum1) > abs(cden)) { + +/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ + + mul = bignum; + done = false; + cnum = cnum1; + } else { + +/* Multiply X by CNUM / CDEN and return. */ + + mul = cnum / cden; + done = true; + } + +/* Scale the vector X by MUL */ + + dscal_(n, &mul, &sx[1], incx); + + if (! done) { + goto L10; + } + + return 0; + +/* End of DRSCL */ + +} /* drscl_ */ + +/* Subroutine */ integer ieeeck_(integer *ispec, float *zero, float *one) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + float nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* IEEECK is called from the ILAENV to verify that Infinity and */ +/* possibly NaN arithmetic is safe (i.e. will not trap). */ + +/* Arguments */ +/* ========= */ + +/* ISPEC (input) INTEGER */ +/* Specifies whether to test just for inifinity arithmetic */ +/* or whether to test for infinity and NaN arithmetic. */ +/* = 0: Verify infinity arithmetic only. */ +/* = 1: Verify infinity and NaN arithmetic. */ + +/* ZERO (input) REAL */ +/* Must contain the value 0.0 */ +/* This is passed to prevent the compiler from optimizing */ +/* away this code. */ + +/* ONE (input) REAL */ +/* Must contain the value 1.0 */ +/* This is passed to prevent the compiler from optimizing */ +/* away this code. */ + +/* RETURN VALUE: INTEGER */ +/* = 0: Arithmetic failed to produce the correct answers */ +/* = 1: Arithmetic produced the correct answers */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + ret_val = 1; + + posinf = *one / *zero; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + + neginf = -(*one) / *zero; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + + negzro = *one / (neginf + *one); + if (negzro != *zero) { + ret_val = 0; + return ret_val; + } + + neginf = *one / negzro; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + + newzro = negzro + *zero; + if (newzro != *zero) { + ret_val = 0; + return ret_val; + } + + posinf = *one / newzro; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + + neginf *= posinf; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + + posinf *= posinf; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + + + + +/* Return if we were only asked to check infinity arithmetic */ + + if (*ispec == 0) { + return ret_val; + } + + nan1 = posinf + neginf; + + nan2 = posinf / neginf; + + nan3 = posinf / posinf; + + nan4 = posinf * *zero; + + nan5 = neginf * negzro; + + nan6 = nan5 * 0.f; + + if (nan1 == nan1) { + ret_val = 0; + return ret_val; + } + + if (nan2 == nan2) { + ret_val = 0; + return ret_val; + } + + if (nan3 == nan3) { + ret_val = 0; + return ret_val; + } + + if (nan4 == nan4) { + ret_val = 0; + return ret_val; + } + + if (nan5 == nan5) { + ret_val = 0; + return ret_val; + } + + if (nan6 == nan6) { + ret_val = 0; + return ret_val; + } + + return ret_val; +} /* ieeeck_ */ + +/* Subroutine */ integer iladlc_(integer *m, integer *n, double *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1; + + /* Local variables */ + integer i__; + + +/* -- LAPACK auxiliary routine (version 3.2.1) -- */ + +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ILADLC scans A for its last non-zero column. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix A. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The m by n matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + if (*n == 0) { + ret_val = *n; + } else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) { + ret_val = *n; + } else { +/* Now scan each column from the end, returning with the first non-zero. */ + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (a[i__ + ret_val * a_dim1] != 0.) { + return ret_val; + } + } + } + } + return ret_val; +} /* iladlc_ */ + +/* Subroutine */ integer iladlr_(integer *m, integer *n, double *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1; + + /* Local variables */ + integer i__, j; + + +/* -- LAPACK auxiliary routine (version 3.2.1) -- */ + +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ILADLR scans A for its last non-zero row. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix A. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The m by n matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + if (*m == 0) { + ret_val = *m; + } else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) { + ret_val = *m; + } else { +/* Scan up each column tracking the last zero row seen. */ + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + for (i__ = *m; i__ >= 1; --i__) { + if (a[i__ + j * a_dim1] != 0.) { + break; + } + } + ret_val = std::max(ret_val,i__); + } + } + return ret_val; +} /* iladlr_ */ + +/* Subroutine */ integer ilaenv_(integer *ispec, const char *name__, const char *opts, integer *n1, + integer *n2, integer *n3, integer *n4) +{ + /* Table of constant values */ + static integer c__1 = 1; + static float c_b163 = 0.f; + static float c_b164 = 1.f; + static integer c__0 = 0; + + /* System generated locals */ + integer ret_val; + + /* Local variables */ + integer i__; + char c1[1], c2[1], c3[1], c4[1]; + integer ic, nb, iz, nx; + bool cname; + integer nbmin; + bool sname; + char subnam[1]; + integer name_len;//, opts_len; + + name_len = strlen (name__); + // opts_len = strlen (opts); + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* January 2007 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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. */ + +/* ILAENV returns an INTEGER */ +/* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC */ +/* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. */ + +/* 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 (DEPRECATED) */ +/* = 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 method */ +/* for nonsymmetric eigenvalue problems (DEPRECATED) */ +/* = 9: maximum size of the subproblems at the bottom of the */ +/* computation tree in the divide-and-conquer algorithm */ +/* (used by xGELSD and xGESDD) */ +/* =10: ieee NaN arithmetic can be trusted not to trap */ +/* =11: infinity arithmetic can be trusted not to trap */ +/* 12 <= ISPEC <= 16: */ +/* xHSEQR or one of its subroutines, */ +/* see IPARMQ for detailed explanation */ + +/* 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. */ + +/* 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 .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + switch (*ispec) { + case 1: goto L10; + case 2: goto L10; + case 3: goto L10; + case 4: goto L80; + case 5: goto L90; + case 6: goto L100; + case 7: goto L110; + case 8: goto L120; + case 9: goto L130; + case 10: goto L140; + case 11: goto L150; + case 12: goto L160; + case 13: goto L160; + case 14: goto L160; + case 15: goto L160; + case 16: goto L160; + } + +/* Invalid value for ISPEC */ + + ret_val = -1; + return ret_val; + +L10: + +/* Convert NAME to upper case if the first character is lower case. */ + + ret_val = 1; + s_copy(subnam, name__, 1_integer, name_len); + ic = *(unsigned char *)subnam; + iz = 'Z'; + if (iz == 90 || iz == 122) { + +/* ASCII character set */ + + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } +/* L20: */ + } + } + + } else if (iz == 233 || iz == 169) { + +/* EBCDIC character set */ + + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && + ic <= 169) { + *(unsigned char *)subnam = (char) (ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= + 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); + } +/* L30: */ + } + } + + } else if (iz == 218 || iz == 250) { + +/* Prime machines: ASCII+128 */ + + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } +/* L40: */ + } + } + } + + *(unsigned char *)c1 = *(unsigned char *)subnam; + sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D'; + cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z'; + if (! (cname || sname)) { + return ret_val; + } + s_copy(c2, subnam + 1, 1_integer, 2_integer); + s_copy(c3, subnam + 3, 1_integer, 3_integer); + s_copy(c4, c3 + 1, 1_integer, 2_integer); + + switch (*ispec) { + case 1: goto L50; + case 2: goto L60; + case 3: goto L70; + } + +L50: + +/* 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 (s_cmp(c2, "GE", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, "QRF", 1_integer, 3_integer) == 0 || s_cmp(c3, + "RQF", 1_integer, 3_integer) == 0 || s_cmp(c3, "LQF", 1_integer, + 3_integer) == 0 || s_cmp(c3, "QLF", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "HRD", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "BRD", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "TRI", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "PO", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "SY", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (sname && s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { + nb = 32; + } else if (sname && s_cmp(c3, "GST", 1_integer, 3_integer) == 0) { + nb = 64; + } + } else if (cname && s_cmp(c2, "HE", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { + nb = 64; + } else if (s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { + nb = 32; + } else if (s_cmp(c3, "GST", 1_integer, 3_integer) == 0) { + nb = 64; + } + } else if (sname && s_cmp(c2, "OR", 1_integer, 2_integer) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nb = 32; + } + } + } else if (cname && s_cmp(c2, "UN", 1_integer, 2_integer) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nb = 32; + } + } + } else if (s_cmp(c2, "GB", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { + if (sname) { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } + } else if (s_cmp(c2, "PB", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { + if (sname) { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } + } else if (s_cmp(c2, "TR", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRI", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "LA", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "UUM", 1_integer, 3_integer) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (sname && s_cmp(c2, "ST", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "EBZ", 1_integer, 3_integer) == 0) { + nb = 1; + } + } + ret_val = nb; + return ret_val; + +L60: + +/* ISPEC = 2: minimum block size */ + + nbmin = 2; + if (s_cmp(c2, "GE", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "QRF", 1_integer, 3_integer) == 0 || + s_cmp(c3, "RQF", 1_integer, 3_integer) == 0 || + s_cmp(c3, "LQF", 1_integer, 3_integer) == 0 || + s_cmp(c3, "QLF", 1_integer, 3_integer) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "HRD", 1_integer, 3_integer) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "BRD", 1_integer, 3_integer) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "TRI", 1_integer, 3_integer) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } + } else if (s_cmp(c2, "SY", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { + if (sname) { + nbmin = 8; + } else { + nbmin = 8; + } + } else if (sname && s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { + nbmin = 2; + } + } else if (cname && s_cmp(c2, "HE", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { + nbmin = 2; + } + } else if (sname && s_cmp(c2, "OR", 1_integer, 2_integer) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nbmin = 2; + } + } + } else if (cname && s_cmp(c2, "UN", 1_integer, 2_integer) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nbmin = 2; + } + } + } + ret_val = nbmin; + return ret_val; + +L70: + +/* ISPEC = 3: crossover point */ + + nx = 0; + if (s_cmp(c2, "GE", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "QRF", 1_integer, 3_integer) == 0 || + s_cmp(c3, "RQF", 1_integer, 3_integer) == 0 || + s_cmp(c3, "LQF", 1_integer, 3_integer) == 0 || + s_cmp(c3, "QLF", 1_integer, 3_integer) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_cmp(c3, "HRD", 1_integer, 3_integer) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_cmp(c3, "BRD", 1_integer, 3_integer) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } + } else if (s_cmp(c2, "SY", 1_integer, 2_integer) == 0) { + if (sname && s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { + nx = 32; + } + } else if (cname && s_cmp(c2, "HE", 1_integer, 2_integer) == 0) { + if (s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { + nx = 32; + } + } else if (sname && s_cmp(c2, "OR", 1_integer, 2_integer) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nx = 128; + } + } + } else if (cname && s_cmp(c2, "UN", 1_integer, 2_integer) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || + s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || + s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || + s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { + nx = 128; + } + } + } + ret_val = nx; + return ret_val; + +L80: + +/* ISPEC = 4: number of shifts (used by xHSEQR) */ + + ret_val = 6; + return ret_val; + +L90: + +/* ISPEC = 5: minimum column dimension (not used) */ + + ret_val = 2; + return ret_val; + +L100: + +/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */ + + ret_val = (integer) ((float) std::min(*n1,*n2) * 1.6f); + return ret_val; + +L110: + +/* ISPEC = 7: number of processors (not used) */ + + ret_val = 1; + return ret_val; + +L120: + +/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */ + + ret_val = 50; + return ret_val; + +L130: + +/* ISPEC = 9: maximum size of the subproblems at the bottom of the */ +/* computation tree in the divide-and-conquer algorithm */ +/* (used by xGELSD and xGESDD) */ + + ret_val = 25; + return ret_val; + +L140: + +/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */ + +/* ILAENV = 0 */ + ret_val = 1; + if (ret_val == 1) { + ret_val = ieeeck_(&c__1, &c_b163, &c_b164); + } + return ret_val; + +L150: + +/* ISPEC = 11: infinity arithmetic can be trusted not to trap */ + +/* ILAENV = 0 */ + ret_val = 1; + if (ret_val == 1) { + ret_val = ieeeck_(&c__0, &c_b163, &c_b164); + } + return ret_val; + +L160: + +/* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. */ + + ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4) + ; + return ret_val; + +/* End of ILAENV */ + +} /* ilaenv_ */ + +integer ilaprec_(const char *prec) +{ + /* System generated locals */ + integer ret_val; + + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* October 2008 */ +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This subroutine translated from a character string specifying an */ +/* intermediate precision to the relevant BLAST-specified integer */ +/* constant. */ + +/* ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a */ +/* character indicating a supported intermediate precision. Otherwise */ +/* ILAPREC returns the constant value corresponding to PREC. */ + +/* Arguments */ +/* ========= */ +/* PREC (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'S': Single */ +/* = 'D': Double */ +/* = 'I': Indigenous */ +/* = 'X', 'E': Extra */ +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + if (lsame_(prec, "S")) { + ret_val = 211; + } else if (lsame_(prec, "D")) { + ret_val = 212; + } else if (lsame_(prec, "I")) { + ret_val = 213; + } else if (lsame_(prec, "X") || lsame_(prec, "E")) { + ret_val = 214; + } else { + ret_val = -1; + } + return ret_val; + +/* End of ILAPREC */ + +} /* ilaprec_ */ + +integer ilatrans_(const char *trans) +{ + /* System generated locals */ + integer ret_val; + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* October 2008 */ +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This subroutine translates from a character string specifying a */ +/* transposition operation to the relevant BLAST-specified integer */ +/* constant. */ + +/* ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not */ +/* a character indicating a transposition operator. Otherwise ILATRANS */ +/* returns the constant value corresponding to TRANS. */ + +/* Arguments */ +/* ========= */ +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': No transpose */ +/* = 'T': Transpose */ +/* = 'C': Conjugate transpose */ +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + if (lsame_(trans, "N")) { + ret_val = 111; + } else if (lsame_(trans, "T")) { + ret_val = 112; + } else if (lsame_(trans, "C")) { + ret_val = 113; + } else { + ret_val = -1; + } + return ret_val; + +/* End of ILATRANS */ + +} /* ilatrans_ */ + +/* Subroutine */ int ilaver_(integer *vers_major__, integer *vers_minor__, + integer *vers_patch__) +{ + +/* -- LAPACK routine (version 3.1.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* January 2007 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This subroutine return the Lapack version. */ + +/* Arguments */ +/* ========= */ + +/* VERS_MAJOR (output) INTEGER */ +/* return the lapack major version */ +/* VERS_MINOR (output) INTEGER */ +/* return the lapack minor version from the major version */ +/* VERS_PATCH (output) INTEGER */ +/* return the lapack patch version from the minor version */ + +/* .. Executable Statements .. */ + + *vers_major__ = 3; + *vers_minor__ = 1; + *vers_patch__ = 1; +/* ===================================================================== */ + + return 0; +} /* ilaver_ */ + +/* Subroutine */ integer iparmq_(integer *ispec, const char *name__, const char *opts, integer *n, integer + *ilo, integer *ihi, integer *lwork) +{ + /* System generated locals */ + integer ret_val, i__1, i__2; + float r__1; + + /* Local variables */ + integer nh, ns; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ + +/* Purpose */ +/* ======= */ + +/* This program sets problem and machine dependent parameters */ +/* useful for xHSEQR and its subroutines. It is called whenever */ +/* ILAENV is called with 12 <= ISPEC <= 16 */ + +/* Arguments */ +/* ========= */ + +/* ISPEC (input) integer scalar */ +/* ISPEC specifies which tunable parameter IPARMQ should */ +/* return. */ + +/* ISPEC=12: (INMIN) Matrices of order nmin or less */ +/* are sent directly to xLAHQR, the implicit */ +/* double shift QR algorithm. NMIN must be */ +/* at least 11. */ + +/* ISPEC=13: (INWIN) Size of the deflation window. */ +/* This is best set greater than or equal to */ +/* the number of simultaneous shifts NS. */ +/* Larger matrices benefit from larger deflation */ +/* windows. */ + +/* ISPEC=14: (INIBL) Determines when to stop nibbling and */ +/* invest in an (expensive) multi-shift QR sweep. */ +/* If the aggressive early deflation subroutine */ +/* finds LD converged eigenvalues from an order */ +/* NW deflation window and LD.GT.(NW*NIBBLE)/100, */ +/* then the next QR sweep is skipped and early */ +/* deflation is applied immediately to the */ +/* remaining active diagonal block. Setting */ +/* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a */ +/* multi-shift QR sweep whenever early deflation */ +/* finds a converged eigenvalue. Setting */ +/* IPARMQ(ISPEC=14) greater than or equal to 100 */ +/* prevents TTQRE from skipping a multi-shift */ +/* QR sweep. */ + +/* ISPEC=15: (NSHFTS) The number of simultaneous shifts in */ +/* a multi-shift QR iteration. */ + +/* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the */ +/* following meanings. */ +/* 0: During the multi-shift QR sweep, */ +/* xLAQR5 does not accumulate reflections and */ +/* does not use matrix-matrix multiply to */ +/* update the far-from-diagonal matrix */ +/* entries. */ +/* 1: During the multi-shift QR sweep, */ +/* xLAQR5 and/or xLAQRaccumulates reflections and uses */ +/* matrix-matrix multiply to update the */ +/* far-from-diagonal matrix entries. */ +/* 2: During the multi-shift QR sweep. */ +/* xLAQR5 accumulates reflections and takes */ +/* advantage of 2-by-2 block structure during */ +/* matrix-matrix multiplies. */ +/* (If xTRMM is slower than xGEMM, then */ +/* IPARMQ(ISPEC=16)=1 may be more efficient than */ +/* IPARMQ(ISPEC=16)=2 despite the greater level of */ +/* arithmetic work implied by the latter choice.) */ + +/* NAME (input) character string */ +/* Name of the calling subroutine */ + +/* OPTS (input) character string */ +/* This is a concatenation of the string arguments to */ +/* TTQRE. */ + +/* N (input) integer scalar */ +/* N is the order of the Hessenberg matrix H. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* It is assumed that H is already upper triangular */ +/* in rows and columns 1:ILO-1 and IHI+1:N. */ + +/* LWORK (input) integer scalar */ +/* The amount of workspace available. */ + +/* Further Details */ +/* =============== */ + +/* Little is known about how best to choose these parameters. */ +/* It is possible to use different values of the parameters */ +/* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. */ + +/* It is probably best to choose different parameters for */ +/* different matrices and different parameters at different */ +/* times during the iteration, but this has not been */ +/* implemented --- yet. */ + + +/* The best choices of most of the parameters depend */ +/* in an ill-understood way on the relative execution */ +/* rate of xLAQR3 and xLAQR5 and on the nature of each */ +/* particular eigenvalue problem. Experiment may be the */ +/* only practical way to determine which choices are most */ +/* effective. */ + +/* Following is a list of default values supplied by IPARMQ. */ +/* These defaults may be adjusted in order to attain better */ +/* performance in any particular computational environment. */ + +/* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. */ +/* Default: 75. (Must be at least 11.) */ + +/* IPARMQ(ISPEC=13) Recommended deflation window size. */ +/* This depends on ILO, IHI and NS, the */ +/* number of simultaneous shifts returned */ +/* by IPARMQ(ISPEC=15). The default for */ +/* (IHI-ILO+1).LE.500 is NS. The default */ +/* for (IHI-ILO+1).GT.500 is 3*NS/2. */ + +/* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. */ + +/* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. */ +/* a multi-shift QR iteration. */ + +/* If IHI-ILO+1 is ... */ + +/* greater than ...but less ... the */ +/* or equal to ... than default is */ + +/* 0 30 NS = 2+ */ +/* 30 60 NS = 4+ */ +/* 60 150 NS = 10 */ +/* 150 590 NS = ** */ +/* 590 3000 NS = 64 */ +/* 3000 6000 NS = 128 */ +/* 6000 infinity NS = 256 */ + +/* (+) By default matrices of this order are */ +/* passed to the implicit double shift routine */ +/* xLAHQR. See IPARMQ(ISPEC=12) above. These */ +/* values of NS are used only in case of a rare */ +/* xLAHQR failure. */ + +/* (**) The asterisks (**) indicate an ad-hoc */ +/* function increasing from 10 to 64. */ + +/* IPARMQ(ISPEC=16) Select structured matrix multiply. */ +/* (See ISPEC=16 above for details.) */ +/* Default: 3. */ + +/* ================================================================ */ +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + if (*ispec == 15 || *ispec == 13 || *ispec == 16) { + +/* ==== Set the number simultaneous shifts ==== */ + + nh = *ihi - *ilo + 1; + ns = 2; + if (nh >= 30) { + ns = 4; + } + if (nh >= 60) { + ns = 10; + } + if (nh >= 150) { +/* Computing MAX */ + r__1 = log((float) nh) / log(2.f); + i__1 = 10, i__2 = nh / i_nint(&r__1); + ns = std::max(i__1,i__2); + } + if (nh >= 590) { + ns = 64; + } + if (nh >= 3000) { + ns = 128; + } + if (nh >= 6000) { + ns = 256; + } +/* Computing MAX */ + i__1 = 2, i__2 = ns - ns % 2; + ns = std::max(i__1,i__2); + } + + if (*ispec == 12) { + + +/* ===== Matrices of order smaller than NMIN get sent */ +/* . to xLAHQR, the classic double shift algorithm. */ +/* . This must be at least 11. ==== */ + + ret_val = 75; + + } else if (*ispec == 14) { + +/* ==== INIBL: skip a multi-shift qr iteration and */ +/* . whenever aggressive early deflation finds */ +/* . at least (NIBBLE*(window size)/100) deflations. ==== */ + + ret_val = 14; + + } else if (*ispec == 15) { + +/* ==== NSHFTS: The number of simultaneous shifts ===== */ + + ret_val = ns; + + } else if (*ispec == 13) { + +/* ==== NW: deflation window size. ==== */ + + if (nh <= 500) { + ret_val = ns; + } else { + ret_val = ns * 3 / 2; + } + + } else if (*ispec == 16) { + +/* ==== IACC22: Whether to accumulate reflections */ +/* . before updating the far-from-diagonal elements */ +/* . and whether to use 2-by-2 block structure while */ +/* . doing it. A small amount of work could be saved */ +/* . by making this choice dependent also upon the */ +/* . NH=IHI-ILO+1. */ + + ret_val = 0; + if (ns >= 14) { + ret_val = 1; + } + if (ns >= 14) { + ret_val = 2; + } + + } else { +/* ===== invalid value of ispec ===== */ + ret_val = -1; + + } + +/* ==== End of IPARMQ ==== */ + + return ret_val; +} /* iparmq_ */ + +/* Subroutine */ bool lsame_(const char *ca, const char *cb) +{ + /* System generated locals */ + bool ret_val; + + /* Local variables */ + integer inta, intb, zcode; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* LSAME returns .TRUE. if CA is the same letter as CB regardless of */ +/* case. */ + +/* Arguments */ +/* ========= */ + +/* CA (input) CHARACTER*1 */ +/* CB (input) CHARACTER*1 */ +/* CA and CB specify the single characters to be compared. */ + +/* ===================================================================== */ + +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test if the characters are equal */ + + ret_val = *(unsigned char *)ca == *(unsigned char *)cb; + if (ret_val) { + return ret_val; + } + +/* Now test for equivalence if both characters are alphabetic. */ + + zcode = 'Z'; + +/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */ +/* machines, on which ICHAR returns a value with bit 8 set. */ +/* ICHAR('A') on Prime machines returns 193 which is the same as */ +/* ICHAR('A') on an EBCDIC machine. */ + + inta = *(unsigned char *)ca; + intb = *(unsigned char *)cb; + + if (zcode == 90 || zcode == 122) { + +/* ASCII is assumed - ZCODE is the ASCII code of either lower or */ +/* upper case 'Z'. */ + + if (inta >= 97 && inta <= 122) { + inta += -32; + } + if (intb >= 97 && intb <= 122) { + intb += -32; + } + + } else if (zcode == 233 || zcode == 169) { + +/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */ +/* upper case 'Z'. */ + + if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta + >= 162 && inta <= 169) { + inta += 64; + } + if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb + >= 162 && intb <= 169) { + intb += 64; + } + + } else if (zcode == 218 || zcode == 250) { + +/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */ +/* plus 128 of either lower or upper case 'Z'. */ + + if (inta >= 225 && inta <= 250) { + inta += -32; + } + if (intb >= 225 && intb <= 250) { + intb += -32; + } + } + ret_val = inta == intb; + +/* RETURN */ + +/* End of LSAME */ + + return ret_val; +} /* lsame_ */ + +/* Subroutine */ bool lsamen_(integer *n, const char *ca, const char *cb) +{ + /* System generated locals */ + integer i__1; + bool ret_val; + + /* Local variables */ + integer i__; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* LSAMEN tests if the first N letters of CA are the same as the */ +/* first N letters of CB, regardless of case. */ +/* LSAMEN returns .TRUE. if CA and CB are equivalent except for case */ +/* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) */ +/* or LEN( CB ) is less than N. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of characters in CA and CB to be compared. */ + +/* CA (input) CHARACTER*(*) */ +/* CB (input) CHARACTER*(*) */ +/* CA and CB specify two character strings of length at least N. */ +/* Only the first N characters of each string will be accessed. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + ret_val = false; + if (strlen(ca) < *n || strlen(cb) < *n) { + goto L20; + } + +/* Do for each character in the two strings. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Test if the characters are equal using LSAME. */ + + if (! lsame_(ca + (i__ - 1), cb + (i__ - 1))) { + goto L20; + } + +/* L10: */ + } + ret_val = true; + +L20: + return ret_val; + +/* End of LSAMEN */ + +} /* lsamen_ */ + +int slamc1_(integer *beta, integer *t, bool *rnd, bool *ieee1); +int slamc2_(integer *beta, integer *t, bool *rnd, float * + eps, integer *emin, float *rmin, integer *emax, float *rmax); +double slamc3_(float *a, float *b); +int slamc4_(integer *emin, float *start, integer *base); +int slamc5_(integer *beta, integer *p, integer *emin, + bool *ieee, integer *emax, float *rmax); + +double slamch_(const char *cmach) +{ + /* Initialized data */ + + static bool first = true; + + /* System generated locals */ + integer i__1; + float ret_val; + + /* Local variables */ + static float t; + integer it; + static float rnd, eps, base; + integer beta; + static float emin, prec, emax; + integer imin, imax; + bool lrnd; + static float rmin, rmax; + float rmach; + float small; + static float sfmin; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SLAMCH determines single precision machine parameters. */ + +/* Arguments */ +/* ========= */ + +/* CMACH (input) CHARACTER*1 */ +/* Specifies the value to be returned by SLAMCH: */ +/* = 'E' or 'e', SLAMCH := eps */ +/* = 'S' or 's , SLAMCH := sfmin */ +/* = 'B' or 'b', SLAMCH := base */ +/* = 'P' or 'p', SLAMCH := eps*base */ +/* = 'N' or 'n', SLAMCH := t */ +/* = 'R' or 'r', SLAMCH := rnd */ +/* = 'M' or 'm', SLAMCH := emin */ +/* = 'U' or 'u', SLAMCH := rmin */ +/* = 'L' or 'l', SLAMCH := emax */ +/* = 'O' or 'o', SLAMCH := 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Save statement .. */ +/* .. */ +/* .. Data statements .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (first) { + slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); + base = (float) beta; + t = (float) it; + if (lrnd) { + rnd = 1.f; + i__1 = 1 - it; + eps = pow_ri(&base, &i__1) / 2; + } else { + rnd = 0.f; + i__1 = 1 - it; + eps = pow_ri(&base, &i__1); + } + prec = eps * base; + emin = (float) imin; + emax = (float) imax; + sfmin = rmin; + small = 1.f / rmax; + if (small >= sfmin) { + +/* Use SMALL plus a bit, to avoid the possibility of rounding */ +/* causing overflow when computing 1/sfmin. */ + + sfmin = small * (eps + 1.f); + } + } + + if (lsame_(cmach, "E")) { + rmach = eps; + } else if (lsame_(cmach, "S")) { + rmach = sfmin; + } else if (lsame_(cmach, "B")) { + rmach = base; + } else if (lsame_(cmach, "P")) { + rmach = prec; + } else if (lsame_(cmach, "N")) { + rmach = t; + } else if (lsame_(cmach, "R")) { + rmach = rnd; + } else if (lsame_(cmach, "M")) { + rmach = emin; + } else if (lsame_(cmach, "U")) { + rmach = rmin; + } else if (lsame_(cmach, "L")) { + rmach = emax; + } else if (lsame_(cmach, "O")) { + rmach = rmax; + } + + ret_val = rmach; + first = false; + return ret_val; + +/* End of SLAMCH */ + +} /* slamch_ */ + + +/* *********************************************************************** */ + +/* Subroutine */ int slamc1_(integer *beta, integer *t, bool *rnd, bool + *ieee1) +{ + /* Initialized data */ + + static bool first = true; + + /* System generated locals */ + float r__1, r__2; + + /* Local variables */ + float a, b, c__, f, t1, t2; + static integer lt; + float one, qtr; + static bool lrnd; + static integer lbeta; + float savec; + static bool lieee1; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SLAMC1 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 .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Save statement .. */ +/* .. */ +/* .. Data statements .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (first) { + one = 1.f; + +/* LBETA, LIEEE1, LT and LRND are the local values of BETA, */ +/* IEEE1, T and RND. */ + +/* Throughout this routine we use the function SLAMC3 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.f; + c__ = 1.f; + +/* + WHILE( C.EQ.ONE )LOOP */ +L10: + if (c__ == one) { + a *= 2; + c__ = slamc3_(&a, &one); + r__1 = -a; + c__ = slamc3_(&c__, &r__1); + goto L10; + } +/* + END WHILE */ + +/* Now compute b = 2.0**m with the smallest positive integer m */ +/* such that */ + +/* fl( a + b ) .gt. a. */ + + b = 1.f; + c__ = slamc3_(&a, &b); + +/* + WHILE( C.EQ.A )LOOP */ +L20: + if (c__ == a) { + b *= 2; + c__ = slamc3_(&a, &b); + goto L20; + } +/* + 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__; + r__1 = -a; + c__ = slamc3_(&c__, &r__1); + 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 = (float) lbeta; + r__1 = b / 2; + r__2 = -b / 100; + f = slamc3_(&r__1, &r__2); + c__ = slamc3_(&f, &a); + if (c__ == a) { + lrnd = true; + } else { + lrnd = false; + } + r__1 = b / 2; + r__2 = b / 100; + f = slamc3_(&r__1, &r__2); + c__ = slamc3_(&f, &a); + if (lrnd && c__ == 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. */ + + r__1 = b / 2; + t1 = slamc3_(&r__1, &a); + r__1 = b / 2; + t2 = slamc3_(&r__1, &savec); + lieee1 = t1 == a && t2 > savec && 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.f; + c__ = 1.f; + +/* + WHILE( C.EQ.ONE )LOOP */ +L30: + if (c__ == one) { + ++lt; + a *= lbeta; + c__ = slamc3_(&a, &one); + r__1 = -a; + c__ = slamc3_(&c__, &r__1); + goto L30; + } +/* + END WHILE */ + + } + + *beta = lbeta; + *t = lt; + *rnd = lrnd; + *ieee1 = lieee1; + first = false; + return 0; + +/* End of SLAMC1 */ + +} /* slamc1_ */ + + +/* *********************************************************************** */ + +/* Subroutine */ int slamc2_(integer *beta, integer *t, bool *rnd, float * + eps, integer *emin, float *rmin, integer *emax, float *rmax) +{ + /* Initialized data */ + + static bool first = true; + static bool iwarn = false; + + /* System generated locals */ + integer i__1; + float r__1, r__2, r__3, r__4, r__5; + + /* Local variables */ + float a, b, c__; + integer i__; + static integer lt; + float one, two; + bool ieee; + float half; + bool lrnd; + static float leps; + float zero; + static integer lbeta; + float rbase; + static integer lemin, lemax; + integer gnmin; + float small; + integer gpmin; + float third; + static float lrmin, lrmax; + float sixth; + bool lieee1; + integer ngnmin, ngpmin; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SLAMC2 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) REAL */ +/* 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) REAL */ +/* 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) REAL */ +/* 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 .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Save statement .. */ +/* .. */ +/* .. Data statements .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (first) { + zero = 0.f; + one = 1.f; + two = 2.f; + +/* 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 SLAMC3 to ensure */ +/* that relevant values are stored and not held in registers, or */ +/* are not affected by optimizers. */ + +/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */ + + slamc1_(&lbeta, <, &lrnd, &lieee1); + +/* Start to find EPS. */ + + b = (float) lbeta; + i__1 = -lt; + a = pow_ri(&b, &i__1); + leps = a; + +/* Try some tricks to see whether or not this is the correct EPS. */ + + b = two / 3; + half = one / 2; + r__1 = -half; + sixth = slamc3_(&b, &r__1); + third = slamc3_(&sixth, &sixth); + r__1 = -half; + b = slamc3_(&third, &r__1); + b = slamc3_(&b, &sixth); + b = abs(b); + if (b < leps) { + b = leps; + } + + leps = 1.f; + +/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ +L10: + if (leps > b && b > zero) { + leps = b; + r__1 = half * leps; +/* Computing 5th power */ + r__3 = two, r__4 = r__3, r__3 *= r__3; +/* Computing 2nd power */ + r__5 = leps; + r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5); + c__ = slamc3_(&r__1, &r__2); + r__1 = -c__; + c__ = slamc3_(&half, &r__1); + b = slamc3_(&half, &c__); + r__1 = -b; + c__ = slamc3_(&half, &r__1); + b = slamc3_(&half, &c__); + goto L10; + } +/* + END WHILE */ + + if (a < 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; + for (i__ = 1; i__ <= 3; ++i__) { + r__1 = small * rbase; + small = slamc3_(&r__1, &zero); +/* L20: */ + } + a = slamc3_(&one, &small); + slamc4_(&ngpmin, &one, &lbeta); + r__1 = -one; + slamc4_(&ngnmin, &r__1, &lbeta); + slamc4_(&gpmin, &a, &lbeta); + r__1 = -a; + slamc4_(&gnmin, &r__1, &lbeta); + ieee = false; + + if (ngpmin == ngnmin && gpmin == gnmin) { + if (ngpmin == gpmin) { + lemin = ngpmin; +/* ( Non twos-complement machines, no gradual underflow; */ +/* e.g., VAX ) */ + } else if (gpmin - ngpmin == 3) { + lemin = ngpmin - 1 + lt; + ieee = true; +/* ( Non twos-complement machines, with gradual underflow; */ +/* e.g., IEEE standard followers ) */ + } else { + lemin = std::min(ngpmin,gpmin); +/* ( A guess; no known machine ) */ + iwarn = true; + } + + } else if (ngpmin == gpmin && ngnmin == gnmin) { + if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { + lemin = std::max(ngpmin,ngnmin); +/* ( Twos-complement machines, no gradual underflow; */ +/* e.g., CYBER 205 ) */ + } else { + lemin = std::min(ngpmin,ngnmin); +/* ( A guess; no known machine ) */ + iwarn = true; + } + + } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) + { + if (gpmin - std::min(ngpmin,ngnmin) == 3) { + lemin = std::max(ngpmin,ngnmin) - 1 + lt; +/* ( Twos-complement machines with gradual underflow; */ +/* no known machine ) */ + } else { + lemin = std::min(ngpmin,ngnmin); +/* ( A guess; no known machine ) */ + iwarn = true; + } + + } else { +/* Computing MIN */ + i__1 = std::min(ngpmin,ngnmin), i__1 = std::min(i__1,gpmin); + lemin = std::min(i__1,gnmin); +/* ( A guess; no known machine ) */ + iwarn = true; + } + first = false; +/* ** */ +/* Comment out this if block if EMIN is ok */ + if (iwarn) { + first = true; + Melder_warning (U"WARNING. The value EMIN may be incorrect:- \n" + "EMIN = ", lemin, + U"If, after inspection, the value EMIN looks acceptable please comment out \n" + "the IF block as marked within the code of routine SLAMC2; \n " + "otherwise, supply EMIN explicitly.\n"); + } +/* ** */ + +/* Assume IEEE arithmetic if we found denormalised numbers above, */ +/* or if arithmetic seems to round in the IEEE style, determined */ +/* in routine SLAMC1. A true IEEE machine should have both things */ +/* true; however, faulty machines may have one or the other. */ + + ieee = ieee || 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.f; + i__1 = 1 - lemin; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = lrmin * rbase; + lrmin = slamc3_(&r__1, &zero); +/* L30: */ + } + +/* Finally, call SLAMC5 to compute EMAX and RMAX. */ + + slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); + } + + *beta = lbeta; + *t = lt; + *rnd = lrnd; + *eps = leps; + *emin = lemin; + *rmin = lrmin; + *emax = lemax; + *rmax = lrmax; + + return 0; + + +/* End of SLAMC2 */ + +} /* slamc2_ */ + + +/* *********************************************************************** */ + +double slamc3_(float *a, float *b) +{ + /* System generated locals */ + volatile float ret_val; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SLAMC3 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 (input) REAL */ +/* B (input) REAL */ +/* The values A and B. */ + +/* ===================================================================== */ + +/* .. Executable Statements .. */ + + ret_val = *a + *b; + + return ret_val; + +/* End of SLAMC3 */ + +} /* slamc3_ */ + + +/* *********************************************************************** */ + +/* Subroutine */ int slamc4_(integer *emin, float *start, integer *base) +{ + /* System generated locals */ + integer i__1; + float r__1; + + /* Local variables */ + float a; + integer i__; + float b1, b2, c1, c2, d1, d2, one, zero, rbase; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SLAMC4 is a service routine for SLAMC2. */ + +/* Arguments */ +/* ========= */ + +/* EMIN (output) INTEGER */ +/* 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) REAL */ +/* The starting point for determining EMIN. */ + +/* BASE (input) INTEGER */ +/* The base of the machine. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + a = *start; + one = 1.f; + rbase = one / *base; + zero = 0.f; + *emin = 1; + r__1 = a * rbase; + b1 = slamc3_(&r__1, &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 */ +L10: + if (c1 == a && c2 == a && d1 == a && d2 == a) { + --(*emin); + a = b1; + r__1 = a / *base; + b1 = slamc3_(&r__1, &zero); + r__1 = b1 * *base; + c1 = slamc3_(&r__1, &zero); + d1 = zero; + i__1 = *base; + for (i__ = 1; i__ <= i__1; ++i__) { + d1 += b1; +/* L20: */ + } + r__1 = a * rbase; + b2 = slamc3_(&r__1, &zero); + r__1 = b2 / rbase; + c2 = slamc3_(&r__1, &zero); + d2 = zero; + i__1 = *base; + for (i__ = 1; i__ <= i__1; ++i__) { + d2 += b2; +/* L30: */ + } + goto L10; + } +/* + END WHILE */ + + return 0; + +/* End of SLAMC4 */ + +} /* slamc4_ */ + + +/* *********************************************************************** */ + +/* Subroutine */ int slamc5_(integer *beta, integer *p, integer *emin, + bool *ieee, integer *emax, float *rmax) +{ + /* Table of constant values */ + static float c_b32 = 0.f; + + /* System generated locals */ + integer i__1; + float r__1; + + /* Local variables */ + integer i__; + float y, z__; + integer try__, lexp; + float oldy; + integer uexp, nbits; + float recbas; + integer exbits, expsum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* SLAMC5 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) REAL */ +/* The largest machine floating-point number. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. 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; +L10: + try__ = lexp << 1; + if (try__ <= -(*emin)) { + lexp = try__; + ++exbits; + goto L10; + } + if (lexp == -(*emin)) { + uexp = lexp; + } else { + uexp = try__; + ++exbits; + } + +/* 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 > -lexp - *emin) { + expsum = lexp << 1; + } else { + expsum = uexp << 1; + } + +/* EXPSUM is the exponent range, approximately equal to */ +/* EMAX - EMIN + 1 . */ + + *emax = expsum + *emin - 1; + nbits = exbits + 1 + *p; + +/* NBITS is the total number of bits needed to store a */ +/* floating-point number. */ + + if (nbits % 2 == 1 && *beta == 2) { + +/* 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); + } + + if (*ieee) { + +/* Assume we are on an IEEE machine which reserves one exponent */ +/* for infinity and NaN. */ + + --(*emax); + } + +/* 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 = 1.f / *beta; + z__ = *beta - 1.f; + y = 0.f; + i__1 = *p; + for (i__ = 1; i__ <= i__1; ++i__) { + z__ *= recbas; + if (y < 1.f) { + oldy = y; + } + y = slamc3_(&y, &z__); +/* L20: */ + } + if (y >= 1.f) { + y = oldy; + } + +/* Now multiply by BETA**EMAX to get RMAX. */ + + i__1 = *emax; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = y * *beta; + y = slamc3_(&r__1, &c_b32); +/* L30: */ + } + + *rmax = y; + return 0; + +/* End of SLAMC5 */ + +} /* slamc5_ */ diff --git a/external/clapack/lapack/Makefile b/external/clapack/lapack/Makefile deleted file mode 100644 index 906abcb3..00000000 --- a/external/clapack/lapack/Makefile +++ /dev/null @@ -1,149 +0,0 @@ -# Makefile of the library liblapack.a -# David Weenink -# Generated on Fri Mar 13 11:53:58 2020 -# with the script "CLAPACK_copyFiles_to_Praat.praat". -# For CLAPACK version 3.1.1.1. - -include ../../../makefile.defs - -CPPFLAGS = -I ../../../melder -I .. - -OBJECTS = dbdsdc.o dbdsqr.o ddisna.o \ - dgbbrd.o dgbcon.o dgbequ.o dgbequb.o \ - dgbrfs.o dgbrfsx.o dgbsv.o dgbsvx.o dgbsvxx.o \ - dgbtf2.o dgbtrf.o dgbtrs.o \ - dgebak.o dgebal.o dgebd2.o \ - dgebrd.o dgecon.o dgeequ.o dgeequb.o \ - dgees.o dgeesx.o dgeev.o \ - dgeevx.o dgegs.o dgegv.o \ - dgehd2.o dgehrd.o dgelq2.o \ - dgelqf.o dgels.o dgelsd.o \ - dgelss.o dgelsx.o dgelsy.o \ - dgeql2.o dgeqlf.o dgeqp3.o \ - dgeqpf.o dgeqr2.o dgeqrf.o \ - dgerfs.o dgerq2.o dgerqf.o \ - dgesc2.o dgesdd.o dgesv.o \ - dgesvd.o dgesvx.o dgetc2.o \ - dgetf2.o dgetrf.o dgetri.o \ - dgetrs.o dggbak.o dggbal.o \ - dgges.o dggesx.o dggev.o \ - dggevx.o dggglm.o dgghrd.o \ - dgglse.o dggqrf.o dggrqf.o \ - dggsvd.o dggsvp.o dgtcon.o \ - dgtrfs.o dgtsv.o dgtsvx.o \ - dgttrf.o dgttrs.o dgtts2.o \ - dhgeqz.o dhsein.o dhseqr.o \ - disnan.o dlabad.o dlabrd.o \ - dla_gbrcond.o dla_porcond.o \ - dlacn2.o dlacon.o dlacpy.o \ - dladiv.o dlae2.o dlaebz.o \ - dlaed0.o dlaed1.o dlaed2.o \ - dlaed3.o dlaed4.o dlaed5.o \ - dlaed6.o dlaed7.o dlaed8.o \ - dlaed9.o dlaeda.o dlaein.o \ - dlaev2.o dlaexc.o dlag2.o \ - dlag2s.o dlags2.o dlagtf.o \ - dlagtm.o dlagts.o dlagv2.o \ - dlahqr.o dlahr2.o dlahrd.o \ - dlaic1.o dlaisnan.o dlaln2.o \ - dlals0.o dlalsa.o dlalsd.o \ - dlamch.o dlamrg.o dlaneg.o \ - dlangb.o dlange.o dlangt.o \ - dlanhs.o dlansb.o dlansf.o dlansp.o \ - dlanst.o dlansy.o dlantb.o \ - dlantp.o dlantr.o dlanv2.o \ - dlapll.o dlapmt.o dlapy2.o \ - dlapy3.o dlaqgb.o dlaqge.o \ - dlaqp2.o dlaqps.o dlaqr0.o \ - dlaqr1.o dlaqr2.o dlaqr3.o \ - dlaqr4.o dlaqr5.o dlaqsb.o \ - dlaqsp.o dlaqsy.o dlaqtr.o \ - dlar1v.o dlar2v.o dlarf.o \ - dlarfb.o dlarfg.o dlarfp.o dlarft.o \ - dlarfx.o dlargv.o dlarnv.o \ - dlarra.o dlarrb.o dlarrc.o \ - dlarrd.o dlarre.o dlarrf.o \ - dlarrj.o dlarrk.o dlarrr.o \ - dlarrv.o dlarscl2.o dlartg.o dlartv.o \ - dlaruv.o dlarz.o dlarzb.o \ - dlarzt.o dlas2.o dlascl.o dlascl2.o \ - dlasd0.o dlasd1.o dlasd2.o \ - dlasd3.o dlasd4.o dlasd5.o \ - dlasd6.o dlasd7.o dlasd8.o \ - dlasda.o dlasdq.o dlasdt.o \ - dlaset.o dlasq1.o dlasq2.o \ - dlasq3.o dlasq4.o dlasq5.o \ - dlasq6.o dlasr.o dlasrt.o \ - dlassq.o dlasv2.o dlaswp.o \ - dlasy2.o dlasyf.o dlat2s.o dlatbs.o \ - dlatdf.o dlatps.o dlatrd.o \ - dlatrs.o dlatrz.o dlatzm.o \ - dlauu2.o dlauum.o dlazq3.o \ - dlazq4.o dopgtr.o dopmtr.o \ - dorg2l.o dorg2r.o dorgbr.o \ - dorghr.o dorgl2.o dorglq.o \ - dorgql.o dorgqr.o dorgr2.o \ - dorgrq.o dorgtr.o dorm2l.o \ - dorm2r.o dormbr.o dormhr.o \ - dorml2.o dormlq.o dormql.o \ - dormqr.o dormr2.o dormr3.o \ - dormrq.o dormrz.o dormtr.o \ - dpbcon.o dpbequ.o dpbrfs.o \ - dpbstf.o dpbsv.o dpbsvx.o \ - dpbtf2.o dpbtrf.o dpbtrs.o dpftrf.o \ - dpftri.o dpftrs.o dpocon.o dpoequ.o dpoequb.o dporfs.o \ - dposv.o dposvx.o dpotf2.o \ - dpotrf.o dpotri.o dpotrs.o \ - dppcon.o dppequ.o dpprfs.o \ - dppsv.o dpstf2.o dpstrf.o dppsvx.o dpptrf.o \ - dpptri.o dpptrs.o dptcon.o \ - dpteqr.o dptrfs.o dptsv.o \ - dptsvx.o dpttrf.o dpttrs.o \ - dptts2.o drscl.o dsbev.o \ - dsbevd.o dsbevx.o dsbgst.o \ - dsbgv.o dsbgvd.o dsbgvx.o \ - dsbtrd.o dsfrk.o dsgesv.o dspcon.o \ - dspev.o dspevd.o dspevx.o \ - dspgst.o dspgv.o dspgvd.o \ - dspgvx.o dsposv.o dsprfs.o dspsv.o \ - dspsvx.o dsptrd.o dsptrf.o \ - dsptri.o dsptrs.o dstebz.o \ - dstedc.o dstegr.o dstein.o \ - dstemr.o dsteqr.o dsterf.o \ - dstev.o dstevd.o dstevr.o \ - dstevx.o dsycon.o dsyequb.o dsyev.o \ - dsyevd.o dsyevr.o dsyevx.o \ - dsygs2.o dsygst.o dsygv.o \ - dsygvd.o dsygvx.o dsyrfs.o \ - dsysv.o dsysvx.o dsytd2.o \ - dsytf2.o dsytrd.o dsytrf.o \ - dsytri.o dsytrs.o dtbcon.o \ - dtbrfs.o dtbtrs.o dtfsm.o dtftri.o dtfttp.o dtfttr.o dtgevc.o \ - dtgex2.o dtgexc.o dtgsen.o \ - dtgsja.o dtgsna.o dtgsy2.o \ - dtgsyl.o dtpcon.o dtprfs.o \ - dtptri.o dtptrs.o dtrcon.o dtpttf.o dtpttr.o \ - dtrevc.o dtrexc.o dtrrfs.o \ - dtrsen.o dtrsna.o dtrsyl.o \ - dtrti2.o dtrtri.o dtrtrs.o dtrttf.o dtrttp.o \ - dtzrqf.o dtzrzf.o ieeeck.o \ - iladlc.o iladlr.o ilaenv.o ilaver.o iparmq.o \ - lsame.o lsamen.o slamch.o \ - sisnan.o slaisnan.o \ - spotf2.o spotrf.o spotrs.o ssfrk.o - -.PHONY: all clean - -all: liblapack.a - -clean: - $(RM) $(OBJECTS) - $(RM) liblapack.a - -liblapack.a: $(OBJECTS) - touch liblapack.a - rm liblapack.a - $(AR) cq liblapack.a $(OBJECTS) - $(RANLIB) liblapack.a - -$(OBJECTS): ../*.h ../../../melder/*.h diff --git a/external/clapack/lapack/chla_transtype.cpp b/external/clapack/lapack/chla_transtype.cpp deleted file mode 100644 index 089abcf5..00000000 --- a/external/clapack/lapack/chla_transtype.cpp +++ /dev/null @@ -1,49 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -void chla_transtype__(char *ret_val, integer ret_val_len, integer *trans) -{ - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* October 2008 */ -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This subroutine translates from a BLAST-specified integer constant to */ -/* the character string specifying a transposition operation. */ - -/* CHLA_TRANSTYPE returns an CHARACTER*1. If CHLA_TRANSTYPE is 'X', */ -/* then input is not an integer indicating a transposition operator. */ -/* Otherwise CHLA_TRANSTYPE returns the constant value corresponding to */ -/* TRANS. */ - -/* Arguments */ -/* ========= */ -/* TRANS (input) INTEGER */ -/* Specifies the form of the system of equations: */ -/* = BLAS_NO_TRANS = 111 : No Transpose */ -/* = BLAS_TRANS = 112 : Transpose */ -/* = BLAS_CONJ_TRANS = 113 : Conjugate Transpose */ -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Executable Statements .. */ - if (*trans == 111) { - *(unsigned char *)ret_val = 'N'; - } else if (*trans == 112) { - *(unsigned char *)ret_val = 'T'; - } else if (*trans == 113) { - *(unsigned char *)ret_val = 'C'; - } else { - *(unsigned char *)ret_val = 'X'; - } - return ; - -/* End of CHLA_TRANSTYPE */ - -} /* chla_transtype__ */ diff --git a/external/clapack/lapack/dbdsdc.cpp b/external/clapack/lapack/dbdsdc.cpp deleted file mode 100644 index 1a7b0c1a..00000000 --- a/external/clapack/lapack/dbdsdc.cpp +++ /dev/null @@ -1,473 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__9 = 9; -static integer c__0 = 0; -static double c_b15 = 1.; -static integer c__1 = 1; -static double c_b29 = 0.; - -/* Subroutine */ int dbdsdc_(const char *uplo, const char *compq, integer *n, double * - d__, double *e, double *u, integer *ldu, double *vt, - integer *ldvt, double *q, integer *iq, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j, k; - double p, r__; - integer z__, ic, ii, kk; - double cs; - integer is, iu; - double sn; - integer nm1; - double eps; - integer ivt, difl, difr, ierr, perm, mlvl, sqre; - integer poles, iuplo, nsize, start; - integer givcol; - integer icompq; - double orgnrm; - integer givnum, givptr, qstart, smlsiz, wstart, smlszp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DBDSDC computes the singular value decomposition (SVD) of a real */ -/* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */ -/* using a divide and conquer method, where S is a diagonal matrix */ -/* with non-negative diagonal elements (the singular values of B), and */ -/* U and VT are orthogonal matrices of left and right singular vectors, */ -/* respectively. DBDSDC can be used to compute all singular values, */ -/* and optionally, singular vectors or singular vectors in compact form. */ - -/* This code makes very mild assumptions about floating point */ -/* arithmetic. It will work on machines with a guard digit in */ -/* add/subtract, or on those binary machines without guard digits */ -/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ -/* It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. See DLASD3 for details. */ - -/* The code currently calls DLASDQ if singular values only are desired. */ -/* However, it can be slightly modified to compute singular values */ -/* using the divide and conquer method. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': B is upper bidiagonal. */ -/* = 'L': B is lower bidiagonal. */ - -/* COMPQ (input) CHARACTER*1 */ -/* Specifies whether singular vectors are to be computed */ -/* as follows: */ -/* = 'N': Compute singular values only; */ -/* = 'P': Compute singular values and compute singular */ -/* vectors in compact form; */ -/* = 'I': Compute singular values and singular vectors. */ - -/* N (input) INTEGER */ -/* The order of the matrix B. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the bidiagonal matrix B. */ -/* On exit, if INFO=0, the singular values of B. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the elements of E contain the offdiagonal */ -/* elements of the bidiagonal matrix whose SVD is desired. */ -/* On exit, E has been destroyed. */ - -/* U (output) DOUBLE PRECISION array, dimension (LDU,N) */ -/* If COMPQ = 'I', then: */ -/* On exit, if INFO = 0, U contains the left singular vectors */ -/* of the bidiagonal matrix. */ -/* For other values of COMPQ, U is not referenced. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= 1. */ -/* If singular vectors are desired, then LDU >= max( 1, N ). */ - -/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */ -/* If COMPQ = 'I', then: */ -/* On exit, if INFO = 0, VT' contains the right singular */ -/* vectors of the bidiagonal matrix. */ -/* For other values of COMPQ, VT is not referenced. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. LDVT >= 1. */ -/* If singular vectors are desired, then LDVT >= max( 1, N ). */ - -/* Q (output) DOUBLE PRECISION array, dimension (LDQ) */ -/* If COMPQ = 'P', then: */ -/* On exit, if INFO = 0, Q and IQ contain the left */ -/* and right singular vectors in a compact form, */ -/* requiring O(N log N) space instead of 2*N**2. */ -/* In particular, Q contains all the DOUBLE PRECISION data in */ -/* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */ -/* words of memory, where SMLSIZ is returned by ILAENV and */ -/* is equal to the maximum size of the subproblems at the */ -/* bottom of the computation tree (usually about 25). */ -/* For other values of COMPQ, Q is not referenced. */ - -/* IQ (output) INTEGER array, dimension (LDIQ) */ -/* If COMPQ = 'P', then: */ -/* On exit, if INFO = 0, Q and IQ contain the left */ -/* and right singular vectors in a compact form, */ -/* requiring O(N log N) space instead of 2*N**2. */ -/* In particular, IQ contains all INTEGER data in */ -/* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */ -/* words of memory, where SMLSIZ is returned by ILAENV and */ -/* is equal to the maximum size of the subproblems at the */ -/* bottom of the computation tree (usually about 25). */ -/* For other values of COMPQ, IQ is not referenced. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* If COMPQ = 'N' then LWORK >= (4 * N). */ -/* If COMPQ = 'P' then LWORK >= (6 * N). */ -/* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */ - -/* IWORK (workspace) INTEGER array, dimension (8*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: The algorithm failed to compute an singular value. */ -/* The update process of divide and conquer failed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ -/* Changed dimension statement in comment describing E from (N) to */ -/* (N-1). Sven, 17 Feb 05. */ -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - --q; - --iq; - --work; - --iwork; - - /* Function Body */ - *info = 0; - - iuplo = 0; - if (lsame_(uplo, "U")) { - iuplo = 1; - } - if (lsame_(uplo, "L")) { - iuplo = 2; - } - if (lsame_(compq, "N")) { - icompq = 0; - } else if (lsame_(compq, "P")) { - icompq = 1; - } else if (lsame_(compq, "I")) { - icompq = 2; - } else { - icompq = -1; - } - if (iuplo == 0) { - *info = -1; - } else if (icompq < 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ldu < 1 || icompq == 2 && *ldu < *n) { - *info = -7; - } else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DBDSDC", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0); - if (*n == 1) { - if (icompq == 1) { - q[1] = d_sign(&c_b15, &d__[1]); - q[smlsiz * *n + 1] = 1.; - } else if (icompq == 2) { - u[u_dim1 + 1] = d_sign(&c_b15, &d__[1]); - vt[vt_dim1 + 1] = 1.; - } - d__[1] = abs(d__[1]); - return 0; - } - nm1 = *n - 1; - -/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ -/* by applying Givens rotations on the left */ - - wstart = 1; - qstart = 3; - if (icompq == 1) { - dcopy_(n, &d__[1], &c__1, &q[1], &c__1); - i__1 = *n - 1; - dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1); - } - if (iuplo == 2) { - qstart = 5; - wstart = (*n << 1) - 1; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - if (icompq == 1) { - q[i__ + (*n << 1)] = cs; - q[i__ + *n * 3] = sn; - } else if (icompq == 2) { - work[i__] = cs; - work[nm1 + i__] = -sn; - } -/* L10: */ - } - } - -/* If ICOMPQ = 0, use DLASDQ to compute the singular values. */ - - if (icompq == 0) { - dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[ - wstart], info); - goto L40; - } - -/* If N is smaller than the minimum divide size SMLSIZ, then solve */ -/* the problem with another solver. */ - - if (*n <= smlsiz) { - if (icompq == 2) { - dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu); - dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt); - dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset] -, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[ - wstart], info); - } else if (icompq == 1) { - iu = 1; - ivt = iu + *n; - dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n); - dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n); - dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + ( - qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[ - iu + (qstart - 1) * *n], n, &work[wstart], info); - } - goto L40; - } - - if (icompq == 2) { - dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu); - dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt); - } - -/* Scale. */ - - orgnrm = dlanst_("M", n, &d__[1], &e[1]); - if (orgnrm == 0.) { - return 0; - } - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr); - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, & - ierr); - - eps = dlamch_("Epsilon"); - - mlvl = (integer) (log((double) (*n) / (double) (smlsiz + 1)) / - log(2.)) + 1; - smlszp = smlsiz + 1; - - if (icompq == 1) { - iu = 1; - ivt = smlsiz + 1; - difl = ivt + smlszp; - difr = difl + mlvl; - z__ = difr + (mlvl << 1); - ic = z__ + mlvl; - is = ic + 1; - poles = is + 1; - givnum = poles + (mlvl << 1); - - k = 1; - givptr = 2; - perm = 3; - givcol = perm + mlvl; - } - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) < eps) { - d__[i__] = d_sign(&eps, &d__[i__]); - } -/* L20: */ - } - - start = 1; - sqre = 0; - - i__1 = nm1; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { - -/* Subproblem found. First determine its size and then */ -/* apply divide and conquer on it. */ - - if (i__ < nm1) { - -/* A subproblem with E(I) small for I < NM1. */ - - nsize = i__ - start + 1; - } else if ((d__1 = e[i__], abs(d__1)) >= eps) { - -/* A subproblem with E(NM1) not too small but I = NM1. */ - - nsize = *n - start + 1; - } else { - -/* A subproblem with E(NM1) small. This implies an */ -/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */ -/* first. */ - - nsize = i__ - start + 1; - if (icompq == 2) { - u[*n + *n * u_dim1] = d_sign(&c_b15, &d__[*n]); - vt[*n + *n * vt_dim1] = 1.; - } else if (icompq == 1) { - q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]); - q[*n + (smlsiz + qstart - 1) * *n] = 1.; - } - d__[*n] = (d__1 = d__[*n], abs(d__1)); - } - if (icompq == 2) { - dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start + - start * u_dim1], ldu, &vt[start + start * vt_dim1], - ldvt, &smlsiz, &iwork[1], &work[wstart], info); - } else { - dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[ - start], &q[start + (iu + qstart - 2) * *n], n, &q[ - start + (ivt + qstart - 2) * *n], &iq[start + k * *n], - &q[start + (difl + qstart - 2) * *n], &q[start + ( - difr + qstart - 2) * *n], &q[start + (z__ + qstart - - 2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[ - start + givptr * *n], &iq[start + givcol * *n], n, & - iq[start + perm * *n], &q[start + (givnum + qstart - - 2) * *n], &q[start + (ic + qstart - 2) * *n], &q[ - start + (is + qstart - 2) * *n], &work[wstart], & - iwork[1], info); - if (*info != 0) { - return 0; - } - } - start = i__ + 1; - } -/* L30: */ - } - -/* Unscale */ - - dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr); -L40: - -/* Use Selection Sort to minimize swaps of singular vectors */ - - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - kk = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] > p) { - kk = j; - p = d__[j]; - } -/* L50: */ - } - if (kk != i__) { - d__[kk] = d__[i__]; - d__[i__] = p; - if (icompq == 1) { - iq[i__] = kk; - } else if (icompq == 2) { - dswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], & - c__1); - dswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt); - } - } else if (icompq == 1) { - iq[i__] = i__; - } -/* L60: */ - } - -/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */ - - if (icompq == 1) { - if (iuplo == 1) { - iq[*n] = 1; - } else { - iq[*n] = 0; - } - } - -/* If B is lower bidiagonal, update U by those Givens rotations */ -/* which rotated B to be upper bidiagonal */ - - if (iuplo == 2 && icompq == 2) { - dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu); - } - - return 0; - -/* End of DBDSDC */ - -} /* dbdsdc_ */ diff --git a/external/clapack/lapack/dbdsqr.cpp b/external/clapack/lapack/dbdsqr.cpp deleted file mode 100644 index fa9cb994..00000000 --- a/external/clapack/lapack/dbdsqr.cpp +++ /dev/null @@ -1,877 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b15 = -.125; -static integer c__1 = 1; -static double c_b49 = 1.; -static double c_b72 = -1.; - -/* Subroutine */ int dbdsqr_(const char *uplo, integer *n, integer *ncvt, integer * - nru, integer *ncc, double *d__, double *e, double *vt, - integer *ldvt, double *u, integer *ldu, double *c__, integer * - ldc, double *work, integer *info) -{ - /* System generated locals */ - integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - double f, g, h__; - integer i__, j, m; - double r__, cs; - integer ll; - double sn, mu; - integer nm1, nm12, nm13, lll; - double eps, sll, tol, abse; - integer idir; - double abss; - integer oldm; - double cosl; - integer isub, iter; - double unfl, sinl, cosr, smin, smax, sinr; - double oldcs; - integer oldll; - double shift, sigmn, oldsn; - integer maxit; - double sminl, sigmx; - bool lower; - double sminoa, thresh; - bool rotate; - double tolmul; - - -/* -- LAPACK routine (version 3.1.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* January 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DBDSQR computes the singular values and, optionally, the right and/or */ -/* left singular vectors from the singular value decomposition (SVD) of */ -/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */ -/* zero-shift QR algorithm. The SVD of B has the form */ - -/* B = Q * S * P**T */ - -/* where S is the diagonal matrix of singular values, Q is an orthogonal */ -/* matrix of left singular vectors, and P is an orthogonal matrix of */ -/* right singular vectors. If left singular vectors are requested, this */ -/* subroutine actually returns U*Q instead of Q, and, if right singular */ -/* vectors are requested, this subroutine returns P**T*VT instead of */ -/* P**T, for given real input matrices U and VT. When U and VT are the */ -/* orthogonal matrices that reduce a general matrix A to bidiagonal */ -/* form: A = U*B*VT, as computed by DGEBRD, then */ - -/* A = (U*Q) * S * (P**T*VT) */ - -/* is the SVD of A. Optionally, the subroutine may also compute Q**T*C */ -/* for a given real input matrix C. */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices With */ -/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */ -/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */ -/* no. 5, pp. 873-912, Sept 1990) and */ -/* "Accurate singular values and differential qd algorithms," by */ -/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */ -/* Department, University of California at Berkeley, July 1992 */ -/* for a detailed description of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': B is upper bidiagonal; */ -/* = 'L': B is lower bidiagonal. */ - -/* N (input) INTEGER */ -/* The order of the matrix B. N >= 0. */ - -/* NCVT (input) INTEGER */ -/* The number of columns of the matrix VT. NCVT >= 0. */ - -/* NRU (input) INTEGER */ -/* The number of rows of the matrix U. NRU >= 0. */ - -/* NCC (input) INTEGER */ -/* The number of columns of the matrix C. NCC >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the bidiagonal matrix B. */ -/* On exit, if INFO=0, the singular values of B in decreasing */ -/* order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the N-1 offdiagonal elements of the bidiagonal */ -/* matrix B. */ -/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */ -/* will contain the diagonal and superdiagonal elements of a */ -/* bidiagonal matrix orthogonally equivalent to the one given */ -/* as input. */ - -/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */ -/* On entry, an N-by-NCVT matrix VT. */ -/* On exit, VT is overwritten by P**T * VT. */ -/* Not referenced if NCVT = 0. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. */ -/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */ - -/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */ -/* On entry, an NRU-by-N matrix U. */ -/* On exit, U is overwritten by U * Q. */ -/* Not referenced if NRU = 0. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= max(1,NRU). */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */ -/* On entry, an N-by-NCC matrix C. */ -/* On exit, C is overwritten by Q**T * C. */ -/* Not referenced if NCC = 0. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. */ -/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ -/* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: If INFO = -i, the i-th argument had an illegal value */ -/* > 0: the algorithm did not converge; D and E contain the */ -/* elements of a bidiagonal matrix which is orthogonally */ -/* similar to the input matrix B; if INFO = i, i */ -/* elements of E have not converged to zero. */ - -/* Internal Parameters */ -/* =================== */ - -/* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) */ -/* TOLMUL controls the convergence criterion of the QR loop. */ -/* If it is positive, TOLMUL*EPS is the desired relative */ -/* precision in the computed singular values. */ -/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */ -/* desired absolute accuracy in the computed singular */ -/* values (corresponds to relative accuracy */ -/* abs(TOLMUL*EPS) in the largest singular value. */ -/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */ -/* between 10 (for fast convergence) and .1/EPS */ -/* (for there to be some accuracy in the results). */ -/* Default is to lose at either one eighth or 2 of the */ -/* available decimal digits in each computed singular value */ -/* (whichever is smaller). */ - -/* MAXITR INTEGER, default = 6 */ -/* MAXITR controls the maximum number of passes of the */ -/* algorithm through its inner loop. The algorithms stops */ -/* (and so fails to converge) if the number of passes */ -/* through the inner loop exceeds MAXITR*N**2. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - lower = lsame_(uplo, "L"); - if (! lsame_(uplo, "U") && ! lower) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ncvt < 0) { - *info = -3; - } else if (*nru < 0) { - *info = -4; - } else if (*ncc < 0) { - *info = -5; - } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldu < std::max(1_integer,*nru)) { - *info = -11; - } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < std::max(1_integer,*n)) { - *info = -13; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DBDSQR", &i__1); - return 0; - } - if (*n == 0) { - return 0; - } - if (*n == 1) { - goto L160; - } - -/* ROTATE is true if any singular vectors desired, false otherwise */ - - rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; - -/* If no singular vectors desired, use qd algorithm */ - - if (! rotate) { - dlasq1_(n, &d__[1], &e[1], &work[1], info); - return 0; - } - - nm1 = *n - 1; - nm12 = nm1 + nm1; - nm13 = nm12 + nm1; - idir = 0; - -/* Get machine constants */ - - eps = dlamch_("Epsilon"); - unfl = dlamch_("Safe minimum"); - -/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ -/* by applying Givens rotations on the left */ - - if (lower) { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - work[i__] = cs; - work[nm1 + i__] = sn; -/* L10: */ - } - -/* Update singular vectors if desired */ - - if (*nru > 0) { - dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset], - ldu); - } - if (*ncc > 0) { - dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset], - ldc); - } - } - -/* Compute singular values to relative accuracy TOL */ -/* (By setting TOL to be negative, algorithm will compute */ -/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */ - -/* Computing MAX */ -/* Computing MIN */ - d__3 = 100., d__4 = pow_dd(&eps, &c_b15); - d__1 = 10., d__2 = std::min(d__3,d__4); - tolmul = std::max(d__1,d__2); - tol = tolmul * eps; - -/* Compute approximate maximum, minimum singular values */ - - smax = 0.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1)); - smax = std::max(d__2,d__3); -/* L20: */ - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1)); - smax = std::max(d__2,d__3); -/* L30: */ - } - sminl = 0.; - if (tol >= 0.) { - -/* Relative accuracy desired */ - - sminoa = abs(d__[1]); - if (sminoa == 0.) { - goto L50; - } - mu = sminoa; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1] - , abs(d__1)))); - sminoa = std::min(sminoa,mu); - if (sminoa == 0.) { - goto L50; - } -/* L40: */ - } -L50: - sminoa /= sqrt((double) (*n)); -/* Computing MAX */ - d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl; - thresh = std::max(d__1,d__2); - } else { - -/* Absolute accuracy desired */ - -/* Computing MAX */ - d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl; - thresh = std::max(d__1,d__2); - } - -/* Prepare for main iteration loop for the singular values */ -/* (MAXIT is the maximum number of passes through the inner */ -/* loop permitted before nonconvergence signalled.) */ - - maxit = *n * 6 * *n; - iter = 0; - oldll = -1; - oldm = -1; - -/* M points to last element of unconverged part of matrix */ - - m = *n; - -/* Begin main iteration loop */ - -L60: - -/* Check for convergence or exceeding iteration count */ - - if (m <= 1) { - goto L160; - } - if (iter > maxit) { - goto L200; - } - -/* Find diagonal block of matrix to work on */ - - if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) { - d__[m] = 0.; - } - smax = (d__1 = d__[m], abs(d__1)); - smin = smax; - i__1 = m - 1; - for (lll = 1; lll <= i__1; ++lll) { - ll = m - lll; - abss = (d__1 = d__[ll], abs(d__1)); - abse = (d__1 = e[ll], abs(d__1)); - if (tol < 0. && abss <= thresh) { - d__[ll] = 0.; - } - if (abse <= thresh) { - goto L80; - } - smin = std::min(smin,abss); -/* Computing MAX */ - d__1 = std::max(smax,abss); - smax = std::max(d__1,abse); -/* L70: */ - } - ll = 0; - goto L90; -L80: - e[ll] = 0.; - -/* Matrix splits since E(LL) = 0 */ - - if (ll == m - 1) { - -/* Convergence of bottom singular value, return to top of loop */ - - --m; - goto L60; - } -L90: - ++ll; - -/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */ - - if (ll == m - 1) { - -/* 2 by 2 block, handle separately */ - - dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, - &sinl, &cosl); - d__[m - 1] = sigmx; - e[m - 1] = 0.; - d__[m] = sigmn; - -/* Compute singular vectors, if desired */ - - if (*ncvt > 0) { - drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, & - cosr, &sinr); - } - if (*nru > 0) { - drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], & - c__1, &cosl, &sinl); - } - if (*ncc > 0) { - drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, & - cosl, &sinl); - } - m += -2; - goto L60; - } - -/* If working on new submatrix, choose shift direction */ -/* (from larger end diagonal element towards smaller) */ - - if (ll > oldm || m < oldll) { - if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) { - -/* Chase bulge from top (big end) to bottom (small end) */ - - idir = 1; - } else { - -/* Chase bulge from bottom (big end) to top (small end) */ - - idir = 2; - } - } - -/* Apply convergence tests */ - - if (idir == 1) { - -/* Run convergence test in forward direction */ -/* First apply standard test to bottom of matrix */ - - if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs( - d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) - { - e[m - 1] = 0.; - goto L60; - } - - if (tol >= 0.) { - -/* If relative accuracy desired, */ -/* apply convergence criterion forward */ - - mu = (d__1 = d__[ll], abs(d__1)); - sminl = mu; - i__1 = m - 1; - for (lll = ll; lll <= i__1; ++lll) { - if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { - e[lll] = 0.; - goto L60; - } - mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[ - lll], abs(d__1)))); - sminl = std::min(sminl,mu); -/* L100: */ - } - } - - } else { - -/* Run convergence test in backward direction */ -/* First apply standard test to top of matrix */ - - if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1) - ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) { - e[ll] = 0.; - goto L60; - } - - if (tol >= 0.) { - -/* If relative accuracy desired, */ -/* apply convergence criterion backward */ - - mu = (d__1 = d__[m], abs(d__1)); - sminl = mu; - i__1 = ll; - for (lll = m - 1; lll >= i__1; --lll) { - if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { - e[lll] = 0.; - goto L60; - } - mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll] - , abs(d__1)))); - sminl = std::min(sminl,mu); -/* L110: */ - } - } - } - oldll = ll; - oldm = m; - -/* Compute shift. First, test if shifting would ruin relative */ -/* accuracy, and if so set the shift to zero. */ - -/* Computing MAX */ - d__1 = eps, d__2 = tol * .01; - if (tol >= 0. && *n * tol * (sminl / smax) <= std::max(d__1,d__2)) { - -/* Use a zero shift to avoid loss of relative accuracy */ - - shift = 0.; - } else { - -/* Compute the shift from 2-by-2 block at end of matrix */ - - if (idir == 1) { - sll = (d__1 = d__[ll], abs(d__1)); - dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); - } else { - sll = (d__1 = d__[m], abs(d__1)); - dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); - } - -/* Test if shift negligible, and if so set to zero */ - - if (sll > 0.) { -/* Computing 2nd power */ - d__1 = shift / sll; - if (d__1 * d__1 < eps) { - shift = 0.; - } - } - } - -/* Increment iteration count */ - - iter = iter + m - ll; - -/* If SHIFT = 0, do simplified QR iteration */ - - if (shift == 0.) { - if (idir == 1) { - -/* Chase bulge from top to bottom */ -/* Save cosines and sines for later singular vector updates */ - - cs = 1.; - oldcs = 1.; - i__1 = m - 1; - for (i__ = ll; i__ <= i__1; ++i__) { - d__1 = d__[i__] * cs; - dlartg_(&d__1, &e[i__], &cs, &sn, &r__); - if (i__ > ll) { - e[i__ - 1] = oldsn * r__; - } - d__1 = oldcs * r__; - d__2 = d__[i__ + 1] * sn; - dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); - work[i__ - ll + 1] = cs; - work[i__ - ll + 1 + nm1] = sn; - work[i__ - ll + 1 + nm12] = oldcs; - work[i__ - ll + 1 + nm13] = oldsn; -/* L120: */ - } - h__ = d__[m] * cs; - d__[m] = h__ * oldcs; - e[m - 1] = h__ * oldsn; - -/* Update singular vectors */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[ - ll + vt_dim1], ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 - + 1], &u[ll * u_dim1 + 1], ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 - + 1], &c__[ll + c_dim1], ldc); - } - -/* Test convergence */ - - if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { - e[m - 1] = 0.; - } - - } else { - -/* Chase bulge from bottom to top */ -/* Save cosines and sines for later singular vector updates */ - - cs = 1.; - oldcs = 1.; - i__1 = ll + 1; - for (i__ = m; i__ >= i__1; --i__) { - d__1 = d__[i__] * cs; - dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); - if (i__ < m) { - e[i__] = oldsn * r__; - } - d__1 = oldcs * r__; - d__2 = d__[i__ - 1] * sn; - dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); - work[i__ - ll] = cs; - work[i__ - ll + nm1] = -sn; - work[i__ - ll + nm12] = oldcs; - work[i__ - ll + nm13] = -oldsn; -/* L130: */ - } - h__ = d__[ll] * cs; - d__[ll] = h__ * oldcs; - e[ll] = h__ * oldsn; - -/* Update singular vectors */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[ - nm13 + 1], &vt[ll + vt_dim1], ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll * - u_dim1 + 1], ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[ - ll + c_dim1], ldc); - } - -/* Test convergence */ - - if ((d__1 = e[ll], abs(d__1)) <= thresh) { - e[ll] = 0.; - } - } - } else { - -/* Use nonzero shift */ - - if (idir == 1) { - -/* Chase bulge from top to bottom */ -/* Save cosines and sines for later singular vector updates */ - - f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[ - ll]) + shift / d__[ll]); - g = e[ll]; - i__1 = m - 1; - for (i__ = ll; i__ <= i__1; ++i__) { - dlartg_(&f, &g, &cosr, &sinr, &r__); - if (i__ > ll) { - e[i__ - 1] = r__; - } - f = cosr * d__[i__] + sinr * e[i__]; - e[i__] = cosr * e[i__] - sinr * d__[i__]; - g = sinr * d__[i__ + 1]; - d__[i__ + 1] = cosr * d__[i__ + 1]; - dlartg_(&f, &g, &cosl, &sinl, &r__); - d__[i__] = r__; - f = cosl * e[i__] + sinl * d__[i__ + 1]; - d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; - if (i__ < m - 1) { - g = sinl * e[i__ + 1]; - e[i__ + 1] = cosl * e[i__ + 1]; - } - work[i__ - ll + 1] = cosr; - work[i__ - ll + 1 + nm1] = sinr; - work[i__ - ll + 1 + nm12] = cosl; - work[i__ - ll + 1 + nm13] = sinl; -/* L140: */ - } - e[m - 1] = f; - -/* Update singular vectors */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[ - ll + vt_dim1], ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 - + 1], &u[ll * u_dim1 + 1], ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 - + 1], &c__[ll + c_dim1], ldc); - } - -/* Test convergence */ - - if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { - e[m - 1] = 0.; - } - - } else { - -/* Chase bulge from bottom to top */ -/* Save cosines and sines for later singular vector updates */ - - f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m] - ) + shift / d__[m]); - g = e[m - 1]; - i__1 = ll + 1; - for (i__ = m; i__ >= i__1; --i__) { - dlartg_(&f, &g, &cosr, &sinr, &r__); - if (i__ < m) { - e[i__] = r__; - } - f = cosr * d__[i__] + sinr * e[i__ - 1]; - e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; - g = sinr * d__[i__ - 1]; - d__[i__ - 1] = cosr * d__[i__ - 1]; - dlartg_(&f, &g, &cosl, &sinl, &r__); - d__[i__] = r__; - f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; - d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; - if (i__ > ll + 1) { - g = sinl * e[i__ - 2]; - e[i__ - 2] = cosl * e[i__ - 2]; - } - work[i__ - ll] = cosr; - work[i__ - ll + nm1] = -sinr; - work[i__ - ll + nm12] = cosl; - work[i__ - ll + nm13] = -sinl; -/* L150: */ - } - e[ll] = f; - -/* Test convergence */ - - if ((d__1 = e[ll], abs(d__1)) <= thresh) { - e[ll] = 0.; - } - -/* Update singular vectors if desired */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[ - nm13 + 1], &vt[ll + vt_dim1], ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll * - u_dim1 + 1], ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[ - ll + c_dim1], ldc); - } - } - } - -/* QR iteration finished, go back and check convergence */ - - goto L60; - -/* All singular values converged, so make them positive */ - -L160: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] < 0.) { - d__[i__] = -d__[i__]; - -/* Change sign of singular vectors, if desired */ - - if (*ncvt > 0) { - dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt); - } - } -/* L170: */ - } - -/* Sort the singular values into decreasing order (insertion sort on */ -/* singular values, but only one transposition per singular vector) */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Scan for smallest D(I) */ - - isub = 1; - smin = d__[1]; - i__2 = *n + 1 - i__; - for (j = 2; j <= i__2; ++j) { - if (d__[j] <= smin) { - isub = j; - smin = d__[j]; - } -/* L180: */ - } - if (isub != *n + 1 - i__) { - -/* Swap singular values and vectors */ - - d__[isub] = d__[*n + 1 - i__]; - d__[*n + 1 - i__] = smin; - if (*ncvt > 0) { - dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + - vt_dim1], ldvt); - } - if (*nru > 0) { - dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * - u_dim1 + 1], &c__1); - } - if (*ncc > 0) { - dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + - c_dim1], ldc); - } - } -/* L190: */ - } - goto L220; - -/* Maximum number of iterations exceeded, failure to converge */ - -L200: - *info = 0; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } -/* L210: */ - } -L220: - return 0; - -/* End of DBDSQR */ - -} /* dbdsqr_ */ diff --git a/external/clapack/lapack/ddisna.cpp b/external/clapack/lapack/ddisna.cpp deleted file mode 100644 index 00786067..00000000 --- a/external/clapack/lapack/ddisna.cpp +++ /dev/null @@ -1,215 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int ddisna_(const char *job, integer *m, integer *n, double * - d__, double *sep, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, k; - double eps; - bool decr, left, incr, sing, eigen; - - double anorm; - bool right; - - double oldgap, safmin; - - double newgap, thresh; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DDISNA computes the reciprocal condition numbers for the eigenvectors */ -/* of a real symmetric or complex Hermitian matrix or for the left or */ -/* right singular vectors of a general m-by-n matrix. The reciprocal */ -/* condition number is the 'gap' between the corresponding eigenvalue or */ -/* singular value and the nearest other one. */ - -/* The bound on the error, measured by angle in radians, in the I-th */ -/* computed vector is given by */ - -/* DLAMCH( 'E' ) * ( ANORM / SEP( I ) ) */ - -/* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed */ -/* to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of */ -/* the error bound. */ - -/* DDISNA may also be used to compute error bounds for eigenvectors of */ -/* the generalized symmetric definite eigenproblem. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* Specifies for which problem the reciprocal condition numbers */ -/* should be computed: */ -/* = 'E': the eigenvectors of a symmetric/Hermitian matrix; */ -/* = 'L': the left singular vectors of a general matrix; */ -/* = 'R': the right singular vectors of a general matrix. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix. M >= 0. */ - -/* N (input) INTEGER */ -/* If JOB = 'L' or 'R', the number of columns of the matrix, */ -/* in which case N >= 0. Ignored if JOB = 'E'. */ - -/* D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E' */ -/* dimension (min(M,N)) if JOB = 'L' or 'R' */ -/* The eigenvalues (if JOB = 'E') or singular values (if JOB = */ -/* 'L' or 'R') of the matrix, in either increasing or decreasing */ -/* order. If singular values, they must be non-negative. */ - -/* SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E' */ -/* dimension (min(M,N)) if JOB = 'L' or 'R' */ -/* The reciprocal condition numbers of the vectors. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - --sep; - --d__; - - /* Function Body */ - *info = 0; - eigen = lsame_(job, "E"); - left = lsame_(job, "L"); - right = lsame_(job, "R"); - sing = left || right; - if (eigen) { - k = *m; - } else if (sing) { - k = std::min(*m,*n); - } - if (! eigen && ! sing) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (k < 0) { - *info = -3; - } else { - incr = true; - decr = true; - i__1 = k - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (incr) { - incr = incr && d__[i__] <= d__[i__ + 1]; - } - if (decr) { - decr = decr && d__[i__] >= d__[i__ + 1]; - } -/* L10: */ - } - if (sing && k > 0) { - if (incr) { - incr = incr && 0. <= d__[1]; - } - if (decr) { - decr = decr && d__[k] >= 0.; - } - } - if (! (incr || decr)) { - *info = -4; - } - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DDISNA", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (k == 0) { - return 0; - } - -/* Compute reciprocal condition numbers */ - - if (k == 1) { - sep[1] = dlamch_("O"); - } else { - oldgap = (d__1 = d__[2] - d__[1], abs(d__1)); - sep[1] = oldgap; - i__1 = k - 1; - for (i__ = 2; i__ <= i__1; ++i__) { - newgap = (d__1 = d__[i__ + 1] - d__[i__], abs(d__1)); - sep[i__] = std::min(oldgap,newgap); - oldgap = newgap; -/* L20: */ - } - sep[k] = oldgap; - } - if (sing) { - if (left && *m > *n || right && *m < *n) { - if (incr) { - sep[1] = std::min(sep[1],d__[1]); - } - if (decr) { -/* Computing MIN */ - d__1 = sep[k], d__2 = d__[k]; - sep[k] = std::min(d__1,d__2); - } - } - } - -/* Ensure that reciprocal condition numbers are not less than */ -/* threshold, in order to limit the size of the error bound */ - - eps = dlamch_("E"); - safmin = dlamch_("S"); -/* Computing MAX */ - d__2 = abs(d__[1]), d__3 = (d__1 = d__[k], abs(d__1)); - anorm = std::max(d__2,d__3); - if (anorm == 0.) { - thresh = eps; - } else { -/* Computing MAX */ - d__1 = eps * anorm; - thresh = std::max(d__1,safmin); - } - i__1 = k; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = sep[i__]; - sep[i__] = std::max(d__1,thresh); -/* L30: */ - } - - return 0; - -/* End of DDISNA */ - -} /* ddisna_ */ diff --git a/external/clapack/lapack/dgbbrd.cpp b/external/clapack/lapack/dgbbrd.cpp deleted file mode 100644 index 4cd5bee0..00000000 --- a/external/clapack/lapack/dgbbrd.cpp +++ /dev/null @@ -1,543 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b8 = 0.; -static double c_b9 = 1.; -static integer c__1 = 1; - -/* Subroutine */ int dgbbrd_(const char *vect, integer *m, integer *n, integer *ncc, - integer *kl, integer *ku, double *ab, integer *ldab, double * - d__, double *e, double *q, integer *ldq, double *pt, - integer *ldpt, double *c__, integer *ldc, double *work, - integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1, - q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; - - /* Local variables */ - integer i__, j, l, j1, j2, kb; - double ra, rb, rc; - integer kk, ml, mn, nr, mu; - double rs; - integer kb1, ml0, mu0, klm, kun, nrt, klu1, inca; - bool wantb, wantc; - integer minmn; - bool wantq; - bool wantpt; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBBRD reduces a real general m-by-n band matrix A to upper */ -/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */ - -/* The routine computes B, and optionally forms Q or P', or computes */ -/* Q'*C for a given matrix C. */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* Specifies whether or not the matrices Q and P' are to be */ -/* formed. */ -/* = 'N': do not form Q or P'; */ -/* = 'Q': form Q only; */ -/* = 'P': form P' only; */ -/* = 'B': form both. */ - -/* 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. */ - -/* NCC (input) INTEGER */ -/* The number of columns of the matrix C. NCC >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals of the matrix A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals of the matrix A. KU >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the m-by-n band matrix A, stored in rows 1 to */ -/* KL+KU+1. The j-th column of A is stored in the j-th column of */ -/* the array AB as follows: */ -/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */ -/* On exit, A is overwritten by values generated during the */ -/* reduction. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array A. LDAB >= KL+KU+1. */ - -/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The diagonal elements of the bidiagonal matrix B. */ - -/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */ -/* The superdiagonal elements of the bidiagonal matrix B. */ - -/* Q (output) DOUBLE PRECISION array, dimension (LDQ,M) */ -/* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. */ -/* If VECT = 'N' or 'P', the array Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. */ -/* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */ - -/* PT (output) DOUBLE PRECISION array, dimension (LDPT,N) */ -/* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. */ -/* If VECT = 'N' or 'Q', the array PT is not referenced. */ - -/* LDPT (input) INTEGER */ -/* The leading dimension of the array PT. */ -/* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC) */ -/* On entry, an m-by-ncc matrix C. */ -/* On exit, C is overwritten by Q'*C. */ -/* C is not referenced if NCC = 0. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. */ -/* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N)) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --d__; - --e; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - pt_dim1 = *ldpt; - pt_offset = 1 + pt_dim1; - pt -= pt_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - wantb = lsame_(vect, "B"); - wantq = lsame_(vect, "Q") || wantb; - wantpt = lsame_(vect, "P") || wantb; - wantc = *ncc > 0; - klu1 = *kl + *ku + 1; - *info = 0; - if (! wantq && ! wantpt && ! lsame_(vect, "N")) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ncc < 0) { - *info = -4; - } else if (*kl < 0) { - *info = -5; - } else if (*ku < 0) { - *info = -6; - } else if (*ldab < klu1) { - *info = -8; - } else if (*ldq < 1 || wantq && *ldq < std::max(1_integer,*m)) { - *info = -12; - } else if (*ldpt < 1 || wantpt && *ldpt < std::max(1_integer,*n)) { - *info = -14; - } else if (*ldc < 1 || wantc && *ldc < std::max(1_integer,*m)) { - *info = -16; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBBRD", &i__1); - return 0; - } - -/* Initialize Q and P' to the unit matrix, if needed */ - - if (wantq) { - dlaset_("Full", m, m, &c_b8, &c_b9, &q[q_offset], ldq); - } - if (wantpt) { - dlaset_("Full", n, n, &c_b8, &c_b9, &pt[pt_offset], ldpt); - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - return 0; - } - - minmn = std::min(*m,*n); - - if (*kl + *ku > 1) { - -/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */ -/* first to lower bidiagonal form and then transform to upper */ -/* bidiagonal */ - - if (*ku > 0) { - ml0 = 1; - mu0 = 2; - } else { - ml0 = 2; - mu0 = 1; - } - -/* Wherever possible, plane rotations are generated and applied in */ -/* vector operations of length NR over the index set J1:J2:KLU1. */ - -/* The sines of the plane rotations are stored in WORK(1:max(m,n)) */ -/* and the cosines in WORK(max(m,n)+1:2*max(m,n)). */ - - mn = std::max(*m,*n); -/* Computing MIN */ - i__1 = *m - 1; - klm = std::min(i__1,*kl); -/* Computing MIN */ - i__1 = *n - 1; - kun = std::min(i__1,*ku); - kb = klm + kun; - kb1 = kb + 1; - inca = kb1 * *ldab; - nr = 0; - j1 = klm + 2; - j2 = 1 - kun; - - i__1 = minmn; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Reduce i-th column and i-th row of matrix to bidiagonal form */ - - ml = klm + 1; - mu = kun + 1; - i__2 = kb; - for (kk = 1; kk <= i__2; ++kk) { - j1 += kb; - j2 += kb; - -/* generate plane rotations to annihilate nonzero elements */ -/* which have been created below the band */ - - if (nr > 0) { - dlargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca, - &work[j1], &kb1, &work[mn + j1], &kb1); - } - -/* apply plane rotations from the left */ - - i__3 = kb; - for (l = 1; l <= i__3; ++l) { - if (j2 - klm + l - 1 > *n) { - nrt = nr - 1; - } else { - nrt = nr; - } - if (nrt > 0) { - dlartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) * - ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm - + l - 1) * ab_dim1], &inca, &work[mn + j1], & - work[j1], &kb1); - } -/* L10: */ - } - - if (ml > ml0) { - if (ml <= *m - i__ + 1) { - -/* generate plane rotation to annihilate a(i+ml-1,i) */ -/* within the band, and apply rotation from the left */ - - dlartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku + - ml + i__ * ab_dim1], &work[mn + i__ + ml - 1], - &work[i__ + ml - 1], &ra); - ab[*ku + ml - 1 + i__ * ab_dim1] = ra; - if (i__ < *n) { -/* Computing MIN */ - i__4 = *ku + ml - 2, i__5 = *n - i__; - i__3 = std::min(i__4,i__5); - i__6 = *ldab - 1; - i__7 = *ldab - 1; - drot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) * - ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__ - + 1) * ab_dim1], &i__7, &work[mn + i__ + - ml - 1], &work[i__ + ml - 1]); - } - } - ++nr; - j1 -= kb1; - } - - if (wantq) { - -/* accumulate product of plane rotations in Q */ - - i__3 = j2; - i__4 = kb1; - for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) - { - drot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j * - q_dim1 + 1], &c__1, &work[mn + j], &work[j]); -/* L20: */ - } - } - - if (wantc) { - -/* apply plane rotations to C */ - - i__4 = j2; - i__3 = kb1; - for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) - { - drot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1] -, ldc, &work[mn + j], &work[j]); -/* L30: */ - } - } - - if (j2 + kun > *n) { - -/* adjust J2 to keep within the bounds of the matrix */ - - --nr; - j2 -= kb1; - } - - i__3 = j2; - i__4 = kb1; - for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { - -/* create nonzero element a(j-1,j+ku) above the band */ -/* and store it in WORK(n+1:2*n) */ - - work[j + kun] = work[j] * ab[(j + kun) * ab_dim1 + 1]; - ab[(j + kun) * ab_dim1 + 1] = work[mn + j] * ab[(j + kun) - * ab_dim1 + 1]; -/* L40: */ - } - -/* generate plane rotations to annihilate nonzero elements */ -/* which have been generated above the band */ - - if (nr > 0) { - dlargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, & - work[j1 + kun], &kb1, &work[mn + j1 + kun], &kb1); - } - -/* apply plane rotations from the right */ - - i__4 = kb; - for (l = 1; l <= i__4; ++l) { - if (j2 + l - 1 > *m) { - nrt = nr - 1; - } else { - nrt = nr; - } - if (nrt > 0) { - dlartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], & - inca, &ab[l + (j1 + kun) * ab_dim1], &inca, & - work[mn + j1 + kun], &work[j1 + kun], &kb1); - } -/* L50: */ - } - - if (ml == ml0 && mu > mu0) { - if (mu <= *n - i__ + 1) { - -/* generate plane rotation to annihilate a(i,i+mu-1) */ -/* within the band, and apply rotation from the right */ - - dlartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1], - &ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1], - &work[mn + i__ + mu - 1], &work[i__ + mu - 1], - &ra); - ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1] = ra; -/* Computing MIN */ - i__3 = *kl + mu - 2, i__5 = *m - i__; - i__4 = std::min(i__3,i__5); - drot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) * - ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu - - 1) * ab_dim1], &c__1, &work[mn + i__ + mu - - 1], &work[i__ + mu - 1]); - } - ++nr; - j1 -= kb1; - } - - if (wantpt) { - -/* accumulate product of plane rotations in P' */ - - i__4 = j2; - i__3 = kb1; - for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) - { - drot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j + - kun + pt_dim1], ldpt, &work[mn + j + kun], & - work[j + kun]); -/* L60: */ - } - } - - if (j2 + kb > *m) { - -/* adjust J2 to keep within the bounds of the matrix */ - - --nr; - j2 -= kb1; - } - - i__3 = j2; - i__4 = kb1; - for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { - -/* create nonzero element a(j+kl+ku,j+ku-1) below the */ -/* band and store it in WORK(1:n) */ - - work[j + kb] = work[j + kun] * ab[klu1 + (j + kun) * - ab_dim1]; - ab[klu1 + (j + kun) * ab_dim1] = work[mn + j + kun] * ab[ - klu1 + (j + kun) * ab_dim1]; -/* L70: */ - } - - if (ml > ml0) { - --ml; - } else { - --mu; - } -/* L80: */ - } -/* L90: */ - } - } - - if (*ku == 0 && *kl > 0) { - -/* A has been reduced to lower bidiagonal form */ - -/* Transform lower bidiagonal form to upper bidiagonal by applying */ -/* plane rotations from the left, storing diagonal elements in D */ -/* and off-diagonal elements in E */ - -/* Computing MIN */ - i__2 = *m - 1; - i__1 = std::min(i__2,*n); - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs, - &ra); - d__[i__] = ra; - if (i__ < *n) { - e[i__] = rs * ab[(i__ + 1) * ab_dim1 + 1]; - ab[(i__ + 1) * ab_dim1 + 1] = rc * ab[(i__ + 1) * ab_dim1 + 1] - ; - } - if (wantq) { - drot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 + - 1], &c__1, &rc, &rs); - } - if (wantc) { - drot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1], - ldc, &rc, &rs); - } -/* L100: */ - } - if (*m <= *n) { - d__[*m] = ab[*m * ab_dim1 + 1]; - } - } else if (*ku > 0) { - -/* A has been reduced to upper bidiagonal form */ - - if (*m < *n) { - -/* Annihilate a(m,m+1) by applying plane rotations from the */ -/* right, storing diagonal elements in D and off-diagonal */ -/* elements in E */ - - rb = ab[*ku + (*m + 1) * ab_dim1]; - for (i__ = *m; i__ >= 1; --i__) { - dlartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra); - d__[i__] = ra; - if (i__ > 1) { - rb = -rs * ab[*ku + i__ * ab_dim1]; - e[i__ - 1] = rc * ab[*ku + i__ * ab_dim1]; - } - if (wantpt) { - drot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1], - ldpt, &rc, &rs); - } -/* L110: */ - } - } else { - -/* Copy off-diagonal elements to E and diagonal elements to D */ - - i__1 = minmn - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - e[i__] = ab[*ku + (i__ + 1) * ab_dim1]; -/* L120: */ - } - i__1 = minmn; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = ab[*ku + 1 + i__ * ab_dim1]; -/* L130: */ - } - } - } else { - -/* A is diagonal. Set elements of E to zero and copy diagonal */ -/* elements to D. */ - - i__1 = minmn - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - e[i__] = 0.; -/* L140: */ - } - i__1 = minmn; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = ab[i__ * ab_dim1 + 1]; -/* L150: */ - } - } - return 0; - -/* End of DGBBRD */ - -} /* dgbbrd_ */ diff --git a/external/clapack/lapack/dgbcon.cpp b/external/clapack/lapack/dgbcon.cpp deleted file mode 100644 index f1fb18fa..00000000 --- a/external/clapack/lapack/dgbcon.cpp +++ /dev/null @@ -1,256 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgbcon_(const char *norm, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, integer *ipiv, double *anorm, - double *rcond, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer j; - double t; - integer kd, lm, jp, ix, kase; - integer kase1; - double scale; - integer isave[3]; - bool lnoti; - double ainvnm; - bool onenrm; - char normin[1]; - double smlnum; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBCON estimates the reciprocal of the condition number of a real */ -/* general band matrix A, in either the 1-norm or the infinity-norm, */ -/* using the LU factorization computed by DGBTRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as */ -/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* Details of the LU factorization of the band matrix A, as */ -/* computed by DGBTRF. U is stored as an upper triangular band */ -/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ -/* the multipliers used during the factorization are stored in */ -/* rows KL+KU+2 to 2*KL+KU+1. */ -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices; for 1 <= i <= N, row i of the matrix was */ -/* interchanged with row IPIV(i). */ - -/* ANORM (input) DOUBLE PRECISION */ -/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ -/* If NORM = 'I', the infinity-norm of the original matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --ipiv; - --work; - --iwork; - - /* Function Body */ - *info = 0; - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); - if (! onenrm && ! lsame_(norm, "I")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < (*kl << 1) + *ku + 1) { - *info = -6; - } else if (*anorm < 0.) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - - smlnum = dlamch_("Safe minimum"); - -/* Estimate the norm of inv(A). */ - - ainvnm = 0.; - *(unsigned char *)normin = 'N'; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kd = *kl + *ku + 1; - lnoti = *kl > 0; - kase = 0; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(L). */ - - if (lnoti) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *kl, i__3 = *n - j; - lm = std::min(i__2,i__3); - jp = ipiv[j]; - t = work[jp]; - if (jp != j) { - work[jp] = work[j]; - work[j] = t; - } - d__1 = -t; - daxpy_(&lm, &d__1, &ab[kd + 1 + j * ab_dim1], &c__1, & - work[j + 1], &c__1); -/* L20: */ - } - } - -/* Multiply by inv(U). */ - - i__1 = *kl + *ku; - dlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, & - ab[ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + - 1], info); - } else { - -/* Multiply by inv(U'). */ - - i__1 = *kl + *ku; - dlatbs_("Upper", "Transpose", "Non-unit", normin, n, &i__1, &ab[ - ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 1], - info); - -/* Multiply by inv(L'). */ - - if (lnoti) { - for (j = *n - 1; j >= 1; --j) { -/* Computing MIN */ - i__1 = *kl, i__2 = *n - j; - lm = std::min(i__1,i__2); - work[j] -= ddot_(&lm, &ab[kd + 1 + j * ab_dim1], &c__1, & - work[j + 1], &c__1); - jp = ipiv[j]; - if (jp != j) { - t = work[jp]; - work[jp] = work[j]; - work[j] = t; - } -/* L30: */ - } - } - } - -/* Divide X by 1/SCALE if doing so will not cause overflow. */ - - *(unsigned char *)normin = 'Y'; - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) - { - goto L40; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - -L40: - return 0; - -/* End of DGBCON */ - -} /* dgbcon_ */ diff --git a/external/clapack/lapack/dgbequ.cpp b/external/clapack/lapack/dgbequ.cpp deleted file mode 100644 index dc9eaef5..00000000 --- a/external/clapack/lapack/dgbequ.cpp +++ /dev/null @@ -1,306 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgbequ_(integer *m, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, double *r__, double *c__, - double *rowcnd, double *colcnd, double *amax, integer * - info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, kd; - double rcmin, rcmax; - double bignum, smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBEQU computes row and column scalings intended to equilibrate an */ -/* M-by-N band matrix A and reduce its condition number. R returns the */ -/* row scale factors and C the column scale factors, chosen to try to */ -/* make the largest element in each row and column of the matrix B with */ -/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ - -/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ -/* number and BIGNUM = largest safe number. Use of these scaling */ -/* factors is not guaranteed to reduce the condition number of A but */ -/* works well in practice. */ - -/* 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. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ -/* column of A is stored in the j-th column of the array AB as */ -/* follows: */ -/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* R (output) DOUBLE PRECISION array, dimension (M) */ -/* If INFO = 0, or INFO > M, R contains the row scale factors */ -/* for A. */ - -/* C (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, C contains the column scale factors for A. */ - -/* ROWCND (output) DOUBLE PRECISION */ -/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ -/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ -/* AMAX is neither too large nor too small, it is not worth */ -/* scaling by R. */ - -/* COLCND (output) DOUBLE PRECISION */ -/* If INFO = 0, COLCND contains the ratio of the smallest */ -/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ -/* worth scaling by C. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= M: the i-th row of A is exactly zero */ -/* > M: the (i-M)-th column of A is exactly zero */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --r__; - --c__; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < *kl + *ku + 1) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBEQU", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - *rowcnd = 1.; - *colcnd = 1.; - *amax = 0.; - return 0; - } - -/* Get machine constants. */ - - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - -/* Compute row scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - r__[i__] = 0.; -/* L10: */ - } - -/* Find the maximum element in each row. */ - - kd = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = j - *ku; -/* Computing MIN */ - i__4 = j + *kl; - i__3 = std::min(i__4,*m); - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = r__[i__], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], - abs(d__1)); - r__[i__] = std::max(d__2,d__3); -/* L20: */ - } -/* L30: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[i__]; - rcmax = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[i__]; - rcmin = std::min(d__1,d__2); -/* L40: */ - } - *amax = rcmax; - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (r__[i__] == 0.) { - *info = i__; - return 0; - } -/* L50: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = r__[i__]; - d__1 = std::max(d__2,smlnum); - r__[i__] = 1. / std::min(d__1,bignum); -/* L60: */ - } - -/* Compute ROWCND = min(R(I)) / max(R(I)) */ - - *rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } - -/* Compute column scale factors */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - c__[j] = 0.; -/* L70: */ - } - -/* Find the maximum element in each column, */ -/* assuming the row scaling computed above. */ - - kd = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__3 = j - *ku; -/* Computing MIN */ - i__4 = j + *kl; - i__2 = std::min(i__4,*m); - for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = c__[j], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs( - d__1)) * r__[i__]; - c__[j] = std::max(d__2,d__3); -/* L80: */ - } -/* L90: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = std::max(d__1,d__2); -/* L100: */ - } - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (c__[j] == 0.) { - *info = *m + j; - return 0; - } -/* L110: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = c__[j]; - d__1 = std::max(d__2,smlnum); - c__[j] = 1. / std::min(d__1,bignum); -/* L120: */ - } - -/* Compute COLCND = min(C(J)) / max(C(J)) */ - - *colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } - - return 0; - -/* End of DGBEQU */ - -} /* dgbequ_ */ diff --git a/external/clapack/lapack/dgbequb.cpp b/external/clapack/lapack/dgbequb.cpp deleted file mode 100644 index 88733d74..00000000 --- a/external/clapack/lapack/dgbequb.cpp +++ /dev/null @@ -1,330 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgbequb_(integer *m, integer *n, integer *kl, integer * - ku, double *ab, integer *ldab, double *r__, double *c__, - double *rowcnd, double *colcnd, double *amax, integer * - info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, kd; - double radix, rcmin, rcmax; - double bignum, logrdx, smlnum; - - -/* -- LAPACK routine (version 3.2) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBEQUB computes row and column scalings intended to equilibrate an */ -/* M-by-N matrix A and reduce its condition number. R returns the row */ -/* scale factors and C the column scale factors, chosen to try to make */ -/* the largest element in each row and column of the matrix B with */ -/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */ -/* the radix. */ - -/* R(i) and C(j) are restricted to be a power of the radix between */ -/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */ -/* of these scaling factors is not guaranteed to reduce the condition */ -/* number of A but works well in practice. */ - -/* This routine differs from DGEEQU by restricting the scaling factors */ -/* to a power of the radix. Baring over- and underflow, scaling by */ -/* these factors introduces no additional rounding errors. However, the */ -/* scaled entries' magnitured are no longer approximately 1 but lie */ -/* between sqrt(radix) and 1/sqrt(radix). */ - -/* 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. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array A. LDAB >= max(1,M). */ - -/* R (output) DOUBLE PRECISION array, dimension (M) */ -/* If INFO = 0 or INFO > M, R contains the row scale factors */ -/* for A. */ - -/* C (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, C contains the column scale factors for A. */ - -/* ROWCND (output) DOUBLE PRECISION */ -/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ -/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ -/* AMAX is neither too large nor too small, it is not worth */ -/* scaling by R. */ - -/* COLCND (output) DOUBLE PRECISION */ -/* If INFO = 0, COLCND contains the ratio of the smallest */ -/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ -/* worth scaling by C. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= M: the i-th row of A is exactly zero */ -/* > M: the (i-M)-th column of A is exactly zero */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --r__; - --c__; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < *kl + *ku + 1) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBEQUB", &i__1); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - *rowcnd = 1.; - *colcnd = 1.; - *amax = 0.; - return 0; - } - -/* Get machine constants. Assume SMLNUM is a power of the radix. */ - - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - radix = dlamch_("B"); - logrdx = log(radix); - -/* Compute row scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - r__[i__] = 0.; -/* L10: */ - } - -/* Find the maximum element in each row. */ - - kd = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = j - *ku; -/* Computing MIN */ - i__4 = j + *kl; - i__3 = std::min(i__4,*m); - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = r__[i__], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], - abs(d__1)); - r__[i__] = std::max(d__2,d__3); -/* L20: */ - } -/* L30: */ - } - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (r__[i__] > 0.) { - i__3 = (integer) (log(r__[i__]) / logrdx); - r__[i__] = pow_di(&radix, &i__3); - } - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[i__]; - rcmax = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[i__]; - rcmin = std::min(d__1,d__2); -/* L40: */ - } - *amax = rcmax; - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (r__[i__] == 0.) { - *info = i__; - return 0; - } -/* L50: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = r__[i__]; - d__1 = std::max(d__2,smlnum); - r__[i__] = 1. / std::min(d__1,bignum); -/* L60: */ - } - -/* Compute ROWCND = min(R(I)) / max(R(I)). */ - - *rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } - -/* Compute column scale factors. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - c__[j] = 0.; -/* L70: */ - } - -/* Find the maximum element in each column, */ -/* assuming the row scaling computed above. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__3 = j - *ku; -/* Computing MIN */ - i__4 = j + *kl; - i__2 = std::min(i__4,*m); - for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = c__[j], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs( - d__1)) * r__[i__]; - c__[j] = std::max(d__2,d__3); -/* L80: */ - } - if (c__[j] > 0.) { - i__2 = (integer) (log(c__[j]) / logrdx); - c__[j] = pow_di(&radix, &i__2); - } -/* L90: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = std::max(d__1,d__2); -/* L100: */ - } - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (c__[j] == 0.) { - *info = *m + j; - return 0; - } -/* L110: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = c__[j]; - d__1 = std::max(d__2,smlnum); - c__[j] = 1. / std::min(d__1,bignum); -/* L120: */ - } - -/* Compute COLCND = min(C(J)) / max(C(J)). */ - - *colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } - - return 0; - -/* End of DGBEQUB */ - -} /* dgbequb_ */ diff --git a/external/clapack/lapack/dgbrfs.cpp b/external/clapack/lapack/dgbrfs.cpp deleted file mode 100644 index 36203dd5..00000000 --- a/external/clapack/lapack/dgbrfs.cpp +++ /dev/null @@ -1,430 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b15 = -1.; -static double c_b17 = 1.; - -/* Subroutine */ int dgbrfs_(const char *trans, integer *n, integer *kl, integer * - ku, integer *nrhs, double *ab, integer *ldab, double *afb, - integer *ldafb, integer *ipiv, double *b, integer *ldb, - double *x, integer *ldx, double *ferr, double *berr, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, - x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s; - integer kk; - double xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - integer count; - double safmin; - bool notran; - char transt[1]; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBRFS improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is banded, and provides */ -/* error bounds and backward error estimates for the solution. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The original band matrix A, stored in rows 1 to KL+KU+1. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ -/* Details of the LU factorization of the band matrix A, as */ -/* computed by DGBTRF. U is stored as an upper triangular band */ -/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ -/* the multipliers used during the factorization are stored in */ -/* rows KL+KU+2 to 2*KL+KU+1. */ - -/* LDAFB (input) INTEGER */ -/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from DGBTRF; for 1<=i<=N, row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DGBTRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T") && ! lsame_( - trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*ldab < *kl + *ku + 1) { - *info = -7; - } else if (*ldafb < (*kl << 1) + *ku + 1) { - *info = -9; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -12; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -14; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - -/* Computing MIN */ - i__1 = *kl + *ku + 2, i__2 = *n + 1; - nz = std::min(i__1,i__2); - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - op(A) * X, */ -/* where op(A) = A, A**T, or A**H, depending on TRANS. */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dgbmv_(trans, n, n, kl, ku, &c_b15, &ab[ab_offset], ldab, &x[j * - x_dim1 + 1], &c__1, &c_b17, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L30: */ - } - -/* Compute abs(op(A))*abs(X) + abs(B). */ - - if (notran) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - kk = *ku + 1 - k; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); -/* Computing MAX */ - i__3 = 1, i__4 = k - *ku; -/* Computing MIN */ - i__6 = *n, i__7 = k + *kl; - i__5 = std::min(i__6,i__7); - for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) { - work[i__] += (d__1 = ab[kk + i__ + k * ab_dim1], abs(d__1) - ) * xk; -/* L40: */ - } -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - kk = *ku + 1 - k; -/* Computing MAX */ - i__5 = 1, i__3 = k - *ku; -/* Computing MIN */ - i__6 = *n, i__7 = k + *kl; - i__4 = std::min(i__6,i__7); - for (i__ = std::max(i__5,i__3); i__ <= i__4; ++i__) { - s += (d__1 = ab[kk + i__ + k * ab_dim1], abs(d__1)) * ( - d__2 = x[i__ + j * x_dim1], abs(d__2)); -/* L60: */ - } - work[k] += s; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] -, &work[*n + 1], n, info); - daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(op(A)))* */ -/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(op(A)) is the inverse of op(A) */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(op(A)) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(op(A)**T). */ - - dgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & - ipiv[1], &work[*n + 1], n, info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] *= work[i__]; -/* L110: */ - } - } else { - -/* Multiply by inv(op(A))*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] *= work[i__]; -/* L120: */ - } - dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & - ipiv[1], &work[*n + 1], n, info); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DGBRFS */ - -} /* dgbrfs_ */ diff --git a/external/clapack/lapack/dgbrfsx.cpp b/external/clapack/lapack/dgbrfsx.cpp deleted file mode 100644 index 891aa0c2..00000000 --- a/external/clapack/lapack/dgbrfsx.cpp +++ /dev/null @@ -1,651 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c_n1 = -1; -static integer c__0 = 0; -static integer c__1 = 1; - -/* Subroutine */ int dgbrfsx_(const char *trans, const char *equed, integer *n, integer * - kl, integer *ku, integer *nrhs, double *ab, integer *ldab, - double *afb, integer *ldafb, integer *ipiv, double *r__, - double *c__, double *b, integer *ldb, double *x, integer * - ldx, double *rcond, double *berr, integer *n_err_bnds__, - double *err_bnds_norm__, double *err_bnds_comp__, integer * - nparams, double *params, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, - x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, - err_bnds_comp_dim1, err_bnds_comp_offset, i__1; - double d__1, d__2; - - /* Local variables */ - double illrcond_thresh__, unstable_thresh__, err_lbnd__; - integer ref_type__; - integer j; - double rcond_tmp__; - integer prec_type__, trans_type__; - double cwise_wrong__; - char norm[1]; - bool ignore_cwise__; - double anorm; - bool colequ, notran, rowequ; - integer ithresh, n_norms__; - double rthresh; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBRFSX improves the computed solution to a system of linear */ -/* equations and provides error bounds and backward error estimates */ -/* for the solution. In addition to normwise error bound, the code */ -/* provides maximum componentwise error bound if possible. See */ -/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */ -/* error bounds. */ - -/* The original system of linear equations may have been equilibrated */ -/* before calling this routine, as described by arguments EQUED, R */ -/* and C below. In this case, the solution and error bounds returned */ -/* are for the original unequilibrated system. */ - -/* Arguments */ -/* ========= */ - -/* Some optional parameters are bundled in the PARAMS array. These */ -/* settings determine how refinement is performed, but often the */ -/* defaults are acceptable. If the defaults are acceptable, users */ -/* can pass NPARAMS = 0 which prevents the source code from accessing */ -/* the PARAMS argument. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* EQUED (input) CHARACTER*1 */ -/* Specifies the form of equilibration that was done to A */ -/* before calling this routine. This is needed to compute */ -/* the solution and error bounds correctly. */ -/* = 'N': No equilibration */ -/* = 'R': Row equilibration, i.e., A has been premultiplied by */ -/* diag(R). */ -/* = 'C': Column equilibration, i.e., A has been postmultiplied */ -/* by diag(C). */ -/* = 'B': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(R) * A * diag(C). */ -/* The right hand side B has been changed accordingly. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The original band matrix A, stored in rows 1 to KL+KU+1. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ -/* Details of the LU factorization of the band matrix A, as */ -/* computed by DGBTRF. U is stored as an upper triangular band */ -/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ -/* the multipliers used during the factorization are stored in */ -/* rows KL+KU+2 to 2*KL+KU+1. */ - -/* LDAFB (input) INTEGER */ -/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* R (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The row scale factors for A. If EQUED = 'R' or 'B', A is */ -/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ -/* is not accessed. R is an input argument if FACT = 'F'; */ -/* otherwise, R is an output argument. If FACT = 'F' and */ -/* EQUED = 'R' or 'B', each element of R must be positive. */ -/* If R is output, each element of R is a power of the radix. */ -/* If R is input, each element of R should be a power of the radix */ -/* to ensure a reliable solution and error estimates. Scaling by */ -/* powers of the radix does not cause rounding errors unless the */ -/* result underflows or overflows. Rounding errors during scaling */ -/* lead to refining with a matrix that is not equivalent to the */ -/* input matrix, producing error estimates that may not be */ -/* reliable. */ - -/* C (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The column scale factors for A. If EQUED = 'C' or 'B', A is */ -/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ -/* is not accessed. C is an input argument if FACT = 'F'; */ -/* otherwise, C is an output argument. If FACT = 'F' and */ -/* EQUED = 'C' or 'B', each element of C must be positive. */ -/* If C is output, each element of C is a power of the radix. */ -/* If C is input, each element of C should be a power of the radix */ -/* to ensure a reliable solution and error estimates. Scaling by */ -/* powers of the radix does not cause rounding errors unless the */ -/* result underflows or overflows. Rounding errors during scaling */ -/* lead to refining with a matrix that is not equivalent to the */ -/* input matrix, producing error estimates that may not be */ -/* reliable. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DGETRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* Reciprocal scaled condition number. This is an estimate of the */ -/* reciprocal Skeel condition number of the matrix A after */ -/* equilibration (if done). If this is less than the machine */ -/* precision (in particular, if it is zero), the matrix is singular */ -/* to working precision. Note that the error may still be small even */ -/* if this number is very small and the matrix appears ill- */ -/* conditioned. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* Componentwise relative backward error. This is the */ -/* componentwise relative backward error of each solution vector X(j) */ -/* (i.e., the smallest relative change in any element of A or B that */ -/* makes X(j) an exact solution). */ - -/* N_ERR_BNDS (input) INTEGER */ -/* Number of error bounds to return for each right hand side */ -/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */ -/* ERR_BNDS_COMP below. */ - -/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ -/* For each right-hand side, this array contains information about */ -/* various error bounds and condition numbers corresponding to the */ -/* normwise relative error, which is defined as follows: */ - -/* Normwise relative error in the ith solution vector: */ -/* max_j (abs(XTRUE(j,i) - X(j,i))) */ -/* ------------------------------ */ -/* max_j abs(X(j,i)) */ - -/* The array is indexed by the type of error information as described */ -/* below. There currently are up to three pieces of information */ -/* returned. */ - -/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ -/* right-hand side. */ - -/* The second index in ERR_BNDS_NORM(:,err) contains the following */ -/* three fields: */ -/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ -/* reciprocal condition number is less than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). */ - -/* err = 2 "Guaranteed" error bound: The estimated forward error, */ -/* almost certainly within a factor of 10 of the true error */ -/* so long as the next entry is greater than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ -/* be trusted if the previous boolean is true. */ - -/* err = 3 Reciprocal condition number: Estimated normwise */ -/* reciprocal condition number. Compared with the threshold */ -/* sqrt(n) * dlamch('Epsilon') to determine if the error */ -/* estimate is "guaranteed". These reciprocal condition */ -/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ -/* appropriately scaled matrix Z. */ -/* Let Z = S*A, where S scales each row by a power of the */ -/* radix so all absolute row sums of Z are approximately 1. */ - -/* See Lapack Working Note 165 for further details and extra */ -/* cautions. */ - -/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ -/* For each right-hand side, this array contains information about */ -/* various error bounds and condition numbers corresponding to the */ -/* componentwise relative error, which is defined as follows: */ - -/* Componentwise relative error in the ith solution vector: */ -/* abs(XTRUE(j,i) - X(j,i)) */ -/* max_j ---------------------- */ -/* abs(X(j,i)) */ - -/* The array is indexed by the right-hand side i (on which the */ -/* componentwise relative error depends), and the type of error */ -/* information as described below. There currently are up to three */ -/* pieces of information returned for each right-hand side. If */ -/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ -/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ -/* the first (:,N_ERR_BNDS) entries are returned. */ - -/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ -/* right-hand side. */ - -/* The second index in ERR_BNDS_COMP(:,err) contains the following */ -/* three fields: */ -/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ -/* reciprocal condition number is less than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). */ - -/* err = 2 "Guaranteed" error bound: The estimated forward error, */ -/* almost certainly within a factor of 10 of the true error */ -/* so long as the next entry is greater than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ -/* be trusted if the previous boolean is true. */ - -/* err = 3 Reciprocal condition number: Estimated componentwise */ -/* reciprocal condition number. Compared with the threshold */ -/* sqrt(n) * dlamch('Epsilon') to determine if the error */ -/* estimate is "guaranteed". These reciprocal condition */ -/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ -/* appropriately scaled matrix Z. */ -/* Let Z = S*(A*diag(x)), where x is the solution for the */ -/* current right-hand side and S scales each row of */ -/* A*diag(x) by a power of the radix so all absolute row */ -/* sums of Z are approximately 1. */ - -/* See Lapack Working Note 165 for further details and extra */ -/* cautions. */ - -/* NPARAMS (input) INTEGER */ -/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */ -/* PARAMS array is never referenced and default values are used. */ - -/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */ -/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */ -/* that entry will be filled with default value used for that */ -/* parameter. Only positions up to NPARAMS are accessed; defaults */ -/* are used for higher-numbered parameters. */ - -/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ -/* refinement or not. */ -/* Default: 1.0D+0 */ -/* = 0.0 : No refinement is performed, and no error bounds are */ -/* computed. */ -/* = 1.0 : Use the double-precision refinement algorithm, */ -/* possibly with doubled-single computations if the */ -/* compilation environment does not support DOUBLE */ -/* PRECISION. */ -/* (other values are reserved for future use) */ - -/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ -/* computations allowed for refinement. */ -/* Default: 10 */ -/* Aggressive: Set to 100 to permit convergence using approximate */ -/* factorizations or factorizations other than LU. If */ -/* the factorization uses a technique other than */ -/* Gaussian elimination, the guarantees in */ -/* err_bnds_norm and err_bnds_comp may no longer be */ -/* trustworthy. */ - -/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ -/* will attempt to find a solution with small componentwise */ -/* relative error in the double-precision algorithm. Positive */ -/* is true, 0.0 is false. */ -/* Default: 1.0 (attempt componentwise convergence) */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: Successful exit. The solution to every right-hand side is */ -/* guaranteed. */ -/* < 0: If INFO = -i, the i-th argument had an illegal value */ -/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly singular, so */ -/* the solution and error bounds could not be computed. RCOND = 0 */ -/* is returned. */ -/* = N+J: The solution corresponding to the Jth right-hand side is */ -/* not guaranteed. The solutions corresponding to other right- */ -/* hand sides K with K > J may not be guaranteed as well, but */ -/* only the first such right-hand side is reported. If a small */ -/* componentwise error is not requested (PARAMS(3) = 0.0) then */ -/* the Jth right-hand side is the first with a normwise error */ -/* bound that is not guaranteed (the smallest J such */ -/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ -/* the Jth right-hand side is the first with either a normwise or */ -/* componentwise error bound that is not guaranteed (the smallest */ -/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ -/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ -/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ -/* about all of the right-hand sides check ERR_BNDS_NORM or */ -/* ERR_BNDS_COMP. */ - -/* ================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Check the input parameters. */ - - /* Parameter adjustments */ - err_bnds_comp_dim1 = *nrhs; - err_bnds_comp_offset = 1 + err_bnds_comp_dim1; - err_bnds_comp__ -= err_bnds_comp_offset; - err_bnds_norm_dim1 = *nrhs; - err_bnds_norm_offset = 1 + err_bnds_norm_dim1; - err_bnds_norm__ -= err_bnds_norm_offset; - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - --ipiv; - --r__; - --c__; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --berr; - --params; - --work; - --iwork; - - /* Function Body */ - *info = 0; - trans_type__ = ilatrans_(trans); - ref_type__ = 1; - if (*nparams >= 1) { - if (params[1] < 0.) { - params[1] = 1.; - } else { - ref_type__ = (integer) params[1]; - } - } - -/* Set default parameters. */ - - illrcond_thresh__ = (double) (*n) * dlamch_("Epsilon"); - ithresh = 10; - rthresh = .5; - unstable_thresh__ = .25; - ignore_cwise__ = false; - - if (*nparams >= 2) { - if (params[2] < 0.) { - params[2] = (double) ithresh; - } else { - ithresh = (integer) params[2]; - } - } - if (*nparams >= 3) { - if (params[3] < 0.) { - if (ignore_cwise__) { - params[3] = 0.; - } else { - params[3] = 1.; - } - } else { - ignore_cwise__ = params[3] == 0.; - } - } - if (ref_type__ == 0 || *n_err_bnds__ == 0) { - n_norms__ = 0; - } else if (ignore_cwise__) { - n_norms__ = 1; - } else { - n_norms__ = 2; - } - - notran = lsame_(trans, "N"); - rowequ = lsame_(equed, "R") || lsame_(equed, "B"); - colequ = lsame_(equed, "C") || lsame_(equed, "B"); - -/* Test input parameters. */ - - if (trans_type__ == -1) { - *info = -1; - } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*kl < 0) { - *info = -4; - } else if (*ku < 0) { - *info = -5; - } else if (*nrhs < 0) { - *info = -6; - } else if (*ldab < *kl + *ku + 1) { - *info = -8; - } else if (*ldafb < (*kl << 1) + *ku + 1) { - *info = -10; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -13; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -15; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBRFSX", &i__1); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *nrhs == 0) { - *rcond = 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - berr[j] = 0.; - if (*n_err_bnds__ >= 1) { - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } else if (*n_err_bnds__ >= 2) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.; - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.; - } else if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.; - } - } - return 0; - } - -/* Default to failure. */ - - *rcond = 0.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - berr[j] = 1.; - if (*n_err_bnds__ >= 1) { - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } else if (*n_err_bnds__ >= 2) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - } else if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.; - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.; - } - } - -/* Compute the norm of A and the reciprocal of the condition */ -/* number of A. */ - - if (notran) { - *(unsigned char *)norm = 'I'; - } else { - *(unsigned char *)norm = '1'; - } - anorm = dlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]); - dgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, - &work[1], &iwork[1], info); - -/* Perform refinement on each right-hand side */ - - if (ref_type__ != 0) { - prec_type__ = ilaprec_("E"); - if (notran) { - dla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku, - nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, & - ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset] - , ldx, &berr[1], &n_norms__, &err_bnds_norm__[ - err_bnds_norm_offset], &err_bnds_comp__[ - err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n - << 1) + 1], &work[1], rcond, &ithresh, &rthresh, & - unstable_thresh__, &ignore_cwise__, info); - } else { - dla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku, - nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, & - ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset] - , ldx, &berr[1], &n_norms__, &err_bnds_norm__[ - err_bnds_norm_offset], &err_bnds_comp__[ - err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n - << 1) + 1], &work[1], rcond, &ithresh, &rthresh, & - unstable_thresh__, &ignore_cwise__, info); - } - } -/* Computing MAX */ - d__1 = 10., d__2 = sqrt((double) (*n)); - err_lbnd__ = std::max(d__1,d__2) * dlamch_("Epsilon"); - if (*n_err_bnds__ >= 1 && n_norms__ >= 1) { - -/* Compute scaled normwise condition number cond(A*C). */ - - if (colequ && notran) { - rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset], - ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &c__[1], - info, &work[1], &iwork[1], 1_integer); - } else if (rowequ && ! notran) { - rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset], - ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &r__[1], - info, &work[1], &iwork[1], 1_integer); - } else { - rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset], - ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__0, &r__[1], - info, &work[1], &iwork[1], 1_integer); - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Cap the error at 1.0. */ - - if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 - << 1)] > 1.) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - } - -/* Threshold the error (see LAWN). */ - - if (rcond_tmp__ < illrcond_thresh__) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - err_bnds_norm__[j + err_bnds_norm_dim1] = 0.; - if (*info <= *n) { - *info = *n + j; - } - } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < - err_lbnd__) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__; - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - } - -/* Save the condition number. */ - - if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__; - } - } - } - if (*n_err_bnds__ >= 1 && n_norms__ >= 2) { - -/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */ -/* each right-hand side using the current solution as an estimate of */ -/* the true solution. If the componentwise error estimate is too */ -/* large, then the solution is a lousy estimate of truth and the */ -/* estimated RCOND may be too optimistic. To avoid misleading users, */ -/* the inverse condition number is set to 0.0 when the estimated */ -/* cwise error is at least CWISE_WRONG. */ - - cwise_wrong__ = sqrt(dlamch_("Epsilon")); - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < - cwise_wrong__) { - rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset], - ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__1, &x[j * - x_dim1 + 1], info, &work[1], &iwork[1], 1_integer); - } else { - rcond_tmp__ = 0.; - } - -/* Cap the error at 1.0. */ - - if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 - << 1)] > 1.) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - } - -/* Threshold the error (see LAWN). */ - - if (rcond_tmp__ < illrcond_thresh__) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 0.; - if (params[3] == 1. && *info < *n + j) { - *info = *n + j; - } - } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < - err_lbnd__) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } - -/* Save the condition number. */ - - if (*n_err_bnds__ >= 3) { - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__; - } - } - } - - return 0; - -/* End of DGBRFSX */ - -} /* dgbrfsx_ */ diff --git a/external/clapack/lapack/dgbsv.cpp b/external/clapack/lapack/dgbsv.cpp deleted file mode 100644 index 2ba44162..00000000 --- a/external/clapack/lapack/dgbsv.cpp +++ /dev/null @@ -1,156 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgbsv_(integer *n, integer *kl, integer *ku, integer * - nrhs, double *ab, integer *ldab, integer *ipiv, double *b, - integer *ldb, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBSV computes the solution to a real system of linear equations */ -/* A * X = B, where A is a band matrix of order N with KL subdiagonals */ -/* and KU superdiagonals, and X and B are N-by-NRHS matrices. */ - -/* The LU decomposition with partial pivoting and row interchanges is */ -/* used to factor A as A = L * U, where L is a product of permutation */ -/* and unit lower triangular matrices with KL subdiagonals, and U is */ -/* upper triangular with KL+KU superdiagonals. The factored form of A */ -/* is then used to solve the system of equations A * X = B. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows KL+1 to */ -/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) */ -/* On exit, details of the factorization: U is stored as an */ -/* upper triangular band matrix with KL+KU superdiagonals in */ -/* rows 1 to KL+KU+1, and the multipliers used during the */ -/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ -/* See below for further details. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* The pivot indices that define the permutation matrix P; */ -/* row i of the matrix was interchanged with row IPIV(i). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly */ -/* singular, and the solution has not been computed. */ - -/* Further Details */ -/* =============== */ - -/* The band storage scheme is illustrated by the following example, when */ -/* M = N = 6, KL = 2, KU = 1: */ - -/* On entry: On exit: */ - -/* * * * + + + * * * u14 u25 u36 */ -/* * * + + + + * * u13 u24 u35 u46 */ -/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ -/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ -/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ -/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ - -/* Array elements marked * are not used by the routine; elements marked */ -/* + need not be set on entry, but are required by the routine to store */ -/* elements of U because of fill-in resulting from the row interchanges. */ - -/* ===================================================================== */ - -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*kl < 0) { - *info = -2; - } else if (*ku < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*ldab < (*kl << 1) + *ku + 1) { - *info = -6; - } else if (*ldb < std::max(*n,1_integer)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBSV ", &i__1); - return 0; - } - -/* Compute the LU factorization of the band matrix A. */ - - dgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[ - 1], &b[b_offset], ldb, info); - } - return 0; - -/* End of DGBSV */ - -} /* dgbsv_ */ diff --git a/external/clapack/lapack/dgbsvx.cpp b/external/clapack/lapack/dgbsvx.cpp deleted file mode 100644 index 611d0139..00000000 --- a/external/clapack/lapack/dgbsvx.cpp +++ /dev/null @@ -1,610 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgbsvx_(const char *fact, const char *trans, integer *n, integer *kl, - integer *ku, integer *nrhs, double *ab, integer *ldab, - double *afb, integer *ldafb, integer *ipiv, char *equed, - double *r__, double *c__, double *b, integer *ldb, - double *x, integer *ldx, double *rcond, double *ferr, - double *berr, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, - x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, j1, j2; - double amax; - char norm[1]; - double rcmin, rcmax, anorm; - bool equil; - double colcnd; - bool nofact; - double bignum; - integer infequ; - bool colequ; - double rowcnd; - bool notran; - double smlnum; - bool rowequ; - double rpvgrw; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBSVX uses the LU factorization to compute the solution to a real */ -/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */ -/* where A is a band matrix of order N with KL subdiagonals and KU */ -/* superdiagonals, and X and B are N-by-NRHS matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed by this subroutine: */ - -/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ -/* the system: */ -/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ -/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ -/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ -/* Whether or not the system will be equilibrated depends on the */ -/* scaling of the matrix A, but if equilibration is used, A is */ -/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ -/* or diag(C)*B (if TRANS = 'T' or 'C'). */ - -/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */ -/* matrix A (after equilibration if FACT = 'E') as */ -/* A = L * U, */ -/* where L is a product of permutation and unit lower triangular */ -/* matrices with KL subdiagonals, and U is upper triangular with */ -/* KL+KU superdiagonals. */ - -/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */ -/* returns with INFO = i. Otherwise, the factored form of A is used */ -/* to estimate the condition number of the matrix A. If the */ -/* reciprocal of the condition number is less than machine precision, */ -/* INFO = N+1 is returned as a warning, but the routine still goes on */ -/* to solve for X and compute error bounds as described below. */ - -/* 4. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 5. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* 6. If equilibration was used, the matrix X is premultiplied by */ -/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ -/* that it solves the original system before equilibration. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of the matrix A is */ -/* supplied on entry, and if not, whether the matrix A should be */ -/* equilibrated before it is factored. */ -/* = 'F': On entry, AFB and IPIV contain the factored form of */ -/* A. If EQUED is not 'N', the matrix A has been */ -/* equilibrated with scaling factors given by R and C. */ -/* AB, AFB, and IPIV are not modified. */ -/* = 'N': The matrix A will be copied to AFB and factored. */ -/* = 'E': The matrix A will be equilibrated if necessary, then */ -/* copied to AFB and factored. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations. */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Transpose) */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ - -/* If FACT = 'F' and EQUED is not 'N', then A must have been */ -/* equilibrated by the scaling factors in R and/or C. AB is not */ -/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */ -/* EQUED = 'N' on exit. */ - -/* On exit, if EQUED .ne. 'N', A is scaled as follows: */ -/* EQUED = 'R': A := diag(R) * A */ -/* EQUED = 'C': A := A * diag(C) */ -/* EQUED = 'B': A := diag(R) * A * diag(C). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */ -/* If FACT = 'F', then AFB is an input argument and on entry */ -/* contains details of the LU factorization of the band matrix */ -/* A, as computed by DGBTRF. U is stored as an upper triangular */ -/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ -/* and the multipliers used during the factorization are stored */ -/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */ -/* the factored form of the equilibrated matrix A. */ - -/* If FACT = 'N', then AFB is an output argument and on exit */ -/* returns details of the LU factorization of A. */ - -/* If FACT = 'E', then AFB is an output argument and on exit */ -/* returns details of the LU factorization of the equilibrated */ -/* matrix A (see the description of AB for the form of the */ -/* equilibrated matrix). */ - -/* LDAFB (input) INTEGER */ -/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ - -/* IPIV (input or output) INTEGER array, dimension (N) */ -/* If FACT = 'F', then IPIV is an input argument and on entry */ -/* contains the pivot indices from the factorization A = L*U */ -/* as computed by DGBTRF; row i of the matrix was interchanged */ -/* with row IPIV(i). */ - -/* If FACT = 'N', then IPIV is an output argument and on exit */ -/* contains the pivot indices from the factorization A = L*U */ -/* of the original matrix A. */ - -/* If FACT = 'E', then IPIV is an output argument and on exit */ -/* contains the pivot indices from the factorization A = L*U */ -/* of the equilibrated matrix A. */ - -/* EQUED (input or output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration (always true if FACT = 'N'). */ -/* = 'R': Row equilibration, i.e., A has been premultiplied by */ -/* diag(R). */ -/* = 'C': Column equilibration, i.e., A has been postmultiplied */ -/* by diag(C). */ -/* = 'B': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(R) * A * diag(C). */ -/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ -/* output argument. */ - -/* R (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The row scale factors for A. If EQUED = 'R' or 'B', A is */ -/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ -/* is not accessed. R is an input argument if FACT = 'F'; */ -/* otherwise, R is an output argument. If FACT = 'F' and */ -/* EQUED = 'R' or 'B', each element of R must be positive. */ - -/* C (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The column scale factors for A. If EQUED = 'C' or 'B', A is */ -/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ -/* is not accessed. C is an input argument if FACT = 'F'; */ -/* otherwise, C is an output argument. If FACT = 'F' and */ -/* EQUED = 'C' or 'B', each element of C must be positive. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, */ -/* if EQUED = 'N', B is not modified; */ -/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ -/* diag(R)*B; */ -/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ -/* overwritten by diag(C)*B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */ -/* to the original system of equations. Note that A and B are */ -/* modified on exit if EQUED .ne. 'N', and the solution to the */ -/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */ -/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */ -/* and EQUED = 'R' or 'B'. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The estimate of the reciprocal condition number of the matrix */ -/* A after equilibration (if done). If RCOND is less than the */ -/* machine precision (in particular, if RCOND = 0), the matrix */ -/* is singular to working precision. This condition is */ -/* indicated by a return code of INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (3*N) */ -/* On exit, WORK(1) contains the reciprocal pivot growth */ -/* factor norm(A)/norm(U). The "max absolute element" norm is */ -/* used. If WORK(1) is much less than 1, then the stability */ -/* of the LU factorization of the (equilibrated) matrix A */ -/* could be poor. This also means that the solution X, condition */ -/* estimator RCOND, and forward error bound FERR could be */ -/* unreliable. If factorization fails with 0 0: if INFO = i, and i is */ -/* <= N: U(i,i) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly */ -/* singular, so the solution and error bounds */ -/* could not be computed. RCOND = 0 is returned. */ -/* = N+1: U is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - --ipiv; - --r__; - --c__; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - equil = lsame_(fact, "E"); - notran = lsame_(trans, "N"); - if (nofact || equil) { - *(unsigned char *)equed = 'N'; - rowequ = false; - colequ = false; - } else { - rowequ = lsame_(equed, "R") || lsame_(equed, - "B"); - colequ = lsame_(equed, "C") || lsame_(equed, - "B"); - smlnum = dlamch_("Safe minimum"); - bignum = 1. / smlnum; - } - -/* Test the input parameters. */ - - if (! nofact && ! equil && ! lsame_(fact, "F")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*kl < 0) { - *info = -4; - } else if (*ku < 0) { - *info = -5; - } else if (*nrhs < 0) { - *info = -6; - } else if (*ldab < *kl + *ku + 1) { - *info = -8; - } else if (*ldafb < (*kl << 1) + *ku + 1) { - *info = -10; - } else if (lsame_(fact, "F") && ! (rowequ || colequ - || lsame_(equed, "N"))) { - *info = -12; - } else { - if (rowequ) { - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[j]; - rcmax = std::max(d__1,d__2); -/* L10: */ - } - if (rcmin <= 0.) { - *info = -13; - } else if (*n > 0) { - rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } else { - rowcnd = 1.; - } - } - if (colequ && *info == 0) { - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = std::max(d__1,d__2); -/* L20: */ - } - if (rcmin <= 0.) { - *info = -14; - } else if (*n > 0) { - colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } else { - colcnd = 1.; - } - } - if (*info == 0) { - if (*ldb < std::max(1_integer,*n)) { - *info = -16; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -18; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBSVX", &i__1); - return 0; - } - - if (equil) { - -/* Compute row and column scalings to equilibrate the matrix A. */ - - dgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd, - &colcnd, &amax, &infequ); - if (infequ == 0) { - -/* Equilibrate the matrix. */ - - dlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & - rowcnd, &colcnd, &amax, equed); - rowequ = lsame_(equed, "R") || lsame_(equed, - "B"); - colequ = lsame_(equed, "C") || lsame_(equed, - "B"); - } - } - -/* Scale the right hand side. */ - - if (notran) { - if (rowequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else if (colequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1]; -/* L50: */ - } -/* L60: */ - } - } - - if (nofact || equil) { - -/* Compute the LU factorization of the band matrix A. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = j - *ku; - j1 = std::max(i__2,1_integer); -/* Computing MIN */ - i__2 = j + *kl; - j2 = std::min(i__2,*n); - i__2 = j2 - j1 + 1; - dcopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[* - kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1); -/* L70: */ - } - - dgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - -/* Compute the reciprocal pivot growth factor of the */ -/* leading rank-deficient INFO columns of A. */ - - anorm = 0.; - i__1 = *info; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = *ku + 2 - j; -/* Computing MIN */ - i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; - i__3 = std::min(i__4,i__5); - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = anorm, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs( - d__1)); - anorm = std::max(d__2,d__3); -/* L80: */ - } -/* L90: */ - } -/* Computing MIN */ - i__3 = *info - 1, i__2 = *kl + *ku; - i__1 = std::min(i__3,i__2); -/* Computing MAX */ - i__4 = 1, i__5 = *kl + *ku + 2 - *info; - rpvgrw = dlantb_("M", "U", "N", info, &i__1, &afb[std::max(i__4, i__5) - + afb_dim1], ldafb, &work[1]); - if (rpvgrw == 0.) { - rpvgrw = 1.; - } else { - rpvgrw = anorm / rpvgrw; - } - work[1] = rpvgrw; - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A and the */ -/* reciprocal pivot growth factor RPVGRW. */ - - if (notran) { - *(unsigned char *)norm = '1'; - } else { - *(unsigned char *)norm = 'I'; - } - anorm = dlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]); - i__1 = *kl + *ku; - rpvgrw = dlantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &work[ - 1]); - if (rpvgrw == 0.) { - rpvgrw = 1.; - } else { - rpvgrw = dlangb_("M", n, kl, ku, &ab[ab_offset], ldab, &work[1]) / rpvgrw; - } - -/* Compute the reciprocal of the condition number of A. */ - - dgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, - &work[1], &iwork[1], info); - -/* Compute the solution matrix X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ - x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solution and */ -/* compute error bounds and backward error estimates for it. */ - - dgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], - ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], & - berr[1], &work[1], &iwork[1], info); - -/* Transform the solution matrix X to a solution of the original */ -/* system. */ - - if (notran) { - if (colequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1]; -/* L100: */ - } -/* L110: */ - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] /= colcnd; -/* L120: */ - } - } - } else if (rowequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1]; -/* L130: */ - } -/* L140: */ - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] /= rowcnd; -/* L150: */ - } - } - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - - work[1] = rpvgrw; - return 0; - -/* End of DGBSVX */ - -} /* dgbsvx_ */ diff --git a/external/clapack/lapack/dgbsvxx.cpp b/external/clapack/lapack/dgbsvxx.cpp deleted file mode 100644 index 801ba1b5..00000000 --- a/external/clapack/lapack/dgbsvxx.cpp +++ /dev/null @@ -1,705 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgbsvxx_(const char *fact, const char *trans, integer *n, integer * - kl, integer *ku, integer *nrhs, double *ab, integer *ldab, - double *afb, integer *ldafb, integer *ipiv, char *equed, - double *r__, double *c__, double *b, integer *ldb, - double *x, integer *ldx, double *rcond, double *rpvgrw, - double *berr, integer *n_err_bnds__, double *err_bnds_norm__, - double *err_bnds_comp__, integer *nparams, double *params, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, - x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, - err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double amax; - double rcmin, rcmax; - bool equil; - double colcnd; - bool nofact; - double bignum; - integer infequ; - bool colequ; - double rowcnd; - bool notran; - double smlnum; - bool rowequ; - -/* -- LAPACK driver routine (version 3.2) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBSVXX uses the LU factorization to compute the solution to a */ -/* double precision system of linear equations A * X = B, where A is an */ -/* N-by-N matrix and X and B are N-by-NRHS matrices. */ - -/* If requested, both normwise and maximum componentwise error bounds */ -/* are returned. DGBSVXX will return a solution with a tiny */ -/* guaranteed error (O(eps) where eps is the working machine */ -/* precision) unless the matrix is very ill-conditioned, in which */ -/* case a warning is returned. Relevant condition numbers also are */ -/* calculated and returned. */ - -/* DGBSVXX accepts user-provided factorizations and equilibration */ -/* factors; see the definitions of the FACT and EQUED options. */ -/* Solving with refinement and using a factorization from a previous */ -/* DGBSVXX call will also produce a solution with either O(eps) */ -/* errors or warnings, but we cannot make that claim for general */ -/* user-provided factorizations and equilibration factors if they */ -/* differ from what DGBSVXX would itself produce. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */ -/* the system: */ - -/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ -/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ -/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ - -/* Whether or not the system will be equilibrated depends on the */ -/* scaling of the matrix A, but if equilibration is used, A is */ -/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ -/* or diag(C)*B (if TRANS = 'T' or 'C'). */ - -/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */ -/* the matrix A (after equilibration if FACT = 'E') as */ - -/* A = P * L * U, */ - -/* where P is a permutation matrix, L is a unit lower triangular */ -/* matrix, and U is upper triangular. */ - -/* 3. If some U(i,i)=0, so that U is exactly singular, then the */ -/* routine returns with INFO = i. Otherwise, the factored form of A */ -/* is used to estimate the condition number of the matrix A (see */ -/* argument RCOND). If the reciprocal of the condition number is less */ -/* than machine precision, the routine still goes on to solve for X */ -/* and compute error bounds as described below. */ - -/* 4. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ -/* the routine will use iterative refinement to try to get a small */ -/* error and error bounds. Refinement calculates the residual to at */ -/* least twice the working precision. */ - -/* 6. If equilibration was used, the matrix X is premultiplied by */ -/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ -/* that it solves the original system before equilibration. */ - -/* Arguments */ -/* ========= */ - -/* Some optional parameters are bundled in the PARAMS array. These */ -/* settings determine how refinement is performed, but often the */ -/* defaults are acceptable. If the defaults are acceptable, users */ -/* can pass NPARAMS = 0 which prevents the source code from accessing */ -/* the PARAMS argument. */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of the matrix A is */ -/* supplied on entry, and if not, whether the matrix A should be */ -/* equilibrated before it is factored. */ -/* = 'F': On entry, AF and IPIV contain the factored form of A. */ -/* If EQUED is not 'N', the matrix A has been */ -/* equilibrated with scaling factors given by R and C. */ -/* A, AF, and IPIV are not modified. */ -/* = 'N': The matrix A will be copied to AF and factored. */ -/* = 'E': The matrix A will be equilibrated if necessary, then */ -/* copied to AF and factored. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ - -/* If FACT = 'F' and EQUED is not 'N', then AB must have been */ -/* equilibrated by the scaling factors in R and/or C. AB is not */ -/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */ -/* EQUED = 'N' on exit. */ - -/* On exit, if EQUED .ne. 'N', A is scaled as follows: */ -/* EQUED = 'R': A := diag(R) * A */ -/* EQUED = 'C': A := A * diag(C) */ -/* EQUED = 'B': A := diag(R) * A * diag(C). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */ -/* If FACT = 'F', then AFB is an input argument and on entry */ -/* contains details of the LU factorization of the band matrix */ -/* A, as computed by DGBTRF. U is stored as an upper triangular */ -/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ -/* and the multipliers used during the factorization are stored */ -/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */ -/* the factored form of the equilibrated matrix A. */ - -/* If FACT = 'N', then AF is an output argument and on exit */ -/* returns the factors L and U from the factorization A = P*L*U */ -/* of the original matrix A. */ - -/* If FACT = 'E', then AF is an output argument and on exit */ -/* returns the factors L and U from the factorization A = P*L*U */ -/* of the equilibrated matrix A (see the description of A for */ -/* the form of the equilibrated matrix). */ - -/* LDAFB (input) INTEGER */ -/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ - -/* IPIV (input or output) INTEGER array, dimension (N) */ -/* If FACT = 'F', then IPIV is an input argument and on entry */ -/* contains the pivot indices from the factorization A = P*L*U */ -/* as computed by DGETRF; row i of the matrix was interchanged */ -/* with row IPIV(i). */ - -/* If FACT = 'N', then IPIV is an output argument and on exit */ -/* contains the pivot indices from the factorization A = P*L*U */ -/* of the original matrix A. */ - -/* If FACT = 'E', then IPIV is an output argument and on exit */ -/* contains the pivot indices from the factorization A = P*L*U */ -/* of the equilibrated matrix A. */ - -/* EQUED (input or output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration (always true if FACT = 'N'). */ -/* = 'R': Row equilibration, i.e., A has been premultiplied by */ -/* diag(R). */ -/* = 'C': Column equilibration, i.e., A has been postmultiplied */ -/* by diag(C). */ -/* = 'B': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(R) * A * diag(C). */ -/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ -/* output argument. */ - -/* R (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The row scale factors for A. If EQUED = 'R' or 'B', A is */ -/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ -/* is not accessed. R is an input argument if FACT = 'F'; */ -/* otherwise, R is an output argument. If FACT = 'F' and */ -/* EQUED = 'R' or 'B', each element of R must be positive. */ -/* If R is output, each element of R is a power of the radix. */ -/* If R is input, each element of R should be a power of the radix */ -/* to ensure a reliable solution and error estimates. Scaling by */ -/* powers of the radix does not cause rounding errors unless the */ -/* result underflows or overflows. Rounding errors during scaling */ -/* lead to refining with a matrix that is not equivalent to the */ -/* input matrix, producing error estimates that may not be */ -/* reliable. */ - -/* C (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The column scale factors for A. If EQUED = 'C' or 'B', A is */ -/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ -/* is not accessed. C is an input argument if FACT = 'F'; */ -/* otherwise, C is an output argument. If FACT = 'F' and */ -/* EQUED = 'C' or 'B', each element of C must be positive. */ -/* If C is output, each element of C is a power of the radix. */ -/* If C is input, each element of C should be a power of the radix */ -/* to ensure a reliable solution and error estimates. Scaling by */ -/* powers of the radix does not cause rounding errors unless the */ -/* result underflows or overflows. Rounding errors during scaling */ -/* lead to refining with a matrix that is not equivalent to the */ -/* input matrix, producing error estimates that may not be */ -/* reliable. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, */ -/* if EQUED = 'N', B is not modified; */ -/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ -/* diag(R)*B; */ -/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ -/* overwritten by diag(C)*B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0, the N-by-NRHS solution matrix X to the original */ -/* system of equations. Note that A and B are modified on exit */ -/* if EQUED .ne. 'N', and the solution to the equilibrated system is */ -/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */ -/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* Reciprocal scaled condition number. This is an estimate of the */ -/* reciprocal Skeel condition number of the matrix A after */ -/* equilibration (if done). If this is less than the machine */ -/* precision (in particular, if it is zero), the matrix is singular */ -/* to working precision. Note that the error may still be small even */ -/* if this number is very small and the matrix appears ill- */ -/* conditioned. */ - -/* RPVGRW (output) DOUBLE PRECISION */ -/* Reciprocal pivot growth. On exit, this contains the reciprocal */ -/* pivot growth factor norm(A)/norm(U). The "max absolute element" */ -/* norm is used. If this is much less than 1, then the stability of */ -/* the LU factorization of the (equilibrated) matrix A could be poor. */ -/* This also means that the solution X, estimated condition numbers, */ -/* and error bounds could be unreliable. If factorization fails with */ -/* 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly singular, so */ -/* the solution and error bounds could not be computed. RCOND = 0 */ -/* is returned. */ -/* = N+J: The solution corresponding to the Jth right-hand side is */ -/* not guaranteed. The solutions corresponding to other right- */ -/* hand sides K with K > J may not be guaranteed as well, but */ -/* only the first such right-hand side is reported. If a small */ -/* componentwise error is not requested (PARAMS(3) = 0.0) then */ -/* the Jth right-hand side is the first with a normwise error */ -/* bound that is not guaranteed (the smallest J such */ -/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ -/* the Jth right-hand side is the first with either a normwise or */ -/* componentwise error bound that is not guaranteed (the smallest */ -/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ -/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ -/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ -/* about all of the right-hand sides check ERR_BNDS_NORM or */ -/* ERR_BNDS_COMP. */ - -/* ================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - err_bnds_comp_dim1 = *nrhs; - err_bnds_comp_offset = 1 + err_bnds_comp_dim1; - err_bnds_comp__ -= err_bnds_comp_offset; - err_bnds_norm_dim1 = *nrhs; - err_bnds_norm_offset = 1 + err_bnds_norm_dim1; - err_bnds_norm__ -= err_bnds_norm_offset; - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - --ipiv; - --r__; - --c__; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --berr; - --params; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - equil = lsame_(fact, "E"); - notran = lsame_(trans, "N"); - smlnum = dlamch_("Safe minimum"); - bignum = 1. / smlnum; - if (nofact || equil) { - *(unsigned char *)equed = 'N'; - rowequ = false; - colequ = false; - } else { - rowequ = lsame_(equed, "R") || lsame_(equed, "B"); - colequ = lsame_(equed, "C") || lsame_(equed, "B"); - } - -/* Default is failure. If an input parameter is wrong or */ -/* factorization fails, make everything look horrible. Only the */ -/* pivot growth is set here, the rest is initialized in DGBRFSX. */ - - *rpvgrw = 0.; - -/* Test the input parameters. PARAMS is not tested until DGBRFSX. */ - - if (! nofact && ! equil && ! lsame_(fact, "F")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*kl < 0) { - *info = -4; - } else if (*ku < 0) { - *info = -5; - } else if (*nrhs < 0) { - *info = -6; - } else if (*ldab < *kl + *ku + 1) { - *info = -8; - } else if (*ldafb < (*kl << 1) + *ku + 1) { - *info = -10; - } else if (lsame_(fact, "F") && ! (rowequ || colequ - || lsame_(equed, "N"))) { - *info = -12; - } else { - if (rowequ) { - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[j]; - rcmax = std::max(d__1,d__2); -/* L10: */ - } - if (rcmin <= 0.) { - *info = -13; - } else if (*n > 0) { - rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } else { - rowcnd = 1.; - } - } - if (colequ && *info == 0) { - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = std::max(d__1,d__2); -/* L20: */ - } - if (rcmin <= 0.) { - *info = -14; - } else if (*n > 0) { - colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } else { - colcnd = 1.; - } - } - if (*info == 0) { - if (*ldb < std::max(1_integer,*n)) { - *info = -15; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -16; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBSVXX", &i__1); - return 0; - } - - if (equil) { - -/* Compute row and column scalings to equilibrate the matrix A. */ - - dgbequb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & - rowcnd, &colcnd, &amax, &infequ); - if (infequ == 0) { - -/* Equilibrate the matrix. */ - - dlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & - rowcnd, &colcnd, &amax, equed); - rowequ = lsame_(equed, "R") || lsame_(equed, - "B"); - colequ = lsame_(equed, "C") || lsame_(equed, - "B"); - } - -/* If the scaling factors are not applied, set them to 1.0. */ - - if (! rowequ) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - r__[j] = 1.; - } - } - if (! colequ) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - c__[j] = 1.; - } - } - } - -/* Scale the right hand side. */ - - if (notran) { - if (rowequ) { - dlascl2_(n, nrhs, &r__[1], &b[b_offset], ldb); - } - } else { - if (colequ) { - dlascl2_(n, nrhs, &c__[1], &b[b_offset], ldb); - } - } - - if (nofact || equil) { - -/* Compute the LU factorization of A. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = (*kl << 1) + *ku + 1; - for (i__ = *kl + 1; i__ <= i__2; ++i__) { - afb[i__ + j * afb_dim1] = ab[i__ - *kl + j * ab_dim1]; -/* L30: */ - } -/* L40: */ - } - dgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - -/* Pivot in column INFO is exactly 0 */ -/* Compute the reciprocal pivot growth factor of the */ -/* leading rank-deficient INFO columns of A. */ - - *rpvgrw = dla_gbrpvgrw__(n, kl, ku, info, &ab[ab_offset], ldab, & - afb[afb_offset], ldafb); - return 0; - } - } - -/* Compute the reciprocal pivot growth factor RPVGRW. */ - - *rpvgrw = dla_gbrpvgrw__(n, kl, ku, n, &ab[ab_offset], ldab, &afb[ - afb_offset], ldafb); - -/* Compute the solution matrix X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ - x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solution and */ -/* compute error bounds and backward error estimates for it. */ - - dgbrfsx_(trans, equed, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[ - afb_offset], ldafb, &ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, - &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, & - err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[ - err_bnds_comp_offset], nparams, ¶ms[1], &work[1], &iwork[1], - info); - -/* Scale solutions. */ - - if (colequ && notran) { - dlascl2_(n, nrhs, &c__[1], &x[x_offset], ldx); - } else if (rowequ && ! notran) { - dlascl2_(n, nrhs, &r__[1], &x[x_offset], ldx); - } - - return 0; - -/* End of DGBSVXX */ - -} /* dgbsvxx_ */ diff --git a/external/clapack/lapack/dgbtf2.cpp b/external/clapack/lapack/dgbtf2.cpp deleted file mode 100644 index a7d21637..00000000 --- a/external/clapack/lapack/dgbtf2.cpp +++ /dev/null @@ -1,243 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b9 = -1.; - -/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, integer *ipiv, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - double d__1; - - /* Local variables */ - integer i__, j, km, jp, ju, kv; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBTF2 computes an LU factorization of a real m-by-n band matrix A */ -/* using partial pivoting with row interchanges. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* 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. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows KL+1 to */ -/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */ - -/* On exit, details of the factorization: U is stored as an */ -/* upper triangular band matrix with KL+KU superdiagonals in */ -/* rows 1 to KL+KU+1, and the multipliers used during the */ -/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ -/* See below for further details. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ - -/* IPIV (output) INTEGER array, dimension (min(M,N)) */ -/* The pivot indices; for 1 <= i <= min(M,N), row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly */ -/* singular, and division by zero will occur if it is used */ -/* to solve a system of equations. */ - -/* Further Details */ -/* =============== */ - -/* The band storage scheme is illustrated by the following example, when */ -/* M = N = 6, KL = 2, KU = 1: */ - -/* On entry: On exit: */ - -/* * * * + + + * * * u14 u25 u36 */ -/* * * + + + + * * u13 u24 u35 u46 */ -/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ -/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ -/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ -/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ - -/* Array elements marked * are not used by the routine; elements marked */ -/* + need not be set on entry, but are required by the routine to store */ -/* elements of U, because of fill-in resulting from the row */ -/* interchanges. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* KV is the number of superdiagonals in the factor U, allowing for */ -/* fill-in. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --ipiv; - - /* Function Body */ - kv = *ku + *kl; - -/* Test the input parameters. */ - - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < *kl + kv + 1) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBTF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Gaussian elimination with partial pivoting */ - -/* Set fill-in elements in columns KU+2 to KV to zero. */ - - i__1 = std::min(kv,*n); - for (j = *ku + 2; j <= i__1; ++j) { - i__2 = *kl; - for (i__ = kv - j + 2; i__ <= i__2; ++i__) { - ab[i__ + j * ab_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - -/* JU is the index of the last column affected by the current stage */ -/* of the factorization. */ - - ju = 1; - - i__1 = std::min(*m,*n); - for (j = 1; j <= i__1; ++j) { - -/* Set fill-in elements in column J+KV to zero. */ - - if (j + kv <= *n) { - i__2 = *kl; - for (i__ = 1; i__ <= i__2; ++i__) { - ab[i__ + (j + kv) * ab_dim1] = 0.; -/* L30: */ - } - } - -/* Find pivot and test for singularity. KM is the number of */ -/* subdiagonal elements in the current column. */ - -/* Computing MIN */ - i__2 = *kl, i__3 = *m - j; - km = std::min(i__2,i__3); - i__2 = km + 1; - jp = idamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1); - ipiv[j] = jp + j - 1; - if (ab[kv + jp + j * ab_dim1] != 0.) { -/* Computing MAX */ -/* Computing MIN */ - i__4 = j + *ku + jp - 1; - i__2 = ju, i__3 = std::min(i__4,*n); - ju = std::max(i__2,i__3); - -/* Apply interchange to columns J to JU. */ - - if (jp != 1) { - i__2 = ju - j + 1; - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 + - j * ab_dim1], &i__4); - } - - if (km > 0) { - -/* Compute multipliers. */ - - d__1 = 1. / ab[kv + 1 + j * ab_dim1]; - dscal_(&km, &d__1, &ab[kv + 2 + j * ab_dim1], &c__1); - -/* Update trailing submatrix within the band. */ - - if (ju > j) { - i__2 = ju - j; - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dger_(&km, &i__2, &c_b9, &ab[kv + 2 + j * ab_dim1], &c__1, - &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 + - (j + 1) * ab_dim1], &i__4); - } - } - } else { - -/* If pivot is zero, set INFO to the index of the pivot */ -/* unless a zero pivot has already been found. */ - - if (*info == 0) { - *info = j; - } - } -/* L40: */ - } - return 0; - -/* End of DGBTF2 */ - -} /* dgbtf2_ */ diff --git a/external/clapack/lapack/dgbtrf.cpp b/external/clapack/lapack/dgbtrf.cpp deleted file mode 100644 index 241582fe..00000000 --- a/external/clapack/lapack/dgbtrf.cpp +++ /dev/null @@ -1,554 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__65 = 65; -static double c_b18 = -1.; -static double c_b31 = 1.; - -/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, integer *ipiv, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; - double d__1; - - /* Local variables */ - integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju, - kv, nw; - double temp; - double work13[4160] /* was [65][64] */, work31[4160] /* - was [65][64] */; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBTRF computes an LU factorization of a real m-by-n band matrix A */ -/* using partial pivoting with row interchanges. */ - -/* This is the blocked version of the algorithm, calling Level 3 BLAS. */ - -/* 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. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows KL+1 to */ -/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */ - -/* On exit, details of the factorization: U is stored as an */ -/* upper triangular band matrix with KL+KU superdiagonals in */ -/* rows 1 to KL+KU+1, and the multipliers used during the */ -/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ -/* See below for further details. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ - -/* IPIV (output) INTEGER array, dimension (min(M,N)) */ -/* The pivot indices; for 1 <= i <= min(M,N), row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly */ -/* singular, and division by zero will occur if it is used */ -/* to solve a system of equations. */ - -/* Further Details */ -/* =============== */ - -/* The band storage scheme is illustrated by the following example, when */ -/* M = N = 6, KL = 2, KU = 1: */ - -/* On entry: On exit: */ - -/* * * * + + + * * * u14 u25 u36 */ -/* * * + + + + * * u13 u24 u35 u46 */ -/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ -/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ -/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ -/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ - -/* Array elements marked * are not used by the routine; elements marked */ -/* + need not be set on entry, but are required by the routine to store */ -/* elements of U because of fill-in resulting from the row interchanges. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* KV is the number of superdiagonals in the factor U, allowing for */ -/* fill-in */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --ipiv; - - /* Function Body */ - kv = *ku + *kl; - -/* Test the input parameters. */ - - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < *kl + kv + 1) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Determine the block size for this environment */ - - nb = ilaenv_(&c__1, "DGBTRF", " ", m, n, kl, ku); - -/* The block size must not exceed the limit set by the size of the */ -/* local arrays WORK13 and WORK31. */ - - nb = std::min(nb,64_integer); - - if (nb <= 1 || nb > *kl) { - -/* Use unblocked code */ - - dgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); - } else { - -/* Use blocked code */ - -/* Zero the superdiagonal elements of the work array WORK13 */ - - i__1 = nb; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work13[i__ + j * 65 - 66] = 0.; -/* L10: */ - } -/* L20: */ - } - -/* Zero the subdiagonal elements of the work array WORK31 */ - - i__1 = nb; - for (j = 1; j <= i__1; ++j) { - i__2 = nb; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work31[i__ + j * 65 - 66] = 0.; -/* L30: */ - } -/* L40: */ - } - -/* Gaussian elimination with partial pivoting */ - -/* Set fill-in elements in columns KU+2 to KV to zero */ - - i__1 = std::min(kv,*n); - for (j = *ku + 2; j <= i__1; ++j) { - i__2 = *kl; - for (i__ = kv - j + 2; i__ <= i__2; ++i__) { - ab[i__ + j * ab_dim1] = 0.; -/* L50: */ - } -/* L60: */ - } - -/* JU is the index of the last column affected by the current */ -/* stage of the factorization */ - - ju = 1; - - i__1 = std::min(*m,*n); - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = std::min(*m,*n) - j + 1; - jb = std::min(i__3,i__4); - -/* The active part of the matrix is partitioned */ - -/* A11 A12 A13 */ -/* A21 A22 A23 */ -/* A31 A32 A33 */ - -/* Here A11, A21 and A31 denote the current block of JB columns */ -/* which is about to be factorized. The number of rows in the */ -/* partitioning are JB, I2, I3 respectively, and the numbers */ -/* of columns are JB, J2, J3. The superdiagonal elements of A13 */ -/* and the subdiagonal elements of A31 lie outside the band. */ - -/* Computing MIN */ - i__3 = *kl - jb, i__4 = *m - j - jb + 1; - i2 = std::min(i__3,i__4); -/* Computing MIN */ - i__3 = jb, i__4 = *m - j - *kl + 1; - i3 = std::min(i__3,i__4); - -/* J2 and J3 are computed after JU has been updated. */ - -/* Factorize the current block of JB columns */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - -/* Set fill-in elements in column JJ+KV to zero */ - - if (jj + kv <= *n) { - i__4 = *kl; - for (i__ = 1; i__ <= i__4; ++i__) { - ab[i__ + (jj + kv) * ab_dim1] = 0.; -/* L70: */ - } - } - -/* Find pivot and test for singularity. KM is the number of */ -/* subdiagonal elements in the current column. */ - -/* Computing MIN */ - i__4 = *kl, i__5 = *m - jj; - km = std::min(i__4,i__5); - i__4 = km + 1; - jp = idamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1); - ipiv[jj] = jp + jj - j; - if (ab[kv + jp + jj * ab_dim1] != 0.) { -/* Computing MAX */ -/* Computing MIN */ - i__6 = jj + *ku + jp - 1; - i__4 = ju, i__5 = std::min(i__6,*n); - ju = std::max(i__4,i__5); - if (jp != 1) { - -/* Apply interchange to columns J to J+JB-1 */ - - if (jp + jj - 1 < j + *kl) { - - i__4 = *ldab - 1; - i__5 = *ldab - 1; - dswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], & - i__4, &ab[kv + jp + jj - j + j * ab_dim1], - &i__5); - } else { - -/* The interchange affects columns J to JJ-1 of A31 */ -/* which are stored in the work array WORK31 */ - - i__4 = jj - j; - i__5 = *ldab - 1; - dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], - &i__5, &work31[jp + jj - j - *kl - 1], & - c__65); - i__4 = j + jb - jj; - i__5 = *ldab - 1; - i__6 = *ldab - 1; - dswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, & - ab[kv + jp + jj * ab_dim1], &i__6); - } - } - -/* Compute multipliers */ - - d__1 = 1. / ab[kv + 1 + jj * ab_dim1]; - dscal_(&km, &d__1, &ab[kv + 2 + jj * ab_dim1], &c__1); - -/* Update trailing submatrix within the band and within */ -/* the current block. JM is the index of the last column */ -/* which needs to be updated. */ - -/* Computing MIN */ - i__4 = ju, i__5 = j + jb - 1; - jm = std::min(i__4,i__5); - if (jm > jj) { - i__4 = jm - jj; - i__5 = *ldab - 1; - i__6 = *ldab - 1; - dger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1], - &c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, & - ab[kv + 1 + (jj + 1) * ab_dim1], &i__6); - } - } else { - -/* If pivot is zero, set INFO to the index of the pivot */ -/* unless a zero pivot has already been found. */ - - if (*info == 0) { - *info = jj; - } - } - -/* Copy current column of A31 into the work array WORK31 */ - -/* Computing MIN */ - i__4 = jj - j + 1; - nw = std::min(i__4,i3); - if (nw > 0) { - dcopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], & - c__1, &work31[(jj - j + 1) * 65 - 65], &c__1); - } -/* L80: */ - } - if (j + jb <= *n) { - -/* Apply the row interchanges to the other blocks. */ - -/* Computing MIN */ - i__3 = ju - j + 1; - j2 = std::min(i__3,kv) - jb; -/* Computing MAX */ - i__3 = 0, i__4 = ju - j - kv + 1; - j3 = std::max(i__3,i__4); - -/* Use DLASWP to apply the row interchanges to A12, A22, and */ -/* A32. */ - - i__3 = *ldab - 1; - dlaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, & - c__1, &jb, &ipiv[j], &c__1); - -/* Adjust the pivot indices. */ - - i__3 = j + jb - 1; - for (i__ = j; i__ <= i__3; ++i__) { - ipiv[i__] = ipiv[i__] + j - 1; -/* L90: */ - } - -/* Apply the row interchanges to A13, A23, and A33 */ -/* columnwise. */ - - k2 = j - 1 + jb + j2; - i__3 = j3; - for (i__ = 1; i__ <= i__3; ++i__) { - jj = k2 + i__; - i__4 = j + jb - 1; - for (ii = j + i__ - 1; ii <= i__4; ++ii) { - ip = ipiv[ii]; - if (ip != ii) { - temp = ab[kv + 1 + ii - jj + jj * ab_dim1]; - ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 + - ip - jj + jj * ab_dim1]; - ab[kv + 1 + ip - jj + jj * ab_dim1] = temp; - } -/* L100: */ - } -/* L110: */ - } - -/* Update the relevant part of the trailing submatrix */ - - if (j2 > 0) { - -/* Update A12 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2, - &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv - + 1 - jb + (j + jb) * ab_dim1], &i__4); - - if (i2 > 0) { - -/* Update A22 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - i__5 = *ldab - 1; - dgemm_("No transpose", "No transpose", &i2, &j2, &jb, - &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3, - &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4, - &c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], & - i__5); - } - - if (i3 > 0) { - -/* Update A32 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dgemm_("No transpose", "No transpose", &i3, &j2, &jb, - &c_b18, work31, &c__65, &ab[kv + 1 - jb + (j - + jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl - + 1 - jb + (j + jb) * ab_dim1], &i__4); - } - } - - if (j3 > 0) { - -/* Copy the lower triangle of A13 into the work array */ -/* WORK13 */ - - i__3 = j3; - for (jj = 1; jj <= i__3; ++jj) { - i__4 = jb; - for (ii = jj; ii <= i__4; ++ii) { - work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj - + j + kv - 1) * ab_dim1]; -/* L120: */ - } -/* L130: */ - } - -/* Update A13 in the work array */ - - i__3 = *ldab - 1; - dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3, - &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13, - &c__65); - - if (i2 > 0) { - -/* Update A23 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dgemm_("No transpose", "No transpose", &i2, &j3, &jb, - &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3, - work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv) - * ab_dim1], &i__4); - } - - if (i3 > 0) { - -/* Update A33 */ - - i__3 = *ldab - 1; - dgemm_("No transpose", "No transpose", &i3, &j3, &jb, - &c_b18, work31, &c__65, work13, &c__65, & - c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], & - i__3); - } - -/* Copy the lower triangle of A13 back into place */ - - i__3 = j3; - for (jj = 1; jj <= i__3; ++jj) { - i__4 = jb; - for (ii = jj; ii <= i__4; ++ii) { - ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] = - work13[ii + jj * 65 - 66]; -/* L140: */ - } -/* L150: */ - } - } - } else { - -/* Adjust the pivot indices. */ - - i__3 = j + jb - 1; - for (i__ = j; i__ <= i__3; ++i__) { - ipiv[i__] = ipiv[i__] + j - 1; -/* L160: */ - } - } - -/* Partially undo the interchanges in the current block to */ -/* restore the upper triangular form of A31 and copy the upper */ -/* triangle of A31 back into place */ - - i__3 = j; - for (jj = j + jb - 1; jj >= i__3; --jj) { - jp = ipiv[jj] - jj + 1; - if (jp != 1) { - -/* Apply interchange to columns J to JJ-1 */ - - if (jp + jj - 1 < j + *kl) { - -/* The interchange does not affect A31 */ - - i__4 = jj - j; - i__5 = *ldab - 1; - i__6 = *ldab - 1; - dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], & - i__5, &ab[kv + jp + jj - j + j * ab_dim1], & - i__6); - } else { - -/* The interchange does affect A31 */ - - i__4 = jj - j; - i__5 = *ldab - 1; - dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], & - i__5, &work31[jp + jj - j - *kl - 1], &c__65); - } - } - -/* Copy the current column of A31 back into place */ - -/* Computing MIN */ - i__4 = i3, i__5 = jj - j + 1; - nw = std::min(i__4,i__5); - if (nw > 0) { - dcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[ - kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1); - } -/* L170: */ - } -/* L180: */ - } - } - - return 0; - -/* End of DGBTRF */ - -} /* dgbtrf_ */ diff --git a/external/clapack/lapack/dgbtrs.cpp b/external/clapack/lapack/dgbtrs.cpp deleted file mode 100644 index d82d6311..00000000 --- a/external/clapack/lapack/dgbtrs.cpp +++ /dev/null @@ -1,221 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b7 = -1.; -static integer c__1 = 1; -static double c_b23 = 1.; - -/* Subroutine */ int dgbtrs_(const char *trans, integer *n, integer *kl, integer * - ku, integer *nrhs, double *ab, integer *ldab, integer *ipiv, - double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, kd, lm; - bool lnoti; - bool notran; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBTRS solves a system of linear equations */ -/* A * X = B or A' * X = B */ -/* with a general band matrix A using the LU factorization computed */ -/* by DGBTRF. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations. */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A'* X = B (Transpose) */ -/* = 'C': A'* X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* Details of the LU factorization of the band matrix A, as */ -/* computed by DGBTRF. U is stored as an upper triangular band */ -/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ -/* the multipliers used during the factorization are stored in */ -/* rows KL+KU+2 to 2*KL+KU+1. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices; for 1 <= i <= N, row i of the matrix was */ -/* interchanged with row IPIV(i). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T") && ! lsame_( - trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*ldab < (*kl << 1) + *ku + 1) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - kd = *ku + *kl + 1; - lnoti = *kl > 0; - - if (notran) { - -/* Solve A*X = B. */ - -/* Solve L*X = B, overwriting B with X. */ - -/* L is represented as a product of permutations and unit lower */ -/* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), */ -/* where each transformation L(i) is a rank-one modification of */ -/* the identity matrix. */ - - if (lnoti) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *kl, i__3 = *n - j; - lm = std::min(i__2,i__3); - l = ipiv[j]; - if (l != j) { - dswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); - } - dger_(&lm, nrhs, &c_b7, &ab[kd + 1 + j * ab_dim1], &c__1, &b[ - j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb); -/* L10: */ - } - } - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Solve U*X = B, overwriting B with X. */ - - i__2 = *kl + *ku; - dtbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[ - ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1); -/* L20: */ - } - - } else { - -/* Solve A'*X = B. */ - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Solve U'*X = B, overwriting B with X. */ - - i__2 = *kl + *ku; - dtbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset], - ldab, &b[i__ * b_dim1 + 1], &c__1); -/* L30: */ - } - -/* Solve L'*X = B, overwriting B with X. */ - - if (lnoti) { - for (j = *n - 1; j >= 1; --j) { -/* Computing MIN */ - i__1 = *kl, i__2 = *n - j; - lm = std::min(i__1,i__2); - dgemv_("Transpose", &lm, nrhs, &c_b7, &b[j + 1 + b_dim1], ldb, - &ab[kd + 1 + j * ab_dim1], &c__1, &c_b23, &b[j + - b_dim1], ldb); - l = ipiv[j]; - if (l != j) { - dswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); - } -/* L40: */ - } - } - } - return 0; - -/* End of DGBTRS */ - -} /* dgbtrs_ */ diff --git a/external/clapack/lapack/dgebak.cpp b/external/clapack/lapack/dgebak.cpp deleted file mode 100644 index 50ff122a..00000000 --- a/external/clapack/lapack/dgebak.cpp +++ /dev/null @@ -1,219 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgebak_(const char *job, const char *side, integer *n, integer *ilo, - integer *ihi, double *scale, integer *m, double *v, integer * - ldv, integer *info) -{ - /* System generated locals */ - integer v_dim1, v_offset, i__1; - - /* Local variables */ - integer i__, k; - double s; - integer ii; - bool leftv; - bool rightv; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEBAK forms the right or left eigenvectors of a real general matrix */ -/* by backward transformation on the computed eigenvectors of the */ -/* balanced matrix output by DGEBAL. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* Specifies the type of backward transformation required: */ -/* = 'N', do nothing, return immediately; */ -/* = 'P', do backward transformation for permutation only; */ -/* = 'S', do backward transformation for scaling only; */ -/* = 'B', do backward transformations for both permutation and */ -/* scaling. */ -/* JOB must be the same as the argument JOB supplied to DGEBAL. */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'R': V contains right eigenvectors; */ -/* = 'L': V contains left eigenvectors. */ - -/* N (input) INTEGER */ -/* The number of rows of the matrix V. N >= 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* The integers ILO and IHI determined by DGEBAL. */ -/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ - -/* SCALE (input) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutation and scaling factors, as returned */ -/* by DGEBAL. */ - -/* M (input) INTEGER */ -/* The number of columns of the matrix V. M >= 0. */ - -/* V (input/output) DOUBLE PRECISION array, dimension (LDV,M) */ -/* On entry, the matrix of right or left eigenvectors to be */ -/* transformed, as returned by DHSEIN or DTREVC. */ -/* On exit, V is overwritten by the transformed eigenvectors. */ - -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. LDV >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and Test the input parameters */ - - /* Parameter adjustments */ - --scale; - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - - /* Function Body */ - rightv = lsame_(side, "R"); - leftv = lsame_(side, "L"); - - *info = 0; - if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") - && ! lsame_(job, "B")) { - *info = -1; - } else if (! rightv && ! leftv) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ilo < 1 || *ilo > std::max(1_integer,*n)) { - *info = -4; - } else if (*ihi < std::min(*ilo,*n) || *ihi > *n) { - *info = -5; - } else if (*m < 0) { - *info = -7; - } else if (*ldv < std::max(1_integer,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEBAK", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - if (*m == 0) { - return 0; - } - if (lsame_(job, "N")) { - return 0; - } - - if (*ilo == *ihi) { - goto L30; - } - -/* Backward balance */ - - if (lsame_(job, "S") || lsame_(job, "B")) { - - if (rightv) { - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - s = scale[i__]; - dscal_(m, &s, &v[i__ + v_dim1], ldv); -/* L10: */ - } - } - - if (leftv) { - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - s = 1. / scale[i__]; - dscal_(m, &s, &v[i__ + v_dim1], ldv); -/* L20: */ - } - } - - } - -/* Backward permutation */ - -/* For I = ILO-1 step -1 until 1, */ -/* IHI+1 step 1 until N do -- */ - -L30: - if (lsame_(job, "P") || lsame_(job, "B")) { - if (rightv) { - i__1 = *n; - for (ii = 1; ii <= i__1; ++ii) { - i__ = ii; - if (i__ >= *ilo && i__ <= *ihi) { - goto L40; - } - if (i__ < *ilo) { - i__ = *ilo - ii; - } - k = (integer) scale[i__]; - if (k == i__) { - goto L40; - } - dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); -L40: - ; - } - } - - if (leftv) { - i__1 = *n; - for (ii = 1; ii <= i__1; ++ii) { - i__ = ii; - if (i__ >= *ilo && i__ <= *ihi) { - goto L50; - } - if (i__ < *ilo) { - i__ = *ilo - ii; - } - k = (integer) scale[i__]; - if (k == i__) { - goto L50; - } - dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); -L50: - ; - } - } - } - - return 0; - -/* End of DGEBAK */ - -} /* dgebak_ */ diff --git a/external/clapack/lapack/dgebal.cpp b/external/clapack/lapack/dgebal.cpp deleted file mode 100644 index a51d30e0..00000000 --- a/external/clapack/lapack/dgebal.cpp +++ /dev/null @@ -1,382 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgebal_(const char *job, integer *n, double *a, integer * - lda, integer *ilo, integer *ihi, double *scale, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - double c__, f, g; - integer i__, j, k, l, m; - double r__, s, ca, ra; - integer ica, ira, iexc; - double sfmin1, sfmin2, sfmax1, sfmax2; - bool noconv; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEBAL balances a general real matrix A. This involves, first, */ -/* permuting A by a similarity transformation to isolate eigenvalues */ -/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */ -/* diagonal; and second, applying a diagonal similarity transformation */ -/* to rows and columns ILO to IHI to make the rows and columns as */ -/* close in norm as possible. Both steps are optional. */ - -/* Balancing may reduce the 1-norm of the matrix, and improve the */ -/* accuracy of the computed eigenvalues and/or eigenvectors. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* Specifies the operations to be performed on A: */ -/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */ -/* for i = 1,...,N; */ -/* = 'P': permute only; */ -/* = 'S': scale only; */ -/* = 'B': both permute and scale. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the input matrix A. */ -/* On exit, A is overwritten by the balanced matrix. */ -/* If JOB = 'N', A is not referenced. */ -/* See Further Details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* ILO (output) INTEGER */ -/* IHI (output) INTEGER */ -/* ILO and IHI are set to integers such that on exit */ -/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */ -/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */ - -/* SCALE (output) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutations and scaling factors applied to */ -/* A. If P(j) is the index of the row and column interchanged */ -/* with row and column j and D(j) is the scaling factor */ -/* applied to row and column j, then */ -/* SCALE(j) = P(j) for j = 1,...,ILO-1 */ -/* = D(j) for j = ILO,...,IHI */ -/* = P(j) for j = IHI+1,...,N. */ -/* The order in which the interchanges are made is N to IHI+1, */ -/* then 1 to ILO-1. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* The permutations consist of row and column interchanges which put */ -/* the matrix in the form */ - -/* ( T1 X Y ) */ -/* P A P = ( 0 B Z ) */ -/* ( 0 0 T2 ) */ - -/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */ -/* along the diagonal. The column indices ILO and IHI mark the starting */ -/* and ending columns of the submatrix B. Balancing consists of applying */ -/* a diagonal similarity transformation inv(D) * B * D to make the */ -/* 1-norms of each row of B and its corresponding column nearly equal. */ -/* The output matrix is */ - -/* ( T1 X*D Y ) */ -/* ( 0 inv(D)*B*D inv(D)*Z ). */ -/* ( 0 0 T2 ) */ - -/* Information about the permutations P and the diagonal matrix D is */ -/* returned in the vector SCALE. */ - -/* This subroutine is based on the EISPACK routine BALANC. */ - -/* Modified by Tzu-Yi Chen, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --scale; - - /* Function Body */ - *info = 0; - if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") - && ! lsame_(job, "B")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEBAL", &i__1); - return 0; - } - - k = 1; - l = *n; - - if (*n == 0) { - goto L210; - } - - if (lsame_(job, "N")) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - scale[i__] = 1.; -/* L10: */ - } - goto L210; - } - - if (lsame_(job, "S")) { - goto L120; - } - -/* Permutation to isolate eigenvalues if possible */ - - goto L50; - -/* Row and column exchange. */ - -L20: - scale[m] = (double) j; - if (j == m) { - goto L30; - } - - dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1); - i__1 = *n - k + 1; - dswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda); - -L30: - switch (iexc) { - case 1: goto L40; - case 2: goto L80; - } - -/* Search for rows isolating an eigenvalue and push them down. */ - -L40: - if (l == 1) { - goto L210; - } - --l; - -L50: - for (j = l; j >= 1; --j) { - - i__1 = l; - for (i__ = 1; i__ <= i__1; ++i__) { - if (i__ == j) { - goto L60; - } - if (a[j + i__ * a_dim1] != 0.) { - goto L70; - } -L60: - ; - } - - m = l; - iexc = 1; - goto L20; -L70: - ; - } - - goto L90; - -/* Search for columns isolating an eigenvalue and push them left. */ - -L80: - ++k; - -L90: - i__1 = l; - for (j = k; j <= i__1; ++j) { - - i__2 = l; - for (i__ = k; i__ <= i__2; ++i__) { - if (i__ == j) { - goto L100; - } - if (a[i__ + j * a_dim1] != 0.) { - goto L110; - } -L100: - ; - } - - m = k; - iexc = 2; - goto L20; -L110: - ; - } - -L120: - i__1 = l; - for (i__ = k; i__ <= i__1; ++i__) { - scale[i__] = 1.; -/* L130: */ - } - - if (lsame_(job, "P")) { - goto L210; - } - -/* Balance the submatrix in rows K to L. */ - -/* Iterative loop for norm reduction */ - - sfmin1 = dlamch_("S") / dlamch_("P"); - sfmax1 = 1. / sfmin1; - sfmin2 = sfmin1 * 2.; - sfmax2 = 1. / sfmin2; -L140: - noconv = false; - - i__1 = l; - for (i__ = k; i__ <= i__1; ++i__) { - c__ = 0.; - r__ = 0.; - - i__2 = l; - for (j = k; j <= i__2; ++j) { - if (j == i__) { - goto L150; - } - c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1)); - r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -L150: - ; - } - ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1); - ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1)); - i__2 = *n - k + 1; - ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda); - ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1)); - -/* Guard against zero C or R due to underflow. */ - - if (c__ == 0. || r__ == 0.) { - goto L200; - } - g = r__ / 2.; - f = 1.; - s = c__ + r__; -L160: -/* Computing MAX */ - d__1 = std::max(f,c__); -/* Computing MIN */ - d__2 = std::min(r__,g); - if (c__ >= g || std::max(d__1,ca) >= sfmax2 || std::min(d__2,ra) <= sfmin2) { - goto L170; - } - f *= 2.; - c__ *= 2.; - ca *= 2.; - r__ /= 2.; - g /= 2.; - ra /= 2.; - goto L160; - -L170: - g = c__ / 2.; -L180: -/* Computing MIN */ - d__1 = std::min(f,c__), d__1 = std::min(d__1,g); - if (g < r__ || std::max(r__,ra) >= sfmax2 || std::min(d__1,ca) <= sfmin2) { - goto L190; - } - f /= 2.; - c__ /= 2.; - g /= 2.; - ca /= 2.; - r__ *= 2.; - ra *= 2.; - goto L180; - -/* Now balance. */ - -L190: - if (c__ + r__ >= s * .95) { - goto L200; - } - if (f < 1. && scale[i__] < 1.) { - if (f * scale[i__] <= sfmin1) { - goto L200; - } - } - if (f > 1. && scale[i__] > 1.) { - if (scale[i__] >= sfmax1 / f) { - goto L200; - } - } - g = 1. / f; - scale[i__] *= f; - noconv = true; - - i__2 = *n - k + 1; - dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda); - dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1); - -L200: - ; - } - - if (noconv) { - goto L140; - } - -L210: - *ilo = k; - *ihi = l; - - return 0; - -/* End of DGEBAL */ - -} /* dgebal_ */ diff --git a/external/clapack/lapack/dgebd2.cpp b/external/clapack/lapack/dgebd2.cpp deleted file mode 100644 index 114e2ca5..00000000 --- a/external/clapack/lapack/dgebd2.cpp +++ /dev/null @@ -1,287 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgebd2_(integer *m, integer *n, double *a, integer * - lda, double *d__, double *e, double *tauq, double * - taup, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEBD2 reduces a real general m by n matrix A to upper or lower */ -/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */ - -/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows in the matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns in the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the m by n general matrix to be reduced. */ -/* On exit, */ -/* if m >= n, the diagonal and the first superdiagonal are */ -/* overwritten with the upper bidiagonal matrix B; the */ -/* elements below the diagonal, with the array TAUQ, represent */ -/* the orthogonal matrix Q as a product of elementary */ -/* reflectors, and the elements above the first superdiagonal, */ -/* with the array TAUP, represent the orthogonal matrix P as */ -/* a product of elementary reflectors; */ -/* if m < n, the diagonal and the first subdiagonal are */ -/* overwritten with the lower bidiagonal matrix B; the */ -/* elements below the first subdiagonal, with the array TAUQ, */ -/* represent the orthogonal matrix Q as a product of */ -/* elementary reflectors, and the elements above the diagonal, */ -/* with the array TAUP, represent the orthogonal matrix P as */ -/* a product of elementary reflectors. */ -/* See Further Details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The diagonal elements of the bidiagonal matrix B: */ -/* D(i) = A(i,i). */ - -/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */ -/* The off-diagonal elements of the bidiagonal matrix B: */ -/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */ -/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */ - -/* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Q. See Further Details. */ - -/* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix P. See Further Details. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* The matrices Q and P are represented as products of elementary */ -/* reflectors: */ - -/* If m >= n, */ - -/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */ - -/* Each H(i) and G(i) has the form: */ - -/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ - -/* where tauq and taup are real scalars, and v and u are real vectors; */ -/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */ -/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */ -/* tauq is stored in TAUQ(i) and taup in TAUP(i). */ - -/* If m < n, */ - -/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */ - -/* Each H(i) and G(i) has the form: */ - -/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ - -/* where tauq and taup are real scalars, and v and u are real vectors; */ -/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */ -/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */ -/* tauq is stored in TAUQ(i) and taup in TAUP(i). */ - -/* The contents of A on exit are illustrated by the following examples: */ - -/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ - -/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */ -/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */ -/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */ -/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */ -/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */ -/* ( v1 v2 v3 v4 v5 ) */ - -/* where d and e denote diagonal and off-diagonal elements of B, vi */ -/* denotes an element of the vector defining H(i), and ui an element of */ -/* the vector defining G(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --d__; - --e; - --tauq; - --taup; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info < 0) { - i__1 = -(*info); - xerbla_("DGEBD2", &i__1); - return 0; - } - - if (*m >= *n) { - -/* Reduce to upper bidiagonal form */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ - - i__2 = *m - i__ + 1; -/* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[std::min(i__3, *m)+ i__ * - a_dim1], &c__1, &tauq[i__]); - d__[i__] = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - -/* Apply H(i) to A(i:m,i+1:n) from the left */ - - if (i__ < *n) { - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & - tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1] -); - } - a[i__ + i__ * a_dim1] = d__[i__]; - - if (i__ < *n) { - -/* Generate elementary reflector G(i) to annihilate */ -/* A(i,i+2:n) */ - - i__2 = *n - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + std::min( - i__3, *n)* a_dim1], lda, &taup[i__]); - e[i__] = a[i__ + (i__ + 1) * a_dim1]; - a[i__ + (i__ + 1) * a_dim1] = 1.; - -/* Apply G(i) to A(i+1:m,i+1:n) from the right */ - - i__2 = *m - i__; - i__3 = *n - i__; - dlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], - lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &work[1]); - a[i__ + (i__ + 1) * a_dim1] = e[i__]; - } else { - taup[i__] = 0.; - } -/* L10: */ - } - } else { - -/* Reduce to lower bidiagonal form */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */ - - i__2 = *n - i__ + 1; -/* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + std::min(i__3, *n)* - a_dim1], lda, &taup[i__]); - d__[i__] = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - -/* Apply G(i) to A(i+1:m,i:n) from the right */ - - if (i__ < *m) { - i__2 = *m - i__; - i__3 = *n - i__ + 1; - dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, & - taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); - } - a[i__ + i__ * a_dim1] = d__[i__]; - - if (i__ < *m) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(i+2:m,i) */ - - i__2 = *m - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *m)+ - i__ * a_dim1], &c__1, &tauq[i__]); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.; - -/* Apply H(i) to A(i+1:m,i+1:n) from the left */ - - i__2 = *m - i__; - i__3 = *n - i__; - dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], & - c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &work[1]); - a[i__ + 1 + i__ * a_dim1] = e[i__]; - } else { - tauq[i__] = 0.; - } -/* L20: */ - } - } - return 0; - -/* End of DGEBD2 */ - -} /* dgebd2_ */ diff --git a/external/clapack/lapack/dgebrd.cpp b/external/clapack/lapack/dgebrd.cpp deleted file mode 100644 index 8e579330..00000000 --- a/external/clapack/lapack/dgebrd.cpp +++ /dev/null @@ -1,313 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; -static double c_b21 = -1.; -static double c_b22 = 1.; - -/* Subroutine */ int dgebrd_(integer *m, integer *n, double *a, integer * - lda, double *d__, double *e, double *tauq, double * - taup, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, nb, nx; - double ws; - integer nbmin, iinfo, minmn; - integer ldwrkx, ldwrky, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEBRD reduces a general real M-by-N matrix A to upper or lower */ -/* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. */ - -/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows in the matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns in the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N general matrix to be reduced. */ -/* On exit, */ -/* if m >= n, the diagonal and the first superdiagonal are */ -/* overwritten with the upper bidiagonal matrix B; the */ -/* elements below the diagonal, with the array TAUQ, represent */ -/* the orthogonal matrix Q as a product of elementary */ -/* reflectors, and the elements above the first superdiagonal, */ -/* with the array TAUP, represent the orthogonal matrix P as */ -/* a product of elementary reflectors; */ -/* if m < n, the diagonal and the first subdiagonal are */ -/* overwritten with the lower bidiagonal matrix B; the */ -/* elements below the first subdiagonal, with the array TAUQ, */ -/* represent the orthogonal matrix Q as a product of */ -/* elementary reflectors, and the elements above the diagonal, */ -/* with the array TAUP, represent the orthogonal matrix P as */ -/* a product of elementary reflectors. */ -/* See Further Details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The diagonal elements of the bidiagonal matrix B: */ -/* D(i) = A(i,i). */ - -/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */ -/* The off-diagonal elements of the bidiagonal matrix B: */ -/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */ -/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */ - -/* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Q. See Further Details. */ - -/* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix P. See Further Details. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of the array WORK. LWORK >= max(1,M,N). */ -/* For optimum performance LWORK >= (M+N)*NB, where NB */ -/* is the optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* The matrices Q and P are represented as products of elementary */ -/* reflectors: */ - -/* If m >= n, */ - -/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */ - -/* Each H(i) and G(i) has the form: */ - -/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ - -/* where tauq and taup are real scalars, and v and u are real vectors; */ -/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */ -/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */ -/* tauq is stored in TAUQ(i) and taup in TAUP(i). */ - -/* If m < n, */ - -/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */ - -/* Each H(i) and G(i) has the form: */ - -/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ - -/* where tauq and taup are real scalars, and v and u are real vectors; */ -/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */ -/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */ -/* tauq is stored in TAUQ(i) and taup in TAUP(i). */ - -/* The contents of A on exit are illustrated by the following examples: */ - -/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ - -/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */ -/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */ -/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */ -/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */ -/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */ -/* ( v1 v2 v3 v4 v5 ) */ - -/* where d and e denote diagonal and off-diagonal elements of B, vi */ -/* denotes an element of the vector defining H(i), and ui an element of */ -/* the vector defining G(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --d__; - --e; - --tauq; - --taup; - --work; - - /* Function Body */ - *info = 0; -/* Computing MAX */ - i__1 = 1, i__2 = ilaenv_(&c__1, "DGEBRD", " ", m, n, &c_n1, &c_n1); - nb = std::max(i__1,i__2); - lwkopt = (*m + *n) * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = std::max(1_integer,*m); - if (*lwork < std::max(i__1,*n) && ! lquery) { - *info = -10; - } - } - if (*info < 0) { - i__1 = -(*info); - xerbla_("DGEBRD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - minmn = std::min(*m,*n); - if (minmn == 0) { - work[1] = 1.; - return 0; - } - - ws = (double) std::max(*m,*n); - ldwrkx = *m; - ldwrky = *n; - - if (nb > 1 && nb < minmn) { - -/* Set the crossover point NX. */ - -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, "DGEBRD", " ", m, n, &c_n1, &c_n1); - nx = std::max(i__1,i__2); - -/* Determine when to switch from blocked to unblocked code. */ - - if (nx < minmn) { - ws = (double) ((*m + *n) * nb); - if ((double) (*lwork) < ws) { - -/* Not enough work space for the optimal NB, consider using */ -/* a smaller block size. */ - - nbmin = ilaenv_(&c__2, "DGEBRD", " ", m, n, &c_n1, &c_n1); - if (*lwork >= (*m + *n) * nbmin) { - nb = *lwork / (*m + *n); - } else { - nb = 1; - nx = minmn; - } - } - } - } else { - nx = minmn; - } - - i__1 = minmn - nx; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - -/* Reduce rows and columns i:i+nb-1 to bidiagonal form and return */ -/* the matrices X and Y which are needed to update the unreduced */ -/* part of the matrix */ - - i__3 = *m - i__ + 1; - i__4 = *n - i__ + 1; - dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[ - i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx - * nb + 1], &ldwrky); - -/* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update */ -/* of the form A := A - V*Y' - X*U' */ - - i__3 = *m - i__ - nb + 1; - i__4 = *n - i__ - nb + 1; - dgemm_("No transpose", "Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__ - + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], & - ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda); - i__3 = *m - i__ - nb + 1; - i__4 = *n - i__ - nb + 1; - dgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &c_b21, & - work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, & - c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda); - -/* Copy diagonal and off-diagonal elements of B back into A */ - - if (*m >= *n) { - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j + j * a_dim1] = d__[j]; - a[j + (j + 1) * a_dim1] = e[j]; -/* L10: */ - } - } else { - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j + j * a_dim1] = d__[j]; - a[j + 1 + j * a_dim1] = e[j]; -/* L20: */ - } - } -/* L30: */ - } - -/* Use unblocked code to reduce the remainder of the matrix */ - - i__2 = *m - i__ + 1; - i__1 = *n - i__ + 1; - dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], & - tauq[i__], &taup[i__], &work[1], &iinfo); - work[1] = ws; - return 0; - -/* End of DGEBRD */ - -} /* dgebrd_ */ diff --git a/external/clapack/lapack/dgecon.cpp b/external/clapack/lapack/dgecon.cpp deleted file mode 100644 index 218bbabe..00000000 --- a/external/clapack/lapack/dgecon.cpp +++ /dev/null @@ -1,204 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgecon_(const char *norm, integer *n, double *a, integer * - lda, double *anorm, double *rcond, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - double d__1; - - /* Local variables */ - double sl; - integer ix; - double su; - integer kase, kase1; - double scale; - integer isave[3]; - double ainvnm; - bool onenrm; - char normin[1]; - double smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGECON estimates the reciprocal of the condition number of a general */ -/* real matrix A, in either the 1-norm or the infinity-norm, using */ -/* the LU factorization computed by DGETRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as */ -/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The factors L and U from the factorization A = P*L*U */ -/* as computed by DGETRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* ANORM (input) DOUBLE PRECISION */ -/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ -/* If NORM = 'I', the infinity-norm of the original matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); - if (! onenrm && ! lsame_(norm, "I")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else if (*anorm < 0.) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGECON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - - smlnum = dlamch_("Safe minimum"); - -/* Estimate the norm of inv(A). */ - - ainvnm = 0.; - *(unsigned char *)normin = 'N'; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kase = 0; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(L). */ - - dlatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], - lda, &work[1], &sl, &work[(*n << 1) + 1], info); - -/* Multiply by inv(U). */ - - dlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ - a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info); - } else { - -/* Multiply by inv(U'). */ - - dlatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset], - lda, &work[1], &su, &work[*n * 3 + 1], info); - -/* Multiply by inv(L'). */ - - dlatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset], - lda, &work[1], &sl, &work[(*n << 1) + 1], info); - } - -/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ - - scale = sl * su; - *(unsigned char *)normin = 'Y'; - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) - { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - -L20: - return 0; - -/* End of DGECON */ - -} /* dgecon_ */ diff --git a/external/clapack/lapack/dgeequ.cpp b/external/clapack/lapack/dgeequ.cpp deleted file mode 100644 index dd146f27..00000000 --- a/external/clapack/lapack/dgeequ.cpp +++ /dev/null @@ -1,282 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgeequ_(integer *m, integer *n, double *a, integer * - lda, double *r__, double *c__, double *rowcnd, double - *colcnd, double *amax, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j; - double rcmin, rcmax; - double bignum, smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEEQU computes row and column scalings intended to equilibrate an */ -/* M-by-N matrix A and reduce its condition number. R returns the row */ -/* scale factors and C the column scale factors, chosen to try to make */ -/* the largest element in each row and column of the matrix B with */ -/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ - -/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ -/* number and BIGNUM = largest safe number. Use of these scaling */ -/* factors is not guaranteed to reduce the condition number of A but */ -/* works well in practice. */ - -/* 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) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The M-by-N matrix whose equilibration factors are */ -/* to be computed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* R (output) DOUBLE PRECISION array, dimension (M) */ -/* If INFO = 0 or INFO > M, R contains the row scale factors */ -/* for A. */ - -/* C (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, C contains the column scale factors for A. */ - -/* ROWCND (output) DOUBLE PRECISION */ -/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ -/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ -/* AMAX is neither too large nor too small, it is not worth */ -/* scaling by R. */ - -/* COLCND (output) DOUBLE PRECISION */ -/* If INFO = 0, COLCND contains the ratio of the smallest */ -/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ -/* worth scaling by C. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= M: the i-th row of A is exactly zero */ -/* > M: the (i-M)-th column of A is exactly zero */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --r__; - --c__; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEEQU", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - *rowcnd = 1.; - *colcnd = 1.; - *amax = 0.; - return 0; - } - -/* Get machine constants. */ - - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - -/* Compute row scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - r__[i__] = 0.; -/* L10: */ - } - -/* Find the maximum element in each row. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = r__[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - r__[i__] = std::max(d__2,d__3); -/* L20: */ - } -/* L30: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[i__]; - rcmax = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[i__]; - rcmin = std::min(d__1,d__2); -/* L40: */ - } - *amax = rcmax; - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (r__[i__] == 0.) { - *info = i__; - return 0; - } -/* L50: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = r__[i__]; - d__1 = std::max(d__2,smlnum); - r__[i__] = 1. / std::min(d__1,bignum); -/* L60: */ - } - -/* Compute ROWCND = min(R(I)) / max(R(I)) */ - - *rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } - -/* Compute column scale factors */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - c__[j] = 0.; -/* L70: */ - } - -/* Find the maximum element in each column, */ -/* assuming the row scaling computed above. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = c__[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) * - r__[i__]; - c__[j] = std::max(d__2,d__3); -/* L80: */ - } -/* L90: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = std::max(d__1,d__2); -/* L100: */ - } - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (c__[j] == 0.) { - *info = *m + j; - return 0; - } -/* L110: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = c__[j]; - d__1 = std::max(d__2,smlnum); - c__[j] = 1. / std::min(d__1,bignum); -/* L120: */ - } - -/* Compute COLCND = min(C(J)) / max(C(J)) */ - - *colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } - - return 0; - -/* End of DGEEQU */ - -} /* dgeequ_ */ diff --git a/external/clapack/lapack/dgeequb.cpp b/external/clapack/lapack/dgeequb.cpp deleted file mode 100644 index 9a3aec51..00000000 --- a/external/clapack/lapack/dgeequb.cpp +++ /dev/null @@ -1,307 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgeequb_(integer *m, integer *n, double *a, integer * - lda, double *r__, double *c__, double *rowcnd, double - *colcnd, double *amax, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j; - double radix, rcmin, rcmax; - double bignum, logrdx, smlnum; - - -/* -- LAPACK routine (version 3.2) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEEQUB computes row and column scalings intended to equilibrate an */ -/* M-by-N matrix A and reduce its condition number. R returns the row */ -/* scale factors and C the column scale factors, chosen to try to make */ -/* the largest element in each row and column of the matrix B with */ -/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */ -/* the radix. */ - -/* R(i) and C(j) are restricted to be a power of the radix between */ -/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */ -/* of these scaling factors is not guaranteed to reduce the condition */ -/* number of A but works well in practice. */ - -/* This routine differs from DGEEQU by restricting the scaling factors */ -/* to a power of the radix. Baring over- and underflow, scaling by */ -/* these factors introduces no additional rounding errors. However, the */ -/* scaled entries' magnitured are no longer approximately 1 but lie */ -/* between sqrt(radix) and 1/sqrt(radix). */ - -/* 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) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The M-by-N matrix whose equilibration factors are */ -/* to be computed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* R (output) DOUBLE PRECISION array, dimension (M) */ -/* If INFO = 0 or INFO > M, R contains the row scale factors */ -/* for A. */ - -/* C (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, C contains the column scale factors for A. */ - -/* ROWCND (output) DOUBLE PRECISION */ -/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ -/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ -/* AMAX is neither too large nor too small, it is not worth */ -/* scaling by R. */ - -/* COLCND (output) DOUBLE PRECISION */ -/* If INFO = 0, COLCND contains the ratio of the smallest */ -/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ -/* worth scaling by C. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= M: the i-th row of A is exactly zero */ -/* > M: the (i-M)-th column of A is exactly zero */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --r__; - --c__; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEEQUB", &i__1); - return 0; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - *rowcnd = 1.; - *colcnd = 1.; - *amax = 0.; - return 0; - } - -/* Get machine constants. Assume SMLNUM is a power of the radix. */ - - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - radix = dlamch_("B"); - logrdx = log(radix); - -/* Compute row scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - r__[i__] = 0.; -/* L10: */ - } - -/* Find the maximum element in each row. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = r__[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - r__[i__] = std::max(d__2,d__3); -/* L20: */ - } -/* L30: */ - } - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (r__[i__] > 0.) { - i__2 = (integer) (log(r__[i__]) / logrdx); - r__[i__] = pow_di(&radix, &i__2); - } - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[i__]; - rcmax = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[i__]; - rcmin = std::min(d__1,d__2); -/* L40: */ - } - *amax = rcmax; - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (r__[i__] == 0.) { - *info = i__; - return 0; - } -/* L50: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = r__[i__]; - d__1 = std::max(d__2,smlnum); - r__[i__] = 1. / std::min(d__1,bignum); -/* L60: */ - } - -/* Compute ROWCND = min(R(I)) / max(R(I)). */ - - *rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } - -/* Compute column scale factors */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - c__[j] = 0.; -/* L70: */ - } - -/* Find the maximum element in each column, */ -/* assuming the row scaling computed above. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = c__[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) * - r__[i__]; - c__[j] = std::max(d__2,d__3); -/* L80: */ - } - if (c__[j] > 0.) { - i__2 = (integer) (log(c__[j]) / logrdx); - c__[j] = pow_di(&radix, &i__2); - } -/* L90: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = std::max(d__1,d__2); -/* L100: */ - } - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (c__[j] == 0.) { - *info = *m + j; - return 0; - } -/* L110: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = c__[j]; - d__1 = std::max(d__2,smlnum); - c__[j] = 1. / std::min(d__1,bignum); -/* L120: */ - } - -/* Compute COLCND = min(C(J)) / max(C(J)). */ - - *colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } - - return 0; - -/* End of DGEEQUB */ - -} /* dgeequb_ */ diff --git a/external/clapack/lapack/dgees.cpp b/external/clapack/lapack/dgees.cpp deleted file mode 100644 index 194b5a64..00000000 --- a/external/clapack/lapack/dgees.cpp +++ /dev/null @@ -1,508 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static integer c_n1 = -1; - -/* Subroutine */ int dgees_(const char *jobvs, const char *sort, bool (*select)(const double *, const double *), - integer *n, double *a, integer *lda, integer *sdim, double *wr, - double *wi, double *vs, integer *ldvs, double *work, - integer *lwork, bool *bwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3; - - /* Builtin functions - double sqrt(double);*/ - - /* Local variables */ - integer i__; - double s; - integer i1, i2, ip, ihi, ilo; - double dum[1], eps, sep; - integer ibal; - double anrm; - integer idum[1], ierr, itau, iwrk, inxt, icond, ieval; - bool cursl; - bool lst2sl, scalea; - double cscale; - double bignum; - bool lastsl; - integer minwrk, maxwrk; - double smlnum; - integer hswork; - bool wantst, lquery, wantvs; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ -/* .. Function Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEES computes for an N-by-N real nonsymmetric matrix A, the */ -/* eigenvalues, the real Schur form T, and, optionally, the matrix of */ -/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */ - -/* Optionally, it also orders the eigenvalues on the diagonal of the */ -/* real Schur form so that selected eigenvalues are at the top left. */ -/* The leading columns of Z then form an orthonormal basis for the */ -/* invariant subspace corresponding to the selected eigenvalues. */ - -/* A matrix is in real Schur form if it is upper quasi-triangular with */ -/* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the */ -/* form */ -/* [ a b ] */ -/* [ c a ] */ - -/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */ - -/* Arguments */ -/* ========= */ - -/* JOBVS (input) CHARACTER*1 */ -/* = 'N': Schur vectors are not computed; */ -/* = 'V': Schur vectors are computed. */ - -/* SORT (input) CHARACTER*1 */ -/* Specifies whether or not to order the eigenvalues on the */ -/* diagonal of the Schur form. */ -/* = 'N': Eigenvalues are not ordered; */ -/* = 'S': Eigenvalues are ordered (see SELECT). */ - -/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */ -/* SELECT must be declared EXTERNAL in the calling subroutine. */ -/* If SORT = 'S', SELECT is used to select eigenvalues to sort */ -/* to the top left of the Schur form. */ -/* If SORT = 'N', SELECT is not referenced. */ -/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */ -/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex */ -/* conjugate pair of eigenvalues is selected, then both complex */ -/* eigenvalues are selected. */ -/* Note that a selected complex eigenvalue may no longer */ -/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */ -/* ordering may change the value of complex eigenvalues */ -/* (especially if the eigenvalue is ill-conditioned); in this */ -/* case INFO is set to N+2 (see INFO below). */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the N-by-N matrix A. */ -/* On exit, A has been overwritten by its real Schur form T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* SDIM (output) INTEGER */ -/* If SORT = 'N', SDIM = 0. */ -/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ -/* for which SELECT is true. (Complex conjugate */ -/* pairs for which SELECT is true for either */ -/* eigenvalue count as 2.) */ - -/* WR (output) DOUBLE PRECISION array, dimension (N) */ -/* WI (output) DOUBLE PRECISION array, dimension (N) */ -/* WR and WI contain the real and imaginary parts, */ -/* respectively, of the computed eigenvalues in the same order */ -/* that they appear on the diagonal of the output Schur form T. */ -/* Complex conjugate pairs of eigenvalues will appear */ -/* consecutively with the eigenvalue having the positive */ -/* imaginary part first. */ - -/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */ -/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */ -/* vectors. */ -/* If JOBVS = 'N', VS is not referenced. */ - -/* LDVS (input) INTEGER */ -/* The leading dimension of the array VS. LDVS >= 1; if */ -/* JOBVS = 'V', LDVS >= N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,3*N). */ -/* For good performance, LWORK must generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* BWORK (workspace) LOGICAL array, dimension (N) */ -/* Not referenced if SORT = 'N'. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = i, and i is */ -/* <= N: the QR algorithm failed to compute all the */ -/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */ -/* contain those eigenvalues which have converged; if */ -/* JOBVS = 'V', VS contains the matrix which reduces A */ -/* to its partially converged Schur form. */ -/* = N+1: the eigenvalues could not be reordered because some */ -/* eigenvalues were too close to separate (the problem */ -/* is very ill-conditioned); */ -/* = N+2: after reordering, roundoff changed values of some */ -/* complex eigenvalues so that leading eigenvalues in */ -/* the Schur form no longer satisfy SELECT=.TRUE. This */ -/* could also be caused by underflow due to scaling. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --wr; - --wi; - vs_dim1 = *ldvs; - vs_offset = 1 + vs_dim1; - vs -= vs_offset; - --work; - --bwork; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - wantvs = lsame_(jobvs, "V"); - wantst = lsame_(sort, "S"); - if (! wantvs && ! lsame_(jobvs, "N")) { - *info = -1; - } else if (! wantst && ! lsame_(sort, "N")) { - *info = -2; - } else if (*n < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldvs < 1 || wantvs && *ldvs < *n) { - *info = -11; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV. */ -/* HSWORK refers to the workspace preferred by DHSEQR, as */ -/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ -/* the worst case.) */ - - if (*info == 0) { - if (*n == 0) { - minwrk = 1; - maxwrk = 1; - } else { - maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, - n, &c__0); - minwrk = *n * 3; - - dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1] -, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval); - hswork = (integer) work[1]; - - if (! wantvs) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + hswork; - maxwrk = std::max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, - "DORGHR", " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + hswork; - maxwrk = std::max(i__1,i__2); - } - } - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -13; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEES ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *sdim = 0; - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - smlnum = sqrt(smlnum) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, dum); - scalea = false; - if (anrm > 0. && anrm < smlnum) { - scalea = true; - cscale = smlnum; - } else if (anrm > bignum) { - scalea = true; - cscale = bignum; - } - if (scalea) { - dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & - ierr); - } - -/* Permute the matrix to make it more nearly triangular */ -/* (Workspace: need N) */ - - ibal = 1; - dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr); - -/* Reduce to upper Hessenberg form */ -/* (Workspace: need 3*N, prefer 2*N+N*NB) */ - - itau = *n + ibal; - iwrk = *n + itau; - i__1 = *lwork - iwrk + 1; - dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, - &ierr); - - if (wantvs) { - -/* Copy Householder vectors to VS */ - - dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs) - ; - -/* Generate orthogonal matrix in VS */ -/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ - - i__1 = *lwork - iwrk + 1; - dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk], - &i__1, &ierr); - } - - *sdim = 0; - -/* Perform QR iteration, accumulating Schur vectors in VS if desired */ -/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ - - iwrk = itau; - i__1 = *lwork - iwrk + 1; - dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[ - vs_offset], ldvs, &work[iwrk], &i__1, &ieval); - if (ieval > 0) { - *info = ieval; - } - -/* Sort eigenvalues if desired */ - - if (wantst && *info == 0) { - if (scalea) { - dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, & - ierr); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, & - ierr); - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - bwork[i__] = (*select)(&wr[i__], &wi[i__]); -/* L10: */ - } - -/* Reorder eigenvalues and transform Schur vectors */ -/* (Workspace: none needed) */ - - i__1 = *lwork - iwrk + 1; - dtrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset], - ldvs, &wr[1], &wi[1], sdim, &s, &sep, &work[iwrk], &i__1, - idum, &c__1, &icond); - if (icond > 0) { - *info = *n + icond; - } - } - - if (wantvs) { - -/* Undo balancing */ -/* (Workspace: need N) */ - - dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs, - &ierr); - } - - if (scalea) { - -/* Undo scaling for the Schur form of A */ - - dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, & - ierr); - i__1 = *lda + 1; - dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1); - if (cscale == smlnum) { - -/* If scaling back towards underflow, adjust WI if an */ -/* offdiagonal element of a 2-by-2 block in the Schur form */ -/* underflows. */ - - if (ieval > 0) { - i1 = ieval + 1; - i2 = ihi - 1; - i__1 = ilo - 1; -/* Computing MAX */ - i__3 = ilo - 1; - i__2 = std::max(i__3,1_integer); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ - 1], &i__2, &ierr); - } else if (wantst) { - i1 = 1; - i2 = *n - 1; - } else { - i1 = ilo; - i2 = ihi - 1; - } - inxt = i1 - 1; - i__1 = i2; - for (i__ = i1; i__ <= i__1; ++i__) { - if (i__ < inxt) { - goto L20; - } - if (wi[i__] == 0.) { - inxt = i__ + 1; - } else { - if (a[i__ + 1 + i__ * a_dim1] == 0.) { - wi[i__] = 0.; - wi[i__ + 1] = 0.; - } else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + ( - i__ + 1) * a_dim1] == 0.) { - wi[i__] = 0.; - wi[i__ + 1] = 0.; - if (i__ > 1) { - i__2 = i__ - 1; - dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[( - i__ + 1) * a_dim1 + 1], &c__1); - } - if (*n > i__ + 1) { - i__2 = *n - i__ - 1; - dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, & - a[i__ + 1 + (i__ + 2) * a_dim1], lda); - } - if (wantvs) { - dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ - + 1) * vs_dim1 + 1], &c__1); - } - a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ * - a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 0.; - } - inxt = i__ + 2; - } -L20: - ; - } - } - -/* Undo scaling for the imaginary part of the eigenvalues */ - - i__1 = *n - ieval; -/* Computing MAX */ - i__3 = *n - ieval; - i__2 = std::max(i__3,1_integer); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval + - 1], &i__2, &ierr); - } - - if (wantst && *info == 0) { - -/* Check if reordering successful */ - - lastsl = true; - lst2sl = true; - *sdim = 0; - ip = 0; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - cursl = (*select)(&wr[i__], &wi[i__]); - if (wi[i__] == 0.) { - if (cursl) { - ++(*sdim); - } - ip = 0; - if (cursl && ! lastsl) { - *info = *n + 2; - } - } else { - if (ip == 1) { - -/* Last eigenvalue of conjugate pair */ - - cursl = cursl || lastsl; - lastsl = cursl; - if (cursl) { - *sdim += 2; - } - ip = -1; - if (cursl && ! lst2sl) { - *info = *n + 2; - } - } else { - -/* First eigenvalue of conjugate pair */ - - ip = 1; - } - } - lst2sl = lastsl; - lastsl = cursl; -/* L30: */ - } - } - - work[1] = (double) maxwrk; - return 0; - -/* End of DGEES */ - -} /* dgees_ */ diff --git a/external/clapack/lapack/dgeesx.cpp b/external/clapack/lapack/dgeesx.cpp deleted file mode 100644 index b192a228..00000000 --- a/external/clapack/lapack/dgeesx.cpp +++ /dev/null @@ -1,604 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static integer c_n1 = -1; - -/* Subroutine */ int dgeesx_(const char *jobvs, const char *sort, bool (*select)(const double *, const double *), - const char *sense, integer *n, double *a, integer *lda, integer *sdim, - double *wr, double *wi, double *vs, integer *ldvs, - double *rconde, double *rcondv, double *work, integer * - lwork, integer *iwork, integer *liwork, bool *bwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, i1, i2, ip, ihi, ilo; - double dum[1], eps; - integer ibal; - double anrm; - integer ierr, itau, iwrk, lwrk, inxt, icond, ieval; - bool cursl; - integer liwrk; - bool lst2sl, scalea; - double cscale; - double bignum; - bool wantsb; - bool wantse, lastsl; - integer minwrk, maxwrk; - bool wantsn; - double smlnum; - integer hswork; - bool wantst, lquery, wantsv, wantvs; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ -/* .. Function Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEESX computes for an N-by-N real nonsymmetric matrix A, the */ -/* eigenvalues, the real Schur form T, and, optionally, the matrix of */ -/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */ - -/* Optionally, it also orders the eigenvalues on the diagonal of the */ -/* real Schur form so that selected eigenvalues are at the top left; */ -/* computes a reciprocal condition number for the average of the */ -/* selected eigenvalues (RCONDE); and computes a reciprocal condition */ -/* number for the right invariant subspace corresponding to the */ -/* selected eigenvalues (RCONDV). The leading columns of Z form an */ -/* orthonormal basis for this invariant subspace. */ - -/* For further explanation of the reciprocal condition numbers RCONDE */ -/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */ -/* these quantities are called s and sep respectively). */ - -/* A real matrix is in real Schur form if it is upper quasi-triangular */ -/* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in */ -/* the form */ -/* [ a b ] */ -/* [ c a ] */ - -/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */ - -/* Arguments */ -/* ========= */ - -/* JOBVS (input) CHARACTER*1 */ -/* = 'N': Schur vectors are not computed; */ -/* = 'V': Schur vectors are computed. */ - -/* SORT (input) CHARACTER*1 */ -/* Specifies whether or not to order the eigenvalues on the */ -/* diagonal of the Schur form. */ -/* = 'N': Eigenvalues are not ordered; */ -/* = 'S': Eigenvalues are ordered (see SELECT). */ - -/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */ -/* SELECT must be declared EXTERNAL in the calling subroutine. */ -/* If SORT = 'S', SELECT is used to select eigenvalues to sort */ -/* to the top left of the Schur form. */ -/* If SORT = 'N', SELECT is not referenced. */ -/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */ -/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a */ -/* complex conjugate pair of eigenvalues is selected, then both */ -/* are. Note that a selected complex eigenvalue may no longer */ -/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */ -/* ordering may change the value of complex eigenvalues */ -/* (especially if the eigenvalue is ill-conditioned); in this */ -/* case INFO may be set to N+3 (see INFO below). */ - -/* SENSE (input) CHARACTER*1 */ -/* Determines which reciprocal condition numbers are computed. */ -/* = 'N': None are computed; */ -/* = 'E': Computed for average of selected eigenvalues only; */ -/* = 'V': Computed for selected right invariant subspace only; */ -/* = 'B': Computed for both. */ -/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the N-by-N matrix A. */ -/* On exit, A is overwritten by its real Schur form T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* SDIM (output) INTEGER */ -/* If SORT = 'N', SDIM = 0. */ -/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ -/* for which SELECT is true. (Complex conjugate */ -/* pairs for which SELECT is true for either */ -/* eigenvalue count as 2.) */ - -/* WR (output) DOUBLE PRECISION array, dimension (N) */ -/* WI (output) DOUBLE PRECISION array, dimension (N) */ -/* WR and WI contain the real and imaginary parts, respectively, */ -/* of the computed eigenvalues, in the same order that they */ -/* appear on the diagonal of the output Schur form T. Complex */ -/* conjugate pairs of eigenvalues appear consecutively with the */ -/* eigenvalue having the positive imaginary part first. */ - -/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */ -/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */ -/* vectors. */ -/* If JOBVS = 'N', VS is not referenced. */ - -/* LDVS (input) INTEGER */ -/* The leading dimension of the array VS. LDVS >= 1, and if */ -/* JOBVS = 'V', LDVS >= N. */ - -/* RCONDE (output) DOUBLE PRECISION */ -/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */ -/* condition number for the average of the selected eigenvalues. */ -/* Not referenced if SENSE = 'N' or 'V'. */ - -/* RCONDV (output) DOUBLE PRECISION */ -/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */ -/* condition number for the selected right invariant subspace. */ -/* Not referenced if SENSE = 'N' or 'E'. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,3*N). */ -/* Also, if SENSE = 'E' or 'V' or 'B', */ -/* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of */ -/* selected eigenvalues computed by this routine. Note that */ -/* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only */ -/* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or */ -/* 'B' this may not be large enough. */ -/* For good performance, LWORK must generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates upper bounds on the optimal sizes of the */ -/* arrays WORK and IWORK, returns these values as the first */ -/* entries of the WORK and IWORK arrays, and no error messages */ -/* related to LWORK or LIWORK are issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). */ -/* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is */ -/* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this */ -/* may not be large enough. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates upper bounds on the optimal sizes of */ -/* the arrays WORK and IWORK, returns these values as the first */ -/* entries of the WORK and IWORK arrays, and no error messages */ -/* related to LWORK or LIWORK are issued by XERBLA. */ - -/* BWORK (workspace) LOGICAL array, dimension (N) */ -/* Not referenced if SORT = 'N'. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = i, and i is */ -/* <= N: the QR algorithm failed to compute all the */ -/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */ -/* contain those eigenvalues which have converged; if */ -/* JOBVS = 'V', VS contains the transformation which */ -/* reduces A to its partially converged Schur form. */ -/* = N+1: the eigenvalues could not be reordered because some */ -/* eigenvalues were too close to separate (the problem */ -/* is very ill-conditioned); */ -/* = N+2: after reordering, roundoff changed values of some */ -/* complex eigenvalues so that leading eigenvalues in */ -/* the Schur form no longer satisfy SELECT=.TRUE. This */ -/* could also be caused by underflow due to scaling. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --wr; - --wi; - vs_dim1 = *ldvs; - vs_offset = 1 + vs_dim1; - vs -= vs_offset; - --work; - --iwork; - --bwork; - - /* Function Body */ - *info = 0; - wantvs = lsame_(jobvs, "V"); - wantst = lsame_(sort, "S"); - wantsn = lsame_(sense, "N"); - wantse = lsame_(sense, "E"); - wantsv = lsame_(sense, "V"); - wantsb = lsame_(sense, "B"); - lquery = *lwork == -1 || *liwork == -1; - if (! wantvs && ! lsame_(jobvs, "N")) { - *info = -1; - } else if (! wantst && ! lsame_(sort, "N")) { - *info = -2; - } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && ! - wantsn) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldvs < 1 || wantvs && *ldvs < *n) { - *info = -12; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "RWorkspace:" describe the */ -/* minimal amount of real workspace needed at that point in the */ -/* code, as well as the preferred amount for good performance. */ -/* IWorkspace refers to integer workspace. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV. */ -/* HSWORK refers to the workspace preferred by DHSEQR, as */ -/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ -/* the worst case. */ -/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */ -/* depends on SDIM, which is computed by the routine DTRSEN later */ -/* in the code.) */ - - if (*info == 0) { - liwrk = 1; - if (*n == 0) { - minwrk = 1; - lwrk = 1; - } else { - maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, - n, &c__0); - minwrk = *n * 3; - - dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1] -, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval); - hswork = (integer) work[1]; - - if (! wantvs) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + hswork; - maxwrk = std::max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, - "DORGHR", " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + hswork; - maxwrk = std::max(i__1,i__2); - } - lwrk = maxwrk; - if (! wantsn) { -/* Computing MAX */ - i__1 = lwrk, i__2 = *n + *n * *n / 2; - lwrk = std::max(i__1,i__2); - } - if (wantsv || wantsb) { - liwrk = *n * *n / 4; - } - } - iwork[1] = liwrk; - work[1] = (double) lwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -16; - } else if (*liwork < 1 && ! lquery) { - *info = -18; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEESX", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *sdim = 0; - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - smlnum = sqrt(smlnum) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, dum); - scalea = false; - if (anrm > 0. && anrm < smlnum) { - scalea = true; - cscale = smlnum; - } else if (anrm > bignum) { - scalea = true; - cscale = bignum; - } - if (scalea) { - dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & - ierr); - } - -/* Permute the matrix to make it more nearly triangular */ -/* (RWorkspace: need N) */ - - ibal = 1; - dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr); - -/* Reduce to upper Hessenberg form */ -/* (RWorkspace: need 3*N, prefer 2*N+N*NB) */ - - itau = *n + ibal; - iwrk = *n + itau; - i__1 = *lwork - iwrk + 1; - dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, - &ierr); - - if (wantvs) { - -/* Copy Householder vectors to VS */ - - dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs) - ; - -/* Generate orthogonal matrix in VS */ -/* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ - - i__1 = *lwork - iwrk + 1; - dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk], - &i__1, &ierr); - } - - *sdim = 0; - -/* Perform QR iteration, accumulating Schur vectors in VS if desired */ -/* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) */ - - iwrk = itau; - i__1 = *lwork - iwrk + 1; - dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[ - vs_offset], ldvs, &work[iwrk], &i__1, &ieval); - if (ieval > 0) { - *info = ieval; - } - -/* Sort eigenvalues if desired */ - - if (wantst && *info == 0) { - if (scalea) { - dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, & - ierr); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, & - ierr); - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - bwork[i__] = (*select)(&wr[i__], &wi[i__]); -/* L10: */ - } - -/* Reorder eigenvalues, transform Schur vectors, and compute */ -/* reciprocal condition numbers */ -/* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) */ -/* otherwise, need N ) */ -/* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) */ -/* otherwise, need 0 ) */ - - i__1 = *lwork - iwrk + 1; - dtrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset], - ldvs, &wr[1], &wi[1], sdim, rconde, rcondv, &work[iwrk], & - i__1, &iwork[1], liwork, &icond); - if (! wantsn) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + (*sdim << 1) * (*n - *sdim); - maxwrk = std::max(i__1,i__2); - } - if (icond == -15) { - -/* Not enough real workspace */ - - *info = -16; - } else if (icond == -17) { - -/* Not enough integer workspace */ - - *info = -18; - } else if (icond > 0) { - -/* DTRSEN failed to reorder or to restore standard Schur form */ - - *info = icond + *n; - } - } - - if (wantvs) { - -/* Undo balancing */ -/* (RWorkspace: need N) */ - - dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs, - &ierr); - } - - if (scalea) { - -/* Undo scaling for the Schur form of A */ - - dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, & - ierr); - i__1 = *lda + 1; - dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1); - if ((wantsv || wantsb) && *info == 0) { - dum[0] = *rcondv; - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, & - c__1, &ierr); - *rcondv = dum[0]; - } - if (cscale == smlnum) { - -/* If scaling back towards underflow, adjust WI if an */ -/* offdiagonal element of a 2-by-2 block in the Schur form */ -/* underflows. */ - - if (ieval > 0) { - i1 = ieval + 1; - i2 = ihi - 1; - i__1 = ilo - 1; - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ - 1], n, &ierr); - } else if (wantst) { - i1 = 1; - i2 = *n - 1; - } else { - i1 = ilo; - i2 = ihi - 1; - } - inxt = i1 - 1; - i__1 = i2; - for (i__ = i1; i__ <= i__1; ++i__) { - if (i__ < inxt) { - goto L20; - } - if (wi[i__] == 0.) { - inxt = i__ + 1; - } else { - if (a[i__ + 1 + i__ * a_dim1] == 0.) { - wi[i__] = 0.; - wi[i__ + 1] = 0.; - } else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + ( - i__ + 1) * a_dim1] == 0.) { - wi[i__] = 0.; - wi[i__ + 1] = 0.; - if (i__ > 1) { - i__2 = i__ - 1; - dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[( - i__ + 1) * a_dim1 + 1], &c__1); - } - if (*n > i__ + 1) { - i__2 = *n - i__ - 1; - dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, & - a[i__ + 1 + (i__ + 2) * a_dim1], lda); - } - dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1) - * vs_dim1 + 1], &c__1); - a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ * - a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 0.; - } - inxt = i__ + 2; - } -L20: - ; - } - } - i__1 = *n - ieval; -/* Computing MAX */ - i__3 = *n - ieval; - i__2 = std::max(i__3,1_integer); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval + - 1], &i__2, &ierr); - } - - if (wantst && *info == 0) { - -/* Check if reordering successful */ - - lastsl = true; - lst2sl = true; - *sdim = 0; - ip = 0; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - cursl = (*select)(&wr[i__], &wi[i__]); - if (wi[i__] == 0.) { - if (cursl) { - ++(*sdim); - } - ip = 0; - if (cursl && ! lastsl) { - *info = *n + 2; - } - } else { - if (ip == 1) { - -/* Last eigenvalue of conjugate pair */ - - cursl = cursl || lastsl; - lastsl = cursl; - if (cursl) { - *sdim += 2; - } - ip = -1; - if (cursl && ! lst2sl) { - *info = *n + 2; - } - } else { - -/* First eigenvalue of conjugate pair */ - - ip = 1; - } - } - lst2sl = lastsl; - lastsl = cursl; -/* L30: */ - } - } - - work[1] = (double) maxwrk; - if (wantsv || wantsb) { -/* Computing MAX */ - i__1 = 1, i__2 = *sdim * (*n - *sdim); - iwork[1] = std::max(i__1,i__2); - } else { - iwork[1] = 1; - } - - return 0; - -/* End of DGEESX */ - -} /* dgeesx_ */ diff --git a/external/clapack/lapack/dgeev.cpp b/external/clapack/lapack/dgeev.cpp deleted file mode 100644 index bfcac0e7..00000000 --- a/external/clapack/lapack/dgeev.cpp +++ /dev/null @@ -1,515 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static integer c_n1 = -1; - -int dgeev_(const char *jobvl, const char *jobvr, integer *n, double *a, integer *lda, double *wr, double *wi, - double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, - i__2, i__3; - double d__1, d__2; - - /* Local variables */ - integer i__, k; - double r__, cs, sn; - integer ihi; - double scl; - integer ilo; - double dum[1], eps; - integer ibal; - char side[1]; - double anrm; - integer ierr, itau; - integer iwrk, nout; - bool scalea; - double cscale; - bool select[1]; - double bignum; - integer minwrk, maxwrk; - bool wantvl; - double smlnum; - integer hswork; - bool lquery, wantvr; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEEV computes for an N-by-N real nonsymmetric matrix A, the */ -/* eigenvalues and, optionally, the left and/or right eigenvectors. */ - -/* The right eigenvector v(j) of A satisfies */ -/* A * v(j) = lambda(j) * v(j) */ -/* where lambda(j) is its eigenvalue. */ -/* The left eigenvector u(j) of A satisfies */ -/* u(j)**H * A = lambda(j) * u(j)**H */ -/* where u(j)**H denotes the conjugate transpose of u(j). */ - -/* The computed eigenvectors are normalized to have Euclidean norm */ -/* equal to 1 and largest component real. */ - -/* Arguments */ -/* ========= */ - -/* JOBVL (input) CHARACTER*1 */ -/* = 'N': left eigenvectors of A are not computed; */ -/* = 'V': left eigenvectors of A are computed. */ - -/* JOBVR (input) CHARACTER*1 */ -/* = 'N': right eigenvectors of A are not computed; */ -/* = 'V': right eigenvectors of A are computed. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the N-by-N matrix A. */ -/* On exit, A has been overwritten. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* WR (output) DOUBLE PRECISION array, dimension (N) */ -/* WI (output) DOUBLE PRECISION array, dimension (N) */ -/* WR and WI contain the real and imaginary parts, */ -/* respectively, of the computed eigenvalues. Complex */ -/* conjugate pairs of eigenvalues appear consecutively */ -/* with the eigenvalue having the positive imaginary part */ -/* first. */ - -/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ -/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ -/* after another in the columns of VL, in the same order */ -/* as their eigenvalues. */ -/* If JOBVL = 'N', VL is not referenced. */ -/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */ -/* the j-th column of VL. */ -/* If the j-th and (j+1)-st eigenvalues form a complex */ -/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */ -/* u(j+1) = VL(:,j) - i*VL(:,j+1). */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the array VL. LDVL >= 1; if */ -/* JOBVL = 'V', LDVL >= N. */ - -/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ -/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ -/* after another in the columns of VR, in the same order */ -/* as their eigenvalues. */ -/* If JOBVR = 'N', VR is not referenced. */ -/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */ -/* the j-th column of VR. */ -/* If the j-th and (j+1)-st eigenvalues form a complex */ -/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */ -/* v(j+1) = VR(:,j) - i*VR(:,j+1). */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the array VR. LDVR >= 1; if */ -/* JOBVR = 'V', LDVR >= N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,3*N), and */ -/* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */ -/* performance, LWORK must generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = i, the QR algorithm failed to compute all the */ -/* eigenvalues, and no eigenvectors have been computed; */ -/* elements i+1:N of WR and WI contain eigenvalues which */ -/* have converged. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --wr; - --wi; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - wantvl = lsame_(jobvl, "V"); - wantvr = lsame_(jobvr, "V"); - if (! wantvl && ! lsame_(jobvl, "N")) { - *info = -1; - } else if (! wantvr && ! lsame_(jobvr, "N")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldvl < 1 || wantvl && *ldvl < *n) { - *info = -9; - } else if (*ldvr < 1 || wantvr && *ldvr < *n) { - *info = -11; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV. */ -/* HSWORK refers to the workspace preferred by DHSEQR, as */ -/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ -/* the worst case.) */ - - if (*info == 0) { - if (*n == 0) { - minwrk = 1; - maxwrk = 1; - } else { - maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, - n, &c__0); - if (wantvl) { - minwrk = *n << 2; -/* Computing MAX */ - i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, - "DORGHR", " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); - dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ - 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info); - hswork = (integer) work[1]; -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + 1, i__1 = std::max(i__1,i__2), i__2 = * - n + hswork; - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n << 2; - maxwrk = std::max(i__1,i__2); - } else if (wantvr) { - minwrk = *n << 2; -/* Computing MAX */ - i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, - "DORGHR", " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); - dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ - 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); - hswork = (integer) work[1]; -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + 1, i__1 = std::max(i__1,i__2), i__2 = * - n + hswork; - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n << 2; - maxwrk = std::max(i__1,i__2); - } else { - minwrk = *n * 3; - dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ - 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); - hswork = (integer) work[1]; -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + 1, i__1 = std::max(i__1,i__2), i__2 = * - n + hswork; - maxwrk = std::max(i__1,i__2); - } - maxwrk = std::max(maxwrk,minwrk); - } - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -13; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEEV ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - smlnum = sqrt(smlnum) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, dum); - scalea = false; - if (anrm > 0. && anrm < smlnum) { - scalea = true; - cscale = smlnum; - } else if (anrm > bignum) { - scalea = true; - cscale = bignum; - } - if (scalea) { - dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & - ierr); - } - -/* Balance the matrix */ -/* (Workspace: need N) */ - - ibal = 1; - dgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr); - -/* Reduce to upper Hessenberg form */ -/* (Workspace: need 3*N, prefer 2*N+N*NB) */ - - itau = ibal + *n; - iwrk = itau + *n; - i__1 = *lwork - iwrk + 1; - dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, - &ierr); - - if (wantvl) { - -/* Want left eigenvectors */ -/* Copy Householder vectors to VL */ - - *(unsigned char *)side = 'L'; - dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) - ; - -/* Generate orthogonal matrix in VL */ -/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ - - i__1 = *lwork - iwrk + 1; - dorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], - &i__1, &ierr); - -/* Perform QR iteration, accumulating Schur vectors in VL */ -/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ - - iwrk = itau; - i__1 = *lwork - iwrk + 1; - dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & - vl[vl_offset], ldvl, &work[iwrk], &i__1, info); - - if (wantvr) { - -/* Want left and right eigenvectors */ -/* Copy Schur vectors to VR */ - - *(unsigned char *)side = 'B'; - dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); - } - - } else if (wantvr) { - -/* Want right eigenvectors */ -/* Copy Householder vectors to VR */ - - *(unsigned char *)side = 'R'; - dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) - ; - -/* Generate orthogonal matrix in VR */ -/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ - - i__1 = *lwork - iwrk + 1; - dorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], - &i__1, &ierr); - -/* Perform QR iteration, accumulating Schur vectors in VR */ -/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ - - iwrk = itau; - i__1 = *lwork - iwrk + 1; - dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & - vr[vr_offset], ldvr, &work[iwrk], &i__1, info); - - } else { - -/* Compute eigenvalues only */ -/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ - - iwrk = itau; - i__1 = *lwork - iwrk + 1; - dhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & - vr[vr_offset], ldvr, &work[iwrk], &i__1, info); - } - -/* If INFO > 0 from DHSEQR, then quit */ - - if (*info > 0) { - goto L50; - } - - if (wantvl || wantvr) { - -/* Compute left and/or right eigenvectors */ -/* (Workspace: need 4*N) */ - - dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, - &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr); - } - - if (wantvl) { - -/* Undo balancing of left eigenvectors */ -/* (Workspace: need N) */ - - dgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl, - &ierr); - -/* Normalize left eigenvectors and make largest component real */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (wi[i__] == 0.) { - scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); - dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); - } else if (wi[i__] > 0.) { - d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); - d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); - scl = 1. / dlapy2_(&d__1, &d__2); - dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); - dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); - i__2 = *n; - for (k = 1; k <= i__2; ++k) { -/* Computing 2nd power */ - d__1 = vl[k + i__ * vl_dim1]; -/* Computing 2nd power */ - d__2 = vl[k + (i__ + 1) * vl_dim1]; - work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2; -/* L10: */ - } - k = idamax_(n, &work[iwrk], &c__1); - dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1], - &cs, &sn, &r__); - drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) * - vl_dim1 + 1], &c__1, &cs, &sn); - vl[k + (i__ + 1) * vl_dim1] = 0.; - } -/* L20: */ - } - } - - if (wantvr) { - -/* Undo balancing of right eigenvectors */ -/* (Workspace: need N) */ - - dgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr, - &ierr); - -/* Normalize right eigenvectors and make largest component real */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (wi[i__] == 0.) { - scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); - dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); - } else if (wi[i__] > 0.) { - d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); - d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); - scl = 1. / dlapy2_(&d__1, &d__2); - dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); - dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); - i__2 = *n; - for (k = 1; k <= i__2; ++k) { -/* Computing 2nd power */ - d__1 = vr[k + i__ * vr_dim1]; -/* Computing 2nd power */ - d__2 = vr[k + (i__ + 1) * vr_dim1]; - work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2; -/* L30: */ - } - k = idamax_(n, &work[iwrk], &c__1); - dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1], - &cs, &sn, &r__); - drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) * - vr_dim1 + 1], &c__1, &cs, &sn); - vr[k + (i__ + 1) * vr_dim1] = 0.; - } -/* L40: */ - } - } - -/* Undo scaling if necessary */ - -L50: - if (scalea) { - i__1 = *n - *info; -/* Computing MAX */ - i__3 = *n - *info; - i__2 = std::max(i__3,1_integer); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info + - 1], &i__2, &ierr); - i__1 = *n - *info; -/* Computing MAX */ - i__3 = *n - *info; - i__2 = std::max(i__3,1_integer); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info + - 1], &i__2, &ierr); - if (*info > 0) { - i__1 = ilo - 1; - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1], - n, &ierr); - i__1 = ilo - 1; - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1], - n, &ierr); - } - } - - work[1] = (double) maxwrk; - return 0; - -/* End of DGEEV */ - -} /* dgeev_ */ diff --git a/external/clapack/lapack/dgeevx.cpp b/external/clapack/lapack/dgeevx.cpp deleted file mode 100644 index 836c7f81..00000000 --- a/external/clapack/lapack/dgeevx.cpp +++ /dev/null @@ -1,654 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static integer c_n1 = -1; - -/* Subroutine */ int dgeevx_(const char *balanc, const char *jobvl, const char *jobvr, const char * - sense, integer *n, double *a, integer *lda, double *wr, - double *wi, double *vl, integer *ldvl, double *vr, - integer *ldvr, integer *ilo, integer *ihi, double *scale, - double *abnrm, double *rconde, double *rcondv, double - *work, integer *lwork, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, - i__2, i__3; - double d__1, d__2; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__, k; - double r__, cs, sn; - char job[1]; - double scl, dum[1], eps; - char side[1]; - double anrm; - integer ierr, itau; - integer iwrk, nout; - integer icond; - bool scalea; - double cscale; - bool select[1]; - double bignum; - integer minwrk, maxwrk; - bool wantvl, wntsnb; - integer hswork; - bool wntsne; - double smlnum; - bool lquery, wantvr, wntsnn, wntsnv; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the */ -/* eigenvalues and, optionally, the left and/or right eigenvectors. */ - -/* Optionally also, it computes a balancing transformation to improve */ -/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */ -/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */ -/* (RCONDE), and reciprocal condition numbers for the right */ -/* eigenvectors (RCONDV). */ - -/* The right eigenvector v(j) of A satisfies */ -/* A * v(j) = lambda(j) * v(j) */ -/* where lambda(j) is its eigenvalue. */ -/* The left eigenvector u(j) of A satisfies */ -/* u(j)**H * A = lambda(j) * u(j)**H */ -/* where u(j)**H denotes the conjugate transpose of u(j). */ - -/* The computed eigenvectors are normalized to have Euclidean norm */ -/* equal to 1 and largest component real. */ - -/* Balancing a matrix means permuting the rows and columns to make it */ -/* more nearly upper triangular, and applying a diagonal similarity */ -/* transformation D * A * D**(-1), where D is a diagonal matrix, to */ -/* make its rows and columns closer in norm and the condition numbers */ -/* of its eigenvalues and eigenvectors smaller. The computed */ -/* reciprocal condition numbers correspond to the balanced matrix. */ -/* Permuting rows and columns will not change the condition numbers */ -/* (in exact arithmetic) but diagonal scaling will. For further */ -/* explanation of balancing, see section 4.10.2 of the LAPACK */ -/* Users' Guide. */ - -/* Arguments */ -/* ========= */ - -/* BALANC (input) CHARACTER*1 */ -/* Indicates how the input matrix should be diagonally scaled */ -/* and/or permuted to improve the conditioning of its */ -/* eigenvalues. */ -/* = 'N': Do not diagonally scale or permute; */ -/* = 'P': Perform permutations to make the matrix more nearly */ -/* upper triangular. Do not diagonally scale; */ -/* = 'S': Diagonally scale the matrix, i.e. replace A by */ -/* D*A*D**(-1), where D is a diagonal matrix chosen */ -/* to make the rows and columns of A more equal in */ -/* norm. Do not permute; */ -/* = 'B': Both diagonally scale and permute A. */ - -/* Computed reciprocal condition numbers will be for the matrix */ -/* after balancing and/or permuting. Permuting does not change */ -/* condition numbers (in exact arithmetic), but balancing does. */ - -/* JOBVL (input) CHARACTER*1 */ -/* = 'N': left eigenvectors of A are not computed; */ -/* = 'V': left eigenvectors of A are computed. */ -/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */ - -/* JOBVR (input) CHARACTER*1 */ -/* = 'N': right eigenvectors of A are not computed; */ -/* = 'V': right eigenvectors of A are computed. */ -/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */ - -/* SENSE (input) CHARACTER*1 */ -/* Determines which reciprocal condition numbers are computed. */ -/* = 'N': None are computed; */ -/* = 'E': Computed for eigenvalues only; */ -/* = 'V': Computed for right eigenvectors only; */ -/* = 'B': Computed for eigenvalues and right eigenvectors. */ - -/* If SENSE = 'E' or 'B', both left and right eigenvectors */ -/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the N-by-N matrix A. */ -/* On exit, A has been overwritten. If JOBVL = 'V' or */ -/* JOBVR = 'V', A contains the real Schur form of the balanced */ -/* version of the input matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* WR (output) DOUBLE PRECISION array, dimension (N) */ -/* WI (output) DOUBLE PRECISION array, dimension (N) */ -/* WR and WI contain the real and imaginary parts, */ -/* respectively, of the computed eigenvalues. Complex */ -/* conjugate pairs of eigenvalues will appear consecutively */ -/* with the eigenvalue having the positive imaginary part */ -/* first. */ - -/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ -/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ -/* after another in the columns of VL, in the same order */ -/* as their eigenvalues. */ -/* If JOBVL = 'N', VL is not referenced. */ -/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */ -/* the j-th column of VL. */ -/* If the j-th and (j+1)-st eigenvalues form a complex */ -/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */ -/* u(j+1) = VL(:,j) - i*VL(:,j+1). */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the array VL. LDVL >= 1; if */ -/* JOBVL = 'V', LDVL >= N. */ - -/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ -/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ -/* after another in the columns of VR, in the same order */ -/* as their eigenvalues. */ -/* If JOBVR = 'N', VR is not referenced. */ -/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */ -/* the j-th column of VR. */ -/* If the j-th and (j+1)-st eigenvalues form a complex */ -/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */ -/* v(j+1) = VR(:,j) - i*VR(:,j+1). */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the array VR. LDVR >= 1, and if */ -/* JOBVR = 'V', LDVR >= N. */ - -/* ILO (output) INTEGER */ -/* IHI (output) INTEGER */ -/* ILO and IHI are integer values determined when A was */ -/* balanced. The balanced A(i,j) = 0 if I > J and */ -/* J = 1,...,ILO-1 or I = IHI+1,...,N. */ - -/* SCALE (output) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutations and scaling factors applied */ -/* when balancing A. If P(j) is the index of the row and column */ -/* interchanged with row and column j, and D(j) is the scaling */ -/* factor applied to row and column j, then */ -/* SCALE(J) = P(J), for J = 1,...,ILO-1 */ -/* = D(J), for J = ILO,...,IHI */ -/* = P(J) for J = IHI+1,...,N. */ -/* The order in which the interchanges are made is N to IHI+1, */ -/* then 1 to ILO-1. */ - -/* ABNRM (output) DOUBLE PRECISION */ -/* The one-norm of the balanced matrix (the maximum */ -/* of the sum of absolute values of elements of any column). */ - -/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */ -/* RCONDE(j) is the reciprocal condition number of the j-th */ -/* eigenvalue. */ - -/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */ -/* RCONDV(j) is the reciprocal condition number of the j-th */ -/* right eigenvector. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. If SENSE = 'N' or 'E', */ -/* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */ -/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */ -/* For good performance, LWORK must generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (2*N-2) */ -/* If SENSE = 'N' or 'E', not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = i, the QR algorithm failed to compute all the */ -/* eigenvalues, and no eigenvectors or condition numbers */ -/* have been computed; elements 1:ILO-1 and i+1:N of WR */ -/* and WI contain eigenvalues which have converged. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --wr; - --wi; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --scale; - --rconde; - --rcondv; - --work; - --iwork; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - wantvl = lsame_(jobvl, "V"); - wantvr = lsame_(jobvr, "V"); - wntsnn = lsame_(sense, "N"); - wntsne = lsame_(sense, "E"); - wntsnv = lsame_(sense, "V"); - wntsnb = lsame_(sense, "B"); - if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") - || lsame_(balanc, "B"))) { - *info = -1; - } else if (! wantvl && ! lsame_(jobvl, "N")) { - *info = -2; - } else if (! wantvr && ! lsame_(jobvr, "N")) { - *info = -3; - } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb) - && ! (wantvl && wantvr)) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldvl < 1 || wantvl && *ldvl < *n) { - *info = -11; - } else if (*ldvr < 1 || wantvr && *ldvr < *n) { - *info = -13; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV. */ -/* HSWORK refers to the workspace preferred by DHSEQR, as */ -/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ -/* the worst case.) */ - - if (*info == 0) { - if (*n == 0) { - minwrk = 1; - maxwrk = 1; - } else { - maxwrk = *n + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, & - c__0); - - if (wantvl) { - dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ - 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info); - } else if (wantvr) { - dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ - 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); - } else { - if (wntsnn) { - dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], - &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1, - info); - } else { - dhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], - &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1, - info); - } - } - hswork = (integer) work[1]; - - if (! wantvl && ! wantvr) { - minwrk = *n << 1; - if (! wntsnn) { -/* Computing MAX */ - i__1 = minwrk, i__2 = *n * *n + *n * 6; - minwrk = std::max(i__1,i__2); - } - maxwrk = std::max(maxwrk,hswork); - if (! wntsnn) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * *n + *n * 6; - maxwrk = std::max(i__1,i__2); - } - } else { - minwrk = *n * 3; - if (! wntsnn && ! wntsne) { -/* Computing MAX */ - i__1 = minwrk, i__2 = *n * *n + *n * 6; - minwrk = std::max(i__1,i__2); - } - maxwrk = std::max(maxwrk,hswork); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "DORGHR", - " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); - if (! wntsnn && ! wntsne) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * *n + *n * 6; - maxwrk = std::max(i__1,i__2); - } -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3; - maxwrk = std::max(i__1,i__2); - } - maxwrk = std::max(maxwrk,minwrk); - } - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -21; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEEVX", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - smlnum = sqrt(smlnum) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - icond = 0; - anrm = dlange_("M", n, n, &a[a_offset], lda, dum); - scalea = false; - if (anrm > 0. && anrm < smlnum) { - scalea = true; - cscale = smlnum; - } else if (anrm > bignum) { - scalea = true; - cscale = bignum; - } - if (scalea) { - dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & - ierr); - } - -/* Balance the matrix and compute ABNRM */ - - dgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr); - *abnrm = dlange_("1", n, n, &a[a_offset], lda, dum); - if (scalea) { - dum[0] = *abnrm; - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, & - ierr); - *abnrm = dum[0]; - } - -/* Reduce to upper Hessenberg form */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - itau = 1; - iwrk = itau + *n; - i__1 = *lwork - iwrk + 1; - dgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, & - ierr); - - if (wantvl) { - -/* Want left eigenvectors */ -/* Copy Householder vectors to VL */ - - *(unsigned char *)side = 'L'; - dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) - ; - -/* Generate orthogonal matrix in VL */ -/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */ - - i__1 = *lwork - iwrk + 1; - dorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], & - i__1, &ierr); - -/* Perform QR iteration, accumulating Schur vectors in VL */ -/* (Workspace: need 1, prefer HSWORK (see comments) ) */ - - iwrk = itau; - i__1 = *lwork - iwrk + 1; - dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[ - vl_offset], ldvl, &work[iwrk], &i__1, info); - - if (wantvr) { - -/* Want left and right eigenvectors */ -/* Copy Schur vectors to VR */ - - *(unsigned char *)side = 'B'; - dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); - } - - } else if (wantvr) { - -/* Want right eigenvectors */ -/* Copy Householder vectors to VR */ - - *(unsigned char *)side = 'R'; - dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) - ; - -/* Generate orthogonal matrix in VR */ -/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */ - - i__1 = *lwork - iwrk + 1; - dorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], & - i__1, &ierr); - -/* Perform QR iteration, accumulating Schur vectors in VR */ -/* (Workspace: need 1, prefer HSWORK (see comments) ) */ - - iwrk = itau; - i__1 = *lwork - iwrk + 1; - dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[ - vr_offset], ldvr, &work[iwrk], &i__1, info); - - } else { - -/* Compute eigenvalues only */ -/* If condition numbers desired, compute Schur form */ - - if (wntsnn) { - *(unsigned char *)job = 'E'; - } else { - *(unsigned char *)job = 'S'; - } - -/* (Workspace: need 1, prefer HSWORK (see comments) ) */ - - iwrk = itau; - i__1 = *lwork - iwrk + 1; - dhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[ - vr_offset], ldvr, &work[iwrk], &i__1, info); - } - -/* If INFO > 0 from DHSEQR, then quit */ - - if (*info > 0) { - goto L50; - } - - if (wantvl || wantvr) { - -/* Compute left and/or right eigenvectors */ -/* (Workspace: need 3*N) */ - - dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, - &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr); - } - -/* Compute condition numbers if desired */ -/* (Workspace: need N*N+6*N unless SENSE = 'E') */ - - if (! wntsnn) { - dtrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset], - ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout, - &work[iwrk], n, &iwork[1], &icond); - } - - if (wantvl) { - -/* Undo balancing of left eigenvectors */ - - dgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl, - &ierr); - -/* Normalize left eigenvectors and make largest component real */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (wi[i__] == 0.) { - scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); - dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); - } else if (wi[i__] > 0.) { - d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); - d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); - scl = 1. / dlapy2_(&d__1, &d__2); - dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); - dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); - i__2 = *n; - for (k = 1; k <= i__2; ++k) { -/* Computing 2nd power */ - d__1 = vl[k + i__ * vl_dim1]; -/* Computing 2nd power */ - d__2 = vl[k + (i__ + 1) * vl_dim1]; - work[k] = d__1 * d__1 + d__2 * d__2; -/* L10: */ - } - k = idamax_(n, &work[1], &c__1); - dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1], - &cs, &sn, &r__); - drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) * - vl_dim1 + 1], &c__1, &cs, &sn); - vl[k + (i__ + 1) * vl_dim1] = 0.; - } -/* L20: */ - } - } - - if (wantvr) { - -/* Undo balancing of right eigenvectors */ - - dgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr, - &ierr); - -/* Normalize right eigenvectors and make largest component real */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (wi[i__] == 0.) { - scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); - dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); - } else if (wi[i__] > 0.) { - d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); - d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); - scl = 1. / dlapy2_(&d__1, &d__2); - dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); - dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); - i__2 = *n; - for (k = 1; k <= i__2; ++k) { -/* Computing 2nd power */ - d__1 = vr[k + i__ * vr_dim1]; -/* Computing 2nd power */ - d__2 = vr[k + (i__ + 1) * vr_dim1]; - work[k] = d__1 * d__1 + d__2 * d__2; -/* L30: */ - } - k = idamax_(n, &work[1], &c__1); - dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1], - &cs, &sn, &r__); - drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) * - vr_dim1 + 1], &c__1, &cs, &sn); - vr[k + (i__ + 1) * vr_dim1] = 0.; - } -/* L40: */ - } - } - -/* Undo scaling if necessary */ - -L50: - if (scalea) { - i__1 = *n - *info; -/* Computing MAX */ - i__3 = *n - *info; - i__2 = std::max(i__3,1_integer); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info + - 1], &i__2, &ierr); - i__1 = *n - *info; -/* Computing MAX */ - i__3 = *n - *info; - i__2 = std::max(i__3,1_integer); - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info + - 1], &i__2, &ierr); - if (*info == 0) { - if ((wntsnv || wntsnb) && icond == 0) { - dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[ - 1], n, &ierr); - } - } else { - i__1 = *ilo - 1; - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1], - n, &ierr); - i__1 = *ilo - 1; - dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1], - n, &ierr); - } - } - - work[1] = (double) maxwrk; - return 0; - -/* End of DGEEVX */ - -} /* dgeevx_ */ diff --git a/external/clapack/lapack/dgegs.cpp b/external/clapack/lapack/dgegs.cpp deleted file mode 100644 index 6bfd8e64..00000000 --- a/external/clapack/lapack/dgegs.cpp +++ /dev/null @@ -1,503 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b36 = 0.; -static double c_b37 = 1.; - -/* Subroutine */ int dgegs_(const char *jobvsl, const char *jobvsr, integer *n, - double *a, integer *lda, double *b, integer *ldb, double * - alphar, double *alphai, double *beta, double *vsl, - integer *ldvsl, double *vsr, integer *ldvsr, double *work, - integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, - vsr_dim1, vsr_offset, i__1, i__2; - - /* Local variables */ - integer nb, nb1, nb2, nb3, ihi, ilo; - double eps, anrm, bnrm; - integer itau, lopt; - integer ileft, iinfo, icols; - bool ilvsl; - integer iwork; - bool ilvsr; - integer irows; - bool ilascl, ilbscl; - double safmin; - double bignum; - integer ijobvl, iright, ijobvr; - double anrmto; - integer lwkmin; - double bnrmto; - double smlnum; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This routine is deprecated and has been replaced by routine DGGES. */ - -/* DGEGS computes the eigenvalues, real Schur form, and, optionally, */ -/* left and or/right Schur vectors of a real matrix pair (A,B). */ -/* Given two square matrices A and B, the generalized real Schur */ -/* factorization has the form */ - -/* A = Q*S*Z**T, B = Q*T*Z**T */ - -/* where Q and Z are orthogonal matrices, T is upper triangular, and S */ -/* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */ -/* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */ -/* of eigenvalues of (A,B). The columns of Q are the left Schur vectors */ -/* and the columns of Z are the right Schur vectors. */ - -/* If only the eigenvalues of (A,B) are needed, the driver routine */ -/* DGEGV should be used instead. See DGEGV for a description of the */ -/* eigenvalues of the generalized nonsymmetric eigenvalue problem */ -/* (GNEP). */ - -/* Arguments */ -/* ========= */ - -/* JOBVSL (input) CHARACTER*1 */ -/* = 'N': do not compute the left Schur vectors; */ -/* = 'V': compute the left Schur vectors (returned in VSL). */ - -/* JOBVSR (input) CHARACTER*1 */ -/* = 'N': do not compute the right Schur vectors; */ -/* = 'V': compute the right Schur vectors (returned in VSR). */ - -/* N (input) INTEGER */ -/* The order of the matrices A, B, VSL, and VSR. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the matrix A. */ -/* On exit, the upper quasi-triangular matrix S from the */ -/* generalized real Schur factorization. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the matrix B. */ -/* On exit, the upper triangular matrix T from the generalized */ -/* real Schur factorization. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B. LDB >= max(1,N). */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ -/* The real parts of each scalar alpha defining an eigenvalue */ -/* of GNEP. */ - -/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ -/* The imaginary parts of each scalar alpha defining an */ -/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */ -/* eigenvalue is real; if positive, then the j-th and (j+1)-st */ -/* eigenvalues are a complex conjugate pair, with */ -/* ALPHAI(j+1) = -ALPHAI(j). */ - -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* The scalars beta that define the eigenvalues of GNEP. */ -/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ -/* beta = BETA(j) represent the j-th eigenvalue of the matrix */ -/* pair (A,B), in one of the forms lambda = alpha/beta or */ -/* mu = beta/alpha. Since either lambda or mu may overflow, */ -/* they should not, in general, be computed. */ - -/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */ -/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */ -/* Not referenced if JOBVSL = 'N'. */ - -/* LDVSL (input) INTEGER */ -/* The leading dimension of the matrix VSL. LDVSL >=1, and */ -/* if JOBVSL = 'V', LDVSL >= N. */ - -/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */ -/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */ -/* Not referenced if JOBVSR = 'N'. */ - -/* LDVSR (input) INTEGER */ -/* The leading dimension of the matrix VSR. LDVSR >= 1, and */ -/* if JOBVSR = 'V', LDVSR >= N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,4*N). */ -/* For good performance, LWORK must generally be larger. */ -/* To compute the optimal value of LWORK, call ILAENV to get */ -/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */ -/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR */ -/* The optimal LWORK is 2*N + N*(NB+1). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1,...,N: */ -/* The QZ iteration failed. (A,B) are not in Schur */ -/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ -/* be correct for j=INFO+1,...,N. */ -/* > N: errors that usually indicate LAPACK problems: */ -/* =N+1: error return from DGGBAL */ -/* =N+2: error return from DGEQRF */ -/* =N+3: error return from DORMQR */ -/* =N+4: error return from DORGQR */ -/* =N+5: error return from DGGHRD */ -/* =N+6: error return from DHGEQZ (other than failed */ -/* iteration) */ -/* =N+7: error return from DGGBAK (computing VSL) */ -/* =N+8: error return from DGGBAK (computing VSR) */ -/* =N+9: error return from DLASCL (various places) */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alphar; - --alphai; - --beta; - vsl_dim1 = *ldvsl; - vsl_offset = 1 + vsl_dim1; - vsl -= vsl_offset; - vsr_dim1 = *ldvsr; - vsr_offset = 1 + vsr_dim1; - vsr -= vsr_offset; - --work; - - /* Function Body */ - if (lsame_(jobvsl, "N")) { - ijobvl = 1; - ilvsl = false; - } else if (lsame_(jobvsl, "V")) { - ijobvl = 2; - ilvsl = true; - } else { - ijobvl = -1; - ilvsl = false; - } - - if (lsame_(jobvsr, "N")) { - ijobvr = 1; - ilvsr = false; - } else if (lsame_(jobvsr, "V")) { - ijobvr = 2; - ilvsr = true; - } else { - ijobvr = -1; - ilvsr = false; - } - -/* Test the input arguments */ - -/* Computing MAX */ - i__1 = *n << 2; - lwkmin = std::max(i__1,1_integer); - lwkopt = lwkmin; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - *info = 0; - if (ijobvl <= 0) { - *info = -1; - } else if (ijobvr <= 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { - *info = -12; - } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { - *info = -14; - } else if (*lwork < lwkmin && ! lquery) { - *info = -16; - } - - if (*info == 0) { - nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1); - nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1); - nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1); -/* Computing MAX */ - i__1 = std::max(nb1,nb2); - nb = std::max(i__1,nb3); - lopt = (*n << 1) + *n * (nb + 1); - work[1] = (double) lopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEGS ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("E") * dlamch_("B"); - safmin = dlamch_("S"); - smlnum = *n * safmin / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); - ilascl = false; - if (anrm > 0. && anrm < smlnum) { - anrmto = smlnum; - ilascl = true; - } else if (anrm > bignum) { - anrmto = bignum; - ilascl = true; - } - - if (ilascl) { - dlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, & - iinfo); - if (iinfo != 0) { - *info = *n + 9; - return 0; - } - } - -/* Scale B if max element outside range [SMLNUM,BIGNUM] */ - - bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); - ilbscl = false; - if (bnrm > 0. && bnrm < smlnum) { - bnrmto = smlnum; - ilbscl = true; - } else if (bnrm > bignum) { - bnrmto = bignum; - ilbscl = true; - } - - if (ilbscl) { - dlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & - iinfo); - if (iinfo != 0) { - *info = *n + 9; - return 0; - } - } - -/* Permute the matrix to make it more nearly triangular */ -/* Workspace layout: (2*N words -- "work..." not actually used) */ -/* left_permutation, right_permutation, work... */ - - ileft = 1; - iright = *n + 1; - iwork = iright + *n; - dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ - ileft], &work[iright], &work[iwork], &iinfo); - if (iinfo != 0) { - *info = *n + 1; - goto L10; - } - -/* Reduce B to triangular form, and initialize VSL and/or VSR */ -/* Workspace layout: ("work..." must have at least N words) */ -/* left_permutation, right_permutation, tau, work... */ - - irows = ihi + 1 - ilo; - icols = *n + 1 - ilo; - itau = iwork; - iwork = itau + irows; - i__1 = *lwork + 1 - iwork; - dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ - iwork], &i__1, &iinfo); - if (iinfo >= 0) { -/* Computing MAX */ - i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; - lwkopt = std::max(i__1,i__2); - } - if (iinfo != 0) { - *info = *n + 2; - goto L10; - } - - i__1 = *lwork + 1 - iwork; - dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & - work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & - iinfo); - if (iinfo >= 0) { -/* Computing MAX */ - i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; - lwkopt = std::max(i__1,i__2); - } - if (iinfo != 0) { - *info = *n + 3; - goto L10; - } - - if (ilvsl) { - dlaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl); - i__1 = irows - 1; - i__2 = irows - 1; - dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo - + 1 + ilo * vsl_dim1], ldvsl); - i__1 = *lwork + 1 - iwork; - dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & - work[itau], &work[iwork], &i__1, &iinfo); - if (iinfo >= 0) { -/* Computing MAX */ - i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; - lwkopt = std::max(i__1,i__2); - } - if (iinfo != 0) { - *info = *n + 4; - goto L10; - } - } - - if (ilvsr) { - dlaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr); - } - -/* Reduce to generalized Hessenberg form */ - - dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], - ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo); - if (iinfo != 0) { - *info = *n + 5; - goto L10; - } - -/* Perform QZ algorithm, computing Schur vectors if desired */ -/* Workspace layout: ("work..." must have at least 1 word) */ -/* left_permutation, right_permutation, work... */ - - iwork = itau; - i__1 = *lwork + 1 - iwork; - dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ - b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] -, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo); - if (iinfo >= 0) { -/* Computing MAX */ - i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; - lwkopt = std::max(i__1,i__2); - } - if (iinfo != 0) { - if (iinfo > 0 && iinfo <= *n) { - *info = iinfo; - } else if (iinfo > *n && iinfo <= *n << 1) { - *info = iinfo - *n; - } else { - *info = *n + 6; - } - goto L10; - } - -/* Apply permutation to VSL and VSR */ - - if (ilvsl) { - dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ - vsl_offset], ldvsl, &iinfo); - if (iinfo != 0) { - *info = *n + 7; - goto L10; - } - } - if (ilvsr) { - dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ - vsr_offset], ldvsr, &iinfo); - if (iinfo != 0) { - *info = *n + 8; - goto L10; - } - } - -/* Undo scaling */ - - if (ilascl) { - dlascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, & - iinfo); - if (iinfo != 0) { - *info = *n + 9; - return 0; - } - dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, & - iinfo); - if (iinfo != 0) { - *info = *n + 9; - return 0; - } - dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, & - iinfo); - if (iinfo != 0) { - *info = *n + 9; - return 0; - } - } - - if (ilbscl) { - dlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & - iinfo); - if (iinfo != 0) { - *info = *n + 9; - return 0; - } - dlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & - iinfo); - if (iinfo != 0) { - *info = *n + 9; - return 0; - } - } - -L10: - work[1] = (double) lwkopt; - - return 0; - -/* End of DGEGS */ - -} /* dgegs_ */ diff --git a/external/clapack/lapack/dgegv.cpp b/external/clapack/lapack/dgegv.cpp deleted file mode 100644 index 7a2a1971..00000000 --- a/external/clapack/lapack/dgegv.cpp +++ /dev/null @@ -1,794 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b27 = 1.; -static double c_b38 = 0.; - -/* Subroutine */ int dgegv_(const char *jobvl, const char *jobvr, integer *n, double * - a, integer *lda, double *b, integer *ldb, double *alphar, - double *alphai, double *beta, double *vl, integer *ldvl, - double *vr, integer *ldvr, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, - vr_offset, i__1, i__2; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo; - double eps; - bool ilv; - double absb, anrm, bnrm; - integer itau; - double temp; - bool ilvl, ilvr; - integer lopt; - double anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta; - integer ileft, iinfo, icols, iwork, irows; - double salfai; - double salfar; - double safmin; - double safmax; - char chtemp[1]; - bool ldumma[1]; - integer ijobvl, iright; - bool ilimit; - integer ijobvr; - double onepls; - integer lwkmin; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This routine is deprecated and has been replaced by routine DGGEV. */ - -/* DGEGV computes the eigenvalues and, optionally, the left and/or right */ -/* eigenvectors of a real matrix pair (A,B). */ -/* Given two square matrices A and B, */ -/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */ -/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */ -/* that */ - -/* A*x = lambda*B*x. */ - -/* An alternate form is to find the eigenvalues mu and corresponding */ -/* eigenvectors y such that */ - -/* mu*A*y = B*y. */ - -/* These two forms are equivalent with mu = 1/lambda and x = y if */ -/* neither lambda nor mu is zero. In order to deal with the case that */ -/* lambda or mu is zero or small, two values alpha and beta are returned */ -/* for each eigenvalue, such that lambda = alpha/beta and */ -/* mu = beta/alpha. */ - -/* The vectors x and y in the above equations are right eigenvectors of */ -/* the matrix pair (A,B). Vectors u and v satisfying */ - -/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */ - -/* are left eigenvectors of (A,B). */ - -/* Note: this routine performs "full balancing" on A and B -- see */ -/* "Further Details", below. */ - -/* Arguments */ -/* ========= */ - -/* JOBVL (input) CHARACTER*1 */ -/* = 'N': do not compute the left generalized eigenvectors; */ -/* = 'V': compute the left generalized eigenvectors (returned */ -/* in VL). */ - -/* JOBVR (input) CHARACTER*1 */ -/* = 'N': do not compute the right generalized eigenvectors; */ -/* = 'V': compute the right generalized eigenvectors (returned */ -/* in VR). */ - -/* N (input) INTEGER */ -/* The order of the matrices A, B, VL, and VR. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the matrix A. */ -/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */ -/* contains the real Schur form of A from the generalized Schur */ -/* factorization of the pair (A,B) after balancing. */ -/* If no eigenvectors were computed, then only the diagonal */ -/* blocks from the Schur form will be correct. See DGGHRD and */ -/* DHGEQZ for details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the matrix B. */ -/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */ -/* upper triangular matrix obtained from B in the generalized */ -/* Schur factorization of the pair (A,B) after balancing. */ -/* If no eigenvectors were computed, then only those elements of */ -/* B corresponding to the diagonal blocks from the Schur form of */ -/* A will be correct. See DGGHRD and DHGEQZ for details. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B. LDB >= max(1,N). */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ -/* The real parts of each scalar alpha defining an eigenvalue of */ -/* GNEP. */ - -/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ -/* The imaginary parts of each scalar alpha defining an */ -/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */ -/* eigenvalue is real; if positive, then the j-th and */ -/* (j+1)-st eigenvalues are a complex conjugate pair, with */ -/* ALPHAI(j+1) = -ALPHAI(j). */ - -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* The scalars beta that define the eigenvalues of GNEP. */ - -/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ -/* beta = BETA(j) represent the j-th eigenvalue of the matrix */ -/* pair (A,B), in one of the forms lambda = alpha/beta or */ -/* mu = beta/alpha. Since either lambda or mu may overflow, */ -/* they should not, in general, be computed. */ - -/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ -/* If JOBVL = 'V', the left eigenvectors u(j) are stored */ -/* in the columns of VL, in the same order as their eigenvalues. */ -/* If the j-th eigenvalue is real, then u(j) = VL(:,j). */ -/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */ -/* pair, then */ -/* u(j) = VL(:,j) + i*VL(:,j+1) */ -/* and */ -/* u(j+1) = VL(:,j) - i*VL(:,j+1). */ - -/* Each eigenvector is scaled so that its largest component has */ -/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */ -/* corresponding to an eigenvalue with alpha = beta = 0, which */ -/* are set to zero. */ -/* Not referenced if JOBVL = 'N'. */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the matrix VL. LDVL >= 1, and */ -/* if JOBVL = 'V', LDVL >= N. */ - -/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ -/* If JOBVR = 'V', the right eigenvectors x(j) are stored */ -/* in the columns of VR, in the same order as their eigenvalues. */ -/* If the j-th eigenvalue is real, then x(j) = VR(:,j). */ -/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */ -/* pair, then */ -/* x(j) = VR(:,j) + i*VR(:,j+1) */ -/* and */ -/* x(j+1) = VR(:,j) - i*VR(:,j+1). */ - -/* Each eigenvector is scaled so that its largest component has */ -/* abs(real part) + abs(imag. part) = 1, except for eigenvalues */ -/* corresponding to an eigenvalue with alpha = beta = 0, which */ -/* are set to zero. */ -/* Not referenced if JOBVR = 'N'. */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the matrix VR. LDVR >= 1, and */ -/* if JOBVR = 'V', LDVR >= N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,8*N). */ -/* For good performance, LWORK must generally be larger. */ -/* To compute the optimal value of LWORK, call ILAENV to get */ -/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */ -/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR; */ -/* The optimal LWORK is: */ -/* 2*N + MAX( 6*N, N*(NB+1) ). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1,...,N: */ -/* The QZ iteration failed. No eigenvectors have been */ -/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ -/* should be correct for j=INFO+1,...,N. */ -/* > N: errors that usually indicate LAPACK problems: */ -/* =N+1: error return from DGGBAL */ -/* =N+2: error return from DGEQRF */ -/* =N+3: error return from DORMQR */ -/* =N+4: error return from DORGQR */ -/* =N+5: error return from DGGHRD */ -/* =N+6: error return from DHGEQZ (other than failed */ -/* iteration) */ -/* =N+7: error return from DTGEVC */ -/* =N+8: error return from DGGBAK (computing VL) */ -/* =N+9: error return from DGGBAK (computing VR) */ -/* =N+10: error return from DLASCL (various calls) */ - -/* Further Details */ -/* =============== */ - -/* Balancing */ -/* --------- */ - -/* This driver calls DGGBAL to both permute and scale rows and columns */ -/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */ -/* and PL*B*R will be upper triangular except for the diagonal blocks */ -/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */ -/* possible. The diagonal scaling matrices DL and DR are chosen so */ -/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */ -/* one (except for the elements that start out zero.) */ - -/* After the eigenvalues and eigenvectors of the balanced matrices */ -/* have been computed, DGGBAK transforms the eigenvectors back to what */ -/* they would have been (in perfect arithmetic) if they had not been */ -/* balanced. */ - -/* Contents of A and B on Exit */ -/* -------- -- - --- - -- ---- */ - -/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */ -/* both), then on exit the arrays A and B will contain the real Schur */ -/* form[*] of the "balanced" versions of A and B. If no eigenvectors */ -/* are computed, then only the diagonal blocks will be correct. */ - -/* [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations", */ -/* by Golub & van Loan, pub. by Johns Hopkins U. Press. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alphar; - --alphai; - --beta; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --work; - - /* Function Body */ - if (lsame_(jobvl, "N")) { - ijobvl = 1; - ilvl = false; - } else if (lsame_(jobvl, "V")) { - ijobvl = 2; - ilvl = true; - } else { - ijobvl = -1; - ilvl = false; - } - - if (lsame_(jobvr, "N")) { - ijobvr = 1; - ilvr = false; - } else if (lsame_(jobvr, "V")) { - ijobvr = 2; - ilvr = true; - } else { - ijobvr = -1; - ilvr = false; - } - ilv = ilvl || ilvr; - -/* Test the input arguments */ - -/* Computing MAX */ - i__1 = *n << 3; - lwkmin = std::max(i__1,1_integer); - lwkopt = lwkmin; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - *info = 0; - if (ijobvl <= 0) { - *info = -1; - } else if (ijobvr <= 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldvl < 1 || ilvl && *ldvl < *n) { - *info = -12; - } else if (*ldvr < 1 || ilvr && *ldvr < *n) { - *info = -14; - } else if (*lwork < lwkmin && ! lquery) { - *info = -16; - } - - if (*info == 0) { - nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1); - nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1); - nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1); -/* Computing MAX */ - i__1 = std::max(nb1,nb2); - nb = std::max(i__1,nb3); -/* Computing MAX */ - i__1 = *n * 6, i__2 = *n * (nb + 1); - lopt = (*n << 1) + std::max(i__1,i__2); - work[1] = (double) lopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEGV ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("E") * dlamch_("B"); - safmin = dlamch_("S"); - safmin += safmin; - safmax = 1. / safmin; - onepls = eps * 4 + 1.; - -/* Scale A */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); - anrm1 = anrm; - anrm2 = 1.; - if (anrm < 1.) { - if (safmax * anrm < 1.) { - anrm1 = safmin; - anrm2 = safmax * anrm; - } - } - - if (anrm > 0.) { - dlascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, & - iinfo); - if (iinfo != 0) { - *info = *n + 10; - return 0; - } - } - -/* Scale B */ - - bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); - bnrm1 = bnrm; - bnrm2 = 1.; - if (bnrm < 1.) { - if (safmax * bnrm < 1.) { - bnrm1 = safmin; - bnrm2 = safmax * bnrm; - } - } - - if (bnrm > 0.) { - dlascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, & - iinfo); - if (iinfo != 0) { - *info = *n + 10; - return 0; - } - } - -/* Permute the matrix to make it more nearly triangular */ -/* Workspace layout: (8*N words -- "work" requires 6*N words) */ -/* left_permutation, right_permutation, work... */ - - ileft = 1; - iright = *n + 1; - iwork = iright + *n; - dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ - ileft], &work[iright], &work[iwork], &iinfo); - if (iinfo != 0) { - *info = *n + 1; - goto L120; - } - -/* Reduce B to triangular form, and initialize VL and/or VR */ -/* Workspace layout: ("work..." must have at least N words) */ -/* left_permutation, right_permutation, tau, work... */ - - irows = ihi + 1 - ilo; - if (ilv) { - icols = *n + 1 - ilo; - } else { - icols = irows; - } - itau = iwork; - iwork = itau + irows; - i__1 = *lwork + 1 - iwork; - dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ - iwork], &i__1, &iinfo); - if (iinfo >= 0) { -/* Computing MAX */ - i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; - lwkopt = std::max(i__1,i__2); - } - if (iinfo != 0) { - *info = *n + 2; - goto L120; - } - - i__1 = *lwork + 1 - iwork; - dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & - work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & - iinfo); - if (iinfo >= 0) { -/* Computing MAX */ - i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; - lwkopt = std::max(i__1,i__2); - } - if (iinfo != 0) { - *info = *n + 3; - goto L120; - } - - if (ilvl) { - dlaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl) - ; - i__1 = irows - 1; - i__2 = irows - 1; - dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo + - 1 + ilo * vl_dim1], ldvl); - i__1 = *lwork + 1 - iwork; - dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ - itau], &work[iwork], &i__1, &iinfo); - if (iinfo >= 0) { -/* Computing MAX */ - i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; - lwkopt = std::max(i__1,i__2); - } - if (iinfo != 0) { - *info = *n + 4; - goto L120; - } - } - - if (ilvr) { - dlaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr) - ; - } - -/* Reduce to generalized Hessenberg form */ - - if (ilv) { - -/* Eigenvectors requested -- work on whole matrix. */ - - dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], - ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo); - } else { - dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, - &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ - vr_offset], ldvr, &iinfo); - } - if (iinfo != 0) { - *info = *n + 5; - goto L120; - } - -/* Perform QZ algorithm */ -/* Workspace layout: ("work..." must have at least 1 word) */ -/* left_permutation, right_permutation, work... */ - - iwork = itau; - if (ilv) { - *(unsigned char *)chtemp = 'S'; - } else { - *(unsigned char *)chtemp = 'E'; - } - i__1 = *lwork + 1 - iwork; - dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ - b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], - ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo); - if (iinfo >= 0) { -/* Computing MAX */ - i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; - lwkopt = std::max(i__1,i__2); - } - if (iinfo != 0) { - if (iinfo > 0 && iinfo <= *n) { - *info = iinfo; - } else if (iinfo > *n && iinfo <= *n << 1) { - *info = iinfo - *n; - } else { - *info = *n + 6; - } - goto L120; - } - - if (ilv) { - -/* Compute Eigenvectors (DTGEVC requires 6*N words of workspace) */ - - if (ilvl) { - if (ilvr) { - *(unsigned char *)chtemp = 'B'; - } else { - *(unsigned char *)chtemp = 'L'; - } - } else { - *(unsigned char *)chtemp = 'R'; - } - - dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, - &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ - iwork], &iinfo); - if (iinfo != 0) { - *info = *n + 7; - goto L120; - } - -/* Undo balancing on VL and VR, rescale */ - - if (ilvl) { - dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, & - vl[vl_offset], ldvl, &iinfo); - if (iinfo != 0) { - *info = *n + 8; - goto L120; - } - i__1 = *n; - for (jc = 1; jc <= i__1; ++jc) { - if (alphai[jc] < 0.) { - goto L50; - } - temp = 0.; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], - abs(d__1)); - temp = std::max(d__2,d__3); -/* L10: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], - abs(d__1)) + (d__2 = vl[jr + (jc + 1) * - vl_dim1], abs(d__2)); - temp = std::max(d__3,d__4); -/* L20: */ - } - } - if (temp < safmin) { - goto L50; - } - temp = 1. / temp; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vl[jr + jc * vl_dim1] *= temp; -/* L30: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vl[jr + jc * vl_dim1] *= temp; - vl[jr + (jc + 1) * vl_dim1] *= temp; -/* L40: */ - } - } -L50: - ; - } - } - if (ilvr) { - dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, & - vr[vr_offset], ldvr, &iinfo); - if (iinfo != 0) { - *info = *n + 9; - goto L120; - } - i__1 = *n; - for (jc = 1; jc <= i__1; ++jc) { - if (alphai[jc] < 0.) { - goto L100; - } - temp = 0.; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], - abs(d__1)); - temp = std::max(d__2,d__3); -/* L60: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], - abs(d__1)) + (d__2 = vr[jr + (jc + 1) * - vr_dim1], abs(d__2)); - temp = std::max(d__3,d__4); -/* L70: */ - } - } - if (temp < safmin) { - goto L100; - } - temp = 1. / temp; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + jc * vr_dim1] *= temp; -/* L80: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + jc * vr_dim1] *= temp; - vr[jr + (jc + 1) * vr_dim1] *= temp; -/* L90: */ - } - } -L100: - ; - } - } - -/* End of eigenvector calculation */ - - } - -/* Undo scaling in alpha, beta */ - -/* Note: this does not give the alpha and beta for the unscaled */ -/* problem. */ - -/* Un-scaling is limited to avoid underflow in alpha and beta */ -/* if they are significant. */ - - i__1 = *n; - for (jc = 1; jc <= i__1; ++jc) { - absar = (d__1 = alphar[jc], abs(d__1)); - absai = (d__1 = alphai[jc], abs(d__1)); - absb = (d__1 = beta[jc], abs(d__1)); - salfar = anrm * alphar[jc]; - salfai = anrm * alphai[jc]; - sbeta = bnrm * beta[jc]; - ilimit = false; - scale = 1.; - -/* Check for significant underflow in ALPHAI */ - -/* Computing MAX */ - d__1 = safmin, d__2 = eps * absar, d__1 = std::max(d__1,d__2), d__2 = eps * - absb; - if (abs(salfai) < safmin && absai >= std::max(d__1,d__2)) { - ilimit = true; -/* Computing MAX */ - d__1 = onepls * safmin, d__2 = anrm2 * absai; - scale = onepls * safmin / anrm1 / std::max(d__1,d__2); - - } else if (salfai == 0.) { - -/* If insignificant underflow in ALPHAI, then make the */ -/* conjugate eigenvalue real. */ - - if (alphai[jc] < 0. && jc > 1) { - alphai[jc - 1] = 0.; - } else if (alphai[jc] > 0. && jc < *n) { - alphai[jc + 1] = 0.; - } - } - -/* Check for significant underflow in ALPHAR */ - -/* Computing MAX */ - d__1 = safmin, d__2 = eps * absai, d__1 = std::max(d__1,d__2), d__2 = eps * - absb; - if (abs(salfar) < safmin && absar >= std::max(d__1,d__2)) { - ilimit = true; -/* Computing MAX */ -/* Computing MAX */ - d__3 = onepls * safmin, d__4 = anrm2 * absar; - d__1 = scale, d__2 = onepls * safmin / anrm1 / std::max(d__3,d__4); - scale = std::max(d__1,d__2); - } - -/* Check for significant underflow in BETA */ - -/* Computing MAX */ - d__1 = safmin, d__2 = eps * absar, d__1 = std::max(d__1,d__2), d__2 = eps * - absai; - if (abs(sbeta) < safmin && absb >= std::max(d__1,d__2)) { - ilimit = true; -/* Computing MAX */ -/* Computing MAX */ - d__3 = onepls * safmin, d__4 = bnrm2 * absb; - d__1 = scale, d__2 = onepls * safmin / bnrm1 / std::max(d__3,d__4); - scale = std::max(d__1,d__2); - } - -/* Check for possible overflow when limiting scaling */ - - if (ilimit) { -/* Computing MAX */ - d__1 = abs(salfar), d__2 = abs(salfai), d__1 = std::max(d__1,d__2), - d__2 = abs(sbeta); - temp = scale * safmin * std::max(d__1,d__2); - if (temp > 1.) { - scale /= temp; - } - if (scale < 1.) { - ilimit = false; - } - } - -/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */ - - if (ilimit) { - salfar = scale * alphar[jc] * anrm; - salfai = scale * alphai[jc] * anrm; - sbeta = scale * beta[jc] * bnrm; - } - alphar[jc] = salfar; - alphai[jc] = salfai; - beta[jc] = sbeta; -/* L110: */ - } - -L120: - work[1] = (double) lwkopt; - - return 0; - -/* End of DGEGV */ - -} /* dgegv_ */ diff --git a/external/clapack/lapack/dgehd2.cpp b/external/clapack/lapack/dgehd2.cpp deleted file mode 100644 index dffee450..00000000 --- a/external/clapack/lapack/dgehd2.cpp +++ /dev/null @@ -1,174 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgehd2_(integer *n, integer *ilo, integer *ihi, - double *a, integer *lda, double *tau, double *work, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - double aii; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by */ -/* an orthogonal similarity transformation: Q' * A * Q = H . */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* It is assumed that A is already upper triangular in rows */ -/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ -/* set by a previous call to DGEBAL; otherwise they should be */ -/* set to 1 and N respectively. See Further Details. */ -/* 1 <= ILO <= IHI <= max(1,N). */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the n by n general matrix to be reduced. */ -/* On exit, the upper triangle and the first subdiagonal of A */ -/* are overwritten with the upper Hessenberg matrix H, and the */ -/* elements below the first subdiagonal, 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,N). */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* 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 (ihi-ilo) elementary */ -/* reflectors */ - -/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ - -/* 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */ -/* exit in A(i+2:ihi,i), and tau in TAU(i). */ - -/* The contents of A are illustrated by the following example, with */ -/* n = 7, ilo = 2 and ihi = 6: */ - -/* on entry, on exit, */ - -/* ( a a a a a a a ) ( a a h h h h a ) */ -/* ( a a a a a a ) ( a h h h h a ) */ -/* ( a a a a a a ) ( h h h h h h ) */ -/* ( a a a a a a ) ( v2 h h h h h ) */ -/* ( a a a a a a ) ( v2 v3 h h h h ) */ -/* ( a a a a a a ) ( v2 v3 v4 h h h ) */ -/* ( a ) ( a ) */ - -/* where a denotes an element of the original matrix A, h denotes a */ -/* modified element of the upper Hessenberg matrix H, and vi denotes an */ -/* element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*ilo < 1 || *ilo > std::max(1_integer,*n)) { - *info = -2; - } else if (*ihi < std::min(*ilo,*n) || *ihi > *n) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEHD2", &i__1); - return 0; - } - - i__1 = *ihi - 1; - for (i__ = *ilo; i__ <= i__1; ++i__) { - -/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */ - - i__2 = *ihi - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *n)+ i__ * - a_dim1], &c__1, &tau[i__]); - aii = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.; - -/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */ - - i__2 = *ihi - i__; - dlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ - i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]); - -/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */ - - i__2 = *ihi - i__; - i__3 = *n - i__; - dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ - i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]); - - a[i__ + 1 + i__ * a_dim1] = aii; -/* L10: */ - } - - return 0; - -/* End of DGEHD2 */ - -} /* dgehd2_ */ diff --git a/external/clapack/lapack/dgehrd.cpp b/external/clapack/lapack/dgehrd.cpp deleted file mode 100644 index 6e613e68..00000000 --- a/external/clapack/lapack/dgehrd.cpp +++ /dev/null @@ -1,314 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; -static integer c__65 = 65; -static double c_b25 = -1.; -static double c_b26 = 1.; - -/* Subroutine */ int dgehrd_(integer *n, integer *ilo, integer *ihi, - double *a, integer *lda, double *tau, double *work, - integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j; - double t[4160] /* was [65][64] */; - integer ib; - double ei; - integer nb, nh, nx, iws; - integer nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEHRD reduces a real general matrix A to upper Hessenberg form H by */ -/* an orthogonal similarity transformation: Q' * A * Q = H . */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* It is assumed that A is already upper triangular in rows */ -/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ -/* set by a previous call to DGEBAL; otherwise they should be */ -/* set to 1 and N respectively. See Further Details. */ -/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the N-by-N general matrix to be reduced. */ -/* On exit, the upper triangle and the first subdiagonal of A */ -/* are overwritten with the upper Hessenberg matrix H, and the */ -/* elements below the first subdiagonal, 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,N). */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */ -/* zero. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of the array WORK. LWORK >= max(1,N). */ -/* For optimum performance LWORK >= N*NB, where NB is the */ -/* optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* 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 (ihi-ilo) elementary */ -/* reflectors */ - -/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ - -/* 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */ -/* exit in A(i+2:ihi,i), and tau in TAU(i). */ - -/* The contents of A are illustrated by the following example, with */ -/* n = 7, ilo = 2 and ihi = 6: */ - -/* on entry, on exit, */ - -/* ( a a a a a a a ) ( a a h h h h a ) */ -/* ( a a a a a a ) ( a h h h h a ) */ -/* ( a a a a a a ) ( h h h h h h ) */ -/* ( a a a a a a ) ( v2 h h h h h ) */ -/* ( a a a a a a ) ( v2 v3 h h h h ) */ -/* ( a a a a a a ) ( v2 v3 v4 h h h ) */ -/* ( a ) ( a ) */ - -/* where a denotes an element of the original matrix A, h denotes a */ -/* modified element of the upper Hessenberg matrix H, and vi denotes an */ -/* element of the vector defining H(i). */ - -/* This file is a slight modification of LAPACK-3.0's DGEHRD */ -/* subroutine incorporating improvements proposed by Quintana-Orti and */ -/* Van de Geijn (2005). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; -/* Computing MIN */ - i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1); - nb = std::min(i__1,i__2); - lwkopt = *n * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*n < 0) { - *info = -1; - } else if (*ilo < 1 || *ilo > std::max(1_integer,*n)) { - *info = -2; - } else if (*ihi < std::min(*ilo,*n) || *ihi > *n) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*lwork < std::max(1_integer,*n) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEHRD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */ - - i__1 = *ilo - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - tau[i__] = 0.; -/* L10: */ - } - i__1 = *n - 1; - for (i__ = std::max(1_integer,*ihi); i__ <= i__1; ++i__) { - tau[i__] = 0.; -/* L20: */ - } - -/* Quick return if possible */ - - nh = *ihi - *ilo + 1; - if (nh <= 1) { - work[1] = 1.; - return 0; - } - -/* Determine the block size */ - -/* Computing MIN */ - i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1); - nb = std::min(i__1,i__2); - nbmin = 2; - iws = 1; - if (nb > 1 && nb < nh) { - -/* Determine when to cross over from blocked to unblocked code */ -/* (last block is always handled by unblocked code) */ - -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, "DGEHRD", " ", n, ilo, ihi, &c_n1); - nx = std::max(i__1,i__2); - if (nx < nh) { - -/* Determine if workspace is large enough for blocked code */ - - iws = *n * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: determine the */ -/* minimum value of NB, and reduce NB or force use of */ -/* unblocked code */ - -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGEHRD", " ", n, ilo, ihi, & - c_n1); - nbmin = std::max(i__1,i__2); - if (*lwork >= *n * nbmin) { - nb = *lwork / *n; - } else { - nb = 1; - } - } - } - } - ldwork = *n; - - if (nb < nbmin || nb >= nh) { - -/* Use unblocked code below */ - - i__ = *ilo; - - } else { - -/* Use blocked code */ - - i__1 = *ihi - 1 - nx; - i__2 = nb; - for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *ihi - i__; - ib = std::min(i__3,i__4); - -/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */ -/* matrices V and T of the block reflector H = I - V*T*V' */ -/* which performs the reduction, and also the matrix Y = A*V*T */ - - dlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, & - c__65, &work[1], &ldwork); - -/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */ -/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */ -/* to 1 */ - - ei = a[i__ + ib + (i__ + ib - 1) * a_dim1]; - a[i__ + ib + (i__ + ib - 1) * a_dim1] = 1.; - i__3 = *ihi - i__ - ib + 1; - dgemm_("No transpose", "Transpose", ihi, &i__3, &ib, &c_b25, & - work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, & - c_b26, &a[(i__ + ib) * a_dim1 + 1], lda); - a[i__ + ib + (i__ + ib - 1) * a_dim1] = ei; - -/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */ -/* right */ - - i__3 = ib - 1; - dtrmm_("Right", "Lower", "Transpose", "Unit", &i__, &i__3, &c_b26, - &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &ldwork); - i__3 = ib - 2; - for (j = 0; j <= i__3; ++j) { - daxpy_(&i__, &c_b25, &work[ldwork * j + 1], &c__1, &a[(i__ + - j + 1) * a_dim1 + 1], &c__1); -/* L30: */ - } - -/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */ -/* left */ - - i__3 = *ihi - i__; - i__4 = *n - i__ - ib + 1; - dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, & - i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &c__65, &a[ - i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &ldwork); -/* L40: */ - } - } - -/* Use unblocked code to reduce the rest of the matrix */ - - dgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo); - work[1] = (double) iws; - - return 0; - -/* End of DGEHRD */ - -} /* dgehrd_ */ diff --git a/external/clapack/lapack/dgelq2.cpp b/external/clapack/lapack/dgelq2.cpp deleted file mode 100644 index 1005c825..00000000 --- a/external/clapack/lapack/dgelq2.cpp +++ /dev/null @@ -1,140 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgelq2_(integer *m, integer *n, double *a, integer * - lda, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, k; - double aii; - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGELQ2 computes an LQ factorization of a real m by n matrix A: */ -/* A = L * Q. */ - -/* 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 below the diagonal of the array */ -/* contain the m by min(m,n) lower trapezoidal matrix L (L is */ -/* lower triangular if m <= n); the elements above 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 (M) */ - -/* 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(k) . . . H(2) H(1), 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:n) is stored on exit in A(i,i+1:n), */ -/* and tau in TAU(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELQ2", &i__1); - return 0; - } - - k = std::min(*m,*n); - - i__1 = k; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */ - - i__2 = *n - i__ + 1; -/* Computing MIN */ - i__3 = i__ + 1; - dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + std::min(i__3, *n)* a_dim1] -, lda, &tau[i__]); - if (i__ < *m) { - -/* Apply H(i) to A(i+1:m,i:n) from the right */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - i__2 = *m - i__; - i__3 = *n - i__ + 1; - dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ - i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); - a[i__ + i__ * a_dim1] = aii; - } -/* L10: */ - } - return 0; - -/* End of DGELQ2 */ - -} /* dgelq2_ */ diff --git a/external/clapack/lapack/dgelqf.cpp b/external/clapack/lapack/dgelqf.cpp deleted file mode 100644 index 85466c3f..00000000 --- a/external/clapack/lapack/dgelqf.cpp +++ /dev/null @@ -1,231 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dgelqf_(integer *m, integer *n, double *a, integer * - lda, double *tau, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, k, ib, nb, nx, iws, nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGELQF computes an LQ factorization of a real M-by-N matrix A: */ -/* A = L * Q. */ - -/* 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 below the diagonal of the array */ -/* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */ -/* lower triangular if m <= n); the elements above 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,M). */ -/* For optimum performance LWORK >= M*NB, where NB is the */ -/* optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* 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(k) . . . H(2) H(1), 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:n) is stored on exit in A(i,i+1:n), */ -/* and tau in TAU(i). */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1); - lwkopt = *m * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } else if (*lwork < std::max(1_integer,*m) && ! lquery) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELQF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - k = std::min(*m,*n); - if (k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - nx = 0; - iws = *m; - if (nb > 1 && nb < k) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1); - nx = std::max(i__1,i__2); - if (nx < k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, & - c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < k && nx < k) { - -/* Use blocked code initially */ - - i__1 = k - nx; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = k - i__ + 1; - ib = std::min(i__3,nb); - -/* Compute the LQ factorization of the current block */ -/* A(i:i+ib-1,i:n) */ - - i__3 = *n - i__ + 1; - dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ - 1], &iinfo); - if (i__ + ib <= *m) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__3 = *n - i__ + 1; - dlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork); - -/* Apply H to A(i+ib:m,i:n) from the right */ - - i__3 = *m - i__ - ib + 1; - i__4 = *n - i__ + 1; - dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, - &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & - ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + - 1], &ldwork); - } -/* L10: */ - } - } else { - i__ = 1; - } - -/* Use unblocked code to factor the last or only block. */ - - if (i__ <= k) { - i__2 = *m - i__ + 1; - i__1 = *n - i__ + 1; - dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] -, &iinfo); - } - - work[1] = (double) iws; - return 0; - -/* End of DGELQF */ - -} /* dgelqf_ */ diff --git a/external/clapack/lapack/dgels.cpp b/external/clapack/lapack/dgels.cpp deleted file mode 100644 index f29224e1..00000000 --- a/external/clapack/lapack/dgels.cpp +++ /dev/null @@ -1,480 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b33 = 0.; -static integer c__0 = 0; - -/* Subroutine */ int dgels_(const char *trans, integer *m, integer *n, integer * - nrhs, double *a, integer *lda, double *b, integer *ldb, - double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, nb, mn; - double anrm, bnrm; - integer brow; - bool tpsd; - integer iascl, ibscl; - integer wsize; - double rwork[1]; - integer scllen; - double bignum; - double smlnum; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGELS solves overdetermined or underdetermined real linear systems */ -/* involving an M-by-N matrix A, or its transpose, using a QR or LQ */ -/* factorization of A. It is assumed that A has full rank. */ - -/* The following options are provided: */ - -/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */ -/* an overdetermined system, i.e., solve the least squares problem */ -/* minimize || B - A*X ||. */ - -/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */ -/* an underdetermined system A * X = B. */ - -/* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of */ -/* an undetermined system A**T * X = B. */ - -/* 4. If TRANS = 'T' and m < n: find the least squares solution of */ -/* an overdetermined system, i.e., solve the least squares problem */ -/* minimize || B - A**T * X ||. */ - -/* Several right hand side vectors b and solution vectors x can be */ -/* handled in a single call; they are stored as the columns of the */ -/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ -/* matrix X. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': the linear system involves A; */ -/* = 'T': the linear system involves A**T. */ - -/* 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. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of */ -/* columns of the matrices B and X. NRHS >=0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, */ -/* if M >= N, A is overwritten by details of its QR */ -/* factorization as returned by DGEQRF; */ -/* if M < N, A is overwritten by details of its LQ */ -/* factorization as returned by DGELQF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the matrix B of right hand side vectors, stored */ -/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */ -/* if TRANS = 'T'. */ -/* On exit, if INFO = 0, B is overwritten by the solution */ -/* vectors, stored columnwise: */ -/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */ -/* squares solution vectors; the residual sum of squares for the */ -/* solution in each column is given by the sum of squares of */ -/* elements N+1 to M in that column; */ -/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */ -/* minimum norm solution vectors; */ -/* if TRANS = 'T' and m >= n, rows 1 to M of B contain the */ -/* minimum norm solution vectors; */ -/* if TRANS = 'T' and m < n, rows 1 to M of B contain the */ -/* least squares solution vectors; the residual sum of squares */ -/* for the solution in each column is given by the sum of */ -/* squares of elements M+1 to N in that column. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= MAX(1,M,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* LWORK >= max( 1, MN + max( MN, NRHS ) ). */ -/* For optimal performance, */ -/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */ -/* where MN = min(M,N) and NB is the optimum block size. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element of the */ -/* triangular factor of A is zero, so that A does not have */ -/* full rank; the least squares solution could not be */ -/* computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --work; - - /* Function Body */ - *info = 0; - mn = std::min(*m,*n); - lquery = *lwork == -1; - if (! (lsame_(trans, "N") || lsame_(trans, "T"))) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*m)) { - *info = -6; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = std::max(1_integer,*m); - if (*ldb < std::max(i__1,*n)) { - *info = -8; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = 1, i__2 = mn + std::max(mn,*nrhs); - if (*lwork < std::max(i__1,i__2) && ! lquery) { - *info = -10; - } - } - } - -/* Figure out optimal block size */ - - if (*info == 0 || *info == -10) { - - tpsd = true; - if (lsame_(trans, "N")) { - tpsd = false; - } - - if (*m >= *n) { - nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); - if (tpsd) { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, & - c_n1); - nb = std::max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, & - c_n1); - nb = std::max(i__1,i__2); - } - } else { - nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1); - if (tpsd) { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, & - c_n1); - nb = std::max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, & - c_n1); - nb = std::max(i__1,i__2); - } - } - -/* Computing MAX */ - i__1 = 1, i__2 = mn + std::max(mn,*nrhs) * nb; - wsize = std::max(i__1,i__2); - work[1] = (double) wsize; - - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELS ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - -/* Computing MIN */ - i__1 = std::min(*m,*n); - if (std::min(i__1,*nrhs) == 0) { - i__1 = std::max(*m,*n); - dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb); - return 0; - } - -/* Get machine parameters */ - - smlnum = dlamch_("S") / dlamch_("P"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, rwork); - iascl = 0; - if (anrm > 0. && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info); - iascl = 1; - } else if (anrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = std::max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb); - goto L50; - } - - brow = *m; - if (tpsd) { - brow = *n; - } - bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork); - ibscl = 0; - if (bnrm > 0. && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], - ldb, info); - ibscl = 1; - } else if (bnrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], - ldb, info); - ibscl = 2; - } - - if (*m >= *n) { - -/* compute QR factorization of A */ - - i__1 = *lwork - mn; - dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) - ; - -/* workspace at least N, optimally N*NB */ - - if (! tpsd) { - -/* Least-Squares Problem min || A * X - B || */ - -/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ - - i__1 = *lwork - mn; - dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[ - 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); - -/* workspace at least NRHS, optimally NRHS*NB */ - -/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */ - - dtrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset] -, lda, &b[b_offset], ldb, info); - - if (*info > 0) { - return 0; - } - - scllen = *n; - - } else { - -/* Overdetermined system of equations A' * X = B */ - -/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */ - - dtrtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset], - lda, &b[b_offset], ldb, info); - - if (*info > 0) { - return 0; - } - -/* B(N+1:M,1:NRHS) = ZERO */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = *n + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - -/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */ - - i__1 = *lwork - mn; - dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, & - work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); - -/* workspace at least NRHS, optimally NRHS*NB */ - - scllen = *m; - - } - - } else { - -/* Compute LQ factorization of A */ - - i__1 = *lwork - mn; - dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) - ; - -/* workspace at least M, optimally M*NB. */ - - if (! tpsd) { - -/* underdetermined system of equations A * X = B */ - -/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */ - - dtrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset] -, lda, &b[b_offset], ldb, info); - - if (*info > 0) { - return 0; - } - -/* B(M+1:N,1:NRHS) = 0 */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = *m + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - -/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */ - - i__1 = *lwork - mn; - dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[ - 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); - -/* workspace at least NRHS, optimally NRHS*NB */ - - scllen = *n; - - } else { - -/* overdetermined system min || A' * X - B || */ - -/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */ - - i__1 = *lwork - mn; - dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, & - work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); - -/* workspace at least NRHS, optimally NRHS*NB */ - -/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */ - - dtrtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset], - lda, &b[b_offset], ldb, info); - - if (*info > 0) { - return 0; - } - - scllen = *m; - - } - - } - -/* Undo scaling */ - - if (iascl == 1) { - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset] -, ldb, info); - } else if (iascl == 2) { - dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset] -, ldb, info); - } - if (ibscl == 1) { - dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset] -, ldb, info); - } else if (ibscl == 2) { - dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset] -, ldb, info); - } - -L50: - work[1] = (double) wsize; - - return 0; - -/* End of DGELS */ - -} /* dgels_ */ diff --git a/external/clapack/lapack/dgelsd.cpp b/external/clapack/lapack/dgelsd.cpp deleted file mode 100644 index 97abd96f..00000000 --- a/external/clapack/lapack/dgelsd.cpp +++ /dev/null @@ -1,652 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__6 = 6; -static integer c_n1 = -1; -static integer c__9 = 9; -static integer c__0 = 0; -static integer c__1 = 1; -static double c_b82 = 0.; - -int dgelsd_(integer *m, integer *n, integer *nrhs, - double *a, integer *lda, double *b, integer *ldb, double * - s, double *rcond, integer *rank, double *work, integer *lwork, - integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; - - /* Builtin functions - double log(double); */ - - /* Local variables */ - integer ie, il, mm; - double eps, anrm, bnrm; - integer itau, nlvl, iascl, ibscl; - double sfmin; - integer minmn, maxmn, itaup, itauq, mnthr, nwork; - double bignum; - integer wlalsd; - integer ldwork; - integer minwrk, maxwrk; - double smlnum; - bool lquery; - integer smlsiz; - - -/* -- LAPACK driver routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGELSD computes the minimum-norm solution to a real linear least */ -/* squares problem: */ -/* minimize 2-norm(| b - A*x |) */ -/* using the singular value decomposition (SVD) of A. A is an M-by-N */ -/* matrix which may be rank-deficient. */ - -/* Several right hand side vectors b and solution vectors x can be */ -/* handled in a single call; they are stored as the columns of the */ -/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ -/* matrix X. */ - -/* The problem is solved in three steps: */ -/* (1) Reduce the coefficient matrix A to bidiagonal form with */ -/* Householder transformations, reducing the original problem */ -/* into a "bidiagonal least squares problem" (BLS) */ -/* (2) Solve the BLS using a divide and conquer approach. */ -/* (3) Apply back all the Householder tranformations to solve */ -/* the original least squares problem. */ - -/* The effective rank of A is determined by treating as zero those */ -/* singular values which are less than RCOND times the largest singular */ -/* value. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, A has been destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the M-by-NRHS right hand side matrix B. */ -/* On exit, B is overwritten by the N-by-NRHS solution */ -/* matrix X. If m >= n and RANK = n, the residual */ -/* sum-of-squares for the solution in the i-th column is given */ -/* by the sum of squares of elements n+1:m in that column. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */ - -/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The singular values of A in decreasing order. */ -/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */ - -/* RCOND (input) DOUBLE PRECISION */ -/* RCOND is used to determine the effective rank of A. */ -/* Singular values S(i) <= RCOND*S(1) are treated as zero. */ -/* If RCOND < 0, machine precision is used instead. */ - -/* RANK (output) INTEGER */ -/* The effective rank of A, i.e., the number of singular values */ -/* which are greater than RCOND*S(1). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK must be at least 1. */ -/* The exact minimum amount of workspace needed depends on M, */ -/* N and NRHS. As long as LWORK is at least */ -/* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, */ -/* if M is greater than or equal to N or */ -/* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, */ -/* if M is less than N, the code will execute correctly. */ -/* SMLSIZ is returned by ILAENV and is equal to the maximum */ -/* size of the subproblems at the bottom of the computation */ -/* tree (usually about 25), and */ -/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */ -/* For good performance, LWORK should generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, */ -/* where MINMN = MIN( M,N ). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: the algorithm for computing the SVD failed to converge; */ -/* if INFO = i, i off-diagonal elements of an intermediate */ -/* bidiagonal form did not converge to zero. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */ -/* California at Berkeley, USA */ -/* Osni Marques, LBNL/NERSC, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --s; - --work; - --iwork; - - /* Function Body */ - *info = 0; - minmn = std::min(*m,*n); - maxmn = std::max(*m,*n); - mnthr = ilaenv_(&c__6, "DGELSD", " ", m, n, nrhs, &c_n1); - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else if (*ldb < std::max(1_integer,maxmn)) { - *info = -7; - } - - smlsiz = ilaenv_(&c__9, "DGELSD", " ", &c__0, &c__0, &c__0, &c__0); - -/* Compute workspace. */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV.) */ - - minwrk = 1; - minmn = std::max(1_integer,minmn); -/* Computing MAX */ - i__1 = (integer) (log((double) minmn / (double) (smlsiz + 1)) / - log(2.)) + 1; - nlvl = std::max(i__1,0_integer); - - if (*info == 0) { - maxwrk = 0; - mm = *m; - if (*m >= *n && *m >= mnthr) { - -/* Path 1a - overdetermined, with many more rows than columns. */ - - mm = *n; -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, - n, &c_n1, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT", - m, nrhs, n, &c_n1); - maxwrk = std::max(i__1,i__2); - } - if (*m >= *n) { - -/* Path 1 - overdetermined or exactly determined. */ - -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD" -, " ", &mm, n, &c_n1, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR", - "QLT", &mm, nrhs, n, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORMBR", - "PLN", n, nrhs, n, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing 2nd power */ - i__1 = smlsiz + 1; - wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * * - nrhs + i__1 * i__1; -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + wlalsd; - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = std::max(i__1,i__2), - i__2 = *n * 3 + wlalsd; - minwrk = std::max(i__1,i__2); - } - if (*n > *m) { -/* Computing 2nd power */ - i__1 = smlsiz + 1; - wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * * - nrhs + i__1 * i__1; - if (*n >= mnthr) { - -/* Path 2a - underdetermined, with many more columns */ -/* than rows. */ - - maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, - &c_n1); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * - ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(& - c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * - ilaenv_(&c__1, "DORMBR", "PLN", m, nrhs, m, &c_n1); - maxwrk = std::max(i__1,i__2); - if (*nrhs > 1) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; - maxwrk = std::max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 1); - maxwrk = std::max(i__1,i__2); - } -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ", - "LT", n, nrhs, m, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd; - maxwrk = std::max(i__1,i__2); -/* XXX: Ensure the Path 2a case below is triggered. The workspace */ -/* calculation should use queries for all routines eventually. */ -/* Computing MAX */ -/* Computing MAX */ - i__3 = *m, i__4 = (*m << 1) - 4, i__3 = std::max(i__3,i__4), i__3 = - std::max(i__3,*nrhs), i__4 = *n - *m * 3; - i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + std::max(i__3,i__4); - maxwrk = std::max(i__1,i__2); - } else { - -/* Path 2 - remaining underdetermined cases. */ - - maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m, - n, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR" -, "QLT", m, nrhs, n, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR", - "PLN", n, nrhs, m, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + wlalsd; - maxwrk = std::max(i__1,i__2); - } -/* Computing MAX */ - i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = std::max(i__1,i__2), - i__2 = *m * 3 + wlalsd; - minwrk = std::max(i__1,i__2); - } - minwrk = std::min(minwrk,maxwrk); - work[1] = (double) maxwrk; - if (*lwork < minwrk && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELSD", &i__1); - return 0; - } else if (lquery) { - goto L10; - } - -/* Quick return if possible. */ - - if (*m == 0 || *n == 0) { - *rank = 0; - return 0; - } - -/* Get machine parameters. */ - - eps = dlamch_("P"); - sfmin = dlamch_("S"); - smlnum = sfmin / eps; - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); - iascl = 0; - if (anrm > 0. && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM. */ - - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info); - iascl = 1; - } else if (anrm > bignum) { - -/* Scale matrix norm down to BIGNUM. */ - - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = std::max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb); - dlaset_("F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1); - *rank = 0; - goto L10; - } - -/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */ - - bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); - ibscl = 0; - if (bnrm > 0. && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM. */ - - dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 1; - } else if (bnrm > bignum) { - -/* Scale matrix norm down to BIGNUM. */ - - dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 2; - } - -/* If M < N make sure certain entries of B are zero. */ - - if (*m < *n) { - i__1 = *n - *m; - dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb); - } - -/* Overdetermined case. */ - - if (*m >= *n) { - -/* Path 1 - overdetermined or exactly determined. */ - - mm = *m; - if (*m >= mnthr) { - -/* Path 1a - overdetermined, with many more rows than columns. */ - - mm = *n; - itau = 1; - nwork = itau + *n; - -/* Compute A=Q*R. */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, - info); - -/* Multiply B by transpose(Q). */ -/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */ - - i__1 = *lwork - nwork + 1; - dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[nwork], &i__1, info); - -/* Zero out below R. */ - - if (*n > 1) { - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_("L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2], - lda); - } - } - - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in A. */ -/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__1, info); - -/* Multiply B by transpose of left bidiagonalizing vectors of R. */ -/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], - &b[b_offset], ldb, &work[nwork], &i__1, info); - -/* Solve the bidiagonal least squares problem. */ - - dlalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, - rcond, rank, &work[nwork], &iwork[1], info); - if (*info != 0) { - goto L10; - } - -/* Multiply B by right bidiagonalizing vectors of R. */ - - i__1 = *lwork - nwork + 1; - dormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], & - b[b_offset], ldb, &work[nwork], &i__1, info); - - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = *m, i__2 = (*m << 1) - 4, i__1 = std::max(i__1,i__2), i__1 = std::max( - i__1,*nrhs), i__2 = *n - *m * 3, i__1 = std::max(i__1,i__2); - if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + std::max(i__1,wlalsd)) { - -/* Path 2a - underdetermined, with many more columns than rows */ -/* and sufficient workspace for an efficient algorithm. */ - - ldwork = *m; -/* Computing MAX */ -/* Computing MAX */ - i__3 = *m, i__4 = (*m << 1) - 4, i__3 = std::max(i__3,i__4), i__3 = - std::max(i__3,*nrhs), i__4 = *n - *m * 3; - i__1 = (*m << 2) + *m * *lda + std::max(i__3,i__4), i__2 = *m * *lda + - *m + *m * *nrhs, i__1 = std::max(i__1,i__2), i__2 = (*m << 2) - + *m * *lda + wlalsd; - if (*lwork >= std::max(i__1,i__2)) { - ldwork = *lda; - } - itau = 1; - nwork = *m + 1; - -/* Compute A=L*Q. */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, - info); - il = nwork; - -/* Copy L to WORK(IL), zeroing out above its diagonal. */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); - i__1 = *m - 1; - i__2 = *m - 1; - dlaset_("U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], & - ldwork); - ie = il + ldwork * *m; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in WORK(IL). */ -/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], - &work[itaup], &work[nwork], &i__1, info); - -/* Multiply B by transpose of left bidiagonalizing vectors of L. */ -/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[ - itauq], &b[b_offset], ldb, &work[nwork], &i__1, info); - -/* Solve the bidiagonal least squares problem. */ - - dlalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], - ldb, rcond, rank, &work[nwork], &iwork[1], info); - if (*info != 0) { - goto L10; - } - -/* Multiply B by right bidiagonalizing vectors of L. */ - - i__1 = *lwork - nwork + 1; - dormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[ - itaup], &b[b_offset], ldb, &work[nwork], &i__1, info); - -/* Zero out below first M rows of B. */ - - i__1 = *n - *m; - dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], - ldb); - nwork = itau + *m; - -/* Multiply transpose(Q) by B. */ -/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */ - - i__1 = *lwork - nwork + 1; - dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[nwork], &i__1, info); - - } else { - -/* Path 2 - remaining underdetermined cases. */ - - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize A. */ -/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__1, info); - -/* Multiply B by transpose of left bidiagonalizing vectors. */ -/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq] -, &b[b_offset], ldb, &work[nwork], &i__1, info); - -/* Solve the bidiagonal least squares problem. */ - - dlalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], - ldb, rcond, rank, &work[nwork], &iwork[1], info); - if (*info != 0) { - goto L10; - } - -/* Multiply B by right bidiagonalizing vectors of A. */ - - i__1 = *lwork - nwork + 1; - dormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup] -, &b[b_offset], ldb, &work[nwork], &i__1, info); - - } - } - -/* Undo scaling. */ - - if (iascl == 1) { - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, info); - } else if (iascl == 2) { - dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, info); - } - if (ibscl == 1) { - dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } else if (ibscl == 2) { - dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } - -L10: - work[1] = (double) maxwrk; - return 0; - -/* End of DGELSD */ - -} /* dgelsd_ */ diff --git a/external/clapack/lapack/dgelss.cpp b/external/clapack/lapack/dgelss.cpp deleted file mode 100644 index 77df9636..00000000 --- a/external/clapack/lapack/dgelss.cpp +++ /dev/null @@ -1,776 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__6 = 6; -static integer c_n1 = -1; -static integer c__1 = 1; -static integer c__0 = 0; -static double c_b74 = 0.; -static double c_b108 = 1.; - -/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs, - double *a, integer *lda, double *b, integer *ldb, double * - s, double *rcond, integer *rank, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; - double d__1; - - /* Local variables */ - integer i__, bl, ie, il, mm; - double eps, thr, anrm, bnrm; - integer itau; - double vdum[1]; - integer iascl, ibscl; - integer chunk; - double sfmin; - integer minmn; - integer maxmn, itaup, itauq, mnthr, iwork; - integer bdspac; - double bignum; - integer ldwork; - integer minwrk, maxwrk; - double smlnum; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGELSS computes the minimum norm solution to a real linear least */ -/* squares problem: */ - -/* Minimize 2-norm(| b - A*x |). */ - -/* using the singular value decomposition (SVD) of A. A is an M-by-N */ -/* matrix which may be rank-deficient. */ - -/* Several right hand side vectors b and solution vectors x can be */ -/* handled in a single call; they are stored as the columns of the */ -/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix */ -/* X. */ - -/* The effective rank of A is determined by treating as zero those */ -/* singular values which are less than RCOND times the largest singular */ -/* value. */ - -/* 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. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, the first min(m,n) rows of A are overwritten with */ -/* its right singular vectors, stored rowwise. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the M-by-NRHS right hand side matrix B. */ -/* On exit, B is overwritten by the N-by-NRHS solution */ -/* matrix X. If m >= n and RANK = n, the residual */ -/* sum-of-squares for the solution in the i-th column is given */ -/* by the sum of squares of elements n+1:m in that column. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */ - -/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The singular values of A in decreasing order. */ -/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */ - -/* RCOND (input) DOUBLE PRECISION */ -/* RCOND is used to determine the effective rank of A. */ -/* Singular values S(i) <= RCOND*S(1) are treated as zero. */ -/* If RCOND < 0, machine precision is used instead. */ - -/* RANK (output) INTEGER */ -/* The effective rank of A, i.e., the number of singular values */ -/* which are greater than RCOND*S(1). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= 1, and also: */ -/* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) */ -/* For good performance, LWORK should generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: the algorithm for computing the SVD failed to converge; */ -/* if INFO = i, i off-diagonal elements of an intermediate */ -/* bidiagonal form did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --s; - --work; - - /* Function Body */ - *info = 0; - minmn = std::min(*m,*n); - maxmn = std::max(*m,*n); - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else if (*ldb < std::max(1_integer,maxmn)) { - *info = -7; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV.) */ - - if (*info == 0) { - minwrk = 1; - maxwrk = 1; - if (minmn > 0) { - mm = *m; - mnthr = ilaenv_(&c__6, "DGELSS", " ", m, n, nrhs, &c_n1); - if (*m >= *n && *m >= mnthr) { - -/* Path 1a - overdetermined, with many more rows than */ -/* columns */ - - mm = *n; -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", - " ", m, n, &c_n1, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", - "LT", m, nrhs, n, &c_n1); - maxwrk = std::max(i__1,i__2); - } - if (*m >= *n) { - -/* Path 1 - overdetermined or exactly determined */ - -/* Compute workspace needed for DBDSQR */ - -/* Computing MAX */ - i__1 = 1, i__2 = *n * 5; - bdspac = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, - "DGEBRD", " ", &mm, n, &c_n1, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR" -, "QLT", &mm, nrhs, n, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, - "DORGBR", "P", n, n, n, &c_n1); - maxwrk = std::max(i__1,i__2); - maxwrk = std::max(maxwrk,bdspac); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * *nrhs; - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = std::max(i__1, - i__2); - minwrk = std::max(i__1,bdspac); - maxwrk = std::max(minwrk,maxwrk); - } - if (*n > *m) { - -/* Compute workspace needed for DBDSQR */ - -/* Computing MAX */ - i__1 = 1, i__2 = *m * 5; - bdspac = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = std::max(i__1, - i__2); - minwrk = std::max(i__1,bdspac); - if (*n >= mnthr) { - -/* Path 2a - underdetermined, with many more columns */ -/* than rows */ - - maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * - ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * - ilaenv_(&c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * - ilaenv_(&c__1, "DORGBR", "P", m, m, m, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + *m + bdspac; - maxwrk = std::max(i__1,i__2); - if (*nrhs > 1) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; - maxwrk = std::max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 1); - maxwrk = std::max(i__1,i__2); - } -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ" -, "LT", n, nrhs, m, &c_n1); - maxwrk = std::max(i__1,i__2); - } else { - -/* Path 2 - underdetermined */ - - maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", - " ", m, n, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, - "DORMBR", "QLT", m, nrhs, m, &c_n1); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORG" - "BR", "P", m, n, m, &c_n1); - maxwrk = std::max(i__1,i__2); - maxwrk = std::max(maxwrk,bdspac); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * *nrhs; - maxwrk = std::max(i__1,i__2); - } - } - maxwrk = std::max(minwrk,maxwrk); - } - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELSS", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - *rank = 0; - return 0; - } - -/* Get machine parameters */ - - eps = dlamch_("P"); - sfmin = dlamch_("S"); - smlnum = sfmin / eps; - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); - iascl = 0; - if (anrm > 0. && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info); - iascl = 1; - } else if (anrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = std::max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[b_offset], ldb); - dlaset_("F", &minmn, &c__1, &c_b74, &c_b74, &s[1], &c__1); - *rank = 0; - goto L70; - } - -/* Scale B if max element outside range [SMLNUM,BIGNUM] */ - - bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); - ibscl = 0; - if (bnrm > 0. && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 1; - } else if (bnrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 2; - } - -/* Overdetermined case */ - - if (*m >= *n) { - -/* Path 1 - overdetermined or exactly determined */ - - mm = *m; - if (*m >= mnthr) { - -/* Path 1a - overdetermined, with many more rows than columns */ - - mm = *n; - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__1 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, - info); - -/* Multiply B by transpose(Q) */ -/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */ - - i__1 = *lwork - iwork + 1; - dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[iwork], &i__1, info); - -/* Zero out below R */ - - if (*n > 1) { - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_("L", &i__1, &i__2, &c_b74, &c_b74, &a[a_dim1 + 2], - lda); - } - } - - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in A */ -/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */ - - i__1 = *lwork - iwork + 1; - dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__1, info); - -/* Multiply B by transpose of left bidiagonalizing vectors of R */ -/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */ - - i__1 = *lwork - iwork + 1; - dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], - &b[b_offset], ldb, &work[iwork], &i__1, info); - -/* Generate right bidiagonalizing vectors of R in A */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__1 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], & - i__1, info); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration */ -/* multiply B by transpose of left singular vectors */ -/* compute right singular vectors in A */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda, - vdum, &c__1, &b[b_offset], ldb, &work[iwork], info) - ; - if (*info != 0) { - goto L70; - } - -/* Multiply B by reciprocals of singular values */ - -/* Computing MAX */ - d__1 = *rcond * s[1]; - thr = std::max(d__1,sfmin); - if (*rcond < 0.) { -/* Computing MAX */ - d__1 = eps * s[1]; - thr = std::max(d__1,sfmin); - } - *rank = 0; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); - ++(*rank); - } else { - dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1], - ldb); - } -/* L10: */ - } - -/* Multiply B by right singular vectors */ -/* (Workspace: need N, prefer N*NRHS) */ - - if (*lwork >= *ldb * *nrhs && *nrhs > 1) { - dgemm_("T", "N", n, nrhs, n, &c_b108, &a[a_offset], lda, &b[ - b_offset], ldb, &c_b74, &work[1], ldb); - dlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb) - ; - } else if (*nrhs > 1) { - chunk = *lwork / *n; - i__1 = *nrhs; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = std::min(i__3,chunk); - dgemm_("T", "N", n, &bl, n, &c_b108, &a[a_offset], lda, &b[ - i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n); - dlacpy_("G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb); -/* L20: */ - } - } else { - dgemv_("T", n, n, &c_b108, &a[a_offset], lda, &b[b_offset], &c__1, - &c_b74, &work[1], &c__1); - dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); - } - - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__2 = *m, i__1 = (*m << 1) - 4, i__2 = std::max(i__2,i__1), i__2 = std::max( - i__2,*nrhs), i__1 = *n - *m * 3; - if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + std::max(i__2,i__1)) { - -/* Path 2a - underdetermined, with many more columns than rows */ -/* and sufficient workspace for an efficient algorithm */ - - ldwork = *m; -/* Computing MAX */ -/* Computing MAX */ - i__3 = *m, i__4 = (*m << 1) - 4, i__3 = std::max(i__3,i__4), i__3 = - std::max(i__3,*nrhs), i__4 = *n - *m * 3; - i__2 = (*m << 2) + *m * *lda + std::max(i__3,i__4), i__1 = *m * *lda + - *m + *m * *nrhs; - if (*lwork >= std::max(i__2,i__1)) { - ldwork = *lda; - } - itau = 1; - iwork = *m + 1; - -/* Compute A=L*Q */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, - info); - il = iwork; - -/* Copy L to WORK(IL), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); - i__2 = *m - 1; - i__1 = *m - 1; - dlaset_("U", &i__2, &i__1, &c_b74, &c_b74, &work[il + ldwork], & - ldwork); - ie = il + ldwork * *m; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IL) */ -/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], - &work[itaup], &work[iwork], &i__2, info); - -/* Multiply B by transpose of left bidiagonalizing vectors of L */ -/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[ - itauq], &b[b_offset], ldb, &work[iwork], &i__2, info); - -/* Generate right bidiagonalizing vectors of R in WORK(IL) */ -/* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[ - iwork], &i__2, info); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, */ -/* computing right singular vectors of L in WORK(IL) and */ -/* multiplying B by transpose of left singular vectors */ -/* (Workspace: need M*M+M+BDSPAC) */ - - dbdsqr_("U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], & - ldwork, &a[a_offset], lda, &b[b_offset], ldb, &work[iwork] -, info); - if (*info != 0) { - goto L70; - } - -/* Multiply B by reciprocals of singular values */ - -/* Computing MAX */ - d__1 = *rcond * s[1]; - thr = std::max(d__1,sfmin); - if (*rcond < 0.) { -/* Computing MAX */ - d__1 = eps * s[1]; - thr = std::max(d__1,sfmin); - } - *rank = 0; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); - ++(*rank); - } else { - dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1] -, ldb); - } -/* L30: */ - } - iwork = ie; - -/* Multiply B by right singular vectors of L in WORK(IL) */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) */ - - if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { - dgemm_("T", "N", m, nrhs, m, &c_b108, &work[il], &ldwork, &b[ - b_offset], ldb, &c_b74, &work[iwork], ldb); - dlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb); - } else if (*nrhs > 1) { - chunk = (*lwork - iwork + 1) / *m; - i__2 = *nrhs; - i__1 = chunk; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { -/* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = std::min(i__3,chunk); - dgemm_("T", "N", m, &bl, m, &c_b108, &work[il], &ldwork, & - b[i__ * b_dim1 + 1], ldb, &c_b74, &work[iwork], m); - dlacpy_("G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1] -, ldb); -/* L40: */ - } - } else { - dgemv_("T", m, m, &c_b108, &work[il], &ldwork, &b[b_dim1 + 1], - &c__1, &c_b74, &work[iwork], &c__1); - dcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1); - } - -/* Zero out below first M rows of B */ - - i__1 = *n - *m; - dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[*m + 1 + b_dim1], - ldb); - iwork = itau + *m; - -/* Multiply transpose(Q) by B */ -/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */ - - i__1 = *lwork - iwork + 1; - dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[iwork], &i__1, info); - - } else { - -/* Path 2 - remaining underdetermined cases */ - - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize A */ -/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ - - i__1 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__1, info); - -/* Multiply B by transpose of left bidiagonalizing vectors */ -/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */ - - i__1 = *lwork - iwork + 1; - dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq] -, &b[b_offset], ldb, &work[iwork], &i__1, info); - -/* Generate right bidiagonalizing vectors in A */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__1 = *lwork - iwork + 1; - dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ - iwork], &i__1, info); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, */ -/* computing right singular vectors of A in A and */ -/* multiplying B by transpose of left singular vectors */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], - lda, vdum, &c__1, &b[b_offset], ldb, &work[iwork], info); - if (*info != 0) { - goto L70; - } - -/* Multiply B by reciprocals of singular values */ - -/* Computing MAX */ - d__1 = *rcond * s[1]; - thr = std::max(d__1,sfmin); - if (*rcond < 0.) { -/* Computing MAX */ - d__1 = eps * s[1]; - thr = std::max(d__1,sfmin); - } - *rank = 0; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); - ++(*rank); - } else { - dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1] -, ldb); - } -/* L50: */ - } - -/* Multiply B by right singular vectors of A */ -/* (Workspace: need N, prefer N*NRHS) */ - - if (*lwork >= *ldb * *nrhs && *nrhs > 1) { - dgemm_("T", "N", n, nrhs, m, &c_b108, &a[a_offset], lda, &b[ - b_offset], ldb, &c_b74, &work[1], ldb); - dlacpy_("F", n, nrhs, &work[1], ldb, &b[b_offset], ldb); - } else if (*nrhs > 1) { - chunk = *lwork / *n; - i__1 = *nrhs; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = std::min(i__3,chunk); - dgemm_("T", "N", n, &bl, m, &c_b108, &a[a_offset], lda, & - b[i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n); - dlacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], - ldb); -/* L60: */ - } - } else { - dgemv_("T", m, n, &c_b108, &a[a_offset], lda, &b[b_offset], & - c__1, &c_b74, &work[1], &c__1); - dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); - } - } - } - -/* Undo scaling */ - - if (iascl == 1) { - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, info); - } else if (iascl == 2) { - dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, info); - } - if (ibscl == 1) { - dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } else if (ibscl == 2) { - dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } - -L70: - work[1] = (double) maxwrk; - return 0; - -/* End of DGELSS */ - -} /* dgelss_ */ diff --git a/external/clapack/lapack/dgelsx.cpp b/external/clapack/lapack/dgelsx.cpp deleted file mode 100644 index 2202a9f3..00000000 --- a/external/clapack/lapack/dgelsx.cpp +++ /dev/null @@ -1,404 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__0 = 0; -static double c_b13 = 0.; -static integer c__2 = 2; -static integer c__1 = 1; -static double c_b36 = 1.; - -/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs, - double *a, integer *lda, double *b, integer *ldb, integer * - jpvt, double *rcond, integer *rank, double *work, integer * - info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j, k; - double c1, c2, s1, s2, t1, t2; - integer mn; - double anrm, bnrm, smin, smax; - integer iascl, ibscl, ismin, ismax; - double bignum; - double sminpr, smaxpr, smlnum; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This routine is deprecated and has been replaced by routine DGELSY. */ - -/* DGELSX computes the minimum-norm solution to a real linear least */ -/* squares problem: */ -/* minimize || A * X - B || */ -/* using a complete orthogonal factorization of A. A is an M-by-N */ -/* matrix which may be rank-deficient. */ - -/* Several right hand side vectors b and solution vectors x can be */ -/* handled in a single call; they are stored as the columns of the */ -/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ -/* matrix X. */ - -/* The routine first computes a QR factorization with column pivoting: */ -/* A * P = Q * [ R11 R12 ] */ -/* [ 0 R22 ] */ -/* with R11 defined as the largest leading submatrix whose estimated */ -/* condition number is less than 1/RCOND. The order of R11, RANK, */ -/* is the effective rank of A. */ - -/* Then, R22 is considered to be negligible, and R12 is annihilated */ -/* by orthogonal transformations from the right, arriving at the */ -/* complete orthogonal factorization: */ -/* A * P = Q * [ T11 0 ] * Z */ -/* [ 0 0 ] */ -/* The minimum-norm solution is then */ -/* X = P * Z' [ inv(T11)*Q1'*B ] */ -/* [ 0 ] */ -/* where Q1 consists of the first RANK columns of Q. */ - -/* 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. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of */ -/* columns of matrices B and X. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, A has been overwritten by details of its */ -/* complete orthogonal factorization. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the M-by-NRHS right hand side matrix B. */ -/* On exit, the N-by-NRHS solution matrix X. */ -/* If m >= n and RANK = n, the residual sum-of-squares for */ -/* the solution in the i-th column is given by the sum of */ -/* squares of elements N+1:M in that column. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,M,N). */ - -/* JPVT (input/output) INTEGER array, dimension (N) */ -/* On entry, if JPVT(i) .ne. 0, the i-th column of A is an */ -/* initial column, otherwise it is a free column. Before */ -/* the QR factorization of A, all initial columns are */ -/* permuted to the leading positions; only the remaining */ -/* free columns are moved as a result of column pivoting */ -/* during the factorization. */ -/* On exit, if JPVT(i) = k, then the i-th column of A*P */ -/* was the k-th column of A. */ - -/* RCOND (input) DOUBLE PRECISION */ -/* RCOND is used to determine the effective rank of A, which */ -/* is defined as the order of the largest leading triangular */ -/* submatrix R11 in the QR factorization with pivoting of A, */ -/* whose estimated condition number < 1/RCOND. */ - -/* RANK (output) INTEGER */ -/* The effective rank of A, i.e., the order of the submatrix */ -/* R11. This is the same as the order of the submatrix T11 */ -/* in the complete orthogonal factorization of A. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension */ -/* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )), */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --jpvt; - --work; - - /* Function Body */ - mn = std::min(*m,*n); - ismin = mn + 1; - ismax = (mn << 1) + 1; - -/* Test the input arguments. */ - - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = std::max(1_integer,*m); - if (*ldb < std::max(i__1,*n)) { - *info = -7; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELSX", &i__1); - return 0; - } - -/* Quick return if possible */ - -/* Computing MIN */ - i__1 = std::min(*m,*n); - if (std::min(i__1,*nrhs) == 0) { - *rank = 0; - return 0; - } - -/* Get machine parameters */ - - smlnum = dlamch_("S") / dlamch_("P"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); - iascl = 0; - if (anrm > 0. && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info); - iascl = 1; - } else if (anrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = std::max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb); - *rank = 0; - goto L100; - } - - bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); - ibscl = 0; - if (bnrm > 0. && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 1; - } else if (bnrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 2; - } - -/* Compute QR factorization with column pivoting of A: */ -/* A * P = Q * R */ - - dgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info); - -/* workspace 3*N. Details of Householder rotations stored */ -/* in WORK(1:MN). */ - -/* Determine RANK using incremental condition estimation */ - - work[ismin] = 1.; - work[ismax] = 1.; - smax = (d__1 = a[a_dim1 + 1], abs(d__1)); - smin = smax; - if ((d__1 = a[a_dim1 + 1], abs(d__1)) == 0.) { - *rank = 0; - i__1 = std::max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb); - goto L100; - } else { - *rank = 1; - } - -L10: - if (*rank < mn) { - i__ = *rank + 1; - dlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ - i__ + i__ * a_dim1], &sminpr, &s1, &c1); - dlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ - i__ + i__ * a_dim1], &smaxpr, &s2, &c2); - - if (smaxpr * *rcond <= sminpr) { - i__1 = *rank; - for (i__ = 1; i__ <= i__1; ++i__) { - work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1]; - work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1]; -/* L20: */ - } - work[ismin + *rank] = c1; - work[ismax + *rank] = c2; - smin = sminpr; - smax = smaxpr; - ++(*rank); - goto L10; - } - } - -/* Logically partition R = [ R11 R12 ] */ -/* [ 0 R22 ] */ -/* where R11 = R(1:RANK,1:RANK) */ - -/* [R11,R12] = [ T11, 0 ] * Y */ - - if (*rank < *n) { - dtzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info); - } - -/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ - -/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ - - dorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], & - b[b_offset], ldb, &work[(mn << 1) + 1], info); - -/* workspace NRHS */ - -/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ - - dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, & - a[a_offset], lda, &b[b_offset], ldb); - - i__1 = *n; - for (i__ = *rank + 1; i__ <= i__1; ++i__) { - i__2 = *nrhs; - for (j = 1; j <= i__2; ++j) { - b[i__ + j * b_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - -/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */ - - if (*rank < *n) { - i__1 = *rank; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *n - *rank + 1; - dlatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, - &work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], - ldb, &work[(mn << 1) + 1]); -/* L50: */ - } - } - -/* workspace NRHS */ - -/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[(mn << 1) + i__] = 1.; -/* L60: */ - } - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[(mn << 1) + i__] == 1.) { - if (jpvt[i__] != i__) { - k = i__; - t1 = b[k + j * b_dim1]; - t2 = b[jpvt[k] + j * b_dim1]; -L70: - b[jpvt[k] + j * b_dim1] = t1; - work[(mn << 1) + k] = 0.; - t1 = t2; - k = jpvt[k]; - t2 = b[jpvt[k] + j * b_dim1]; - if (jpvt[k] != i__) { - goto L70; - } - b[i__ + j * b_dim1] = t1; - work[(mn << 1) + k] = 0.; - } - } -/* L80: */ - } -/* L90: */ - } - -/* Undo scaling */ - - if (iascl == 1) { - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], - lda, info); - } else if (iascl == 2) { - dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], - lda, info); - } - if (ibscl == 1) { - dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } else if (ibscl == 2) { - dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } - -L100: - - return 0; - -/* End of DGELSX */ - -} /* dgelsx_ */ diff --git a/external/clapack/lapack/dgelsy.cpp b/external/clapack/lapack/dgelsy.cpp deleted file mode 100644 index c7f3123f..00000000 --- a/external/clapack/lapack/dgelsy.cpp +++ /dev/null @@ -1,456 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__0 = 0; -static double c_b31 = 0.; -static integer c__2 = 2; -static double c_b54 = 1.; - -/* Subroutine */ int dgelsy_(integer *m, integer *n, integer *nrhs, - double *a, integer *lda, double *b, integer *ldb, integer * - jpvt, double *rcond, integer *rank, double *work, integer * - lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double c1, c2, s1, s2; - integer nb, mn, nb1, nb2, nb3, nb4; - double anrm, bnrm, smin, smax; - integer iascl, ibscl; - integer ismin, ismax; - double wsize; - double bignum; - integer lwkmin; - double sminpr, smaxpr, smlnum; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGELSY computes the minimum-norm solution to a real linear least */ -/* squares problem: */ -/* minimize || A * X - B || */ -/* using a complete orthogonal factorization of A. A is an M-by-N */ -/* matrix which may be rank-deficient. */ - -/* Several right hand side vectors b and solution vectors x can be */ -/* handled in a single call; they are stored as the columns of the */ -/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ -/* matrix X. */ - -/* The routine first computes a QR factorization with column pivoting: */ -/* A * P = Q * [ R11 R12 ] */ -/* [ 0 R22 ] */ -/* with R11 defined as the largest leading submatrix whose estimated */ -/* condition number is less than 1/RCOND. The order of R11, RANK, */ -/* is the effective rank of A. */ - -/* Then, R22 is considered to be negligible, and R12 is annihilated */ -/* by orthogonal transformations from the right, arriving at the */ -/* complete orthogonal factorization: */ -/* A * P = Q * [ T11 0 ] * Z */ -/* [ 0 0 ] */ -/* The minimum-norm solution is then */ -/* X = P * Z' [ inv(T11)*Q1'*B ] */ -/* [ 0 ] */ -/* where Q1 consists of the first RANK columns of Q. */ - -/* This routine is basically identical to the original xGELSX except */ -/* three differences: */ -/* o The call to the subroutine xGEQPF has been substituted by the */ -/* the call to the subroutine xGEQP3. This subroutine is a Blas-3 */ -/* version of the QR factorization with column pivoting. */ -/* o Matrix B (the right hand side) is updated with Blas-3. */ -/* o The permutation of matrix B (the right hand side) is faster and */ -/* more simple. */ - -/* 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. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of */ -/* columns of matrices B and X. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, A has been overwritten by details of its */ -/* complete orthogonal factorization. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the M-by-NRHS right hand side matrix B. */ -/* On exit, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,M,N). */ - -/* 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 AP, otherwise column i is a free column. */ -/* On exit, if JPVT(i) = k, then the i-th column of AP */ -/* was the k-th column of A. */ - -/* RCOND (input) DOUBLE PRECISION */ -/* RCOND is used to determine the effective rank of A, which */ -/* is defined as the order of the largest leading triangular */ -/* submatrix R11 in the QR factorization with pivoting of A, */ -/* whose estimated condition number < 1/RCOND. */ - -/* RANK (output) INTEGER */ -/* The effective rank of A, i.e., the order of the submatrix */ -/* R11. This is the same as the order of the submatrix T11 */ -/* in the complete orthogonal factorization of A. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* The unblocked strategy requires that: */ -/* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ), */ -/* where MN = min( M, N ). */ -/* The block algorithm requires that: */ -/* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ), */ -/* where NB is an upper bound on the blocksize returned */ -/* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR, */ -/* and DORMRZ. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: If INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ -/* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ -/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --jpvt; - --work; - - /* Function Body */ - mn = std::min(*m,*n); - ismin = mn + 1; - ismax = (mn << 1) + 1; - -/* Test the input arguments. */ - - *info = 0; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = std::max(1_integer,*m); - if (*ldb < std::max(i__1,*n)) { - *info = -7; - } - } - -/* Figure out optimal block size */ - - if (*info == 0) { - if (mn == 0 || *nrhs == 0) { - lwkmin = 1; - lwkopt = 1; - } else { - nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); - nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); - nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, nrhs, &c_n1); - nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, nrhs, &c_n1); -/* Computing MAX */ - i__1 = std::max(nb1,nb2), i__1 = std::max(i__1,nb3); - nb = std::max(i__1,nb4); -/* Computing MAX */ - i__1 = mn << 1, i__2 = *n + 1, i__1 = std::max(i__1,i__2), i__2 = mn + - *nrhs; - lwkmin = mn + std::max(i__1,i__2); -/* Computing MAX */ - i__1 = lwkmin, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = std::max( - i__1,i__2), i__2 = (mn << 1) + nb * *nrhs; - lwkopt = std::max(i__1,i__2); - } - work[1] = (double) lwkopt; - - if (*lwork < lwkmin && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELSY", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (mn == 0 || *nrhs == 0) { - *rank = 0; - return 0; - } - -/* Get machine parameters */ - - smlnum = dlamch_("S") / dlamch_("P"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); - iascl = 0; - if (anrm > 0. && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info); - iascl = 1; - } else if (anrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = std::max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b31, &c_b31, &b[b_offset], ldb); - *rank = 0; - goto L70; - } - - bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); - ibscl = 0; - if (bnrm > 0. && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 1; - } else if (bnrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 2; - } - -/* Compute QR factorization with column pivoting of A: */ -/* A * P = Q * R */ - - i__1 = *lwork - mn; - dgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1, - info); - wsize = mn + work[mn + 1]; - -/* workspace: MN+2*N+NB*(N+1). */ -/* Details of Householder rotations stored in WORK(1:MN). */ - -/* Determine RANK using incremental condition estimation */ - - work[ismin] = 1.; - work[ismax] = 1.; - smax = (d__1 = a[a_dim1 + 1], abs(d__1)); - smin = smax; - if ((d__1 = a[a_dim1 + 1], abs(d__1)) == 0.) { - *rank = 0; - i__1 = std::max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b31, &c_b31, &b[b_offset], ldb); - goto L70; - } else { - *rank = 1; - } - -L10: - if (*rank < mn) { - i__ = *rank + 1; - dlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ - i__ + i__ * a_dim1], &sminpr, &s1, &c1); - dlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ - i__ + i__ * a_dim1], &smaxpr, &s2, &c2); - - if (smaxpr * *rcond <= sminpr) { - i__1 = *rank; - for (i__ = 1; i__ <= i__1; ++i__) { - work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1]; - work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1]; -/* L20: */ - } - work[ismin + *rank] = c1; - work[ismax + *rank] = c2; - smin = sminpr; - smax = smaxpr; - ++(*rank); - goto L10; - } - } - -/* workspace: 3*MN. */ - -/* Logically partition R = [ R11 R12 ] */ -/* [ 0 R22 ] */ -/* where R11 = R(1:RANK,1:RANK) */ - -/* [R11,R12] = [ T11, 0 ] * Y */ - - if (*rank < *n) { - i__1 = *lwork - (mn << 1); - dtzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) + - 1], &i__1, info); - } - -/* workspace: 2*MN. */ -/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ - -/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ - - i__1 = *lwork - (mn << 1); - dormqr_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], & - b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info); -/* Computing MAX */ - d__1 = wsize, d__2 = (mn << 1) + work[(mn << 1) + 1]; - wsize = std::max(d__1,d__2); - -/* workspace: 2*MN+NB*NRHS. */ - -/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ - - dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b54, & - a[a_offset], lda, &b[b_offset], ldb); - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = *rank + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - -/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */ - - if (*rank < *n) { - i__1 = *n - *rank; - i__2 = *lwork - (mn << 1); - dormrz_("Left", "Transpose", n, nrhs, rank, &i__1, &a[a_offset], lda, - &work[mn + 1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__2, - info); - } - -/* workspace: 2*MN+NRHS. */ - -/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[jpvt[i__]] = b[i__ + j * b_dim1]; -/* L50: */ - } - dcopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1); -/* L60: */ - } - -/* workspace: N. */ - -/* Undo scaling */ - - if (iascl == 1) { - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], - lda, info); - } else if (iascl == 2) { - dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], - lda, info); - } - if (ibscl == 1) { - dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } else if (ibscl == 2) { - dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } - -L70: - work[1] = (double) lwkopt; - - return 0; - -/* End of DGELSY */ - -} /* dgelsy_ */ diff --git a/external/clapack/lapack/dgeql2.cpp b/external/clapack/lapack/dgeql2.cpp deleted file mode 100644 index f665db52..00000000 --- a/external/clapack/lapack/dgeql2.cpp +++ /dev/null @@ -1,142 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgeql2_(integer *m, integer *n, double *a, integer * - lda, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, k; - double aii; - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEQL2 computes a QL factorization of a real m by n matrix A: */ -/* A = Q * L. */ - -/* 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, if m >= n, the lower triangle of the subarray */ -/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */ -/* if m <= n, the elements on and below the (n-m)-th */ -/* superdiagonal contain the m by n lower trapezoidal matrix L; */ -/* the remaining elements, 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(k) . . . H(2) H(1), 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */ -/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEQL2", &i__1); - return 0; - } - - k = std::min(*m,*n); - - for (i__ = k; i__ >= 1; --i__) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(1:m-k+i-1,n-k+i) */ - - i__1 = *m - k + i__; - dlarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[(*n - k - + i__) * a_dim1 + 1], &c__1, &tau[i__]); - -/* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left */ - - aii = a[*m - k + i__ + (*n - k + i__) * a_dim1]; - a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.; - i__1 = *m - k + i__; - i__2 = *n - k + i__ - 1; - dlarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, & - tau[i__], &a[a_offset], lda, &work[1]); - a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DGEQL2 */ - -} /* dgeql2_ */ diff --git a/external/clapack/lapack/dgeqlf.cpp b/external/clapack/lapack/dgeqlf.cpp deleted file mode 100644 index 285553bc..00000000 --- a/external/clapack/lapack/dgeqlf.cpp +++ /dev/null @@ -1,250 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dgeqlf_(integer *m, integer *n, double *a, integer * - lda, double *tau, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEQLF computes a QL factorization of a real M-by-N matrix A: */ -/* A = Q * L. */ - -/* 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, */ -/* if m >= n, the lower triangle of the subarray */ -/* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; */ -/* if m <= n, the elements on and below the (n-m)-th */ -/* superdiagonal contain the M-by-N lower trapezoidal matrix L; */ -/* the remaining elements, 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* 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(k) . . . H(2) H(1), 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */ -/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - - if (*info == 0) { - k = std::min(*m,*n); - if (k == 0) { - lwkopt = 1; - } else { - nb = ilaenv_(&c__1, "DGEQLF", " ", m, n, &c_n1, &c_n1); - lwkopt = *n * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < std::max(1_integer,*n) && ! lquery) { - *info = -7; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEQLF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (k == 0) { - return 0; - } - - nbmin = 2; - nx = 1; - iws = *n; - if (nb > 1 && nb < k) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQLF", " ", m, n, &c_n1, &c_n1); - nx = std::max(i__1,i__2); - if (nx < k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQLF", " ", m, n, &c_n1, & - c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < k && nx < k) { - -/* Use blocked code initially. */ -/* The last kk columns are handled by the block method. */ - - ki = (k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = k, i__2 = ki + nb; - kk = std::min(i__1,i__2); - - i__1 = k - kk + 1; - i__2 = -nb; - for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ - += i__2) { -/* Computing MIN */ - i__3 = k - i__ + 1; - ib = std::min(i__3,nb); - -/* Compute the QL factorization of the current block */ -/* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) */ - - i__3 = *m - k + i__ + ib - 1; - dgeql2_(&i__3, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &tau[ - i__], &work[1], &iinfo); - if (*n - k + i__ > 1) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__3 = *m - k + i__ + ib - 1; - dlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - k + - i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork); - -/* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ - - i__3 = *m - k + i__ + ib - 1; - i__4 = *n - k + i__ - 1; - dlarfb_("Left", "Transpose", "Backward", "Columnwise", &i__3, - &i__4, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, & - work[1], &ldwork, &a[a_offset], lda, &work[ib + 1], & - ldwork); - } -/* L10: */ - } - mu = *m - k + i__ + nb - 1; - nu = *n - k + i__ + nb - 1; - } else { - mu = *m; - nu = *n; - } - -/* Use unblocked code to factor the last or only block */ - - if (mu > 0 && nu > 0) { - dgeql2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo); - } - - work[1] = (double) iws; - return 0; - -/* End of DGEQLF */ - -} /* dgeqlf_ */ diff --git a/external/clapack/lapack/dgeqp3.cpp b/external/clapack/lapack/dgeqp3.cpp deleted file mode 100644 index 6dc0ddcb..00000000 --- a/external/clapack/lapack/dgeqp3.cpp +++ /dev/null @@ -1,329 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dgeqp3_(integer *m, integer *n, double *a, integer * - lda, integer *jpvt, double *tau, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer j, jb, na, nb, sm, sn, nx, fjb, iws, nfxd; - integer nbmin, minmn; - integer minws; - integer topbmn, sminmn; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEQP3 computes a QR factorization with column pivoting of a */ -/* matrix A: A*P = Q*R using Level 3 BLAS. */ - -/* 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 trapezoidal 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(J).ne.0, the J-th column of A is permuted */ -/* to the front of A*P (a leading column); if JPVT(J)=0, */ -/* the J-th column of A is a free column. */ -/* On exit, if JPVT(J)=K, then the J-th column of A*P was the */ -/* the K-th column of A. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= 3*N+1. */ -/* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB */ -/* is the optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* 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/complex scalar, and v is a real/complex 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). */ - -/* Based on contributions by */ -/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ -/* X. Sun, Computer Science Dept., Duke University, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test input arguments */ -/* ==================== */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --jpvt; - --tau; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - - if (*info == 0) { - minmn = std::min(*m,*n); - if (minmn == 0) { - iws = 1; - lwkopt = 1; - } else { - iws = *n * 3 + 1; - nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); - lwkopt = (*n << 1) + (*n + 1) * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < iws && ! lquery) { - *info = -8; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEQP3", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible. */ - - if (minmn == 0) { - return 0; - } - -/* Move initial columns up front. */ - - nfxd = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (jpvt[j] != 0) { - if (j != nfxd) { - dswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nfxd * a_dim1 + 1], & - c__1); - jpvt[j] = jpvt[nfxd]; - jpvt[nfxd] = j; - } else { - jpvt[j] = j; - } - ++nfxd; - } else { - jpvt[j] = j; - } -/* L10: */ - } - --nfxd; - -/* Factorize fixed columns */ -/* ======================= */ - -/* Compute the QR factorization of fixed columns and update */ -/* remaining columns. */ - - if (nfxd > 0) { - na = std::min(*m,nfxd); -/* CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) */ - dgeqrf_(m, &na, &a[a_offset], lda, &tau[1], &work[1], lwork, info); -/* Computing MAX */ - i__1 = iws, i__2 = (integer) work[1]; - iws = std::max(i__1,i__2); - if (na < *n) { -/* CC CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, */ -/* CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) */ - i__1 = *n - na; - dormqr_("Left", "Transpose", m, &i__1, &na, &a[a_offset], lda, & - tau[1], &a[(na + 1) * a_dim1 + 1], lda, &work[1], lwork, - info); -/* Computing MAX */ - i__1 = iws, i__2 = (integer) work[1]; - iws = std::max(i__1,i__2); - } - } - -/* Factorize free columns */ -/* ====================== */ - - if (nfxd < minmn) { - - sm = *m - nfxd; - sn = *n - nfxd; - sminmn = minmn - nfxd; - -/* Determine the block size. */ - - nb = ilaenv_(&c__1, "DGEQRF", " ", &sm, &sn, &c_n1, &c_n1); - nbmin = 2; - nx = 0; - - if (nb > 1 && nb < sminmn) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", &sm, &sn, &c_n1, & - c_n1); - nx = std::max(i__1,i__2); - - - if (nx < sminmn) { - -/* Determine if workspace is large enough for blocked code. */ - - minws = (sn << 1) + (sn + 1) * nb; - iws = std::max(iws,minws); - if (*lwork < minws) { - -/* Not enough workspace to use optimal NB: Reduce NB and */ -/* determine the minimum value of NB. */ - - nb = (*lwork - (sn << 1)) / (sn + 1); -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", &sm, &sn, & - c_n1, &c_n1); - nbmin = std::max(i__1,i__2); - - - } - } - } - -/* Initialize partial column norms. The first N elements of work */ -/* store the exact column norms. */ - - i__1 = *n; - for (j = nfxd + 1; j <= i__1; ++j) { - work[j] = dnrm2_(&sm, &a[nfxd + 1 + j * a_dim1], &c__1); - work[*n + j] = work[j]; -/* L20: */ - } - - if (nb >= nbmin && nb < sminmn && nx < sminmn) { - -/* Use blocked code initially. */ - - j = nfxd + 1; - -/* Compute factorization: while loop. */ - - - topbmn = minmn - nx; -L30: - if (j <= topbmn) { -/* Computing MIN */ - i__1 = nb, i__2 = topbmn - j + 1; - jb = std::min(i__1,i__2); - -/* Factorize JB columns among columns J:N. */ - - i__1 = *n - j + 1; - i__2 = j - 1; - i__3 = *n - j + 1; - dlaqps_(m, &i__1, &i__2, &jb, &fjb, &a[j * a_dim1 + 1], lda, & - jpvt[j], &tau[j], &work[j], &work[*n + j], &work[(*n - << 1) + 1], &work[(*n << 1) + jb + 1], &i__3); - - j += fjb; - goto L30; - } - } else { - j = nfxd + 1; - } - -/* Use unblocked code to factor the last or only block. */ - - - if (j <= minmn) { - i__1 = *n - j + 1; - i__2 = j - 1; - dlaqp2_(m, &i__1, &i__2, &a[j * a_dim1 + 1], lda, &jpvt[j], &tau[ - j], &work[j], &work[*n + j], &work[(*n << 1) + 1]); - } - - } - - work[1] = (double) iws; - return 0; - -/* End of DGEQP3 */ - -} /* dgeqp3_ */ diff --git a/external/clapack/lapack/dgeqpf.cpp b/external/clapack/lapack/dgeqpf.cpp deleted file mode 100644 index 54eb163d..00000000 --- a/external/clapack/lapack/dgeqpf.cpp +++ /dev/null @@ -1,274 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -int dgeqpf_(integer *m, integer *n, double *a, integer * - lda, integer *jpvt, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1, d__2; - - /* Local variables */ - integer i__, j, ma, mn; - double aii; - integer pvt; - double temp; - double temp2, tol3z; - integer itemp; - -/* -- LAPACK deprecated driver routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This routine is deprecated and has been replaced by routine DGEQP3. */ - -/* 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. */ - -/* Partial column norm updating strategy modified by */ -/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ -/* University of Zagreb, Croatia. */ -/* June 2006. */ -/* For more details see LAPACK Working Note 176. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --jpvt; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEQPF", &i__1); - return 0; - } - - mn = std::min(*m,*n); - tol3z = sqrt(dlamch_("Epsilon")); - -/* Move initial columns up front */ - - itemp = 1; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (jpvt[i__] != 0) { - if (i__ != itemp) { - dswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1], - &c__1); - jpvt[i__] = jpvt[itemp]; - jpvt[itemp] = i__; - } else { - jpvt[i__] = i__; - } - ++itemp; - } else { - jpvt[i__] = i__; - } -/* L10: */ - } - --itemp; - -/* Compute the QR factorization and update remaining columns */ - - if (itemp > 0) { - ma = std::min(itemp,*m); - dgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info); - if (ma < *n) { - i__1 = *n - ma; - dorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, & - tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info); - } - } - - if (itemp < mn) { - -/* Initialize partial column norms. The first n elements of */ -/* work store the exact column norms. */ - - i__1 = *n; - for (i__ = itemp + 1; i__ <= i__1; ++i__) { - i__2 = *m - itemp; - work[i__] = dnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1); - work[*n + i__] = work[i__]; -/* L20: */ - } - -/* Compute factorization */ - - i__1 = mn; - for (i__ = itemp + 1; i__ <= i__1; ++i__) { - -/* Determine ith pivot column and swap if necessary */ - - i__2 = *n - i__ + 1; - pvt = i__ - 1 + idamax_(&i__2, &work[i__], &c__1); - - if (pvt != i__) { - dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & - c__1); - itemp = jpvt[pvt]; - jpvt[pvt] = jpvt[i__]; - jpvt[i__] = itemp; - work[pvt] = work[i__]; - work[*n + pvt] = work[*n + i__]; - } - -/* Generate elementary reflector H(i) */ - - if (i__ < *m) { - i__2 = *m - i__ + 1; - dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ * - a_dim1], &c__1, &tau[i__]); - } else { - dlarfp_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], & - c__1, &tau[*m]); - } - - if (i__ < *n) { - -/* Apply H(i) to A(i:m,i+1:n) from the left */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dlarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & - tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(* - n << 1) + 1]); - a[i__ + i__ * a_dim1] = aii; - } - -/* Update partial column norms */ - - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - if (work[j] != 0.) { - -/* NOTE: The following 4 lines follow from the analysis in */ -/* Lapack Working Note 176. */ - - temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / work[j]; -/* Computing MAX */ - d__1 = 0., d__2 = (temp + 1.) * (1. - temp); - temp = std::max(d__1,d__2); -/* Computing 2nd power */ - d__1 = work[j] / work[*n + j]; - temp2 = temp * (d__1 * d__1); - if (temp2 <= tol3z) { - if (*m - i__ > 0) { - i__3 = *m - i__; - work[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], - &c__1); - work[*n + j] = work[j]; - } else { - work[j] = 0.; - work[*n + j] = 0.; - } - } else { - work[j] *= sqrt(temp); - } - } -/* L30: */ - } - -/* L40: */ - } - } - return 0; - -/* End of DGEQPF */ - -} /* dgeqpf_ */ diff --git a/external/clapack/lapack/dgeqr2.cpp b/external/clapack/lapack/dgeqr2.cpp deleted file mode 100644 index 9c0cc934..00000000 --- a/external/clapack/lapack/dgeqr2.cpp +++ /dev/null @@ -1,144 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgeqr2_(integer *m, integer *n, double *a, integer * - lda, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, k; - double aii; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEQR2", &i__1); - return 0; - } - - k = std::min(*m,*n); - - i__1 = k; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ - - i__2 = *m - i__ + 1; -/* Computing MIN */ - i__3 = i__ + 1; - dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[std::min(i__3, *m)+ i__ * a_dim1] -, &c__1, &tau[i__]); - if (i__ < *n) { - -/* Apply H(i) to A(i:m,i+1:n) from the left */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[ - i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); - a[i__ + i__ * a_dim1] = aii; - } -/* L10: */ - } - return 0; - -/* End of DGEQR2 */ - -} /* dgeqr2_ */ diff --git a/external/clapack/lapack/dgeqrf.cpp b/external/clapack/lapack/dgeqrf.cpp deleted file mode 100644 index aafee2e0..00000000 --- a/external/clapack/lapack/dgeqrf.cpp +++ /dev/null @@ -1,232 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dgeqrf_(integer *m, integer *n, double *a, integer * - lda, double *tau, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, k, ib, nb, nx, iws, nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* 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 .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } else if (*lwork < std::max(1_integer,*n) && ! lquery) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEQRF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - k = std::min(*m,*n); - if (k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - nx = 0; - iws = *n; - if (nb > 1 && nb < k) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1); - nx = std::max(i__1,i__2); - if (nx < k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, & - c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < k && nx < k) { - -/* Use blocked code initially */ - - i__1 = k - nx; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = k - i__ + 1; - ib = std::min(i__3,nb); - -/* Compute the QR factorization of the current block */ -/* A(i:m,i:i+ib-1) */ - - i__3 = *m - i__ + 1; - dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ - 1], &iinfo); - if (i__ + ib <= *n) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__3 = *m - i__ + 1; - dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork); - -/* Apply H' to A(i:m,i+ib:n) from the left */ - - i__3 = *m - i__ + 1; - i__4 = *n - i__ - ib + 1; - dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, & - i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & - ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib - + 1], &ldwork); - } -/* L10: */ - } - } else { - i__ = 1; - } - -/* Use unblocked code to factor the last or only block. */ - - if (i__ <= k) { - i__2 = *m - i__ + 1; - i__1 = *n - i__ + 1; - dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] -, &iinfo); - } - - work[1] = (double) iws; - return 0; - -/* End of DGEQRF */ - -} /* dgeqrf_ */ diff --git a/external/clapack/lapack/dgerfs.cpp b/external/clapack/lapack/dgerfs.cpp deleted file mode 100644 index d065e476..00000000 --- a/external/clapack/lapack/dgerfs.cpp +++ /dev/null @@ -1,399 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b15 = -1.; -static double c_b17 = 1.; - -/* Subroutine */ int dgerfs_(const char *trans, integer *n, integer *nrhs, - double *a, integer *lda, double *af, integer *ldaf, integer * - ipiv, double *b, integer *ldb, double *x, integer *ldx, - double *ferr, double *berr, double *work, integer *iwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s, xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - integer count; - double safmin; - bool notran; - char transt[1]; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGERFS improves the computed solution to a system of linear */ -/* equations and provides error bounds and backward error estimates for */ -/* the solution. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The original N-by-N matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* The factors L and U from the factorization A = P*L*U */ -/* as computed by DGETRF. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DGETRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T") && ! lsame_( - trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -10; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGERFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *n + 1; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - op(A) * X, */ -/* where op(A) = A, A**T, or A**H, depending on TRANS. */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x[j * x_dim1 + 1], & - c__1, &c_b17, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L30: */ - } - -/* Compute abs(op(A))*abs(X) + abs(B). */ - - if (notran) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; -/* L40: */ - } -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ - i__ + j * x_dim1], abs(d__2)); -/* L60: */ - } - work[k] += s; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n - + 1], n, info); - daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(op(A)))* */ -/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(op(A)) is the inverse of op(A) */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(op(A)) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(op(A)**T). */ - - dgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & - work[*n + 1], n, info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L110: */ - } - } else { - -/* Multiply by inv(op(A))*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L120: */ - } - dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & - work[*n + 1], n, info); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DGERFS */ - -} /* dgerfs_ */ diff --git a/external/clapack/lapack/dgerq2.cpp b/external/clapack/lapack/dgerq2.cpp deleted file mode 100644 index 9e1cded7..00000000 --- a/external/clapack/lapack/dgerq2.cpp +++ /dev/null @@ -1,137 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dgerq2_(integer *m, integer *n, double *a, integer *lda, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, k; - double aii; - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGERQ2 computes an RQ factorization of a real m by n matrix A: */ -/* A = R * Q. */ - -/* 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, if m <= n, the upper triangle of the subarray */ -/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */ -/* if m >= n, the elements on and above the (m-n)-th subdiagonal */ -/* contain the m by n upper trapezoidal matrix R; the remaining */ -/* elements, 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 (M) */ - -/* 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */ -/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGERQ2", &i__1); - return 0; - } - - k = std::min(*m,*n); - - for (i__ = k; i__ >= 1; --i__) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(m-k+i,1:n-k+i-1) */ - - i__1 = *n - k + i__; - dlarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[*m - k - + i__ + a_dim1], lda, &tau[i__]); - -/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */ - - aii = a[*m - k + i__ + (*n - k + i__) * a_dim1]; - a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.; - i__1 = *m - k + i__ - 1; - i__2 = *n - k + i__; - dlarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[ - i__], &a[a_offset], lda, &work[1]); - a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DGERQ2 */ - -} /* dgerq2_ */ diff --git a/external/clapack/lapack/dgerqf.cpp b/external/clapack/lapack/dgerqf.cpp deleted file mode 100644 index a52b5a24..00000000 --- a/external/clapack/lapack/dgerqf.cpp +++ /dev/null @@ -1,249 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dgerqf_(integer *m, integer *n, double *a, integer * - lda, double *tau, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGERQF computes an RQ factorization of a real M-by-N matrix A: */ -/* A = R * Q. */ - -/* 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, */ -/* if m <= n, the upper triangle of the subarray */ -/* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; */ -/* if m >= n, the elements on and above the (m-n)-th subdiagonal */ -/* contain the M-by-N upper trapezoidal matrix R; */ -/* the remaining elements, 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,M). */ -/* For optimum performance LWORK >= M*NB, where NB is */ -/* the optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */ -/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - - if (*info == 0) { - k = std::min(*m,*n); - if (k == 0) { - lwkopt = 1; - } else { - nb = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); - lwkopt = *m * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < std::max(1_integer,*m) && ! lquery) { - *info = -7; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGERQF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (k == 0) { - return 0; - } - - nbmin = 2; - nx = 1; - iws = *m; - if (nb > 1 && nb < k) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DGERQF", " ", m, n, &c_n1, &c_n1); - nx = std::max(i__1,i__2); - if (nx < k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGERQF", " ", m, n, &c_n1, & - c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < k && nx < k) { - -/* Use blocked code initially. */ -/* The last kk rows are handled by the block method. */ - - ki = (k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = k, i__2 = ki + nb; - kk = std::min(i__1,i__2); - - i__1 = k - kk + 1; - i__2 = -nb; - for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ - += i__2) { -/* Computing MIN */ - i__3 = k - i__ + 1; - ib = std::min(i__3,nb); - -/* Compute the RQ factorization of the current block */ -/* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) */ - - i__3 = *n - k + i__ + ib - 1; - dgerq2_(&ib, &i__3, &a[*m - k + i__ + a_dim1], lda, &tau[i__], & - work[1], &iinfo); - if (*m - k + i__ > 1) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__3 = *n - k + i__ + ib - 1; - dlarft_("Backward", "Rowwise", &i__3, &ib, &a[*m - k + i__ + - a_dim1], lda, &tau[i__], &work[1], &ldwork); - -/* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */ - - i__3 = *m - k + i__ - 1; - i__4 = *n - k + i__ + ib - 1; - dlarfb_("Right", "No transpose", "Backward", "Rowwise", &i__3, - &i__4, &ib, &a[*m - k + i__ + a_dim1], lda, &work[1], - &ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork); - } -/* L10: */ - } - mu = *m - k + i__ + nb - 1; - nu = *n - k + i__ + nb - 1; - } else { - mu = *m; - nu = *n; - } - -/* Use unblocked code to factor the last or only block */ - - if (mu > 0 && nu > 0) { - dgerq2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo); - } - - work[1] = (double) iws; - return 0; - -/* End of DGERQF */ - -} /* dgerqf_ */ diff --git a/external/clapack/lapack/dgesc2.cpp b/external/clapack/lapack/dgesc2.cpp deleted file mode 100644 index 3940cf4c..00000000 --- a/external/clapack/lapack/dgesc2.cpp +++ /dev/null @@ -1,158 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dgesc2_(integer *n, double *a, integer *lda, - double *rhs, integer *ipiv, integer *jpiv, double *scale) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double eps, temp; - double bignum; - double smlnum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGESC2 solves a system of linear equations */ - -/* A * X = scale* RHS */ - -/* with a general N-by-N matrix A using the LU factorization with */ -/* complete pivoting computed by DGETC2. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the LU part of the factorization of the n-by-n */ -/* matrix A computed by DGETC2: A = P * L * U * Q */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1, N). */ - -/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */ -/* On entry, the right hand side vector b. */ -/* On exit, the solution vector X. */ - -/* IPIV (input) INTEGER array, dimension (N). */ -/* The pivot indices; for 1 <= i <= N, row i of the */ -/* matrix has been interchanged with row IPIV(i). */ - -/* JPIV (input) INTEGER array, dimension (N). */ -/* The pivot indices; for 1 <= j <= N, column j of the */ -/* matrix has been interchanged with column JPIV(j). */ - -/* SCALE (output) DOUBLE PRECISION */ -/* On exit, SCALE contains the scale factor. SCALE is chosen */ -/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Set constant to control owerflow */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --rhs; - --ipiv; - --jpiv; - - /* Function Body */ - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Apply permutations IPIV to RHS */ - - i__1 = *n - 1; - dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1); - -/* Solve for L part */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - rhs[j] -= a[j + i__ * a_dim1] * rhs[i__]; -/* L10: */ - } -/* L20: */ - } - -/* Solve for U part */ - - *scale = 1.; - -/* Check for scaling */ - - i__ = idamax_(n, &rhs[1], &c__1); - if (smlnum * 2. * (d__1 = rhs[i__], abs(d__1)) > (d__2 = a[*n + *n * - a_dim1], abs(d__2))) { - temp = .5 / (d__1 = rhs[i__], abs(d__1)); - dscal_(n, &temp, &rhs[1], &c__1); - *scale *= temp; - } - - for (i__ = *n; i__ >= 1; --i__) { - temp = 1. / a[i__ + i__ * a_dim1]; - rhs[i__] *= temp; - i__1 = *n; - for (j = i__ + 1; j <= i__1; ++j) { - rhs[i__] -= rhs[j] * (a[i__ + j * a_dim1] * temp); -/* L30: */ - } -/* L40: */ - } - -/* Apply permutations JPIV to the solution (RHS) */ - - i__1 = *n - 1; - dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1); - return 0; - -/* End of DGESC2 */ - -} /* dgesc2_ */ diff --git a/external/clapack/lapack/dgesdd.cpp b/external/clapack/lapack/dgesdd.cpp deleted file mode 100644 index ccf1bb89..00000000 --- a/external/clapack/lapack/dgesdd.cpp +++ /dev/null @@ -1,1562 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__0 = 0; -static double c_b227 = 0.; -static double c_b248 = 1.; - -/* Subroutine */ int dgesdd_(const char *jobz, integer *m, integer *n, double * - a, integer *lda, double *s, double *u, integer *ldu, - double *vt, integer *ldvt, double *work, integer *lwork, - integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2, i__3; - - /* Local variables */ - integer i__, ie, il, ir, iu, blk; - double dum[1], eps; - integer ivt, iscl; - double anrm; - integer idum[1], ierr, itau; - integer chunk, minmn, wrkbl, itaup, itauq, mnthr; - bool wntqa; - integer nwork; - bool wntqn, wntqo, wntqs; - integer bdspac; - double bignum; - integer ldwrkl, ldwrkr, minwrk, ldwrku, maxwrk, ldwkvt; - double smlnum; - bool wntqas, lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGESDD computes the singular value decomposition (SVD) of a real */ -/* M-by-N matrix A, optionally computing the left and right singular */ -/* vectors. If singular vectors are desired, it uses a */ -/* divide-and-conquer algorithm. */ - -/* The SVD is written */ - -/* A = U * SIGMA * transpose(V) */ - -/* where SIGMA is an M-by-N matrix which is zero except for its */ -/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */ -/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */ -/* are the singular values of A; they are real and non-negative, and */ -/* are returned in descending order. The first min(m,n) columns of */ -/* U and V are the left and right singular vectors of A. */ - -/* Note that the routine returns VT = V**T, not V. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* Specifies options for computing all or part of the matrix U: */ -/* = 'A': all M columns of U and all N rows of V**T are */ -/* returned in the arrays U and VT; */ -/* = 'S': the first min(M,N) columns of U and the first */ -/* min(M,N) rows of V**T are returned in the arrays U */ -/* and VT; */ -/* = 'O': If M >= N, the first N columns of U are overwritten */ -/* on the array A and all rows of V**T are returned in */ -/* the array VT; */ -/* otherwise, all columns of U are returned in the */ -/* array U and the first M rows of V**T are overwritten */ -/* in the array A; */ -/* = 'N': no columns of U or rows of V**T are computed. */ - -/* M (input) INTEGER */ -/* The number of rows of the input matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the input matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, */ -/* if JOBZ = 'O', A is overwritten with the first N columns */ -/* of U (the left singular vectors, stored */ -/* columnwise) if M >= N; */ -/* A is overwritten with the first M rows */ -/* of V**T (the right singular vectors, stored */ -/* rowwise) otherwise. */ -/* if JOBZ .ne. 'O', the contents of A are destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The singular values of A, sorted so that S(i) >= S(i+1). */ - -/* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) */ -/* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; */ -/* UCOL = min(M,N) if JOBZ = 'S'. */ -/* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M */ -/* orthogonal matrix U; */ -/* if JOBZ = 'S', U contains the first min(M,N) columns of U */ -/* (the left singular vectors, stored columnwise); */ -/* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= 1; if */ -/* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. */ - -/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */ -/* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the */ -/* N-by-N orthogonal matrix V**T; */ -/* if JOBZ = 'S', VT contains the first min(M,N) rows of */ -/* V**T (the right singular vectors, stored rowwise); */ -/* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. LDVT >= 1; if */ -/* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; */ -/* if JOBZ = 'S', LDVT >= min(M,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= 1. */ -/* If JOBZ = 'N', */ -/* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)). */ -/* If JOBZ = 'O', */ -/* LWORK >= 3*min(M,N)*min(M,N) + */ -/* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). */ -/* If JOBZ = 'S' or 'A' */ -/* LWORK >= 3*min(M,N)*min(M,N) + */ -/* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)). */ -/* For good performance, LWORK should generally be larger. */ -/* If LWORK = -1 but other input arguments are legal, WORK(1) */ -/* returns the optimal LWORK. */ - -/* IWORK (workspace) INTEGER array, dimension (8*min(M,N)) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: DBDSDC did not converge, updating process failed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --s; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - minmn = std::min(*m,*n); - wntqa = lsame_(jobz, "A"); - wntqs = lsame_(jobz, "S"); - wntqas = wntqa || wntqs; - wntqo = lsame_(jobz, "O"); - wntqn = lsame_(jobz, "N"); - lquery = *lwork == -1; - - if (! (wntqa || wntqs || wntqo || wntqn)) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < * - m) { - *info = -8; - } else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn || - wntqo && *m >= *n && *ldvt < *n) { - *info = -10; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV.) */ - - if (*info == 0) { - minwrk = 1; - maxwrk = 1; - if (*m >= *n && minmn > 0) { - -/* Compute space needed for DBDSDC */ - - mnthr = (integer) (minmn * 11. / 6.); - if (wntqn) { - bdspac = *n * 7; - } else { - bdspac = *n * 3 * *n + (*n << 2); - } - if (*m >= mnthr) { - if (wntqn) { - -/* Path 1 (M much larger than N, JOBZ='N') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n; - maxwrk = std::max(i__1,i__2); - minwrk = bdspac + *n; - } else if (wntqo) { - -/* Path 2 (M much larger than N, JOBZ='O') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = std::max(i__1,i__2); - maxwrk = wrkbl + (*n << 1) * *n; - minwrk = bdspac + (*n << 1) * *n + *n * 3; - } else if (wntqs) { - -/* Path 3 (M much larger than N, JOBZ='S') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = std::max(i__1,i__2); - maxwrk = wrkbl + *n * *n; - minwrk = bdspac + *n * *n + *n * 3; - } else if (wntqa) { - -/* Path 4 (M much larger than N, JOBZ='A') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n + *m * ilaenv_(&c__1, "DORGQR", - " ", m, m, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = std::max(i__1,i__2); - maxwrk = wrkbl + *n * *n; - minwrk = bdspac + *n * *n + *n * 3; - } - } else { - -/* Path 5 (M at least N, but not much larger) */ - - wrkbl = *n * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, - n, &c_n1, &c_n1); - if (wntqn) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - maxwrk = std::max(i__1,i__2); - minwrk = *n * 3 + std::max(*m,bdspac); - } else if (wntqo) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", m, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - wrkbl = std::max(i__1,i__2); - maxwrk = wrkbl + *m * *n; -/* Computing MAX */ - i__1 = *m, i__2 = *n * *n + bdspac; - minwrk = *n * 3 + std::max(i__1,i__2); - } else if (wntqs) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "QLN", m, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *n * 3; - maxwrk = std::max(i__1,i__2); - minwrk = *n * 3 + std::max(*m,bdspac); - } else if (wntqa) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = bdspac + *n * 3; - maxwrk = std::max(i__1,i__2); - minwrk = *n * 3 + std::max(*m,bdspac); - } - } - } else if (minmn > 0) { - -/* Compute space needed for DBDSDC */ - - mnthr = (integer) (minmn * 11. / 6.); - if (wntqn) { - bdspac = *m * 7; - } else { - bdspac = *m * 3 * *m + (*m << 2); - } - if (*n >= mnthr) { - if (wntqn) { - -/* Path 1t (N much larger than M, JOBZ='N') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m; - maxwrk = std::max(i__1,i__2); - minwrk = bdspac + *m; - } else if (wntqo) { - -/* Path 2t (N much larger than M, JOBZ='O') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = std::max(i__1,i__2); - maxwrk = wrkbl + (*m << 1) * *m; - minwrk = bdspac + (*m << 1) * *m + *m * 3; - } else if (wntqs) { - -/* Path 3t (N much larger than M, JOBZ='S') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = std::max(i__1,i__2); - maxwrk = wrkbl + *m * *m; - minwrk = bdspac + *m * *m + *m * 3; - } else if (wntqa) { - -/* Path 4t (N much larger than M, JOBZ='A') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m + *n * ilaenv_(&c__1, "DORGLQ", - " ", n, n, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, m, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = std::max(i__1,i__2); - maxwrk = wrkbl + *m * *m; - minwrk = bdspac + *m * *m + *m * 3; - } - } else { - -/* Path 5t (N greater than M, but not much larger) */ - - wrkbl = *m * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, - n, &c_n1, &c_n1); - if (wntqn) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = std::max(i__1,i__2); - minwrk = *m * 3 + std::max(*n,bdspac); - } else if (wntqo) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, n, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - wrkbl = std::max(i__1,i__2); - maxwrk = wrkbl + *m * *n; -/* Computing MAX */ - i__1 = *n, i__2 = *m * *m + bdspac; - minwrk = *m * 3 + std::max(i__1,i__2); - } else if (wntqs) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", m, n, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = std::max(i__1,i__2); - minwrk = *m * 3 + std::max(*n,bdspac); - } else if (wntqa) { -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "QLN", m, m, n, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" -, "PRT", n, n, m, &c_n1); - wrkbl = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = wrkbl, i__2 = bdspac + *m * 3; - maxwrk = std::max(i__1,i__2); - minwrk = *m * 3 + std::max(*n,bdspac); - } - } - } - maxwrk = std::max(maxwrk,minwrk); - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGESDD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = sqrt(dlamch_("S")) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, dum); - iscl = 0; - if (anrm > 0. && anrm < smlnum) { - iscl = 1; - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & - ierr); - } else if (anrm > bignum) { - iscl = 1; - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & - ierr); - } - - if (*m >= *n) { - -/* A has at least as many rows as columns. If A has sufficiently */ -/* more rows than columns, first reduce using the QR */ -/* decomposition (if sufficient workspace available) */ - - if (*m >= mnthr) { - - if (wntqn) { - -/* Path 1 (M much larger than N, JOBZ='N') */ -/* No singular vectors to be computed */ - - itau = 1; - nwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Zero out below R */ - - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_("L", &i__1, &i__2, &c_b227, &c_b227, &a[a_dim1 + 2], - lda); - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in A */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - nwork = ie + *n; - -/* Perform bidiagonal SVD, computing singular values only */ -/* (Workspace: need N+BDSPAC) */ - - dbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - - } else if (wntqo) { - -/* Path 2 (M much larger than N, JOBZ = 'O') */ -/* N left singular vectors to be overwritten on A and */ -/* N right singular vectors to be computed in VT */ - - ir = 1; - -/* WORK(IR) is LDWRKR by N */ - - if (*lwork >= *lda * *n + *n * *n + *n * 3 + bdspac) { - ldwrkr = *lda; - } else { - ldwrkr = (*lwork - *n * *n - *n * 3 - bdspac) / *n; - } - itau = ir + ldwrkr * *n; - nwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Copy R to WORK(IR), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_("L", &i__1, &i__2, &c_b227, &c_b227, &work[ir + 1], & - ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], - &i__1, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in VT, copying result to WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - -/* WORK(IU) is N by N */ - - iu = nwork; - nwork = iu + *n * *n; - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite WORK(IU) by left singular vectors of R */ -/* and VT by right singular vectors of R */ -/* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[ - itauq], &work[iu], n, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IU), storing result in WORK(IR) and copying to A */ -/* (Workspace: need 2*N*N, prefer N*N+M*N) */ - - i__1 = *m; - i__2 = ldwrkr; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = *m - i__ + 1; - chunk = std::min(i__3,ldwrkr); - dgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + a_dim1], - lda, &work[iu], n, &c_b227, &work[ir], &ldwrkr); - dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + - a_dim1], lda); -/* L10: */ - } - - } else if (wntqs) { - -/* Path 3 (M much larger than N, JOBZ='S') */ -/* N left singular vectors to be computed in U and */ -/* N right singular vectors to be computed in VT */ - - ir = 1; - -/* WORK(IR) is N by N */ - - ldwrkr = *n; - itau = ir + ldwrkr * *n; - nwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - -/* Copy R to WORK(IR), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); - i__2 = *n - 1; - i__1 = *n - 1; - dlaset_("L", &i__2, &i__1, &c_b227, &c_b227, &work[ir + 1], & - ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], - &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagoal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of R and VT */ -/* by right singular vectors of R */ -/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IR), storing result in U */ -/* (Workspace: need N*N) */ - - dlacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr); - dgemm_("N", "N", m, n, n, &c_b248, &a[a_offset], lda, &work[ - ir], &ldwrkr, &c_b227, &u[u_offset], ldu); - - } else if (wntqa) { - -/* Path 4 (M much larger than N, JOBZ='A') */ -/* M left singular vectors to be computed in U and */ -/* N right singular vectors to be computed in VT */ - - iu = 1; - -/* WORK(IU) is N by N */ - - ldwrku = *n; - itau = iu + ldwrku * *n; - nwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu); - -/* Generate Q in U */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - i__2 = *lwork - nwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork], - &i__2, &ierr); - -/* Produce R in A, zeroing out other entries */ - - i__2 = *n - 1; - i__1 = *n - 1; - dlaset_("L", &i__2, &i__1, &c_b227, &c_b227, &a[a_dim1 + 2], - lda); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize R in A */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite WORK(IU) by left singular vectors of R and VT */ -/* by right singular vectors of R */ -/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", n, n, n, &a[a_offset], lda, &work[ - itauq], &work[iu], &ldwrku, &work[nwork], &i__2, & - ierr); - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply Q in U by left singular vectors of R in */ -/* WORK(IU), storing result in A */ -/* (Workspace: need N*N) */ - - dgemm_("N", "N", m, n, n, &c_b248, &u[u_offset], ldu, &work[ - iu], &ldwrku, &c_b227, &a[a_offset], lda); - -/* Copy left singular vectors of A from A to U */ - - dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu); - - } - - } else { - -/* M .LT. MNTHR */ - -/* Path 5 (M at least N, but not much larger) */ -/* Reduce to bidiagonal form without QR decomposition */ - - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - nwork = itaup + *n; - -/* Bidiagonalize A */ -/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__2, &ierr); - if (wntqn) { - -/* Perform bidiagonal SVD, only computing singular values */ -/* (Workspace: need N+BDSPAC) */ - - dbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - } else if (wntqo) { - iu = nwork; - if (*lwork >= *m * *n + *n * 3 + bdspac) { - -/* WORK( IU ) is M by N */ - - ldwrku = *m; - nwork = iu + ldwrku * *n; - dlaset_("F", m, n, &c_b227, &c_b227, &work[iu], &ldwrku); - } else { - -/* WORK( IU ) is N by N */ - - ldwrku = *n; - nwork = iu + ldwrku * *n; - -/* WORK(IR) is LDWRKR by N */ - - ir = nwork; - ldwrkr = (*lwork - *n * *n - *n * 3) / *n; - } - nwork = iu + ldwrku * *n; - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in WORK(IU) and computing right */ -/* singular vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+N*N+BDSPAC) */ - - dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], &ldwrku, & - vt[vt_offset], ldvt, dum, idum, &work[nwork], &iwork[ - 1], info); - -/* Overwrite VT by right singular vectors of A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - - if (*lwork >= *m * *n + *n * 3 + bdspac) { - -/* Overwrite WORK(IU) by left singular vectors of A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[ - itauq], &work[iu], &ldwrku, &work[nwork], &i__2, & - ierr); - -/* Copy left singular vectors of A from WORK(IU) to A */ - - dlacpy_("F", m, n, &work[iu], &ldwrku, &a[a_offset], lda); - } else { - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - nwork + 1; - dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], & - work[nwork], &i__2, &ierr); - -/* Multiply Q in A by left singular vectors of */ -/* bidiagonal matrix in WORK(IU), storing result in */ -/* WORK(IR) and copying to A */ -/* (Workspace: need 2*N*N, prefer N*N+M*N) */ - - i__2 = *m; - i__1 = ldwrkr; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { -/* Computing MIN */ - i__3 = *m - i__ + 1; - chunk = std::min(i__3,ldwrkr); - dgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + - a_dim1], lda, &work[iu], &ldwrku, &c_b227, & - work[ir], &ldwrkr); - dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + - a_dim1], lda); -/* L20: */ - } - } - - } else if (wntqs) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - dlaset_("F", m, n, &c_b227, &c_b227, &u[u_offset], ldu); - dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 3*N, prefer 2*N+N*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } else if (wntqa) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need N+BDSPAC) */ - - dlaset_("F", m, m, &c_b227, &c_b227, &u[u_offset], ldu); - dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Set the right corner of U to identity matrix */ - - if (*m > *n) { - i__1 = *m - *n; - i__2 = *m - *n; - dlaset_("F", &i__1, &i__2, &c_b227, &c_b248, &u[*n + 1 + ( - *n + 1) * u_dim1], ldu); - } - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } - - } - - } else { - -/* A has more columns than rows. If A has sufficiently more */ -/* columns than rows, first reduce using the LQ decomposition (if */ -/* sufficient workspace available) */ - - if (*n >= mnthr) { - - if (wntqn) { - -/* Path 1t (N much larger than M, JOBZ='N') */ -/* No singular vectors to be computed */ - - itau = 1; - nwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Zero out above L */ - - i__1 = *m - 1; - i__2 = *m - 1; - dlaset_("U", &i__1, &i__2, &c_b227, &c_b227, &a[(a_dim1 << 1) - + 1], lda); - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in A */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - nwork = ie + *m; - -/* Perform bidiagonal SVD, computing singular values only */ -/* (Workspace: need M+BDSPAC) */ - - dbdsdc_("U", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - - } else if (wntqo) { - -/* Path 2t (N much larger than M, JOBZ='O') */ -/* M right singular vectors to be overwritten on A and */ -/* M left singular vectors to be computed in U */ - - ivt = 1; - -/* IVT is M by M */ - - il = ivt + *m * *m; - if (*lwork >= *m * *n + *m * *m + *m * 3 + bdspac) { - -/* WORK(IL) is M by N */ - - ldwrkl = *m; - chunk = *n; - } else { - ldwrkl = *m; - chunk = (*lwork - *m * *m) / *m; - } - itau = il + ldwrkl * *m; - nwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__1, &ierr); - -/* Copy L to WORK(IL), zeroing about above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl); - i__1 = *m - 1; - i__2 = *m - 1; - dlaset_("U", &i__1, &i__2, &c_b227, &c_b227, &work[il + - ldwrkl], &ldwrkl); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], - &i__1, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in WORK(IL) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__1 = *lwork - nwork + 1; - dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__1, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U, and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M+M*M+BDSPAC) */ - - dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], m, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of L and WORK(IVT) */ -/* by right singular vectors of L */ -/* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[ - itaup], &work[ivt], m, &work[nwork], &i__1, &ierr); - -/* Multiply right singular vectors of L in WORK(IVT) by Q */ -/* in A, storing result in WORK(IL) and copying to A */ -/* (Workspace: need 2*M*M, prefer M*M+M*N) */ - - i__1 = *n; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = *n - i__ + 1; - blk = std::min(i__3,chunk); - dgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], m, &a[ - i__ * a_dim1 + 1], lda, &c_b227, &work[il], & - ldwrkl); - dlacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1 - + 1], lda); -/* L30: */ - } - - } else if (wntqs) { - -/* Path 3t (N much larger than M, JOBZ='S') */ -/* M right singular vectors to be computed in VT and */ -/* M left singular vectors to be computed in U */ - - il = 1; - -/* WORK(IL) is M by M */ - - ldwrkl = *m; - itau = il + ldwrkl * *m; - nwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - -/* Copy L to WORK(IL), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl); - i__2 = *m - 1; - i__1 = *m - 1; - dlaset_("U", &i__2, &i__1, &c_b227, &c_b227, &work[il + - ldwrkl], &ldwrkl); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], - &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in WORK(IU), copying result to U */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of L and VT */ -/* by right singular vectors of L */ -/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & - ierr); - -/* Multiply right singular vectors of L in WORK(IL) by */ -/* Q in A, storing result in VT */ -/* (Workspace: need M*M) */ - - dlacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl); - dgemm_("N", "N", m, n, m, &c_b248, &work[il], &ldwrkl, &a[ - a_offset], lda, &c_b227, &vt[vt_offset], ldvt); - - } else if (wntqa) { - -/* Path 4t (N much larger than M, JOBZ='A') */ -/* N right singular vectors to be computed in VT and */ -/* M left singular vectors to be computed in U */ - - ivt = 1; - -/* WORK(IVT) is M by M */ - - ldwkvt = *m; - itau = ivt + ldwkvt * *m; - nwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & - i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); - -/* Generate Q in VT */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[ - nwork], &i__2, &ierr); - -/* Produce L in A, zeroing out other entries */ - - i__2 = *m - 1; - i__1 = *m - 1; - dlaset_("U", &i__2, &i__1, &c_b227, &c_b227, &a[(a_dim1 << 1) - + 1], lda); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize L in A */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[nwork], &i__2, &ierr); - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M+M*M+BDSPAC) */ - - dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1] -, info); - -/* Overwrite U by left singular vectors of L and WORK(IVT) */ -/* by right singular vectors of L */ -/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, m, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, m, m, &a[a_offset], lda, &work[ - itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, & - ierr); - -/* Multiply right singular vectors of L in WORK(IVT) by */ -/* Q in VT, storing result in A */ -/* (Workspace: need M*M) */ - - dgemm_("N", "N", m, n, m, &c_b248, &work[ivt], &ldwkvt, &vt[ - vt_offset], ldvt, &c_b227, &a[a_offset], lda); - -/* Copy right singular vectors of A from A to VT */ - - dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); - - } - - } else { - -/* N .LT. MNTHR */ - -/* Path 5t (N greater than M, but not much larger) */ -/* Reduce to bidiagonal form without LQ decomposition */ - - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - nwork = itaup + *m; - -/* Bidiagonalize A */ -/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ - - i__2 = *lwork - nwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[nwork], &i__2, &ierr); - if (wntqn) { - -/* Perform bidiagonal SVD, only computing singular values */ -/* (Workspace: need M+BDSPAC) */ - - dbdsdc_("L", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, - dum, idum, &work[nwork], &iwork[1], info); - } else if (wntqo) { - ldwkvt = *m; - ivt = nwork; - if (*lwork >= *m * *n + *m * 3 + bdspac) { - -/* WORK( IVT ) is M by N */ - - dlaset_("F", m, n, &c_b227, &c_b227, &work[ivt], &ldwkvt); - nwork = ivt + ldwkvt * *n; - } else { - -/* WORK( IVT ) is M by M */ - - nwork = ivt + ldwkvt * *m; - il = nwork; - -/* WORK(IL) is M by CHUNK */ - - chunk = (*lwork - *m * *m - *m * 3) / *m; - } - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in WORK(IVT) */ -/* (Workspace: need M*M+BDSPAC) */ - - dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & - work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1] -, info); - -/* Overwrite U by left singular vectors of A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); - - if (*lwork >= *m * *n + *m * 3 + bdspac) { - -/* Overwrite WORK(IVT) by left singular vectors of A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[ - itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, - &ierr); - -/* Copy right singular vectors of A from WORK(IVT) to A */ - - dlacpy_("F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda); - } else { - -/* Generate P**T in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - nwork + 1; - dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], & - work[nwork], &i__2, &ierr); - -/* Multiply Q in A by right singular vectors of */ -/* bidiagonal matrix in WORK(IVT), storing result in */ -/* WORK(IL) and copying to A */ -/* (Workspace: need 2*M*M, prefer M*M+M*N) */ - - i__2 = *n; - i__1 = chunk; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { -/* Computing MIN */ - i__3 = *n - i__ + 1; - blk = std::min(i__3,chunk); - dgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], & - ldwkvt, &a[i__ * a_dim1 + 1], lda, &c_b227, & - work[il], m); - dlacpy_("F", m, &blk, &work[il], m, &a[i__ * a_dim1 + - 1], lda); -/* L40: */ - } - } - } else if (wntqs) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - dlaset_("F", m, n, &c_b227, &c_b227, &vt[vt_offset], ldvt); - dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 3*M, prefer 2*M+M*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } else if (wntqa) { - -/* Perform bidiagonal SVD, computing left singular vectors */ -/* of bidiagonal matrix in U and computing right singular */ -/* vectors of bidiagonal matrix in VT */ -/* (Workspace: need M+BDSPAC) */ - - dlaset_("F", n, n, &c_b227, &c_b227, &vt[vt_offset], ldvt); - dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ - vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], - info); - -/* Set the right corner of VT to identity matrix */ - - if (*n > *m) { - i__1 = *n - *m; - i__2 = *n - *m; - dlaset_("F", &i__1, &i__2, &c_b227, &c_b248, &vt[*m + 1 + - (*m + 1) * vt_dim1], ldvt); - } - -/* Overwrite U by left singular vectors of A and VT */ -/* by right singular vectors of A */ -/* (Workspace: need 2*M+N, prefer 2*M+N*NB) */ - - i__1 = *lwork - nwork + 1; - dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ - itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); - i__1 = *lwork - nwork + 1; - dormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[ - itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & - ierr); - } - - } - - } - -/* Undo scaling if necessary */ - - if (iscl == 1) { - if (anrm > bignum) { - dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr); - } - if (anrm < smlnum) { - dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr); - } - } - -/* Return optimal workspace in WORK(1) */ - - work[1] = (double) maxwrk; - - return 0; - -/* End of DGESDD */ - -} /* dgesdd_ */ diff --git a/external/clapack/lapack/dgesv.cpp b/external/clapack/lapack/dgesv.cpp deleted file mode 100644 index 1815e8c2..00000000 --- a/external/clapack/lapack/dgesv.cpp +++ /dev/null @@ -1,120 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgesv_(integer *n, integer *nrhs, double *a, integer - *lda, integer *ipiv, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGESV computes the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ - -/* The LU decomposition with partial pivoting and row interchanges is */ -/* used to factor A as */ -/* A = P * L * U, */ -/* where P is a permutation matrix, L is unit lower triangular, and U is */ -/* upper triangular. The factored form of A is then used to solve the */ -/* system of equations A * X = B. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the N-by-N coefficient matrix A. */ -/* On exit, the factors L and U from the factorization */ -/* A = P*L*U; the unit diagonal elements of L are not stored. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* The pivot indices that define the permutation matrix P; */ -/* row i of the matrix was interchanged with row IPIV(i). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS matrix of right hand side matrix B. */ -/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly */ -/* singular, so the solution could not be computed. */ - -/* ===================================================================== */ - -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*nrhs < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGESV ", &i__1); - return 0; - } - -/* Compute the LU factorization of A. */ - - dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[ - b_offset], ldb, info); - } - return 0; - -/* End of DGESV */ - -} /* dgesv_ */ diff --git a/external/clapack/lapack/dgesvd.cpp b/external/clapack/lapack/dgesvd.cpp deleted file mode 100644 index c2fdd653..00000000 --- a/external/clapack/lapack/dgesvd.cpp +++ /dev/null @@ -1,4003 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__6 = 6; -static integer c__0 = 0; -static integer c__2 = 2; -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b421 = 0.; -static double c_b443 = 1.; - -/* Subroutine */ int dgesvd_(const char *jobu, const char *jobvt, integer *m, integer *n, - double *a, integer *lda, double *s, double *u, integer * - ldu, double *vt, integer *ldvt, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2], - i__2, i__3, i__4; - char ch__1[3]; - - /* Local variables */ - integer i__, ie, ir, iu, blk, ncu; - double dum[1], eps; - integer nru, iscl; - double anrm; - integer ierr, itau, ncvt, nrvt; - integer chunk, minmn, wrkbl, itaup, itauq, mnthr, iwork; - bool wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs; - integer bdspac; - double bignum; - integer ldwrkr, minwrk, ldwrku, maxwrk; - double smlnum; - bool lquery, wntuas, wntvas; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGESVD computes the singular value decomposition (SVD) of a real */ -/* M-by-N matrix A, optionally computing the left and/or right singular */ -/* vectors. The SVD is written */ - -/* A = U * SIGMA * transpose(V) */ - -/* where SIGMA is an M-by-N matrix which is zero except for its */ -/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */ -/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */ -/* are the singular values of A; they are real and non-negative, and */ -/* are returned in descending order. The first min(m,n) columns of */ -/* U and V are the left and right singular vectors of A. */ - -/* Note that the routine returns V**T, not V. */ - -/* Arguments */ -/* ========= */ - -/* JOBU (input) CHARACTER*1 */ -/* Specifies options for computing all or part of the matrix U: */ -/* = 'A': all M columns of U are returned in array U: */ -/* = 'S': the first min(m,n) columns of U (the left singular */ -/* vectors) are returned in the array U; */ -/* = 'O': the first min(m,n) columns of U (the left singular */ -/* vectors) are overwritten on the array A; */ -/* = 'N': no columns of U (no left singular vectors) are */ -/* computed. */ - -/* JOBVT (input) CHARACTER*1 */ -/* Specifies options for computing all or part of the matrix */ -/* V**T: */ -/* = 'A': all N rows of V**T are returned in the array VT; */ -/* = 'S': the first min(m,n) rows of V**T (the right singular */ -/* vectors) are returned in the array VT; */ -/* = 'O': the first min(m,n) rows of V**T (the right singular */ -/* vectors) are overwritten on the array A; */ -/* = 'N': no rows of V**T (no right singular vectors) are */ -/* computed. */ - -/* JOBVT and JOBU cannot both be 'O'. */ - -/* M (input) INTEGER */ -/* The number of rows of the input matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the input matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, */ -/* if JOBU = 'O', A is overwritten with the first min(m,n) */ -/* columns of U (the left singular vectors, */ -/* stored columnwise); */ -/* if JOBVT = 'O', A is overwritten with the first min(m,n) */ -/* rows of V**T (the right singular vectors, */ -/* stored rowwise); */ -/* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */ -/* are destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The singular values of A, sorted so that S(i) >= S(i+1). */ - -/* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) */ -/* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */ -/* If JOBU = 'A', U contains the M-by-M orthogonal matrix U; */ -/* if JOBU = 'S', U contains the first min(m,n) columns of U */ -/* (the left singular vectors, stored columnwise); */ -/* if JOBU = 'N' or 'O', U is not referenced. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= 1; if */ -/* JOBU = 'S' or 'A', LDU >= M. */ - -/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */ -/* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix */ -/* V**T; */ -/* if JOBVT = 'S', VT contains the first min(m,n) rows of */ -/* V**T (the right singular vectors, stored rowwise); */ -/* if JOBVT = 'N' or 'O', VT is not referenced. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. LDVT >= 1; if */ -/* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */ -/* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged */ -/* superdiagonal elements of an upper bidiagonal matrix B */ -/* whose diagonal is in S (not necessarily sorted). B */ -/* satisfies A = U * B * VT, so it has the same singular values */ -/* as A, and singular vectors related by U and VT. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). */ -/* For good performance, LWORK should generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if DBDSQR did not converge, INFO specifies how many */ -/* superdiagonals of an intermediate bidiagonal form B */ -/* did not converge to zero. See the description of WORK */ -/* above for details. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --s; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - --work; - - /* Function Body */ - *info = 0; - minmn = std::min(*m,*n); - wntua = lsame_(jobu, "A"); - wntus = lsame_(jobu, "S"); - wntuas = wntua || wntus; - wntuo = lsame_(jobu, "O"); - wntun = lsame_(jobu, "N"); - wntva = lsame_(jobvt, "A"); - wntvs = lsame_(jobvt, "S"); - wntvas = wntva || wntvs; - wntvo = lsame_(jobvt, "O"); - wntvn = lsame_(jobvt, "N"); - lquery = *lwork == -1; - - if (! (wntua || wntus || wntuo || wntun)) { - *info = -1; - } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*m)) { - *info = -6; - } else if (*ldu < 1 || wntuas && *ldu < *m) { - *info = -9; - } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) { - *info = -11; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV.) */ - - if (*info == 0) { - minwrk = 1; - maxwrk = 1; - if (*m >= *n && minmn > 0) { - -/* Compute space needed for DBDSQR */ - -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = const_cast(jobu); - i__1[1] = 1, a__1[1] = const_cast(jobvt); - s_cat(ch__1, a__1, i__1, &c__2, 2_integer); - ch__1 [2] = '\0'; - mnthr = ilaenv_(&c__6, "DGESVD", ch__1, m, n, &c__0, &c__0); - bdspac = *n * 5; - if (*m >= mnthr) { - if (wntun) { - -/* Path 1 (M much larger than N, JOBU='N') */ - - maxwrk = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - maxwrk = std::max(i__2,i__3); - if (wntvo || wntvas) { -/* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(& - c__1, "DORGBR", "P", n, n, n, &c_n1); - maxwrk = std::max(i__2,i__3); - } - maxwrk = std::max(maxwrk,bdspac); -/* Computing MAX */ - i__2 = *n << 2; - minwrk = std::max(i__2,bdspac); - } else if (wntuo && wntvn) { - -/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" -, "Q", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); -/* Computing MAX */ - i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; - maxwrk = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } else if (wntuo && wntvas) { - -/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or */ -/* 'A') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" -, "Q", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, - "DORGBR", "P", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); -/* Computing MAX */ - i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; - maxwrk = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } else if (wntus && wntvn) { - -/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" -, "Q", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = *n * *n + wrkbl; -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } else if (wntus && wntvo) { - -/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" -, "Q", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, - "DORGBR", "P", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = (*n << 1) * *n + wrkbl; -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } else if (wntus && wntvas) { - -/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or */ -/* 'A') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", m, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" -, "Q", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, - "DORGBR", "P", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = *n * *n + wrkbl; -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } else if (wntua && wntvn) { - -/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR", - " ", m, m, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" -, "Q", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = *n * *n + wrkbl; -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } else if (wntua && wntvo) { - -/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR", - " ", m, m, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" -, "Q", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, - "DORGBR", "P", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = (*n << 1) * *n + wrkbl; -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } else if (wntua && wntvas) { - -/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or */ -/* 'A') */ - - wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR", - " ", m, m, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, - "DGEBRD", " ", n, n, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" -, "Q", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, - "DORGBR", "P", n, n, n, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = *n * *n + wrkbl; -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } - } else { - -/* Path 10 (M at least N, but not much larger) */ - - maxwrk = *n * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, - n, &c_n1, &c_n1); - if (wntus || wntuo) { -/* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORG" - "BR", "Q", m, n, n, &c_n1); - maxwrk = std::max(i__2,i__3); - } - if (wntua) { -/* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + *m * ilaenv_(&c__1, "DORG" - "BR", "Q", m, m, n, &c_n1); - maxwrk = std::max(i__2,i__3); - } - if (! wntvn) { -/* Computing MAX */ - i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, - "DORGBR", "P", n, n, n, &c_n1); - maxwrk = std::max(i__2,i__3); - } - maxwrk = std::max(maxwrk,bdspac); -/* Computing MAX */ - i__2 = *n * 3 + *m; - minwrk = std::max(i__2,bdspac); - } - } else if (minmn > 0) { - -/* Compute space needed for DBDSQR */ - -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = const_cast(jobu); - i__1[1] = 1, a__1[1] = const_cast(jobvt); - s_cat(ch__1, a__1, i__1, &c__2, 2_integer); - ch__1 [2] = '\0'; - mnthr = ilaenv_(&c__6, "DGESVD", ch__1, m, n, &c__0, &c__0); - bdspac = *m * 5; - if (*n >= mnthr) { - if (wntvn) { - -/* Path 1t(N much larger than M, JOBVT='N') */ - - maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - maxwrk = std::max(i__2,i__3); - if (wntuo || wntuas) { -/* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1, - "DORGBR", "Q", m, m, m, &c_n1); - maxwrk = std::max(i__2,i__3); - } - maxwrk = std::max(maxwrk,bdspac); -/* Computing MAX */ - i__2 = *m << 2; - minwrk = std::max(i__2,bdspac); - } else if (wntvo && wntun) { - -/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "P", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); -/* Computing MAX */ - i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; - maxwrk = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } else if (wntvo && wntuas) { - -/* Path 3t(N much larger than M, JOBU='S' or 'A', */ -/* JOBVT='O') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "P", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" -, "Q", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); -/* Computing MAX */ - i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; - maxwrk = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } else if (wntvs && wntun) { - -/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "P", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = *m * *m + wrkbl; -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } else if (wntvs && wntuo) { - -/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "P", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" -, "Q", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = (*m << 1) * *m + wrkbl; -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } else if (wntvs && wntuas) { - -/* Path 6t(N much larger than M, JOBU='S' or 'A', */ -/* JOBVT='S') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", - " ", m, n, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "P", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" -, "Q", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = *m * *m + wrkbl; -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } else if (wntva && wntun) { - -/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ", - " ", n, n, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "P", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = *m * *m + wrkbl; -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } else if (wntva && wntuo) { - -/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ", - " ", n, n, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "P", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" -, "Q", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = (*m << 1) * *m + wrkbl; -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } else if (wntva && wntuas) { - -/* Path 9t(N much larger than M, JOBU='S' or 'A', */ -/* JOBVT='A') */ - - wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & - c_n1, &c_n1); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ", - " ", n, n, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, - "DGEBRD", " ", m, m, &c_n1, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "P", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); -/* Computing MAX */ - i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" -, "Q", m, m, m, &c_n1); - wrkbl = std::max(i__2,i__3); - wrkbl = std::max(wrkbl,bdspac); - maxwrk = *m * *m + wrkbl; -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } - } else { - -/* Path 10t(N greater than M, but not much larger) */ - - maxwrk = *m * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, - n, &c_n1, &c_n1); - if (wntvs || wntvo) { -/* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORG" - "BR", "P", m, n, m, &c_n1); - maxwrk = std::max(i__2,i__3); - } - if (wntva) { -/* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + *n * ilaenv_(&c__1, "DORG" - "BR", "P", n, n, m, &c_n1); - maxwrk = std::max(i__2,i__3); - } - if (! wntun) { -/* Computing MAX */ - i__2 = maxwrk, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, - "DORGBR", "Q", m, m, m, &c_n1); - maxwrk = std::max(i__2,i__3); - } - maxwrk = std::max(maxwrk,bdspac); -/* Computing MAX */ - i__2 = *m * 3 + *n; - minwrk = std::max(i__2,bdspac); - } - } - maxwrk = std::max(maxwrk,minwrk); - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -13; - } - } - - if (*info != 0) { - i__2 = -(*info); - xerbla_("DGESVD", &i__2); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = sqrt(dlamch_("S")) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, dum); - iscl = 0; - if (anrm > 0. && anrm < smlnum) { - iscl = 1; - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & - ierr); - } else if (anrm > bignum) { - iscl = 1; - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & - ierr); - } - - if (*m >= *n) { - -/* A has at least as many rows as columns. If A has sufficiently */ -/* more rows than columns, first reduce using the QR */ -/* decomposition (if sufficient workspace available) */ - - if (*m >= mnthr) { - - if (wntun) { - -/* Path 1 (M much larger than N, JOBU='N') */ -/* No left singular vectors to be computed */ - - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & - i__2, &ierr); - -/* Zero out below R */ - - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[a_dim1 + 2], - lda); - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in A */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); - ncvt = 0; - if (wntvo || wntvas) { - -/* If right singular vectors desired, generate P'. */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], & - work[iwork], &i__2, &ierr); - ncvt = *n; - } - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing right */ -/* singular vectors of A in A if desired */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, dum, &c__1, dum, &c__1, &work[iwork], - info); - -/* If right singular vectors desired in VT, copy them there */ - - if (wntvas) { - dlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - } - - } else if (wntuo && wntvn) { - -/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */ -/* N left singular vectors to be overwritten on A and */ -/* no right singular vectors to be computed */ - -/* Computing MAX */ - i__2 = *n << 2; - if (*lwork >= *n * *n + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - ir = 1; -/* Computing MAX */ - i__2 = wrkbl, i__3 = *lda * *n + *n; - if (*lwork >= std::max(i__2,i__3) + *lda * *n) { - -/* WORK(IU) is LDA by N, WORK(IR) is LDA by N */ - - ldwrku = *lda; - ldwrkr = *lda; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__2 = wrkbl, i__3 = *lda * *n + *n; - if (*lwork >= std::max(i__2,i__3) + *n * *n) { - -/* WORK(IU) is LDA by N, WORK(IR) is N by N */ - - ldwrku = *lda; - ldwrkr = *n; - } else { - -/* WORK(IU) is LDWRKU by N, WORK(IR) is N by N */ - - ldwrku = (*lwork - *n * *n - *n) / *n; - ldwrkr = *n; - } - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] -, &i__2, &ierr); - -/* Copy R to WORK(IR) and zero out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir + 1] -, &ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); - -/* Generate left vectors bidiagonalizing R */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & - work[iwork], &i__2, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of R in WORK(IR) */ -/* (Workspace: need N*N+BDSPAC) */ - - dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, & - c__1, &work[ir], &ldwrkr, dum, &c__1, &work[iwork] -, info); - iu = ie + *n; - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IR), storing result in WORK(IU) and copying to A */ -/* (Workspace: need N*N+2*N, prefer N*N+M*N+N) */ - - i__2 = *m; - i__3 = ldwrku; - for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__3) { -/* Computing MIN */ - i__4 = *m - i__ + 1; - chunk = std::min(i__4,ldwrku); - dgemm_("N", "N", &chunk, n, n, &c_b443, &a[i__ + - a_dim1], lda, &work[ir], &ldwrkr, &c_b421, & - work[iu], &ldwrku); - dlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ + - a_dim1], lda); -/* L10: */ - } - - } else { - -/* Insufficient workspace for a fast algorithm */ - - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize A */ -/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */ - - i__3 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__3, &ierr); - -/* Generate left vectors bidiagonalizing A */ -/* (Workspace: need 4*N, prefer 3*N+N*NB) */ - - i__3 = *lwork - iwork + 1; - dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], & - work[iwork], &i__3, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in A */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, & - c__1, &a[a_offset], lda, dum, &c__1, &work[iwork], - info); - - } - - } else if (wntuo && wntvas) { - -/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') */ -/* N left singular vectors to be overwritten on A and */ -/* N right singular vectors to be computed in VT */ - -/* Computing MAX */ - i__3 = *n << 2; - if (*lwork >= *n * *n + std::max(i__3,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - ir = 1; -/* Computing MAX */ - i__3 = wrkbl, i__2 = *lda * *n + *n; - if (*lwork >= std::max(i__3,i__2) + *lda * *n) { - -/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ - - ldwrku = *lda; - ldwrkr = *lda; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__3 = wrkbl, i__2 = *lda * *n + *n; - if (*lwork >= std::max(i__3,i__2) + *n * *n) { - -/* WORK(IU) is LDA by N and WORK(IR) is N by N */ - - ldwrku = *lda; - ldwrkr = *n; - } else { - -/* WORK(IU) is LDWRKU by N and WORK(IR) is N by N */ - - ldwrku = (*lwork - *n * *n - *n) / *n; - ldwrkr = *n; - } - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__3 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] -, &i__3, &ierr); - -/* Copy R to VT, zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - if (*n > 1) { - i__3 = *n - 1; - i__2 = *n - 1; - dlaset_("L", &i__3, &i__2, &c_b421, &c_b421, &vt[ - vt_dim1 + 2], ldvt); - } - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__3 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__3, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in VT, copying result to WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__3 = *lwork - iwork + 1; - dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], &i__3, & - ierr); - dlacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], & - ldwrkr); - -/* Generate left vectors bidiagonalizing R in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ - - i__3 = *lwork - iwork + 1; - dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & - work[iwork], &i__3, &ierr); - -/* Generate right vectors bidiagonalizing R in VT */ -/* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) */ - - i__3 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], - &work[iwork], &i__3, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of R in WORK(IR) and computing right */ -/* singular vectors of R in VT */ -/* (Workspace: need N*N+BDSPAC) */ - - dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &work[ir], &ldwrkr, dum, &c__1, - &work[iwork], info); - iu = ie + *n; - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IR), storing result in WORK(IU) and copying to A */ -/* (Workspace: need N*N+2*N, prefer N*N+M*N+N) */ - - i__3 = *m; - i__2 = ldwrku; - for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += - i__2) { -/* Computing MIN */ - i__4 = *m - i__ + 1; - chunk = std::min(i__4,ldwrku); - dgemm_("N", "N", &chunk, n, n, &c_b443, &a[i__ + - a_dim1], lda, &work[ir], &ldwrkr, &c_b421, & - work[iu], &ldwrku); - dlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ + - a_dim1], lda); -/* L20: */ - } - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] -, &i__2, &ierr); - -/* Copy R to VT, zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[ - vt_dim1 + 2], ldvt); - } - -/* Generate Q in A */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in VT */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], &i__2, & - ierr); - -/* Multiply Q in A by left vectors bidiagonalizing R */ -/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, & - work[itauq], &a[a_offset], lda, &work[iwork], & - i__2, &ierr); - -/* Generate right vectors bidiagonalizing R in VT */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], - &work[iwork], &i__2, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in A and computing right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & - work[iwork], info); - - } - - } else if (wntus) { - - if (wntvn) { - -/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */ -/* N left singular vectors to be computed in U and */ -/* no right singular vectors to be computed */ - -/* Computing MAX */ - i__2 = *n << 2; - if (*lwork >= *n * *n + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - ir = 1; - if (*lwork >= wrkbl + *lda * *n) { - -/* WORK(IR) is LDA by N */ - - ldwrkr = *lda; - } else { - -/* WORK(IR) is N by N */ - - ldwrkr = *n; - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - -/* Copy R to WORK(IR), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], & - ldwrkr); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir - + 1], &ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Generate left vectors bidiagonalizing R in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] -, &work[iwork], &i__2, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of R in WORK(IR) */ -/* (Workspace: need N*N+BDSPAC) */ - - dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], - dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, & - work[iwork], info); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IR), storing result in U */ -/* (Workspace: need N*N) */ - - dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda, - &work[ir], &ldwrkr, &c_b421, &u[u_offset], - ldu); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Generate Q in U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Zero out below R in A */ - - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[ - a_dim1 + 2], lda); - -/* Bidiagonalize R in A */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply Q in U by left vectors bidiagonalizing R */ -/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & - work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr) - ; - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], - dum, &c__1, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info); - - } - - } else if (wntvo) { - -/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */ -/* N left singular vectors to be computed in U and */ -/* N right singular vectors to be overwritten on A */ - -/* Computing MAX */ - i__2 = *n << 2; - if (*lwork >= (*n << 1) * *n + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - iu = 1; - if (*lwork >= wrkbl + (*lda << 1) * *n) { - -/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ - - ldwrku = *lda; - ir = iu + ldwrku * *n; - ldwrkr = *lda; - } else if (*lwork >= wrkbl + (*lda + *n) * *n) { - -/* WORK(IU) is LDA by N and WORK(IR) is N by N */ - - ldwrku = *lda; - ir = iu + ldwrku * *n; - ldwrkr = *n; - } else { - -/* WORK(IU) is N by N and WORK(IR) is N by N */ - - ldwrku = *n; - ir = iu + ldwrku * *n; - ldwrkr = *n; - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - -/* Copy R to WORK(IU), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & - ldwrku); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu - + 1], &ldwrku); - -/* Generate Q in A */ -/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in WORK(IU), copying result to */ -/* WORK(IR) */ -/* (Workspace: need 2*N*N+4*N, */ -/* prefer 2*N*N+3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], & - ldwrkr); - -/* Generate left bidiagonalizing vectors in WORK(IU) */ -/* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] -, &work[iwork], &i__2, &ierr); - -/* Generate right bidiagonalizing vectors in WORK(IR) */ -/* (Workspace: need 2*N*N+4*N-1, */ -/* prefer 2*N*N+3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup] -, &work[iwork], &i__2, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of R in WORK(IU) and computing */ -/* right singular vectors of R in WORK(IR) */ -/* (Workspace: need 2*N*N+BDSPAC) */ - - dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[ - ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1, - &work[iwork], info); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IU), storing result in U */ -/* (Workspace: need N*N) */ - - dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda, - &work[iu], &ldwrku, &c_b421, &u[u_offset], - ldu); - -/* Copy right singular vectors of R to A */ -/* (Workspace: need N*N) */ - - dlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset], - lda); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Generate Q in U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Zero out below R in A */ - - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[ - a_dim1 + 2], lda); - -/* Bidiagonalize R in A */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply Q in U by left vectors bidiagonalizing R */ -/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & - work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr) - ; - -/* Generate right vectors bidiagonalizing R in A */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], - &work[iwork], &i__2, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U and computing right */ -/* singular vectors of A in A */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, - &work[iwork], info); - - } - - } else if (wntvas) { - -/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' */ -/* or 'A') */ -/* N left singular vectors to be computed in U and */ -/* N right singular vectors to be computed in VT */ - -/* Computing MAX */ - i__2 = *n << 2; - if (*lwork >= *n * *n + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - iu = 1; - if (*lwork >= wrkbl + *lda * *n) { - -/* WORK(IU) is LDA by N */ - - ldwrku = *lda; - } else { - -/* WORK(IU) is N by N */ - - ldwrku = *n; - } - itau = iu + ldwrku * *n; - iwork = itau + *n; - -/* Compute A=Q*R */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - -/* Copy R to WORK(IU), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & - ldwrku); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu - + 1], &ldwrku); - -/* Generate Q in A */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in WORK(IU), copying result to VT */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset], - ldvt); - -/* Generate left bidiagonalizing vectors in WORK(IU) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] -, &work[iwork], &i__2, &ierr); - -/* Generate right bidiagonalizing vectors in VT */ -/* (Workspace: need N*N+4*N-1, */ -/* prefer N*N+3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ - itaup], &work[iwork], &i__2, &ierr) - ; - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of R in WORK(IU) and computing */ -/* right singular vectors of R in VT */ -/* (Workspace: need N*N+BDSPAC) */ - - dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &work[iu], &ldwrku, dum, & - c__1, &work[iwork], info); - -/* Multiply Q in A by left singular vectors of R in */ -/* WORK(IU), storing result in U */ -/* (Workspace: need N*N) */ - - dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda, - &work[iu], &ldwrku, &c_b421, &u[u_offset], - ldu); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Generate Q in U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - -/* Copy R to VT, zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[ - vt_dim1 + 2], ldvt); - } - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in VT */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], - &work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply Q in U by left bidiagonalizing vectors */ -/* in VT */ -/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, - &work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr); - -/* Generate right bidiagonalizing vectors in VT */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ - itaup], &work[iwork], &i__2, &ierr) - ; - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U and computing right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, & - c__1, &work[iwork], info); - - } - - } - - } else if (wntua) { - - if (wntvn) { - -/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */ -/* M left singular vectors to be computed in U and */ -/* no right singular vectors to be computed */ - -/* Computing MAX */ - i__2 = *n + *m, i__3 = *n << 2, i__2 = std::max(i__2,i__3); - if (*lwork >= *n * *n + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - ir = 1; - if (*lwork >= wrkbl + *lda * *n) { - -/* WORK(IR) is LDA by N */ - - ldwrkr = *lda; - } else { - -/* WORK(IR) is N by N */ - - ldwrkr = *n; - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Copy R to WORK(IR), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], & - ldwrkr); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir - + 1], &ldwrkr); - -/* Generate Q in U */ -/* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Generate left bidiagonalizing vectors in WORK(IR) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] -, &work[iwork], &i__2, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of R in WORK(IR) */ -/* (Workspace: need N*N+BDSPAC) */ - - dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], - dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, & - work[iwork], info); - -/* Multiply Q in U by left singular vectors of R in */ -/* WORK(IR), storing result in A */ -/* (Workspace: need N*N) */ - - dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu, - &work[ir], &ldwrkr, &c_b421, &a[a_offset], - lda); - -/* Copy left singular vectors of A from A to U */ - - dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Generate Q in U */ -/* (Workspace: need N+M, prefer N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Zero out below R in A */ - - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[ - a_dim1 + 2], lda); - -/* Bidiagonalize R in A */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply Q in U by left bidiagonalizing vectors */ -/* in A */ -/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & - work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr) - ; - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], - dum, &c__1, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info); - - } - - } else if (wntvo) { - -/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */ -/* M left singular vectors to be computed in U and */ -/* N right singular vectors to be overwritten on A */ - -/* Computing MAX */ - i__2 = *n + *m, i__3 = *n << 2, i__2 = std::max(i__2,i__3); - if (*lwork >= (*n << 1) * *n + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - iu = 1; - if (*lwork >= wrkbl + (*lda << 1) * *n) { - -/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ - - ldwrku = *lda; - ir = iu + ldwrku * *n; - ldwrkr = *lda; - } else if (*lwork >= wrkbl + (*lda + *n) * *n) { - -/* WORK(IU) is LDA by N and WORK(IR) is N by N */ - - ldwrku = *lda; - ir = iu + ldwrku * *n; - ldwrkr = *n; - } else { - -/* WORK(IU) is N by N and WORK(IR) is N by N */ - - ldwrku = *n; - ir = iu + ldwrku * *n; - ldwrkr = *n; - } - itau = ir + ldwrkr * *n; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Generate Q in U */ -/* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - -/* Copy R to WORK(IU), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & - ldwrku); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu - + 1], &ldwrku); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in WORK(IU), copying result to */ -/* WORK(IR) */ -/* (Workspace: need 2*N*N+4*N, */ -/* prefer 2*N*N+3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], & - ldwrkr); - -/* Generate left bidiagonalizing vectors in WORK(IU) */ -/* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] -, &work[iwork], &i__2, &ierr); - -/* Generate right bidiagonalizing vectors in WORK(IR) */ -/* (Workspace: need 2*N*N+4*N-1, */ -/* prefer 2*N*N+3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup] -, &work[iwork], &i__2, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of R in WORK(IU) and computing */ -/* right singular vectors of R in WORK(IR) */ -/* (Workspace: need 2*N*N+BDSPAC) */ - - dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[ - ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1, - &work[iwork], info); - -/* Multiply Q in U by left singular vectors of R in */ -/* WORK(IU), storing result in A */ -/* (Workspace: need N*N) */ - - dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu, - &work[iu], &ldwrku, &c_b421, &a[a_offset], - lda); - -/* Copy left singular vectors of A from A to U */ - - dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Copy right singular vectors of R from WORK(IR) to A */ - - dlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset], - lda); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Generate Q in U */ -/* (Workspace: need N+M, prefer N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Zero out below R in A */ - - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[ - a_dim1 + 2], lda); - -/* Bidiagonalize R in A */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply Q in U by left bidiagonalizing vectors */ -/* in A */ -/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & - work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr) - ; - -/* Generate right bidiagonalizing vectors in A */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], - &work[iwork], &i__2, &ierr); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U and computing right */ -/* singular vectors of A in A */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, - &work[iwork], info); - - } - - } else if (wntvas) { - -/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' */ -/* or 'A') */ -/* M left singular vectors to be computed in U and */ -/* N right singular vectors to be computed in VT */ - -/* Computing MAX */ - i__2 = *n + *m, i__3 = *n << 2, i__2 = std::max(i__2,i__3); - if (*lwork >= *n * *n + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - iu = 1; - if (*lwork >= wrkbl + *lda * *n) { - -/* WORK(IU) is LDA by N */ - - ldwrku = *lda; - } else { - -/* WORK(IU) is N by N */ - - ldwrku = *n; - } - itau = iu + ldwrku * *n; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Generate Q in U */ -/* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - -/* Copy R to WORK(IU), zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & - ldwrku); - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu - + 1], &ldwrku); - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in WORK(IU), copying result to VT */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset], - ldvt); - -/* Generate left bidiagonalizing vectors in WORK(IU) */ -/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] -, &work[iwork], &i__2, &ierr); - -/* Generate right bidiagonalizing vectors in VT */ -/* (Workspace: need N*N+4*N-1, */ -/* prefer N*N+3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ - itaup], &work[iwork], &i__2, &ierr) - ; - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of R in WORK(IU) and computing */ -/* right singular vectors of R in VT */ -/* (Workspace: need N*N+BDSPAC) */ - - dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &work[iu], &ldwrku, dum, & - c__1, &work[iwork], info); - -/* Multiply Q in U by left singular vectors of R in */ -/* WORK(IU), storing result in A */ -/* (Workspace: need N*N) */ - - dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu, - &work[iu], &ldwrku, &c_b421, &a[a_offset], - lda); - -/* Copy left singular vectors of A from A to U */ - - dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R, copying result to U */ -/* (Workspace: need 2*N, prefer N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], - ldu); - -/* Generate Q in U */ -/* (Workspace: need N+M, prefer N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & - work[iwork], &i__2, &ierr); - -/* Copy R from A to VT, zeroing out below it */ - - dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - if (*n > 1) { - i__2 = *n - 1; - i__3 = *n - 1; - dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[ - vt_dim1 + 2], ldvt); - } - ie = itau; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in VT */ -/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], - &work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply Q in U by left bidiagonalizing vectors */ -/* in VT */ -/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, - &work[itauq], &u[u_offset], ldu, &work[iwork], - &i__2, &ierr); - -/* Generate right bidiagonalizing vectors in VT */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ - itaup], &work[iwork], &i__2, &ierr) - ; - iwork = ie + *n; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U and computing right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, & - c__1, &work[iwork], info); - - } - - } - - } - - } else { - -/* M .LT. MNTHR */ - -/* Path 10 (M at least N, but not much larger) */ -/* Reduce to bidiagonal form without QR decomposition */ - - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize A */ -/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__2, &ierr); - if (wntuas) { - -/* If left singular vectors desired in U, copy result to U */ -/* and generate left bidiagonalizing vectors in U */ -/* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB) */ - - dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu); - if (wntus) { - ncu = *n; - } - if (wntua) { - ncu = *m; - } - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], & - work[iwork], &i__2, &ierr); - } - if (wntvas) { - -/* If right singular vectors desired in VT, copy result to */ -/* VT and generate right bidiagonalizing vectors in VT */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt); - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], & - work[iwork], &i__2, &ierr); - } - if (wntuo) { - -/* If left singular vectors desired in A, generate left */ -/* bidiagonalizing vectors in A */ -/* (Workspace: need 4*N, prefer 3*N+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[ - iwork], &i__2, &ierr); - } - if (wntvo) { - -/* If right singular vectors desired in A, generate right */ -/* bidiagonalizing vectors in A */ -/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[ - iwork], &i__2, &ierr); - } - iwork = ie + *n; - if (wntuas || wntuo) { - nru = *m; - } - if (wntun) { - nru = 0; - } - if (wntvas || wntvo) { - ncvt = *n; - } - if (wntvn) { - ncvt = 0; - } - if (! wntuo && ! wntvo) { - -/* Perform bidiagonal QR iteration, if desired, computing */ -/* left singular vectors in U and computing right singular */ -/* vectors in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info); - } else if (! wntuo && wntvo) { - -/* Perform bidiagonal QR iteration, if desired, computing */ -/* left singular vectors in U and computing right singular */ -/* vectors in A */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[ - iwork], info); - } else { - -/* Perform bidiagonal QR iteration, if desired, computing */ -/* left singular vectors in A and computing right singular */ -/* vectors in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & - work[iwork], info); - } - - } - - } else { - -/* A has more columns than rows. If A has sufficiently more */ -/* columns than rows, first reduce using the LQ decomposition (if */ -/* sufficient workspace available) */ - - if (*n >= mnthr) { - - if (wntvn) { - -/* Path 1t(N much larger than M, JOBVT='N') */ -/* No right singular vectors to be computed */ - - itau = 1; - iwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & - i__2, &ierr); - -/* Zero out above L */ - - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(a_dim1 << 1) - + 1], lda); - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in A */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); - if (wntuo || wntuas) { - -/* If left singular vectors desired, generate Q */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], & - work[iwork], &i__2, &ierr); - } - iwork = ie + *m; - nru = 0; - if (wntuo || wntuas) { - nru = *m; - } - -/* Perform bidiagonal QR iteration, computing left singular */ -/* vectors of A in A if desired */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, & - c__1, &a[a_offset], lda, dum, &c__1, &work[iwork], - info); - -/* If left singular vectors desired in U, copy them there */ - - if (wntuas) { - dlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu); - } - - } else if (wntvo && wntun) { - -/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */ -/* M right singular vectors to be overwritten on A and */ -/* no left singular vectors to be computed */ - -/* Computing MAX */ - i__2 = *m << 2; - if (*lwork >= *m * *m + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - ir = 1; -/* Computing MAX */ - i__2 = wrkbl, i__3 = *lda * *n + *m; - if (*lwork >= std::max(i__2,i__3) + *lda * *m) { - -/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */ - - ldwrku = *lda; - chunk = *n; - ldwrkr = *lda; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__2 = wrkbl, i__3 = *lda * *n + *m; - if (*lwork >= std::max(i__2,i__3) + *m * *m) { - -/* WORK(IU) is LDA by N and WORK(IR) is M by M */ - - ldwrku = *lda; - chunk = *n; - ldwrkr = *m; - } else { - -/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */ - - ldwrku = *m; - chunk = (*lwork - *m * *m - *m) / *m; - ldwrkr = *m; - } - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] -, &i__2, &ierr); - -/* Copy L to WORK(IR) and zero out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir + - ldwrkr], &ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IR) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); - -/* Generate right vectors bidiagonalizing L */ -/* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & - work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing right */ -/* singular vectors of L in WORK(IR) */ -/* (Workspace: need M*M+BDSPAC) */ - - dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[ - ir], &ldwrkr, dum, &c__1, dum, &c__1, &work[iwork] -, info); - iu = ie + *m; - -/* Multiply right singular vectors of L in WORK(IR) by Q */ -/* in A, storing result in WORK(IU) and copying to A */ -/* (Workspace: need M*M+2*M, prefer M*M+M*N+M) */ - - i__2 = *n; - i__3 = chunk; - for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__3) { -/* Computing MIN */ - i__4 = *n - i__ + 1; - blk = std::min(i__4,chunk); - dgemm_("N", "N", m, &blk, m, &c_b443, &work[ir], & - ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b421, & - work[iu], &ldwrku); - dlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ * - a_dim1 + 1], lda); -/* L30: */ - } - - } else { - -/* Insufficient workspace for a fast algorithm */ - - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize A */ -/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ - - i__3 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__3, &ierr); - -/* Generate right vectors bidiagonalizing A */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__3 = *lwork - iwork + 1; - dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], & - work[iwork], &i__3, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing right */ -/* singular vectors of A in A */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, dum, &c__1, dum, &c__1, &work[ - iwork], info); - - } - - } else if (wntvo && wntuas) { - -/* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') */ -/* M right singular vectors to be overwritten on A and */ -/* M left singular vectors to be computed in U */ - -/* Computing MAX */ - i__3 = *m << 2; - if (*lwork >= *m * *m + std::max(i__3,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - ir = 1; -/* Computing MAX */ - i__3 = wrkbl, i__2 = *lda * *n + *m; - if (*lwork >= std::max(i__3,i__2) + *lda * *m) { - -/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */ - - ldwrku = *lda; - chunk = *n; - ldwrkr = *lda; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__3 = wrkbl, i__2 = *lda * *n + *m; - if (*lwork >= std::max(i__3,i__2) + *m * *m) { - -/* WORK(IU) is LDA by N and WORK(IR) is M by M */ - - ldwrku = *lda; - chunk = *n; - ldwrkr = *m; - } else { - -/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */ - - ldwrku = *m; - chunk = (*lwork - *m * *m - *m) / *m; - ldwrkr = *m; - } - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__3 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] -, &i__3, &ierr); - -/* Copy L to U, zeroing about above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu); - i__3 = *m - 1; - i__2 = *m - 1; - dlaset_("U", &i__3, &i__2, &c_b421, &c_b421, &u[(u_dim1 << - 1) + 1], ldu); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__3 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__3, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in U, copying result to WORK(IR) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__3 = *lwork - iwork + 1; - dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__3, &ierr); - dlacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr); - -/* Generate right vectors bidiagonalizing L in WORK(IR) */ -/* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */ - - i__3 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & - work[iwork], &i__3, &ierr); - -/* Generate left vectors bidiagonalizing L in U */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */ - - i__3 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], & - work[iwork], &i__3, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of L in U, and computing right */ -/* singular vectors of L in WORK(IR) */ -/* (Workspace: need M*M+BDSPAC) */ - - dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ir], - &ldwrkr, &u[u_offset], ldu, dum, &c__1, &work[ - iwork], info); - iu = ie + *m; - -/* Multiply right singular vectors of L in WORK(IR) by Q */ -/* in A, storing result in WORK(IU) and copying to A */ -/* (Workspace: need M*M+2*M, prefer M*M+M*N+M)) */ - - i__3 = *n; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += - i__2) { -/* Computing MIN */ - i__4 = *n - i__ + 1; - blk = std::min(i__4,chunk); - dgemm_("N", "N", m, &blk, m, &c_b443, &work[ir], & - ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b421, & - work[iu], &ldwrku); - dlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ * - a_dim1 + 1], lda); -/* L40: */ - } - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] -, &i__2, &ierr); - -/* Copy L to U, zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[(u_dim1 << - 1) + 1], ldu); - -/* Generate Q in A */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in U */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[ - itauq], &work[itaup], &work[iwork], &i__2, &ierr); - -/* Multiply right vectors bidiagonalizing L by Q in A */ -/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &work[ - itaup], &a[a_offset], lda, &work[iwork], &i__2, & - ierr); - -/* Generate left vectors bidiagonalizing L in U */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], & - work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U and computing right */ -/* singular vectors of A in A */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info); - - } - - } else if (wntvs) { - - if (wntun) { - -/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */ -/* M right singular vectors to be computed in VT and */ -/* no left singular vectors to be computed */ - -/* Computing MAX */ - i__2 = *m << 2; - if (*lwork >= *m * *m + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - ir = 1; - if (*lwork >= wrkbl + *lda * *m) { - -/* WORK(IR) is LDA by M */ - - ldwrkr = *lda; - } else { - -/* WORK(IR) is M by M */ - - ldwrkr = *m; - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - -/* Copy L to WORK(IR), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], & - ldwrkr); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir - + ldwrkr], &ldwrkr); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IR) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Generate right vectors bidiagonalizing L in */ -/* WORK(IR) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup] -, &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing right */ -/* singular vectors of L in WORK(IR) */ -/* (Workspace: need M*M+BDSPAC) */ - - dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], & - work[ir], &ldwrkr, dum, &c__1, dum, &c__1, & - work[iwork], info); - -/* Multiply right singular vectors of L in WORK(IR) by */ -/* Q in A, storing result in VT */ -/* (Workspace: need M*M) */ - - dgemm_("N", "N", m, n, m, &c_b443, &work[ir], &ldwrkr, - &a[a_offset], lda, &c_b421, &vt[vt_offset], - ldvt); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - -/* Copy result to VT */ - - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Generate Q in VT */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Zero out above L in A */ - - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[( - a_dim1 << 1) + 1], lda); - -/* Bidiagonalize L in A */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply right vectors bidiagonalizing L by Q in VT */ -/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], & - vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, & - work[iwork], info); - - } - - } else if (wntuo) { - -/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */ -/* M right singular vectors to be computed in VT and */ -/* M left singular vectors to be overwritten on A */ - -/* Computing MAX */ - i__2 = *m << 2; - if (*lwork >= (*m << 1) * *m + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - iu = 1; - if (*lwork >= wrkbl + (*lda << 1) * *m) { - -/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */ - - ldwrku = *lda; - ir = iu + ldwrku * *m; - ldwrkr = *lda; - } else if (*lwork >= wrkbl + (*lda + *m) * *m) { - -/* WORK(IU) is LDA by M and WORK(IR) is M by M */ - - ldwrku = *lda; - ir = iu + ldwrku * *m; - ldwrkr = *m; - } else { - -/* WORK(IU) is M by M and WORK(IR) is M by M */ - - ldwrku = *m; - ir = iu + ldwrku * *m; - ldwrkr = *m; - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - -/* Copy L to WORK(IU), zeroing out below it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & - ldwrku); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu - + ldwrku], &ldwrku); - -/* Generate Q in A */ -/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IU), copying result to */ -/* WORK(IR) */ -/* (Workspace: need 2*M*M+4*M, */ -/* prefer 2*M*M+3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], & - ldwrkr); - -/* Generate right bidiagonalizing vectors in WORK(IU) */ -/* (Workspace: need 2*M*M+4*M-1, */ -/* prefer 2*M*M+3*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] -, &work[iwork], &i__2, &ierr); - -/* Generate left bidiagonalizing vectors in WORK(IR) */ -/* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] -, &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of L in WORK(IR) and computing */ -/* right singular vectors of L in WORK(IU) */ -/* (Workspace: need 2*M*M+BDSPAC) */ - - dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ - iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1, - &work[iwork], info); - -/* Multiply right singular vectors of L in WORK(IU) by */ -/* Q in A, storing result in VT */ -/* (Workspace: need M*M) */ - - dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku, - &a[a_offset], lda, &c_b421, &vt[vt_offset], - ldvt); - -/* Copy left singular vectors of L to A */ -/* (Workspace: need M*M) */ - - dlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset], - lda); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Generate Q in VT */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Zero out above L in A */ - - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[( - a_dim1 << 1) + 1], lda); - -/* Bidiagonalize L in A */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply right vectors bidiagonalizing L by Q in VT */ -/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr); - -/* Generate left bidiagonalizing vectors of L in A */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], - &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, compute left */ -/* singular vectors of A in A and compute right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, & - c__1, &work[iwork], info); - - } - - } else if (wntuas) { - -/* Path 6t(N much larger than M, JOBU='S' or 'A', */ -/* JOBVT='S') */ -/* M right singular vectors to be computed in VT and */ -/* M left singular vectors to be computed in U */ - -/* Computing MAX */ - i__2 = *m << 2; - if (*lwork >= *m * *m + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - iu = 1; - if (*lwork >= wrkbl + *lda * *m) { - -/* WORK(IU) is LDA by N */ - - ldwrku = *lda; - } else { - -/* WORK(IU) is LDA by M */ - - ldwrku = *m; - } - itau = iu + ldwrku * *m; - iwork = itau + *m; - -/* Compute A=L*Q */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - -/* Copy L to WORK(IU), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & - ldwrku); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu - + ldwrku], &ldwrku); - -/* Generate Q in A */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IU), copying result to U */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset], - ldu); - -/* Generate right bidiagonalizing vectors in WORK(IU) */ -/* (Workspace: need M*M+4*M-1, */ -/* prefer M*M+3*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] -, &work[iwork], &i__2, &ierr); - -/* Generate left bidiagonalizing vectors in U */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], - &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of L in U and computing right */ -/* singular vectors of L in WORK(IU) */ -/* (Workspace: need M*M+BDSPAC) */ - - dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ - iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info); - -/* Multiply right singular vectors of L in WORK(IU) by */ -/* Q in A, storing result in VT */ -/* (Workspace: need M*M) */ - - dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku, - &a[a_offset], lda, &c_b421, &vt[vt_offset], - ldvt); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Generate Q in VT */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - -/* Copy L to U, zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], - ldu); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[( - u_dim1 << 1) + 1], ldu); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in U */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply right bidiagonalizing vectors in U by Q */ -/* in VT */ -/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr); - -/* Generate left bidiagonalizing vectors in U */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], - &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U and computing right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, & - c__1, &work[iwork], info); - - } - - } - - } else if (wntva) { - - if (wntun) { - -/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */ -/* N right singular vectors to be computed in VT and */ -/* no left singular vectors to be computed */ - -/* Computing MAX */ - i__2 = *n + *m, i__3 = *m << 2, i__2 = std::max(i__2,i__3); - if (*lwork >= *m * *m + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - ir = 1; - if (*lwork >= wrkbl + *lda * *m) { - -/* WORK(IR) is LDA by M */ - - ldwrkr = *lda; - } else { - -/* WORK(IR) is M by M */ - - ldwrkr = *m; - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Copy L to WORK(IR), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], & - ldwrkr); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir - + ldwrkr], &ldwrkr); - -/* Generate Q in VT */ -/* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IR) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Generate right bidiagonalizing vectors in WORK(IR) */ -/* (Workspace: need M*M+4*M-1, */ -/* prefer M*M+3*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup] -, &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing right */ -/* singular vectors of L in WORK(IR) */ -/* (Workspace: need M*M+BDSPAC) */ - - dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], & - work[ir], &ldwrkr, dum, &c__1, dum, &c__1, & - work[iwork], info); - -/* Multiply right singular vectors of L in WORK(IR) by */ -/* Q in VT, storing result in A */ -/* (Workspace: need M*M) */ - - dgemm_("N", "N", m, n, m, &c_b443, &work[ir], &ldwrkr, - &vt[vt_offset], ldvt, &c_b421, &a[a_offset], - lda); - -/* Copy right singular vectors of A from A to VT */ - - dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Generate Q in VT */ -/* (Workspace: need M+N, prefer M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Zero out above L in A */ - - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[( - a_dim1 << 1) + 1], lda); - -/* Bidiagonalize L in A */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply right bidiagonalizing vectors in A by Q */ -/* in VT */ -/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], & - vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, & - work[iwork], info); - - } - - } else if (wntuo) { - -/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */ -/* N right singular vectors to be computed in VT and */ -/* M left singular vectors to be overwritten on A */ - -/* Computing MAX */ - i__2 = *n + *m, i__3 = *m << 2, i__2 = std::max(i__2,i__3); - if (*lwork >= (*m << 1) * *m + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - iu = 1; - if (*lwork >= wrkbl + (*lda << 1) * *m) { - -/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */ - - ldwrku = *lda; - ir = iu + ldwrku * *m; - ldwrkr = *lda; - } else if (*lwork >= wrkbl + (*lda + *m) * *m) { - -/* WORK(IU) is LDA by M and WORK(IR) is M by M */ - - ldwrku = *lda; - ir = iu + ldwrku * *m; - ldwrkr = *m; - } else { - -/* WORK(IU) is M by M and WORK(IR) is M by M */ - - ldwrku = *m; - ir = iu + ldwrku * *m; - ldwrkr = *m; - } - itau = ir + ldwrkr * *m; - iwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Generate Q in VT */ -/* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - -/* Copy L to WORK(IU), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & - ldwrku); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu - + ldwrku], &ldwrku); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IU), copying result to */ -/* WORK(IR) */ -/* (Workspace: need 2*M*M+4*M, */ -/* prefer 2*M*M+3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], & - ldwrkr); - -/* Generate right bidiagonalizing vectors in WORK(IU) */ -/* (Workspace: need 2*M*M+4*M-1, */ -/* prefer 2*M*M+3*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] -, &work[iwork], &i__2, &ierr); - -/* Generate left bidiagonalizing vectors in WORK(IR) */ -/* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] -, &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of L in WORK(IR) and computing */ -/* right singular vectors of L in WORK(IU) */ -/* (Workspace: need 2*M*M+BDSPAC) */ - - dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ - iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1, - &work[iwork], info); - -/* Multiply right singular vectors of L in WORK(IU) by */ -/* Q in VT, storing result in A */ -/* (Workspace: need M*M) */ - - dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku, - &vt[vt_offset], ldvt, &c_b421, &a[a_offset], - lda); - -/* Copy right singular vectors of A from A to VT */ - - dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Copy left singular vectors of A from WORK(IR) to A */ - - dlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset], - lda); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Generate Q in VT */ -/* (Workspace: need M+N, prefer M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Zero out above L in A */ - - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[( - a_dim1 << 1) + 1], lda); - -/* Bidiagonalize L in A */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply right bidiagonalizing vectors in A by Q */ -/* in VT */ -/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr); - -/* Generate left bidiagonalizing vectors in A */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], - &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in A and computing right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, & - c__1, &work[iwork], info); - - } - - } else if (wntuas) { - -/* Path 9t(N much larger than M, JOBU='S' or 'A', */ -/* JOBVT='A') */ -/* N right singular vectors to be computed in VT and */ -/* M left singular vectors to be computed in U */ - -/* Computing MAX */ - i__2 = *n + *m, i__3 = *m << 2, i__2 = std::max(i__2,i__3); - if (*lwork >= *m * *m + std::max(i__2,bdspac)) { - -/* Sufficient workspace for a fast algorithm */ - - iu = 1; - if (*lwork >= wrkbl + *lda * *m) { - -/* WORK(IU) is LDA by M */ - - ldwrku = *lda; - } else { - -/* WORK(IU) is M by M */ - - ldwrku = *m; - } - itau = iu + ldwrku * *m; - iwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Generate Q in VT */ -/* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - -/* Copy L to WORK(IU), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & - ldwrku); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu - + ldwrku], &ldwrku); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IU), copying result to U */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - dlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset], - ldu); - -/* Generate right bidiagonalizing vectors in WORK(IU) */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] -, &work[iwork], &i__2, &ierr); - -/* Generate left bidiagonalizing vectors in U */ -/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], - &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of L in U and computing right */ -/* singular vectors of L in WORK(IU) */ -/* (Workspace: need M*M+BDSPAC) */ - - dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ - iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info); - -/* Multiply right singular vectors of L in WORK(IU) by */ -/* Q in VT, storing result in A */ -/* (Workspace: need M*M) */ - - dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku, - &vt[vt_offset], ldvt, &c_b421, &a[a_offset], - lda); - -/* Copy right singular vectors of A from A to VT */ - - dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - - } else { - -/* Insufficient workspace for a fast algorithm */ - - itau = 1; - iwork = itau + *m; - -/* Compute A=L*Q, copying result to VT */ -/* (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ - iwork], &i__2, &ierr); - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], - ldvt); - -/* Generate Q in VT */ -/* (Workspace: need M+N, prefer M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & - work[iwork], &i__2, &ierr); - -/* Copy L to U, zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], - ldu); - i__2 = *m - 1; - i__3 = *m - 1; - dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[( - u_dim1 << 1) + 1], ldu); - ie = itau; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in U */ -/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], & - work[itauq], &work[itaup], &work[iwork], & - i__2, &ierr); - -/* Multiply right bidiagonalizing vectors in U by Q */ -/* in VT */ -/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, & - work[itaup], &vt[vt_offset], ldvt, &work[ - iwork], &i__2, &ierr); - -/* Generate left bidiagonalizing vectors in U */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], - &work[iwork], &i__2, &ierr); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, computing left */ -/* singular vectors of A in U and computing right */ -/* singular vectors of A in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, & - c__1, &work[iwork], info); - - } - - } - - } - - } else { - -/* N .LT. MNTHR */ - -/* Path 10t(N greater than M, but not much larger) */ -/* Reduce to bidiagonal form without LQ decomposition */ - - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize A */ -/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__2, &ierr); - if (wntuas) { - -/* If left singular vectors desired in U, copy result to U */ -/* and generate left bidiagonalizing vectors in U */ -/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) */ - - dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu); - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[ - iwork], &i__2, &ierr); - } - if (wntvas) { - -/* If right singular vectors desired in VT, copy result to */ -/* VT and generate right bidiagonalizing vectors in VT */ -/* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB) */ - - dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); - if (wntva) { - nrvt = *n; - } - if (wntvs) { - nrvt = *m; - } - i__2 = *lwork - iwork + 1; - dorgbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup], - &work[iwork], &i__2, &ierr); - } - if (wntuo) { - -/* If left singular vectors desired in A, generate left */ -/* bidiagonalizing vectors in A */ -/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[ - iwork], &i__2, &ierr); - } - if (wntvo) { - -/* If right singular vectors desired in A, generate right */ -/* bidiagonalizing vectors in A */ -/* (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ - iwork], &i__2, &ierr); - } - iwork = ie + *m; - if (wntuas || wntuo) { - nru = *m; - } - if (wntun) { - nru = 0; - } - if (wntvas || wntvo) { - ncvt = *n; - } - if (wntvn) { - ncvt = 0; - } - if (! wntuo && ! wntvo) { - -/* Perform bidiagonal QR iteration, if desired, computing */ -/* left singular vectors in U and computing right singular */ -/* vectors in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, & - work[iwork], info); - } else if (! wntuo && wntvo) { - -/* Perform bidiagonal QR iteration, if desired, computing */ -/* left singular vectors in U and computing right singular */ -/* vectors in A */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[ - a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[ - iwork], info); - } else { - -/* Perform bidiagonal QR iteration, if desired, computing */ -/* left singular vectors in A and computing right singular */ -/* vectors in VT */ -/* (Workspace: need BDSPAC) */ - - dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ - vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & - work[iwork], info); - } - - } - - } - -/* If DBDSQR failed to converge, copy unconverged superdiagonals */ -/* to WORK( 2:MINMN ) */ - - if (*info != 0) { - if (ie > 2) { - i__2 = minmn - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__ + 1] = work[i__ + ie - 1]; -/* L50: */ - } - } - if (ie < 2) { - for (i__ = minmn - 1; i__ >= 1; --i__) { - work[i__ + 1] = work[i__ + ie - 1]; -/* L60: */ - } - } - } - -/* Undo scaling if necessary */ - - if (iscl == 1) { - if (anrm > bignum) { - dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr); - } - if (*info != 0 && anrm > bignum) { - i__2 = minmn - 1; - dlascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2], - &minmn, &ierr); - } - if (anrm < smlnum) { - dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, &ierr); - } - if (*info != 0 && anrm < smlnum) { - i__2 = minmn - 1; - dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2], - &minmn, &ierr); - } - } - -/* Return optimal workspace in WORK(1) */ - - work[1] = (double) maxwrk; - - return 0; - -/* End of DGESVD */ - -} /* dgesvd_ */ diff --git a/external/clapack/lapack/dgesvx.cpp b/external/clapack/lapack/dgesvx.cpp deleted file mode 100644 index 9231b100..00000000 --- a/external/clapack/lapack/dgesvx.cpp +++ /dev/null @@ -1,552 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgesvx_(const char *fact, const char *trans, integer *n, integer * - nrhs, double *a, integer *lda, double *af, integer *ldaf, - integer *ipiv, char *equed, double *r__, double *c__, - double *b, integer *ldb, double *x, integer *ldx, double * - rcond, double *ferr, double *berr, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double amax; - char norm[1]; - double rcmin, rcmax, anorm; - bool equil; - double colcnd; - bool nofact; - double bignum; - integer infequ; - bool colequ; - double rowcnd; - bool notran; - double smlnum; - bool rowequ; - double rpvgrw; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGESVX uses the LU factorization to compute the solution to a real */ -/* system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ -/* the system: */ -/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ -/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ -/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ -/* Whether or not the system will be equilibrated depends on the */ -/* scaling of the matrix A, but if equilibration is used, A is */ -/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ -/* or diag(C)*B (if TRANS = 'T' or 'C'). */ - -/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */ -/* matrix A (after equilibration if FACT = 'E') as */ -/* A = P * L * U, */ -/* where P is a permutation matrix, L is a unit lower triangular */ -/* matrix, and U is upper triangular. */ - -/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */ -/* returns with INFO = i. Otherwise, the factored form of A is used */ -/* to estimate the condition number of the matrix A. If the */ -/* reciprocal of the condition number is less than machine precision, */ -/* INFO = N+1 is returned as a warning, but the routine still goes on */ -/* to solve for X and compute error bounds as described below. */ - -/* 4. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 5. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* 6. If equilibration was used, the matrix X is premultiplied by */ -/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ -/* that it solves the original system before equilibration. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of the matrix A is */ -/* supplied on entry, and if not, whether the matrix A should be */ -/* equilibrated before it is factored. */ -/* = 'F': On entry, AF and IPIV contain the factored form of A. */ -/* If EQUED is not 'N', the matrix A has been */ -/* equilibrated with scaling factors given by R and C. */ -/* A, AF, and IPIV are not modified. */ -/* = 'N': The matrix A will be copied to AF and factored. */ -/* = 'E': The matrix A will be equilibrated if necessary, then */ -/* copied to AF and factored. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Transpose) */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */ -/* not 'N', then A must have been equilibrated by the scaling */ -/* factors in R and/or C. A is not modified if FACT = 'F' or */ -/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ - -/* On exit, if EQUED .ne. 'N', A is scaled as follows: */ -/* EQUED = 'R': A := diag(R) * A */ -/* EQUED = 'C': A := A * diag(C) */ -/* EQUED = 'B': A := diag(R) * A * diag(C). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* If FACT = 'F', then AF is an input argument and on entry */ -/* contains the factors L and U from the factorization */ -/* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then */ -/* AF is the factored form of the equilibrated matrix A. */ - -/* If FACT = 'N', then AF is an output argument and on exit */ -/* returns the factors L and U from the factorization A = P*L*U */ -/* of the original matrix A. */ - -/* If FACT = 'E', then AF is an output argument and on exit */ -/* returns the factors L and U from the factorization A = P*L*U */ -/* of the equilibrated matrix A (see the description of A for */ -/* the form of the equilibrated matrix). */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* IPIV (input or output) INTEGER array, dimension (N) */ -/* If FACT = 'F', then IPIV is an input argument and on entry */ -/* contains the pivot indices from the factorization A = P*L*U */ -/* as computed by DGETRF; row i of the matrix was interchanged */ -/* with row IPIV(i). */ - -/* If FACT = 'N', then IPIV is an output argument and on exit */ -/* contains the pivot indices from the factorization A = P*L*U */ -/* of the original matrix A. */ - -/* If FACT = 'E', then IPIV is an output argument and on exit */ -/* contains the pivot indices from the factorization A = P*L*U */ -/* of the equilibrated matrix A. */ - -/* EQUED (input or output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration (always true if FACT = 'N'). */ -/* = 'R': Row equilibration, i.e., A has been premultiplied by */ -/* diag(R). */ -/* = 'C': Column equilibration, i.e., A has been postmultiplied */ -/* by diag(C). */ -/* = 'B': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(R) * A * diag(C). */ -/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ -/* output argument. */ - -/* R (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The row scale factors for A. If EQUED = 'R' or 'B', A is */ -/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ -/* is not accessed. R is an input argument if FACT = 'F'; */ -/* otherwise, R is an output argument. If FACT = 'F' and */ -/* EQUED = 'R' or 'B', each element of R must be positive. */ - -/* C (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The column scale factors for A. If EQUED = 'C' or 'B', A is */ -/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ -/* is not accessed. C is an input argument if FACT = 'F'; */ -/* otherwise, C is an output argument. If FACT = 'F' and */ -/* EQUED = 'C' or 'B', each element of C must be positive. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, */ -/* if EQUED = 'N', B is not modified; */ -/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ -/* diag(R)*B; */ -/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ -/* overwritten by diag(C)*B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */ -/* to the original system of equations. Note that A and B are */ -/* modified on exit if EQUED .ne. 'N', and the solution to the */ -/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */ -/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */ -/* and EQUED = 'R' or 'B'. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The estimate of the reciprocal condition number of the matrix */ -/* A after equilibration (if done). If RCOND is less than the */ -/* machine precision (in particular, if RCOND = 0), the matrix */ -/* is singular to working precision. This condition is */ -/* indicated by a return code of INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (4*N) */ -/* On exit, WORK(1) contains the reciprocal pivot growth */ -/* factor norm(A)/norm(U). The "max absolute element" norm is */ -/* used. If WORK(1) is much less than 1, then the stability */ -/* of the LU factorization of the (equilibrated) matrix A */ -/* could be poor. This also means that the solution X, condition */ -/* estimator RCOND, and forward error bound FERR could be */ -/* unreliable. If factorization fails with 0 0: if INFO = i, and i is */ -/* <= N: U(i,i) is exactly zero. The factorization has */ -/* been completed, but the factor U is exactly */ -/* singular, so the solution and error bounds */ -/* could not be computed. RCOND = 0 is returned. */ -/* = N+1: U is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --ipiv; - --r__; - --c__; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - equil = lsame_(fact, "E"); - notran = lsame_(trans, "N"); - if (nofact || equil) { - *(unsigned char *)equed = 'N'; - rowequ = false; - colequ = false; - } else { - rowequ = lsame_(equed, "R") || lsame_(equed, - "B"); - colequ = lsame_(equed, "C") || lsame_(equed, - "B"); - smlnum = dlamch_("Safe minimum"); - bignum = 1. / smlnum; - } - -/* Test the input parameters. */ - - if (! nofact && ! equil && ! lsame_(fact, "F")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -8; - } else if (lsame_(fact, "F") && ! (rowequ || colequ - || lsame_(equed, "N"))) { - *info = -10; - } else { - if (rowequ) { - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[j]; - rcmax = std::max(d__1,d__2); -/* L10: */ - } - if (rcmin <= 0.) { - *info = -11; - } else if (*n > 0) { - rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } else { - rowcnd = 1.; - } - } - if (colequ && *info == 0) { - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = std::max(d__1,d__2); -/* L20: */ - } - if (rcmin <= 0.) { - *info = -12; - } else if (*n > 0) { - colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); - } else { - colcnd = 1.; - } - } - if (*info == 0) { - if (*ldb < std::max(1_integer,*n)) { - *info = -14; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -16; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGESVX", &i__1); - return 0; - } - - if (equil) { - -/* Compute row and column scalings to equilibrate the matrix A. */ - - dgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, & - amax, &infequ); - if (infequ == 0) { - -/* Equilibrate the matrix. */ - - dlaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, & - colcnd, &amax, equed); - rowequ = lsame_(equed, "R") || lsame_(equed, - "B"); - colequ = lsame_(equed, "C") || lsame_(equed, - "B"); - } - } - -/* Scale the right hand side. */ - - if (notran) { - if (rowequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1]; -/* L30: */ - } -/* L40: */ - } - } - } else if (colequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1]; -/* L50: */ - } -/* L60: */ - } - } - - if (nofact || equil) { - -/* Compute the LU factorization of A. */ - - dlacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf); - dgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - -/* Compute the reciprocal pivot growth factor of the */ -/* leading rank-deficient INFO columns of A. */ - - rpvgrw = dlantr_("M", "U", "N", info, info, &af[af_offset], ldaf, - &work[1]); - if (rpvgrw == 0.) { - rpvgrw = 1.; - } else { - rpvgrw = dlange_("M", n, info, &a[a_offset], lda, &work[1]) / rpvgrw; - } - work[1] = rpvgrw; - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A and the */ -/* reciprocal pivot growth factor RPVGRW. */ - - if (notran) { - *(unsigned char *)norm = '1'; - } else { - *(unsigned char *)norm = 'I'; - } - anorm = dlange_(norm, n, n, &a[a_offset], lda, &work[1]); - rpvgrw = dlantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &work[1]); - if (rpvgrw == 0.) { - rpvgrw = 1.; - } else { - rpvgrw = dlange_("M", n, n, &a[a_offset], lda, &work[1]) / - rpvgrw; - } - -/* Compute the reciprocal of the condition number of A. */ - - dgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1], - info); - -/* Compute the solution matrix X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, - info); - -/* Use iterative refinement to improve the computed solution and */ -/* compute error bounds and backward error estimates for it. */ - - dgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], - &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[ - 1], &iwork[1], info); - -/* Transform the solution matrix X to a solution of the original */ -/* system. */ - - if (notran) { - if (colequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1]; -/* L70: */ - } -/* L80: */ - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] /= colcnd; -/* L90: */ - } - } - } else if (rowequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1]; -/* L100: */ - } -/* L110: */ - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] /= rowcnd; -/* L120: */ - } - } - - work[1] = rpvgrw; - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - return 0; - -/* End of DGESVX */ - -} /* dgesvx_ */ diff --git a/external/clapack/lapack/dgetc2.cpp b/external/clapack/lapack/dgetc2.cpp deleted file mode 100644 index 2cad5af2..00000000 --- a/external/clapack/lapack/dgetc2.cpp +++ /dev/null @@ -1,181 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b10 = -1.; - -/* Subroutine */ int dgetc2_(integer *n, double *a, integer *lda, integer - *ipiv, integer *jpiv, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer i__, j, ip, jp; - double eps; - integer ipv, jpv; - double smin, xmax; - double bignum, smlnum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGETC2 computes an LU factorization with complete pivoting of the */ -/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */ -/* where P and Q are permutation matrices, L is lower triangular with */ -/* unit diagonal elements and U is upper triangular. */ - -/* This is the Level 2 BLAS algorithm. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the n-by-n matrix A to be factored. */ -/* On exit, the factors L and U from the factorization */ -/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */ -/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */ -/* value of SMIN, i.e., giving a nonsingular perturbed system. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension(N). */ -/* The pivot indices; for 1 <= i <= N, row i of the */ -/* matrix has been interchanged with row IPIV(i). */ - -/* JPIV (output) INTEGER array, dimension(N). */ -/* The pivot indices; for 1 <= j <= N, column j of the */ -/* matrix has been interchanged with column JPIV(j). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* > 0: if INFO = k, U(k, k) is likely to produce owerflow if */ -/* we try to solve for x in Ax = b. So U is perturbed to */ -/* avoid the overflow. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Set constants to control overflow */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - --jpiv; - - /* Function Body */ - *info = 0; - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Factorize A using complete pivoting. */ -/* Set pivots less than SMIN to SMIN. */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Find max element in matrix A */ - - xmax = 0.; - i__2 = *n; - for (ip = i__; ip <= i__2; ++ip) { - i__3 = *n; - for (jp = i__; jp <= i__3; ++jp) { - if ((d__1 = a[ip + jp * a_dim1], abs(d__1)) >= xmax) { - xmax = (d__1 = a[ip + jp * a_dim1], abs(d__1)); - ipv = ip; - jpv = jp; - } -/* L10: */ - } -/* L20: */ - } - if (i__ == 1) { -/* Computing MAX */ - d__1 = eps * xmax; - smin = std::max(d__1,smlnum); - } - -/* Swap rows */ - - if (ipv != i__) { - dswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda); - } - ipiv[i__] = ipv; - -/* Swap columns */ - - if (jpv != i__) { - dswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & - c__1); - } - jpiv[i__] = jpv; - -/* Check for singularity */ - - if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) < smin) { - *info = i__; - a[i__ + i__ * a_dim1] = smin; - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - a[j + i__ * a_dim1] /= a[i__ + i__ * a_dim1]; -/* L30: */ - } - i__2 = *n - i__; - i__3 = *n - i__; - dger_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[i__ - + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda); -/* L40: */ - } - - if ((d__1 = a[*n + *n * a_dim1], abs(d__1)) < smin) { - *info = *n; - a[*n + *n * a_dim1] = smin; - } - - return 0; - -/* End of DGETC2 */ - -} /* dgetc2_ */ diff --git a/external/clapack/lapack/dgetf2.cpp b/external/clapack/lapack/dgetf2.cpp deleted file mode 100644 index 1cb0899f..00000000 --- a/external/clapack/lapack/dgetf2.cpp +++ /dev/null @@ -1,171 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b8 = -1.; - -/* Subroutine */ int dgetf2_(integer *m, integer *n, double *a, integer * - lda, integer *ipiv, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer i__, j, jp; - double sfmin; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGETF2 computes an LU factorization of a general m-by-n matrix A */ -/* using partial pivoting with row interchanges. */ - -/* The factorization has the form */ -/* A = P * L * U */ -/* where P is a permutation matrix, L is lower triangular with unit */ -/* diagonal elements (lower trapezoidal if m > n), and U is upper */ -/* triangular (upper trapezoidal if m < n). */ - -/* This is the right-looking Level 2 BLAS version of the algorithm. */ - -/* 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 to be factored. */ -/* On exit, the factors L and U from the factorization */ -/* A = P*L*U; the unit diagonal elements of L are not stored. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* IPIV (output) INTEGER array, dimension (min(M,N)) */ -/* The pivot indices; for 1 <= i <= min(M,N), row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly */ -/* singular, and division by zero will occur if it is used */ -/* to solve a system of equations. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGETF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Compute machine safe minimum */ - - sfmin = dlamch_("S"); - - i__1 = std::min(*m,*n); - for (j = 1; j <= i__1; ++j) { - -/* Find pivot and test for singularity. */ - - i__2 = *m - j + 1; - jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1); - ipiv[j] = jp; - if (a[jp + j * a_dim1] != 0.) { - -/* Apply the interchange to columns 1:N. */ - - if (jp != j) { - dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda); - } - -/* Compute elements J+1:M of J-th column. */ - - if (j < *m) { - if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) { - i__2 = *m - j; - d__1 = 1. / a[j + j * a_dim1]; - dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); - } else { - i__2 = *m - j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[j + i__ + j * a_dim1] /= a[j + j * a_dim1]; -/* L20: */ - } - } - } - - } else if (*info == 0) { - - *info = j; - } - - if (j < std::min(*m,*n)) { - -/* Update trailing submatrix. */ - - i__2 = *m - j; - i__3 = *n - j; - dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + ( - j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda); - } -/* L10: */ - } - return 0; - -/* End of DGETF2 */ - -} /* dgetf2_ */ diff --git a/external/clapack/lapack/dgetrf.cpp b/external/clapack/lapack/dgetrf.cpp deleted file mode 100644 index 5f8e25be..00000000 --- a/external/clapack/lapack/dgetrf.cpp +++ /dev/null @@ -1,195 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b16 = 1.; -static double c_b19 = -1.; - -/* Subroutine */ int dgetrf_(integer *m, integer *n, double *a, integer * - lda, integer *ipiv, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - - /* Local variables */ - integer i__, j, jb, nb; - integer iinfo; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGETRF computes an LU factorization of a general M-by-N matrix A */ -/* using partial pivoting with row interchanges. */ - -/* The factorization has the form */ -/* A = P * L * U */ -/* where P is a permutation matrix, L is lower triangular with unit */ -/* diagonal elements (lower trapezoidal if m > n), and U is upper */ -/* triangular (upper trapezoidal if m < n). */ - -/* This is the right-looking Level 3 BLAS version of the algorithm. */ - -/* 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 to be factored. */ -/* On exit, the factors L and U from the factorization */ -/* A = P*L*U; the unit diagonal elements of L are not stored. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* IPIV (output) INTEGER array, dimension (min(M,N)) */ -/* The pivot indices; for 1 <= i <= min(M,N), row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly */ -/* singular, and division by zero will occur if it is used */ -/* to solve a system of equations. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGETRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DGETRF", " ", m, n, &c_n1, &c_n1); - if (nb <= 1 || nb >= std::min(*m,*n)) { - -/* Use unblocked code. */ - - dgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info); - } else { - -/* Use blocked code. */ - - i__1 = std::min(*m,*n); - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = std::min(*m,*n) - j + 1; - jb = std::min(i__3,nb); - -/* Factor diagonal and subdiagonal blocks and test for exact */ -/* singularity. */ - - i__3 = *m - j + 1; - dgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo); - -/* Adjust INFO and the pivot indices. */ - - if (*info == 0 && iinfo > 0) { - *info = iinfo + j - 1; - } -/* Computing MIN */ - i__4 = *m, i__5 = j + jb - 1; - i__3 = std::min(i__4,i__5); - for (i__ = j; i__ <= i__3; ++i__) { - ipiv[i__] = j - 1 + ipiv[i__]; -/* L10: */ - } - -/* Apply interchanges to columns 1:J-1. */ - - i__3 = j - 1; - i__4 = j + jb - 1; - dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1); - - if (j + jb <= *n) { - -/* Apply interchanges to columns J+JB:N. */ - - i__3 = *n - j - jb + 1; - i__4 = j + jb - 1; - dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, & - ipiv[1], &c__1); - -/* Compute block row of U. */ - - i__3 = *n - j - jb + 1; - dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, & - c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) * - a_dim1], lda); - if (j + jb <= *m) { - -/* Update trailing submatrix. */ - - i__3 = *m - j - jb + 1; - i__4 = *n - j - jb + 1; - dgemm_("No transpose", "No transpose", &i__3, &i__4, &jb, - &c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j + - jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) * - a_dim1], lda); - } - } -/* L20: */ - } - } - return 0; - -/* End of DGETRF */ - -} /* dgetrf_ */ diff --git a/external/clapack/lapack/dgetri.cpp b/external/clapack/lapack/dgetri.cpp deleted file mode 100644 index 465a1573..00000000 --- a/external/clapack/lapack/dgetri.cpp +++ /dev/null @@ -1,237 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; -static double c_b20 = -1.; -static double c_b22 = 1.; - -/* Subroutine */ int dgetri_(integer *n, double *a, integer *lda, integer - *ipiv, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, jb, nb, jj, jp, nn, iws; - integer nbmin; - integer ldwork; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGETRI computes the inverse of a matrix using the LU factorization */ -/* computed by DGETRF. */ - -/* This method inverts U and then computes inv(A) by solving the system */ -/* inv(A)*L = inv(U) for inv(A). */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the factors L and U from the factorization */ -/* A = P*L*U as computed by DGETRF. */ -/* On exit, if INFO = 0, the inverse of the original matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,N). */ -/* For optimal performance LWORK >= N*NB, where NB is */ -/* the optimal blocksize returned by ILAENV. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is */ -/* singular and its inverse could not be computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DGETRI", " ", n, &c_n1, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*n < 0) { - *info = -1; - } else if (*lda < std::max(1_integer,*n)) { - *info = -3; - } else if (*lwork < std::max(1_integer,*n) && ! lquery) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGETRI", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, */ -/* and the inverse is not computed. */ - - dtrtri_("Upper", "Non-unit", n, &a[a_offset], lda, info); - if (*info > 0) { - return 0; - } - - nbmin = 2; - ldwork = *n; - if (nb > 1 && nb < *n) { -/* Computing MAX */ - i__1 = ldwork * nb; - iws = std::max(i__1,1_integer); - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGETRI", " ", n, &c_n1, &c_n1, & - c_n1); - nbmin = std::max(i__1,i__2); - } - } else { - iws = *n; - } - -/* Solve the equation inv(A)*L = inv(U) for inv(A). */ - - if (nb < nbmin || nb >= *n) { - -/* Use unblocked code. */ - - for (j = *n; j >= 1; --j) { - -/* Copy current column of L to WORK and replace with zeros. */ - - i__1 = *n; - for (i__ = j + 1; i__ <= i__1; ++i__) { - work[i__] = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = 0.; -/* L10: */ - } - -/* Compute current column of inv(A). */ - - if (j < *n) { - i__1 = *n - j; - dgemv_("No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1 - + 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1 - + 1], &c__1); - } -/* L20: */ - } - } else { - -/* Use blocked code. */ - - nn = (*n - 1) / nb * nb + 1; - i__1 = -nb; - for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *n - j + 1; - jb = std::min(i__2,i__3); - -/* Copy current block column of L to WORK and replace with */ -/* zeros. */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = *n; - for (i__ = jj + 1; i__ <= i__3; ++i__) { - work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1]; - a[i__ + jj * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - -/* Compute current block column of inv(A). */ - - if (j + jb <= *n) { - i__2 = *n - j - jb + 1; - dgemm_("No transpose", "No transpose", n, &jb, &i__2, &c_b20, - &a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], & - ldwork, &c_b22, &a[j * a_dim1 + 1], lda); - } - dtrsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b22, & - work[j], &ldwork, &a[j * a_dim1 + 1], lda); -/* L50: */ - } - } - -/* Apply column interchanges. */ - - for (j = *n - 1; j >= 1; --j) { - jp = ipiv[j]; - if (jp != j) { - dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1); - } -/* L60: */ - } - - work[1] = (double) iws; - return 0; - -/* End of DGETRI */ - -} /* dgetri_ */ diff --git a/external/clapack/lapack/dgetrs.cpp b/external/clapack/lapack/dgetrs.cpp deleted file mode 100644 index 4e5e6539..00000000 --- a/external/clapack/lapack/dgetrs.cpp +++ /dev/null @@ -1,168 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b12 = 1.; -static integer c_n1 = -1; - -/* Subroutine */ int dgetrs_(const char *trans, integer *n, integer *nrhs, - double *a, integer *lda, integer *ipiv, double *b, integer * - ldb, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - bool notran; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGETRS solves a system of linear equations */ -/* A * X = B or A' * X = B */ -/* with a general N-by-N matrix A using the LU factorization computed */ -/* by DGETRF. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A'* X = B (Transpose) */ -/* = 'C': A'* X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The factors L and U from the factorization A = P*L*U */ -/* as computed by DGETRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T") && ! lsame_( - trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGETRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (notran) { - -/* Solve A * X = B. */ - -/* Apply row interchanges to the right hand sides. */ - - dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); - -/* Solve L*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Solve U*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, & - a[a_offset], lda, &b[b_offset], ldb); - } else { - -/* Solve A' * X = B. */ - -/* Solve U'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Solve L'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Apply row interchanges to the solution vectors. */ - - dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); - } - - return 0; - -/* End of DGETRS */ - -} /* dgetrs_ */ diff --git a/external/clapack/lapack/dggbak.cpp b/external/clapack/lapack/dggbak.cpp deleted file mode 100644 index f08915a7..00000000 --- a/external/clapack/lapack/dggbak.cpp +++ /dev/null @@ -1,258 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dggbak_(const char *job, const char *side, integer *n, integer *ilo, - integer *ihi, double *lscale, double *rscale, integer *m, - double *v, integer *ldv, integer *info) -{ - /* System generated locals */ - integer v_dim1, v_offset, i__1; - - /* Local variables */ - integer i__, k; - bool leftv; - bool rightv; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGBAK forms the right or left eigenvectors of a real generalized */ -/* eigenvalue problem A*x = lambda*B*x, by backward transformation on */ -/* the computed eigenvectors of the balanced pair of matrices output by */ -/* DGGBAL. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* Specifies the type of backward transformation required: */ -/* = 'N': do nothing, return immediately; */ -/* = 'P': do backward transformation for permutation only; */ -/* = 'S': do backward transformation for scaling only; */ -/* = 'B': do backward transformations for both permutation and */ -/* scaling. */ -/* JOB must be the same as the argument JOB supplied to DGGBAL. */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'R': V contains right eigenvectors; */ -/* = 'L': V contains left eigenvectors. */ - -/* N (input) INTEGER */ -/* The number of rows of the matrix V. N >= 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* The integers ILO and IHI determined by DGGBAL. */ -/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ - -/* LSCALE (input) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutations and/or scaling factors applied */ -/* to the left side of A and B, as returned by DGGBAL. */ - -/* RSCALE (input) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutations and/or scaling factors applied */ -/* to the right side of A and B, as returned by DGGBAL. */ - -/* M (input) INTEGER */ -/* The number of columns of the matrix V. M >= 0. */ - -/* V (input/output) DOUBLE PRECISION array, dimension (LDV,M) */ -/* On entry, the matrix of right or left eigenvectors to be */ -/* transformed, as returned by DTGEVC. */ -/* On exit, V is overwritten by the transformed eigenvectors. */ - -/* LDV (input) INTEGER */ -/* The leading dimension of the matrix V. LDV >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* See R.C. Ward, Balancing the generalized eigenvalue problem, */ -/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - --lscale; - --rscale; - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - - /* Function Body */ - rightv = lsame_(side, "R"); - leftv = lsame_(side, "L"); - - *info = 0; - if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") - && ! lsame_(job, "B")) { - *info = -1; - } else if (! rightv && ! leftv) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ilo < 1) { - *info = -4; - } else if (*n == 0 && *ihi == 0 && *ilo != 1) { - *info = -4; - } else if (*n > 0 && (*ihi < *ilo || *ihi > std::max(1_integer,*n))) { - *info = -5; - } else if (*n == 0 && *ilo == 1 && *ihi != 0) { - *info = -5; - } else if (*m < 0) { - *info = -8; - } else if (*ldv < std::max(1_integer,*n)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGBAK", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - if (*m == 0) { - return 0; - } - if (lsame_(job, "N")) { - return 0; - } - - if (*ilo == *ihi) { - goto L30; - } - -/* Backward balance */ - - if (lsame_(job, "S") || lsame_(job, "B")) { - -/* Backward transformation on right eigenvectors */ - - if (rightv) { - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - dscal_(m, &rscale[i__], &v[i__ + v_dim1], ldv); -/* L10: */ - } - } - -/* Backward transformation on left eigenvectors */ - - if (leftv) { - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - dscal_(m, &lscale[i__], &v[i__ + v_dim1], ldv); -/* L20: */ - } - } - } - -/* Backward permutation */ - -L30: - if (lsame_(job, "P") || lsame_(job, "B")) { - -/* Backward permutation on right eigenvectors */ - - if (rightv) { - if (*ilo == 1) { - goto L50; - } - - for (i__ = *ilo - 1; i__ >= 1; --i__) { - k = (integer) rscale[i__]; - if (k == i__) { - goto L40; - } - dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); -L40: - ; - } - -L50: - if (*ihi == *n) { - goto L70; - } - i__1 = *n; - for (i__ = *ihi + 1; i__ <= i__1; ++i__) { - k = (integer) rscale[i__]; - if (k == i__) { - goto L60; - } - dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); -L60: - ; - } - } - -/* Backward permutation on left eigenvectors */ - -L70: - if (leftv) { - if (*ilo == 1) { - goto L90; - } - for (i__ = *ilo - 1; i__ >= 1; --i__) { - k = (integer) lscale[i__]; - if (k == i__) { - goto L80; - } - dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); -L80: - ; - } - -L90: - if (*ihi == *n) { - goto L110; - } - i__1 = *n; - for (i__ = *ihi + 1; i__ <= i__1; ++i__) { - k = (integer) lscale[i__]; - if (k == i__) { - goto L100; - } - dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); -L100: - ; - } - } - } - -L110: - - return 0; - -/* End of DGGBAK */ - -} /* dggbak_ */ diff --git a/external/clapack/lapack/dggbal.cpp b/external/clapack/lapack/dggbal.cpp deleted file mode 100644 index d0d42c9c..00000000 --- a/external/clapack/lapack/dggbal.cpp +++ /dev/null @@ -1,599 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b35 = 10.; -static double c_b71 = .5; - -/* Subroutine */ int dggbal_(const char *job, integer *n, double *a, integer * - lda, double *b, integer *ldb, integer *ilo, integer *ihi, - double *lscale, double *rscale, double *work, integer * - info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k, l, m; - double t; - integer jc; - double ta, tb, tc; - integer ir; - double ew; - integer it, nr, ip1, jp1, lm1; - double cab, rab, ewc, cor, sum; - integer nrp2, icab, lcab; - double beta, coef; - integer irab, lrab; - double basl, cmax; - double coef2, coef5, gamma, alpha; - double sfmin, sfmax; - integer iflow; - integer kount; - double pgamma; - integer lsfmin, lsfmax; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGBAL balances a pair of general real matrices (A,B). This */ -/* involves, first, permuting A and B by similarity transformations to */ -/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */ -/* elements on the diagonal; and second, applying a diagonal similarity */ -/* transformation to rows and columns ILO to IHI to make the rows */ -/* and columns as close in norm as possible. Both steps are optional. */ - -/* Balancing may reduce the 1-norm of the matrices, and improve the */ -/* accuracy of the computed eigenvalues and/or eigenvectors in the */ -/* generalized eigenvalue problem A*x = lambda*B*x. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* Specifies the operations to be performed on A and B: */ -/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */ -/* and RSCALE(I) = 1.0 for i = 1,...,N. */ -/* = 'P': permute only; */ -/* = 'S': scale only; */ -/* = 'B': both permute and scale. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the input matrix A. */ -/* On exit, A is overwritten by the balanced matrix. */ -/* If JOB = 'N', A is not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ -/* On entry, the input matrix B. */ -/* On exit, B is overwritten by the balanced matrix. */ -/* If JOB = 'N', B is not referenced. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* ILO (output) INTEGER */ -/* IHI (output) INTEGER */ -/* ILO and IHI are set to integers such that on exit */ -/* A(i,j) = 0 and B(i,j) = 0 if i > j and */ -/* j = 1,...,ILO-1 or i = IHI+1,...,N. */ -/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */ - -/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutations and scaling factors applied */ -/* to the left side of A and B. If P(j) is the index of the */ -/* row interchanged with row j, and D(j) */ -/* is the scaling factor applied to row j, then */ -/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */ -/* = D(j) for J = ILO,...,IHI */ -/* = P(j) for J = IHI+1,...,N. */ -/* The order in which the interchanges are made is N to IHI+1, */ -/* then 1 to ILO-1. */ - -/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutations and scaling factors applied */ -/* to the right side of A and B. If P(j) is the index of the */ -/* column interchanged with column j, and D(j) */ -/* is the scaling factor applied to column j, then */ -/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */ -/* = D(j) for J = ILO,...,IHI */ -/* = P(j) for J = IHI+1,...,N. */ -/* The order in which the interchanges are made is N to IHI+1, */ -/* then 1 to ILO-1. */ - -/* WORK (workspace) REAL array, dimension (lwork) */ -/* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and */ -/* at least 1 when JOB = 'N' or 'P'. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* See R.C. WARD, Balancing the generalized eigenvalue problem, */ -/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --lscale; - --rscale; - --work; - - /* Function Body */ - *info = 0; - if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") - && ! lsame_(job, "B")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGBAL", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *ilo = 1; - *ihi = *n; - return 0; - } - - if (*n == 1) { - *ilo = 1; - *ihi = *n; - lscale[1] = 1.; - rscale[1] = 1.; - return 0; - } - - if (lsame_(job, "N")) { - *ilo = 1; - *ihi = *n; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - lscale[i__] = 1.; - rscale[i__] = 1.; -/* L10: */ - } - return 0; - } - - k = 1; - l = *n; - if (lsame_(job, "S")) { - goto L190; - } - - goto L30; - -/* Permute the matrices A and B to isolate the eigenvalues. */ - -/* Find row with one nonzero in columns 1 through L */ - -L20: - l = lm1; - if (l != 1) { - goto L30; - } - - rscale[1] = 1.; - lscale[1] = 1.; - goto L190; - -L30: - lm1 = l - 1; - for (i__ = l; i__ >= 1; --i__) { - i__1 = lm1; - for (j = 1; j <= i__1; ++j) { - jp1 = j + 1; - if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { - goto L50; - } -/* L40: */ - } - j = l; - goto L70; - -L50: - i__1 = l; - for (j = jp1; j <= i__1; ++j) { - if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { - goto L80; - } -/* L60: */ - } - j = jp1 - 1; - -L70: - m = l; - iflow = 1; - goto L160; -L80: - ; - } - goto L100; - -/* Find column with one nonzero in rows K through N */ - -L90: - ++k; - -L100: - i__1 = l; - for (j = k; j <= i__1; ++j) { - i__2 = lm1; - for (i__ = k; i__ <= i__2; ++i__) { - ip1 = i__ + 1; - if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { - goto L120; - } -/* L110: */ - } - i__ = l; - goto L140; -L120: - i__2 = l; - for (i__ = ip1; i__ <= i__2; ++i__) { - if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { - goto L150; - } -/* L130: */ - } - i__ = ip1 - 1; -L140: - m = k; - iflow = 2; - goto L160; -L150: - ; - } - goto L190; - -/* Permute rows M and I */ - -L160: - lscale[m] = (double) i__; - if (i__ == m) { - goto L170; - } - i__1 = *n - k + 1; - dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda); - i__1 = *n - k + 1; - dswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb); - -/* Permute columns M and J */ - -L170: - rscale[m] = (double) j; - if (j == m) { - goto L180; - } - dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1); - dswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1); - -L180: - switch (iflow) { - case 1: goto L20; - case 2: goto L90; - } - -L190: - *ilo = k; - *ihi = l; - - if (lsame_(job, "P")) { - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - lscale[i__] = 1.; - rscale[i__] = 1.; -/* L195: */ - } - return 0; - } - - if (*ilo == *ihi) { - return 0; - } - -/* Balance the submatrix in rows ILO to IHI. */ - - nr = *ihi - *ilo + 1; - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - rscale[i__] = 0.; - lscale[i__] = 0.; - - work[i__] = 0.; - work[i__ + *n] = 0.; - work[i__ + (*n << 1)] = 0.; - work[i__ + *n * 3] = 0.; - work[i__ + (*n << 2)] = 0.; - work[i__ + *n * 5] = 0.; -/* L200: */ - } - -/* Compute right side vector in resulting linear equations */ - - basl = d_lg10(&c_b35); - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - i__2 = *ihi; - for (j = *ilo; j <= i__2; ++j) { - tb = b[i__ + j * b_dim1]; - ta = a[i__ + j * a_dim1]; - if (ta == 0.) { - goto L210; - } - d__1 = abs(ta); - ta = d_lg10(&d__1) / basl; -L210: - if (tb == 0.) { - goto L220; - } - d__1 = abs(tb); - tb = d_lg10(&d__1) / basl; -L220: - work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb; - work[j + *n * 5] = work[j + *n * 5] - ta - tb; -/* L230: */ - } -/* L240: */ - } - - coef = 1. / (double) (nr << 1); - coef2 = coef * coef; - coef5 = coef2 * .5; - nrp2 = nr + 2; - beta = 0.; - it = 1; - -/* Start generalized conjugate gradient iteration */ - -L250: - - gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)] -, &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + * - n * 5], &c__1); - - ew = 0.; - ewc = 0.; - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - ew += work[i__ + (*n << 2)]; - ewc += work[i__ + *n * 5]; -/* L260: */ - } - -/* Computing 2nd power */ - d__1 = ew; -/* Computing 2nd power */ - d__2 = ewc; -/* Computing 2nd power */ - d__3 = ew - ewc; - gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * ( - d__3 * d__3); - if (gamma == 0.) { - goto L350; - } - if (it != 1) { - beta = gamma / pgamma; - } - t = coef5 * (ewc - ew * 3.); - tc = coef5 * (ew - ewc * 3.); - - dscal_(&nr, &beta, &work[*ilo], &c__1); - dscal_(&nr, &beta, &work[*ilo + *n], &c__1); - - daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], & - c__1); - daxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1); - - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - work[i__] += tc; - work[i__ + *n] += t; -/* L270: */ - } - -/* Apply matrix to vector */ - - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - kount = 0; - sum = 0.; - i__2 = *ihi; - for (j = *ilo; j <= i__2; ++j) { - if (a[i__ + j * a_dim1] == 0.) { - goto L280; - } - ++kount; - sum += work[j]; -L280: - if (b[i__ + j * b_dim1] == 0.) { - goto L290; - } - ++kount; - sum += work[j]; -L290: - ; - } - work[i__ + (*n << 1)] = (double) kount * work[i__ + *n] + sum; -/* L300: */ - } - - i__1 = *ihi; - for (j = *ilo; j <= i__1; ++j) { - kount = 0; - sum = 0.; - i__2 = *ihi; - for (i__ = *ilo; i__ <= i__2; ++i__) { - if (a[i__ + j * a_dim1] == 0.) { - goto L310; - } - ++kount; - sum += work[i__ + *n]; -L310: - if (b[i__ + j * b_dim1] == 0.) { - goto L320; - } - ++kount; - sum += work[i__ + *n]; -L320: - ; - } - work[j + *n * 3] = (double) kount * work[j] + sum; -/* L330: */ - } - - sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1) - + ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1); - alpha = gamma / sum; - -/* Determine correction to current iteration */ - - cmax = 0.; - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - cor = alpha * work[i__ + *n]; - if (abs(cor) > cmax) { - cmax = abs(cor); - } - lscale[i__] += cor; - cor = alpha * work[i__]; - if (abs(cor) > cmax) { - cmax = abs(cor); - } - rscale[i__] += cor; -/* L340: */ - } - if (cmax < .5) { - goto L350; - } - - d__1 = -alpha; - daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)] -, &c__1); - d__1 = -alpha; - daxpy_(&nr, &d__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], & - c__1); - - pgamma = gamma; - ++it; - if (it <= nrp2) { - goto L250; - } - -/* End generalized conjugate gradient iteration */ - -L350: - sfmin = dlamch_("S"); - sfmax = 1. / sfmin; - lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.); - lsfmax = (integer) (d_lg10(&sfmax) / basl); - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - i__2 = *n - *ilo + 1; - irab = idamax_(&i__2, &a[i__ + *ilo * a_dim1], lda); - rab = (d__1 = a[i__ + (irab + *ilo - 1) * a_dim1], abs(d__1)); - i__2 = *n - *ilo + 1; - irab = idamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb); -/* Computing MAX */ - d__2 = rab, d__3 = (d__1 = b[i__ + (irab + *ilo - 1) * b_dim1], abs( - d__1)); - rab = std::max(d__2,d__3); - d__1 = rab + sfmin; - lrab = (integer) (d_lg10(&d__1) / basl + 1.); - ir = (integer) (lscale[i__] + d_sign(&c_b71, &lscale[i__])); -/* Computing MIN */ - i__2 = std::max(ir,lsfmin), i__2 = std::min(i__2,lsfmax), i__3 = lsfmax - lrab; - ir = std::min(i__2,i__3); - lscale[i__] = pow_di(&c_b35, &ir); - icab = idamax_(ihi, &a[i__ * a_dim1 + 1], &c__1); - cab = (d__1 = a[icab + i__ * a_dim1], abs(d__1)); - icab = idamax_(ihi, &b[i__ * b_dim1 + 1], &c__1); -/* Computing MAX */ - d__2 = cab, d__3 = (d__1 = b[icab + i__ * b_dim1], abs(d__1)); - cab = std::max(d__2,d__3); - d__1 = cab + sfmin; - lcab = (integer) (d_lg10(&d__1) / basl + 1.); - jc = (integer) (rscale[i__] + d_sign(&c_b71, &rscale[i__])); -/* Computing MIN */ - i__2 = std::max(jc,lsfmin), i__2 = std::min(i__2,lsfmax), i__3 = lsfmax - lcab; - jc = std::min(i__2,i__3); - rscale[i__] = pow_di(&c_b35, &jc); -/* L360: */ - } - -/* Row scaling of matrices A and B */ - - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - i__2 = *n - *ilo + 1; - dscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda); - i__2 = *n - *ilo + 1; - dscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb); -/* L370: */ - } - -/* Column scaling of matrices A and B */ - - i__1 = *ihi; - for (j = *ilo; j <= i__1; ++j) { - dscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1); - dscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1); -/* L380: */ - } - - return 0; - -/* End of DGGBAL */ - -} /* dggbal_ */ diff --git a/external/clapack/lapack/dgges.cpp b/external/clapack/lapack/dgges.cpp deleted file mode 100644 index 0195d823..00000000 --- a/external/clapack/lapack/dgges.cpp +++ /dev/null @@ -1,643 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static integer c_n1 = -1; -static double c_b38 = 0.; -static double c_b39 = 1.; - -/* Subroutine */ int dgges_(const char *jobvsl, const char *jobvsr, const char *sort, - bool (*selctg)(const double *, const double *, const double *), - integer *n, double *a, integer *lda, double *b, - integer *ldb, integer *sdim, double *alphar, double *alphai, - double *beta, double *vsl, integer *ldvsl, double *vsr, - integer *ldvsr, double *work, integer *lwork, bool *bwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, - vsr_dim1, vsr_offset, i__1, i__2; - double d__1; - - /* Builtin functions - double sqrt(double);*/ - - /* Local variables */ - integer i__, ip; - double dif[2]; - integer ihi, ilo; - double eps, anrm, bnrm; - integer idum[1], ierr, itau, iwrk; - double pvsl, pvsr; - integer ileft, icols; - bool cursl, ilvsl, ilvsr; - integer irows; - bool lst2sl; - bool ilascl, ilbscl; - double safmin; - double safmax; - double bignum; - integer ijobvl, iright; - integer ijobvr; - double anrmto, bnrmto; - bool lastsl; - integer minwrk, maxwrk; - double smlnum; - bool wantst, lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ -/* .. Function Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), */ -/* the generalized eigenvalues, the generalized real Schur form (S,T), */ -/* optionally, the left and/or right matrices of Schur vectors (VSL and */ -/* VSR). This gives the generalized Schur factorization */ - -/* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) */ - -/* Optionally, it also orders the eigenvalues so that a selected cluster */ -/* of eigenvalues appears in the leading diagonal blocks of the upper */ -/* quasi-triangular matrix S and the upper triangular matrix T.The */ -/* leading columns of VSL and VSR then form an orthonormal basis for the */ -/* corresponding left and right eigenspaces (deflating subspaces). */ - -/* (If only the generalized eigenvalues are needed, use the driver */ -/* DGGEV instead, which is faster.) */ - -/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */ -/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */ -/* usually represented as the pair (alpha,beta), as there is a */ -/* reasonable interpretation for beta=0 or both being zero. */ - -/* A pair of matrices (S,T) is in generalized real Schur form if T is */ -/* upper triangular with non-negative diagonal and S is block upper */ -/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */ -/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */ -/* "standardized" by making the corresponding elements of T have the */ -/* form: */ -/* [ a 0 ] */ -/* [ 0 b ] */ - -/* and the pair of corresponding 2-by-2 blocks in S and T will have a */ -/* complex conjugate pair of generalized eigenvalues. */ - - -/* Arguments */ -/* ========= */ - -/* JOBVSL (input) CHARACTER*1 */ -/* = 'N': do not compute the left Schur vectors; */ -/* = 'V': compute the left Schur vectors. */ - -/* JOBVSR (input) CHARACTER*1 */ -/* = 'N': do not compute the right Schur vectors; */ -/* = 'V': compute the right Schur vectors. */ - -/* SORT (input) CHARACTER*1 */ -/* Specifies whether or not to order the eigenvalues on the */ -/* diagonal of the generalized Schur form. */ -/* = 'N': Eigenvalues are not ordered; */ -/* = 'S': Eigenvalues are ordered (see SELCTG); */ - -/* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments */ -/* SELCTG must be declared EXTERNAL in the calling subroutine. */ -/* If SORT = 'N', SELCTG is not referenced. */ -/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */ -/* to the top left of the Schur form. */ -/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */ -/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */ -/* one of a complex conjugate pair of eigenvalues is selected, */ -/* then both complex eigenvalues are selected. */ - -/* Note that in the ill-conditioned case, a selected complex */ -/* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), */ -/* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 */ -/* in this case. */ - -/* N (input) INTEGER */ -/* The order of the matrices A, B, VSL, and VSR. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the first of the pair of matrices. */ -/* On exit, A has been overwritten by its generalized Schur */ -/* form S. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the second of the pair of matrices. */ -/* On exit, B has been overwritten by its generalized Schur */ -/* form T. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B. LDB >= max(1,N). */ - -/* SDIM (output) INTEGER */ -/* If SORT = 'N', SDIM = 0. */ -/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ -/* for which SELCTG is true. (Complex conjugate pairs for which */ -/* SELCTG is true for either eigenvalue count as 2.) */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ -/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ -/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, */ -/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */ -/* form (S,T) that would result if the 2-by-2 diagonal blocks of */ -/* the real Schur form of (A,B) were further reduced to */ -/* triangular form using 2-by-2 complex unitary transformations. */ -/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ -/* positive, then the j-th and (j+1)-st eigenvalues are a */ -/* complex conjugate pair, with ALPHAI(j+1) negative. */ - -/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ -/* may easily over- or underflow, and BETA(j) may even be zero. */ -/* Thus, the user should avoid naively computing the ratio. */ -/* However, ALPHAR and ALPHAI will be always less than and */ -/* usually comparable with norm(A) in magnitude, and BETA always */ -/* less than and usually comparable with norm(B). */ - -/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */ -/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */ -/* Not referenced if JOBVSL = 'N'. */ - -/* LDVSL (input) INTEGER */ -/* The leading dimension of the matrix VSL. LDVSL >=1, and */ -/* if JOBVSL = 'V', LDVSL >= N. */ - -/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */ -/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */ -/* Not referenced if JOBVSR = 'N'. */ - -/* LDVSR (input) INTEGER */ -/* The leading dimension of the matrix VSR. LDVSR >= 1, and */ -/* if JOBVSR = 'V', LDVSR >= N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* If N = 0, LWORK >= 1, else LWORK >= 8*N+16. */ -/* For good performance , LWORK must generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* BWORK (workspace) LOGICAL array, dimension (N) */ -/* Not referenced if SORT = 'N'. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1,...,N: */ -/* The QZ iteration failed. (A,B) are not in Schur */ -/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ -/* be correct for j=INFO+1,...,N. */ -/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */ -/* =N+2: after reordering, roundoff changed values of */ -/* some complex eigenvalues so that leading */ -/* eigenvalues in the Generalized Schur form no */ -/* longer satisfy SELCTG=.TRUE. This could also */ -/* be caused due to scaling. */ -/* =N+3: reordering failed in DTGSEN. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alphar; - --alphai; - --beta; - vsl_dim1 = *ldvsl; - vsl_offset = 1 + vsl_dim1; - vsl -= vsl_offset; - vsr_dim1 = *ldvsr; - vsr_offset = 1 + vsr_dim1; - vsr -= vsr_offset; - --work; - --bwork; - - /* Function Body */ - if (lsame_(jobvsl, "N")) { - ijobvl = 1; - ilvsl = false; - } else if (lsame_(jobvsl, "V")) { - ijobvl = 2; - ilvsl = true; - } else { - ijobvl = -1; - ilvsl = false; - } - - if (lsame_(jobvsr, "N")) { - ijobvr = 1; - ilvsr = false; - } else if (lsame_(jobvsr, "V")) { - ijobvr = 2; - ilvsr = true; - } else { - ijobvr = -1; - ilvsr = false; - } - - wantst = lsame_(sort, "S"); - -/* Test the input arguments */ - - *info = 0; - lquery = *lwork == -1; - if (ijobvl <= 0) { - *info = -1; - } else if (ijobvr <= 0) { - *info = -2; - } else if (! wantst && ! lsame_(sort, "N")) { - *info = -3; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { - *info = -15; - } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { - *info = -17; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV.) */ - - if (*info == 0) { - if (*n > 0) { -/* Computing MAX */ - i__1 = *n << 3, i__2 = *n * 6 + 16; - minwrk = std::max(i__1,i__2); - maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & - c__1, n, &c__0); -/* Computing MAX */ - i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR", - " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); - if (ilvsl) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR" - "GQR", " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); - } - } else { - minwrk = 1; - maxwrk = 1; - } - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -19; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGES ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *sdim = 0; - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - safmin = dlamch_("S"); - safmax = 1. / safmin; - dlabad_(&safmin, &safmax); - smlnum = sqrt(safmin) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); - ilascl = false; - if (anrm > 0. && anrm < smlnum) { - anrmto = smlnum; - ilascl = true; - } else if (anrm > bignum) { - anrmto = bignum; - ilascl = true; - } - if (ilascl) { - dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & - ierr); - } - -/* Scale B if max element outside range [SMLNUM,BIGNUM] */ - - bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); - ilbscl = false; - if (bnrm > 0. && bnrm < smlnum) { - bnrmto = smlnum; - ilbscl = true; - } else if (bnrm > bignum) { - bnrmto = bignum; - ilbscl = true; - } - if (ilbscl) { - dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & - ierr); - } - -/* Permute the matrix to make it more nearly triangular */ -/* (Workspace: need 6*N + 2*N space for storing balancing factors) */ - - ileft = 1; - iright = *n + 1; - iwrk = iright + *n; - dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ - ileft], &work[iright], &work[iwrk], &ierr); - -/* Reduce B to triangular form (QR decomposition of B) */ -/* (Workspace: need N, prefer N*NB) */ - - irows = ihi + 1 - ilo; - icols = *n + 1 - ilo; - itau = iwrk; - iwrk = itau + irows; - i__1 = *lwork + 1 - iwrk; - dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ - iwrk], &i__1, &ierr); - -/* Apply the orthogonal transformation to matrix A */ -/* (Workspace: need N, prefer N*NB) */ - - i__1 = *lwork + 1 - iwrk; - dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & - work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & - ierr); - -/* Initialize VSL */ -/* (Workspace: need N, prefer N*NB) */ - - if (ilvsl) { - dlaset_("Full", n, n, &c_b38, &c_b39, &vsl[vsl_offset], ldvsl); - if (irows > 1) { - i__1 = irows - 1; - i__2 = irows - 1; - dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ - ilo + 1 + ilo * vsl_dim1], ldvsl); - } - i__1 = *lwork + 1 - iwrk; - dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & - work[itau], &work[iwrk], &i__1, &ierr); - } - -/* Initialize VSR */ - - if (ilvsr) { - dlaset_("Full", n, n, &c_b38, &c_b39, &vsr[vsr_offset], ldvsr); - } - -/* Reduce to generalized Hessenberg form */ -/* (Workspace: none needed) */ - - dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], - ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr); - -/* Perform QZ algorithm, computing Schur vectors if desired */ -/* (Workspace: need N) */ - - iwrk = itau; - i__1 = *lwork + 1 - iwrk; - dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ - b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] -, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr); - if (ierr != 0) { - if (ierr > 0 && ierr <= *n) { - *info = ierr; - } else if (ierr > *n && ierr <= *n << 1) { - *info = ierr - *n; - } else { - *info = *n + 1; - } - goto L50; - } - -/* Sort eigenvalues ALPHA/BETA if desired */ -/* (Workspace: need 4*N+16 ) */ - - *sdim = 0; - if (wantst) { - -/* Undo scaling on eigenvalues before SELCTGing */ - - if (ilascl) { - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], - n, &ierr); - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], - n, &ierr); - } - if (ilbscl) { - dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, - &ierr); - } - -/* Select eigenvalues */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); -/* L10: */ - } - - i__1 = *lwork - iwrk + 1; - dtgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[ - b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ - vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pvsl, & - pvsr, dif, &work[iwrk], &i__1, idum, &c__1, &ierr); - if (ierr == 1) { - *info = *n + 3; - } - - } - -/* Apply back-permutation to VSL and VSR */ -/* (Workspace: none needed) */ - - if (ilvsl) { - dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ - vsl_offset], ldvsl, &ierr); - } - - if (ilvsr) { - dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ - vsr_offset], ldvsr, &ierr); - } - -/* Check if unscaling would cause over/underflow, if so, rescale */ -/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */ -/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */ - - if (ilascl) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (alphai[i__] != 0.) { - if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[ - i__] > anrm / anrmto) { - work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__], - abs(d__1)); - beta[i__] *= work[1]; - alphar[i__] *= work[1]; - alphai[i__] *= work[1]; - } else if (alphai[i__] / safmax > anrmto / anrm || safmin / - alphai[i__] > anrm / anrmto) { - work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[ - i__], abs(d__1)); - beta[i__] *= work[1]; - alphar[i__] *= work[1]; - alphai[i__] *= work[1]; - } - } -/* L20: */ - } - } - - if (ilbscl) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (alphai[i__] != 0.) { - if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__] - > bnrm / bnrmto) { - work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs( - d__1)); - beta[i__] *= work[1]; - alphar[i__] *= work[1]; - alphai[i__] *= work[1]; - } - } -/* L30: */ - } - } - -/* Undo scaling */ - - if (ilascl) { - dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, & - ierr); - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & - ierr); - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & - ierr); - } - - if (ilbscl) { - dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & - ierr); - dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & - ierr); - } - - if (wantst) { - -/* Check if reordering is correct */ - - lastsl = true; - lst2sl = true; - *sdim = 0; - ip = 0; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); - if (alphai[i__] == 0.) { - if (cursl) { - ++(*sdim); - } - ip = 0; - if (cursl && ! lastsl) { - *info = *n + 2; - } - } else { - if (ip == 1) { - -/* Last eigenvalue of conjugate pair */ - - cursl = cursl || lastsl; - lastsl = cursl; - if (cursl) { - *sdim += 2; - } - ip = -1; - if (cursl && ! lst2sl) { - *info = *n + 2; - } - } else { - -/* First eigenvalue of conjugate pair */ - - ip = 1; - } - } - lst2sl = lastsl; - lastsl = cursl; -/* L40: */ - } - - } - -L50: - - work[1] = (double) maxwrk; - - return 0; - -/* End of DGGES */ - -} /* dgges_ */ diff --git a/external/clapack/lapack/dggesx.cpp b/external/clapack/lapack/dggesx.cpp deleted file mode 100644 index 9426b44f..00000000 --- a/external/clapack/lapack/dggesx.cpp +++ /dev/null @@ -1,765 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static integer c_n1 = -1; -static double c_b42 = 0.; -static double c_b43 = 1.; - -/* Subroutine */ int dggesx_(const char *jobvsl, const char *jobvsr, const char *sort, - bool (*selctg)(const double *, const double *, const double *), - const char *sense, integer *n, double *a, integer *lda, - double *b, integer *ldb, integer *sdim, double *alphar, - double *alphai, double *beta, double *vsl, integer *ldvsl, - double *vsr, integer *ldvsr, double *rconde, double * - rcondv, double *work, integer *lwork, integer *iwork, integer * - liwork, bool *bwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, - vsr_dim1, vsr_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, ip; - double pl, pr, dif[2]; - integer ihi, ilo; - double eps; - integer ijob; - double anrm, bnrm; - integer ierr, itau, iwrk, lwrk; - integer ileft, icols; - bool cursl, ilvsl, ilvsr; - integer irows; - bool lst2sl; - bool ilascl, ilbscl; - double safmin; - double safmax; - double bignum; - integer ijobvl, iright; - integer ijobvr; - bool wantsb; - integer liwmin; - bool wantse, lastsl; - double anrmto, bnrmto; - integer minwrk, maxwrk; - bool wantsn; - double smlnum; - bool wantst, lquery, wantsv; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ -/* .. Function Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGESX computes for a pair of N-by-N real nonsymmetric matrices */ -/* (A,B), the generalized eigenvalues, the real Schur form (S,T), and, */ -/* optionally, the left and/or right matrices of Schur vectors (VSL and */ -/* VSR). This gives the generalized Schur factorization */ - -/* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T ) */ - -/* Optionally, it also orders the eigenvalues so that a selected cluster */ -/* of eigenvalues appears in the leading diagonal blocks of the upper */ -/* quasi-triangular matrix S and the upper triangular matrix T; computes */ -/* a reciprocal condition number for the average of the selected */ -/* eigenvalues (RCONDE); and computes a reciprocal condition number for */ -/* the right and left deflating subspaces corresponding to the selected */ -/* eigenvalues (RCONDV). The leading columns of VSL and VSR then form */ -/* an orthonormal basis for the corresponding left and right eigenspaces */ -/* (deflating subspaces). */ - -/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */ -/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */ -/* usually represented as the pair (alpha,beta), as there is a */ -/* reasonable interpretation for beta=0 or for both being zero. */ - -/* A pair of matrices (S,T) is in generalized real Schur form if T is */ -/* upper triangular with non-negative diagonal and S is block upper */ -/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */ -/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */ -/* "standardized" by making the corresponding elements of T have the */ -/* form: */ -/* [ a 0 ] */ -/* [ 0 b ] */ - -/* and the pair of corresponding 2-by-2 blocks in S and T will have a */ -/* complex conjugate pair of generalized eigenvalues. */ - - -/* Arguments */ -/* ========= */ - -/* JOBVSL (input) CHARACTER*1 */ -/* = 'N': do not compute the left Schur vectors; */ -/* = 'V': compute the left Schur vectors. */ - -/* JOBVSR (input) CHARACTER*1 */ -/* = 'N': do not compute the right Schur vectors; */ -/* = 'V': compute the right Schur vectors. */ - -/* SORT (input) CHARACTER*1 */ -/* Specifies whether or not to order the eigenvalues on the */ -/* diagonal of the generalized Schur form. */ -/* = 'N': Eigenvalues are not ordered; */ -/* = 'S': Eigenvalues are ordered (see SELCTG). */ - -/* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments */ -/* SELCTG must be declared EXTERNAL in the calling subroutine. */ -/* If SORT = 'N', SELCTG is not referenced. */ -/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */ -/* to the top left of the Schur form. */ -/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */ -/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */ -/* one of a complex conjugate pair of eigenvalues is selected, */ -/* then both complex eigenvalues are selected. */ -/* Note that a selected complex eigenvalue may no longer satisfy */ -/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering, */ -/* since ordering may change the value of complex eigenvalues */ -/* (especially if the eigenvalue is ill-conditioned), in this */ -/* case INFO is set to N+3. */ - -/* SENSE (input) CHARACTER*1 */ -/* Determines which reciprocal condition numbers are computed. */ -/* = 'N' : None are computed; */ -/* = 'E' : Computed for average of selected eigenvalues only; */ -/* = 'V' : Computed for selected deflating subspaces only; */ -/* = 'B' : Computed for both. */ -/* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. */ - -/* N (input) INTEGER */ -/* The order of the matrices A, B, VSL, and VSR. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the first of the pair of matrices. */ -/* On exit, A has been overwritten by its generalized Schur */ -/* form S. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the second of the pair of matrices. */ -/* On exit, B has been overwritten by its generalized Schur */ -/* form T. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B. LDB >= max(1,N). */ - -/* SDIM (output) INTEGER */ -/* If SORT = 'N', SDIM = 0. */ -/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ -/* for which SELCTG is true. (Complex conjugate pairs for which */ -/* SELCTG is true for either eigenvalue count as 2.) */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ -/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ -/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */ -/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */ -/* form (S,T) that would result if the 2-by-2 diagonal blocks of */ -/* the real Schur form of (A,B) were further reduced to */ -/* triangular form using 2-by-2 complex unitary transformations. */ -/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ -/* positive, then the j-th and (j+1)-st eigenvalues are a */ -/* complex conjugate pair, with ALPHAI(j+1) negative. */ - -/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ -/* may easily over- or underflow, and BETA(j) may even be zero. */ -/* Thus, the user should avoid naively computing the ratio. */ -/* However, ALPHAR and ALPHAI will be always less than and */ -/* usually comparable with norm(A) in magnitude, and BETA always */ -/* less than and usually comparable with norm(B). */ - -/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */ -/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */ -/* Not referenced if JOBVSL = 'N'. */ - -/* LDVSL (input) INTEGER */ -/* The leading dimension of the matrix VSL. LDVSL >=1, and */ -/* if JOBVSL = 'V', LDVSL >= N. */ - -/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */ -/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */ -/* Not referenced if JOBVSR = 'N'. */ - -/* LDVSR (input) INTEGER */ -/* The leading dimension of the matrix VSR. LDVSR >= 1, and */ -/* if JOBVSR = 'V', LDVSR >= N. */ - -/* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 ) */ -/* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the */ -/* reciprocal condition numbers for the average of the selected */ -/* eigenvalues. */ -/* Not referenced if SENSE = 'N' or 'V'. */ - -/* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 ) */ -/* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the */ -/* reciprocal condition numbers for the selected deflating */ -/* subspaces. */ -/* Not referenced if SENSE = 'N' or 'E'. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', */ -/* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else */ -/* LWORK >= max( 8*N, 6*N+16 ). */ -/* Note that 2*SDIM*(N-SDIM) <= N*N/2. */ -/* Note also that an error is only returned if */ -/* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B' */ -/* this may not be large enough. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the bound on the optimal size of the WORK */ -/* array and the minimum size of the IWORK array, returns these */ -/* values as the first entries of the WORK and IWORK arrays, and */ -/* no error message related to LWORK or LIWORK is issued by */ -/* XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise */ -/* LIWORK >= N+6. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the bound on the optimal size of the */ -/* WORK array and the minimum size of the IWORK array, returns */ -/* these values as the first entries of the WORK and IWORK */ -/* arrays, and no error message related to LWORK or LIWORK is */ -/* issued by XERBLA. */ - -/* BWORK (workspace) LOGICAL array, dimension (N) */ -/* Not referenced if SORT = 'N'. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1,...,N: */ -/* The QZ iteration failed. (A,B) are not in Schur */ -/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ -/* be correct for j=INFO+1,...,N. */ -/* > N: =N+1: other than QZ iteration failed in DHGEQZ */ -/* =N+2: after reordering, roundoff changed values of */ -/* some complex eigenvalues so that leading */ -/* eigenvalues in the Generalized Schur form no */ -/* longer satisfy SELCTG=.TRUE. This could also */ -/* be caused due to scaling. */ -/* =N+3: reordering failed in DTGSEN. */ - -/* Further details */ -/* =============== */ - -/* An approximate (asymptotic) bound on the average absolute error of */ -/* the selected eigenvalues is */ - -/* EPS * norm((A, B)) / RCONDE( 1 ). */ - -/* An approximate (asymptotic) bound on the maximum angular error in */ -/* the computed deflating subspaces is */ - -/* EPS * norm((A, B)) / RCONDV( 2 ). */ - -/* See LAPACK User's Guide, section 4.11 for more information. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alphar; - --alphai; - --beta; - vsl_dim1 = *ldvsl; - vsl_offset = 1 + vsl_dim1; - vsl -= vsl_offset; - vsr_dim1 = *ldvsr; - vsr_offset = 1 + vsr_dim1; - vsr -= vsr_offset; - --rconde; - --rcondv; - --work; - --iwork; - --bwork; - - /* Function Body */ - if (lsame_(jobvsl, "N")) { - ijobvl = 1; - ilvsl = false; - } else if (lsame_(jobvsl, "V")) { - ijobvl = 2; - ilvsl = true; - } else { - ijobvl = -1; - ilvsl = false; - } - - if (lsame_(jobvsr, "N")) { - ijobvr = 1; - ilvsr = false; - } else if (lsame_(jobvsr, "V")) { - ijobvr = 2; - ilvsr = true; - } else { - ijobvr = -1; - ilvsr = false; - } - - wantst = lsame_(sort, "S"); - wantsn = lsame_(sense, "N"); - wantse = lsame_(sense, "E"); - wantsv = lsame_(sense, "V"); - wantsb = lsame_(sense, "B"); - lquery = *lwork == -1 || *liwork == -1; - if (wantsn) { - ijob = 0; - } else if (wantse) { - ijob = 1; - } else if (wantsv) { - ijob = 2; - } else if (wantsb) { - ijob = 4; - } - -/* Test the input arguments */ - - *info = 0; - if (ijobvl <= 0) { - *info = -1; - } else if (ijobvr <= 0) { - *info = -2; - } else if (! wantst && ! lsame_(sort, "N")) { - *info = -3; - } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && ! - wantsn) { - *info = -5; - } else if (*n < 0) { - *info = -6; - } else if (*lda < std::max(1_integer,*n)) { - *info = -8; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -10; - } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { - *info = -16; - } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { - *info = -18; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV.) */ - - if (*info == 0) { - if (*n > 0) { -/* Computing MAX */ - i__1 = *n << 3, i__2 = *n * 6 + 16; - minwrk = std::max(i__1,i__2); - maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & - c__1, n, &c__0); -/* Computing MAX */ - i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR", - " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); - if (ilvsl) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR" - "GQR", " ", n, &c__1, n, &c_n1); - maxwrk = std::max(i__1,i__2); - } - lwrk = maxwrk; - if (ijob >= 1) { -/* Computing MAX */ - i__1 = lwrk, i__2 = *n * *n / 2; - lwrk = std::max(i__1,i__2); - } - } else { - minwrk = 1; - maxwrk = 1; - lwrk = 1; - } - work[1] = (double) lwrk; - if (wantsn || *n == 0) { - liwmin = 1; - } else { - liwmin = *n + 6; - } - iwork[1] = liwmin; - - if (*lwork < minwrk && ! lquery) { - *info = -22; - } else if (*liwork < liwmin && ! lquery) { - *info = -24; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGESX", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *sdim = 0; - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - safmin = dlamch_("S"); - safmax = 1. / safmin; - dlabad_(&safmin, &safmax); - smlnum = sqrt(safmin) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); - ilascl = false; - if (anrm > 0. && anrm < smlnum) { - anrmto = smlnum; - ilascl = true; - } else if (anrm > bignum) { - anrmto = bignum; - ilascl = true; - } - if (ilascl) { - dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & - ierr); - } - -/* Scale B if max element outside range [SMLNUM,BIGNUM] */ - - bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); - ilbscl = false; - if (bnrm > 0. && bnrm < smlnum) { - bnrmto = smlnum; - ilbscl = true; - } else if (bnrm > bignum) { - bnrmto = bignum; - ilbscl = true; - } - if (ilbscl) { - dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & - ierr); - } - -/* Permute the matrix to make it more nearly triangular */ -/* (Workspace: need 6*N + 2*N for permutation parameters) */ - - ileft = 1; - iright = *n + 1; - iwrk = iright + *n; - dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ - ileft], &work[iright], &work[iwrk], &ierr); - -/* Reduce B to triangular form (QR decomposition of B) */ -/* (Workspace: need N, prefer N*NB) */ - - irows = ihi + 1 - ilo; - icols = *n + 1 - ilo; - itau = iwrk; - iwrk = itau + irows; - i__1 = *lwork + 1 - iwrk; - dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ - iwrk], &i__1, &ierr); - -/* Apply the orthogonal transformation to matrix A */ -/* (Workspace: need N, prefer N*NB) */ - - i__1 = *lwork + 1 - iwrk; - dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & - work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & - ierr); - -/* Initialize VSL */ -/* (Workspace: need N, prefer N*NB) */ - - if (ilvsl) { - dlaset_("Full", n, n, &c_b42, &c_b43, &vsl[vsl_offset], ldvsl); - if (irows > 1) { - i__1 = irows - 1; - i__2 = irows - 1; - dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ - ilo + 1 + ilo * vsl_dim1], ldvsl); - } - i__1 = *lwork + 1 - iwrk; - dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & - work[itau], &work[iwrk], &i__1, &ierr); - } - -/* Initialize VSR */ - - if (ilvsr) { - dlaset_("Full", n, n, &c_b42, &c_b43, &vsr[vsr_offset], ldvsr); - } - -/* Reduce to generalized Hessenberg form */ -/* (Workspace: none needed) */ - - dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], - ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr); - - *sdim = 0; - -/* Perform QZ algorithm, computing Schur vectors if desired */ -/* (Workspace: need N) */ - - iwrk = itau; - i__1 = *lwork + 1 - iwrk; - dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ - b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] -, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr); - if (ierr != 0) { - if (ierr > 0 && ierr <= *n) { - *info = ierr; - } else if (ierr > *n && ierr <= *n << 1) { - *info = ierr - *n; - } else { - *info = *n + 1; - } - goto L60; - } - -/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of */ -/* condition number(s) */ -/* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) ) */ -/* otherwise, need 8*(N+1) ) */ - - if (wantst) { - -/* Undo scaling on eigenvalues before SELCTGing */ - - if (ilascl) { - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], - n, &ierr); - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], - n, &ierr); - } - if (ilbscl) { - dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, - &ierr); - } - -/* Select eigenvalues */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); -/* L10: */ - } - -/* Reorder eigenvalues, transform Generalized Schur vectors, and */ -/* compute reciprocal condition numbers */ - - i__1 = *lwork - iwrk + 1; - dtgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[ - b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ - vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pl, &pr, - dif, &work[iwrk], &i__1, &iwork[1], liwork, &ierr); - - if (ijob >= 1) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim); - maxwrk = std::max(i__1,i__2); - } - if (ierr == -22) { - -/* not enough real workspace */ - - *info = -22; - } else { - if (ijob == 1 || ijob == 4) { - rconde[1] = pl; - rconde[2] = pr; - } - if (ijob == 2 || ijob == 4) { - rcondv[1] = dif[0]; - rcondv[2] = dif[1]; - } - if (ierr == 1) { - *info = *n + 3; - } - } - - } - -/* Apply permutation to VSL and VSR */ -/* (Workspace: none needed) */ - - if (ilvsl) { - dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ - vsl_offset], ldvsl, &ierr); - } - - if (ilvsr) { - dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ - vsr_offset], ldvsr, &ierr); - } - -/* Check if unscaling would cause over/underflow, if so, rescale */ -/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */ -/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */ - - if (ilascl) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (alphai[i__] != 0.) { - if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[ - i__] > anrm / anrmto) { - work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__], - abs(d__1)); - beta[i__] *= work[1]; - alphar[i__] *= work[1]; - alphai[i__] *= work[1]; - } else if (alphai[i__] / safmax > anrmto / anrm || safmin / - alphai[i__] > anrm / anrmto) { - work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[ - i__], abs(d__1)); - beta[i__] *= work[1]; - alphar[i__] *= work[1]; - alphai[i__] *= work[1]; - } - } -/* L20: */ - } - } - - if (ilbscl) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (alphai[i__] != 0.) { - if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__] - > bnrm / bnrmto) { - work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs( - d__1)); - beta[i__] *= work[1]; - alphar[i__] *= work[1]; - alphai[i__] *= work[1]; - } - } -/* L30: */ - } - } - -/* Undo scaling */ - - if (ilascl) { - dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, & - ierr); - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & - ierr); - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & - ierr); - } - - if (ilbscl) { - dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & - ierr); - dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & - ierr); - } - - if (wantst) { - -/* Check if reordering is correct */ - - lastsl = true; - lst2sl = true; - *sdim = 0; - ip = 0; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); - if (alphai[i__] == 0.) { - if (cursl) { - ++(*sdim); - } - ip = 0; - if (cursl && ! lastsl) { - *info = *n + 2; - } - } else { - if (ip == 1) { - -/* Last eigenvalue of conjugate pair */ - - cursl = cursl || lastsl; - lastsl = cursl; - if (cursl) { - *sdim += 2; - } - ip = -1; - if (cursl && ! lst2sl) { - *info = *n + 2; - } - } else { - -/* First eigenvalue of conjugate pair */ - - ip = 1; - } - } - lst2sl = lastsl; - lastsl = cursl; -/* L50: */ - } - - } - -L60: - - work[1] = (double) maxwrk; - iwork[1] = liwmin; - - return 0; - -/* End of DGGESX */ - -} /* dggesx_ */ diff --git a/external/clapack/lapack/dggev.cpp b/external/clapack/lapack/dggev.cpp deleted file mode 100644 index ca98cfa2..00000000 --- a/external/clapack/lapack/dggev.cpp +++ /dev/null @@ -1,592 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static integer c_n1 = -1; -static double c_b36 = 0.; -static double c_b37 = 1.; - -/* Subroutine */ int dggev_(const char *jobvl, const char *jobvr, integer *n, double * - a, integer *lda, double *b, integer *ldb, double *alphar, - double *alphai, double *beta, double *vl, integer *ldvl, - double *vr, integer *ldvr, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, - vr_offset, i__1, i__2; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer jc, in, jr, ihi, ilo; - double eps; - bool ilv; - double anrm, bnrm; - integer ierr, itau; - double temp; - bool ilvl, ilvr; - integer iwrk; - integer ileft, icols, irows; - bool ilascl, ilbscl; - bool ldumma[1]; - char chtemp[1]; - double bignum; - integer ijobvl, iright, ijobvr; - double anrmto, bnrmto; - integer minwrk, maxwrk; - double smlnum; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B) */ -/* the generalized eigenvalues, and optionally, the left and/or right */ -/* generalized eigenvectors. */ - -/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */ -/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */ -/* singular. It is usually represented as the pair (alpha,beta), as */ -/* there is a reasonable interpretation for beta=0, and even for both */ -/* being zero. */ - -/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */ -/* of (A,B) satisfies */ - -/* A * v(j) = lambda(j) * B * v(j). */ - -/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */ -/* of (A,B) satisfies */ - -/* u(j)**H * A = lambda(j) * u(j)**H * B . */ - -/* where u(j)**H is the conjugate-transpose of u(j). */ - - -/* Arguments */ -/* ========= */ - -/* JOBVL (input) CHARACTER*1 */ -/* = 'N': do not compute the left generalized eigenvectors; */ -/* = 'V': compute the left generalized eigenvectors. */ - -/* JOBVR (input) CHARACTER*1 */ -/* = 'N': do not compute the right generalized eigenvectors; */ -/* = 'V': compute the right generalized eigenvectors. */ - -/* N (input) INTEGER */ -/* The order of the matrices A, B, VL, and VR. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the matrix A in the pair (A,B). */ -/* On exit, A has been overwritten. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the matrix B in the pair (A,B). */ -/* On exit, B has been overwritten. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B. LDB >= max(1,N). */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ -/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ -/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */ -/* the j-th eigenvalue is real; if positive, then the j-th and */ -/* (j+1)-st eigenvalues are a complex conjugate pair, with */ -/* ALPHAI(j+1) negative. */ - -/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ -/* may easily over- or underflow, and BETA(j) may even be zero. */ -/* Thus, the user should avoid naively computing the ratio */ -/* alpha/beta. However, ALPHAR and ALPHAI will be always less */ -/* than and usually comparable with norm(A) in magnitude, and */ -/* BETA always less than and usually comparable with norm(B). */ - -/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ -/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ -/* after another in the columns of VL, in the same order as */ -/* their eigenvalues. If the j-th eigenvalue is real, then */ -/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */ -/* (j+1)-th eigenvalues form a complex conjugate pair, then */ -/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */ -/* Each eigenvector is scaled so the largest component has */ -/* abs(real part)+abs(imag. part)=1. */ -/* Not referenced if JOBVL = 'N'. */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the matrix VL. LDVL >= 1, and */ -/* if JOBVL = 'V', LDVL >= N. */ - -/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ -/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ -/* after another in the columns of VR, in the same order as */ -/* their eigenvalues. If the j-th eigenvalue is real, then */ -/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */ -/* (j+1)-th eigenvalues form a complex conjugate pair, then */ -/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */ -/* Each eigenvector is scaled so the largest component has */ -/* abs(real part)+abs(imag. part)=1. */ -/* Not referenced if JOBVR = 'N'. */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the matrix VR. LDVR >= 1, and */ -/* if JOBVR = 'V', LDVR >= N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,8*N). */ -/* For good performance, LWORK must generally be larger. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1,...,N: */ -/* The QZ iteration failed. No eigenvectors have been */ -/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ -/* should be correct for j=INFO+1,...,N. */ -/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */ -/* =N+2: error return from DTGEVC. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alphar; - --alphai; - --beta; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --work; - - /* Function Body */ - if (lsame_(jobvl, "N")) { - ijobvl = 1; - ilvl = false; - } else if (lsame_(jobvl, "V")) { - ijobvl = 2; - ilvl = true; - } else { - ijobvl = -1; - ilvl = false; - } - - if (lsame_(jobvr, "N")) { - ijobvr = 1; - ilvr = false; - } else if (lsame_(jobvr, "V")) { - ijobvr = 2; - ilvr = true; - } else { - ijobvr = -1; - ilvr = false; - } - ilv = ilvl || ilvr; - -/* Test the input arguments */ - - *info = 0; - lquery = *lwork == -1; - if (ijobvl <= 0) { - *info = -1; - } else if (ijobvr <= 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldvl < 1 || ilvl && *ldvl < *n) { - *info = -12; - } else if (*ldvr < 1 || ilvr && *ldvr < *n) { - *info = -14; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV. The workspace is */ -/* computed assuming ILO = 1 and IHI = N, the worst case.) */ - - if (*info == 0) { -/* Computing MAX */ - i__1 = 1, i__2 = *n << 3; - minwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * (ilaenv_(&c__1, "DGEQRF", " ", n, &c__1, n, & - c__0) + 7); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "DORMQR", " ", n, &c__1, n, - &c__0) + 7); - maxwrk = std::max(i__1,i__2); - if (ilvl) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "DORGQR", " ", n, & - c__1, n, &c_n1) + 7); - maxwrk = std::max(i__1,i__2); - } - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -16; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGEV ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - smlnum = sqrt(smlnum) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); - ilascl = false; - if (anrm > 0. && anrm < smlnum) { - anrmto = smlnum; - ilascl = true; - } else if (anrm > bignum) { - anrmto = bignum; - ilascl = true; - } - if (ilascl) { - dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & - ierr); - } - -/* Scale B if max element outside range [SMLNUM,BIGNUM] */ - - bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); - ilbscl = false; - if (bnrm > 0. && bnrm < smlnum) { - bnrmto = smlnum; - ilbscl = true; - } else if (bnrm > bignum) { - bnrmto = bignum; - ilbscl = true; - } - if (ilbscl) { - dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & - ierr); - } - -/* Permute the matrices A, B to isolate eigenvalues if possible */ -/* (Workspace: need 6*N) */ - - ileft = 1; - iright = *n + 1; - iwrk = iright + *n; - dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ - ileft], &work[iright], &work[iwrk], &ierr); - -/* Reduce B to triangular form (QR decomposition of B) */ -/* (Workspace: need N, prefer N*NB) */ - - irows = ihi + 1 - ilo; - if (ilv) { - icols = *n + 1 - ilo; - } else { - icols = irows; - } - itau = iwrk; - iwrk = itau + irows; - i__1 = *lwork + 1 - iwrk; - dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ - iwrk], &i__1, &ierr); - -/* Apply the orthogonal transformation to matrix A */ -/* (Workspace: need N, prefer N*NB) */ - - i__1 = *lwork + 1 - iwrk; - dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & - work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & - ierr); - -/* Initialize VL */ -/* (Workspace: need N, prefer N*NB) */ - - if (ilvl) { - dlaset_("Full", n, n, &c_b36, &c_b37, &vl[vl_offset], ldvl) - ; - if (irows > 1) { - i__1 = irows - 1; - i__2 = irows - 1; - dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ - ilo + 1 + ilo * vl_dim1], ldvl); - } - i__1 = *lwork + 1 - iwrk; - dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ - itau], &work[iwrk], &i__1, &ierr); - } - -/* Initialize VR */ - - if (ilvr) { - dlaset_("Full", n, n, &c_b36, &c_b37, &vr[vr_offset], ldvr) - ; - } - -/* Reduce to generalized Hessenberg form */ -/* (Workspace: none needed) */ - - if (ilv) { - -/* Eigenvectors requested -- work on whole matrix. */ - - dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], - ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); - } else { - dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, - &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ - vr_offset], ldvr, &ierr); - } - -/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */ -/* Schur forms and Schur vectors) */ -/* (Workspace: need N) */ - - iwrk = itau; - if (ilv) { - *(unsigned char *)chtemp = 'S'; - } else { - *(unsigned char *)chtemp = 'E'; - } - i__1 = *lwork + 1 - iwrk; - dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ - b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], - ldvl, &vr[vr_offset], ldvr, &work[iwrk], &i__1, &ierr); - if (ierr != 0) { - if (ierr > 0 && ierr <= *n) { - *info = ierr; - } else if (ierr > *n && ierr <= *n << 1) { - *info = ierr - *n; - } else { - *info = *n + 1; - } - goto L110; - } - -/* Compute Eigenvectors */ -/* (Workspace: need 6*N) */ - - if (ilv) { - if (ilvl) { - if (ilvr) { - *(unsigned char *)chtemp = 'B'; - } else { - *(unsigned char *)chtemp = 'L'; - } - } else { - *(unsigned char *)chtemp = 'R'; - } - dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, - &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ - iwrk], &ierr); - if (ierr != 0) { - *info = *n + 2; - goto L110; - } - -/* Undo balancing on VL and VR and normalization */ -/* (Workspace: none needed) */ - - if (ilvl) { - dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, & - vl[vl_offset], ldvl, &ierr); - i__1 = *n; - for (jc = 1; jc <= i__1; ++jc) { - if (alphai[jc] < 0.) { - goto L50; - } - temp = 0.; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], - abs(d__1)); - temp = std::max(d__2,d__3); -/* L10: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], - abs(d__1)) + (d__2 = vl[jr + (jc + 1) * - vl_dim1], abs(d__2)); - temp = std::max(d__3,d__4); -/* L20: */ - } - } - if (temp < smlnum) { - goto L50; - } - temp = 1. / temp; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vl[jr + jc * vl_dim1] *= temp; -/* L30: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vl[jr + jc * vl_dim1] *= temp; - vl[jr + (jc + 1) * vl_dim1] *= temp; -/* L40: */ - } - } -L50: - ; - } - } - if (ilvr) { - dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, & - vr[vr_offset], ldvr, &ierr); - i__1 = *n; - for (jc = 1; jc <= i__1; ++jc) { - if (alphai[jc] < 0.) { - goto L100; - } - temp = 0.; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], - abs(d__1)); - temp = std::max(d__2,d__3); -/* L60: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], - abs(d__1)) + (d__2 = vr[jr + (jc + 1) * - vr_dim1], abs(d__2)); - temp = std::max(d__3,d__4); -/* L70: */ - } - } - if (temp < smlnum) { - goto L100; - } - temp = 1. / temp; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + jc * vr_dim1] *= temp; -/* L80: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + jc * vr_dim1] *= temp; - vr[jr + (jc + 1) * vr_dim1] *= temp; -/* L90: */ - } - } -L100: - ; - } - } - -/* End of eigenvector calculation */ - - } - -/* Undo scaling if necessary */ - - if (ilascl) { - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & - ierr); - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & - ierr); - } - - if (ilbscl) { - dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & - ierr); - } - -L110: - - work[1] = (double) maxwrk; - - return 0; - -/* End of DGGEV */ - -} /* dggev_ */ diff --git a/external/clapack/lapack/dggevx.cpp b/external/clapack/lapack/dggevx.cpp deleted file mode 100644 index c95e770a..00000000 --- a/external/clapack/lapack/dggevx.cpp +++ /dev/null @@ -1,834 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static double c_b59 = 0.; -static double c_b60 = 1.; - -/* Subroutine */ int dggevx_(const char *balanc, const char *jobvl, const char *jobvr, const char * - sense, integer *n, double *a, integer *lda, double *b, - integer *ldb, double *alphar, double *alphai, double * - beta, double *vl, integer *ldvl, double *vr, integer *ldvr, - integer *ilo, integer *ihi, double *lscale, double *rscale, - double *abnrm, double *bbnrm, double *rconde, double * - rcondv, double *work, integer *lwork, integer *iwork, bool * - bwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, - vr_offset, i__1, i__2; - double d__1, d__2, d__3, d__4; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__, j, m, jc, in, mm, jr; - double eps; - bool ilv, pair; - double anrm, bnrm; - integer ierr, itau; - double temp; - bool ilvl, ilvr; - integer iwrk, iwrk1; - integer icols; - bool noscl; - integer irows; - bool ilascl, ilbscl; - bool ldumma[1]; - char chtemp[1]; - double bignum; - integer ijobvl; - integer ijobvr; - bool wantsb; - double anrmto; - bool wantse; - double bnrmto; - integer minwrk, maxwrk; - bool wantsn; - double smlnum; - bool lquery, wantsv; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) */ -/* the generalized eigenvalues, and optionally, the left and/or right */ -/* generalized eigenvectors. */ - -/* Optionally also, it computes a balancing transformation to improve */ -/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */ -/* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */ -/* the eigenvalues (RCONDE), and reciprocal condition numbers for the */ -/* right eigenvectors (RCONDV). */ - -/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */ -/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */ -/* singular. It is usually represented as the pair (alpha,beta), as */ -/* there is a reasonable interpretation for beta=0, and even for both */ -/* being zero. */ - -/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */ -/* of (A,B) satisfies */ - -/* A * v(j) = lambda(j) * B * v(j) . */ - -/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */ -/* of (A,B) satisfies */ - -/* u(j)**H * A = lambda(j) * u(j)**H * B. */ - -/* where u(j)**H is the conjugate-transpose of u(j). */ - - -/* Arguments */ -/* ========= */ - -/* BALANC (input) CHARACTER*1 */ -/* Specifies the balance option to be performed. */ -/* = 'N': do not diagonally scale or permute; */ -/* = 'P': permute only; */ -/* = 'S': scale only; */ -/* = 'B': both permute and scale. */ -/* Computed reciprocal condition numbers will be for the */ -/* matrices after permuting and/or balancing. Permuting does */ -/* not change condition numbers (in exact arithmetic), but */ -/* balancing does. */ - -/* JOBVL (input) CHARACTER*1 */ -/* = 'N': do not compute the left generalized eigenvectors; */ -/* = 'V': compute the left generalized eigenvectors. */ - -/* JOBVR (input) CHARACTER*1 */ -/* = 'N': do not compute the right generalized eigenvectors; */ -/* = 'V': compute the right generalized eigenvectors. */ - -/* SENSE (input) CHARACTER*1 */ -/* Determines which reciprocal condition numbers are computed. */ -/* = 'N': none are computed; */ -/* = 'E': computed for eigenvalues only; */ -/* = 'V': computed for eigenvectors only; */ -/* = 'B': computed for eigenvalues and eigenvectors. */ - -/* N (input) INTEGER */ -/* The order of the matrices A, B, VL, and VR. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the matrix A in the pair (A,B). */ -/* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */ -/* or both, then A contains the first part of the real Schur */ -/* form of the "balanced" versions of the input A and B. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the matrix B in the pair (A,B). */ -/* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */ -/* or both, then B contains the second part of the real Schur */ -/* form of the "balanced" versions of the input A and B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B. LDB >= max(1,N). */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ -/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ -/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */ -/* the j-th eigenvalue is real; if positive, then the j-th and */ -/* (j+1)-st eigenvalues are a complex conjugate pair, with */ -/* ALPHAI(j+1) negative. */ - -/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ -/* may easily over- or underflow, and BETA(j) may even be zero. */ -/* Thus, the user should avoid naively computing the ratio */ -/* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less */ -/* than and usually comparable with norm(A) in magnitude, and */ -/* BETA always less than and usually comparable with norm(B). */ - -/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ -/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ -/* after another in the columns of VL, in the same order as */ -/* their eigenvalues. If the j-th eigenvalue is real, then */ -/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */ -/* (j+1)-th eigenvalues form a complex conjugate pair, then */ -/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */ -/* Each eigenvector will be scaled so the largest component have */ -/* abs(real part) + abs(imag. part) = 1. */ -/* Not referenced if JOBVL = 'N'. */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the matrix VL. LDVL >= 1, and */ -/* if JOBVL = 'V', LDVL >= N. */ - -/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ -/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ -/* after another in the columns of VR, in the same order as */ -/* their eigenvalues. If the j-th eigenvalue is real, then */ -/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */ -/* (j+1)-th eigenvalues form a complex conjugate pair, then */ -/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */ -/* Each eigenvector will be scaled so the largest component have */ -/* abs(real part) + abs(imag. part) = 1. */ -/* Not referenced if JOBVR = 'N'. */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the matrix VR. LDVR >= 1, and */ -/* if JOBVR = 'V', LDVR >= N. */ - -/* ILO (output) INTEGER */ -/* IHI (output) INTEGER */ -/* ILO and IHI are integer values such that on exit */ -/* A(i,j) = 0 and B(i,j) = 0 if i > j and */ -/* j = 1,...,ILO-1 or i = IHI+1,...,N. */ -/* If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */ - -/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutations and scaling factors applied */ -/* to the left side of A and B. If PL(j) is the index of the */ -/* row interchanged with row j, and DL(j) is the scaling */ -/* factor applied to row j, then */ -/* LSCALE(j) = PL(j) for j = 1,...,ILO-1 */ -/* = DL(j) for j = ILO,...,IHI */ -/* = PL(j) for j = IHI+1,...,N. */ -/* The order in which the interchanges are made is N to IHI+1, */ -/* then 1 to ILO-1. */ - -/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */ -/* Details of the permutations and scaling factors applied */ -/* to the right side of A and B. If PR(j) is the index of the */ -/* column interchanged with column j, and DR(j) is the scaling */ -/* factor applied to column j, then */ -/* RSCALE(j) = PR(j) for j = 1,...,ILO-1 */ -/* = DR(j) for j = ILO,...,IHI */ -/* = PR(j) for j = IHI+1,...,N */ -/* The order in which the interchanges are made is N to IHI+1, */ -/* then 1 to ILO-1. */ - -/* ABNRM (output) DOUBLE PRECISION */ -/* The one-norm of the balanced matrix A. */ - -/* BBNRM (output) DOUBLE PRECISION */ -/* The one-norm of the balanced matrix B. */ - -/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */ -/* If SENSE = 'E' or 'B', the reciprocal condition numbers of */ -/* the eigenvalues, stored in consecutive elements of the array. */ -/* For a complex conjugate pair of eigenvalues two consecutive */ -/* elements of RCONDE are set to the same value. Thus RCONDE(j), */ -/* RCONDV(j), and the j-th columns of VL and VR all correspond */ -/* to the j-th eigenpair. */ -/* If SENSE = 'N or 'V', RCONDE is not referenced. */ - -/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */ -/* If SENSE = 'V' or 'B', the estimated reciprocal condition */ -/* numbers of the eigenvectors, stored in consecutive elements */ -/* of the array. For a complex eigenvector two consecutive */ -/* elements of RCONDV are set to the same value. If the */ -/* eigenvalues cannot be reordered to compute RCONDV(j), */ -/* RCONDV(j) is set to 0; this can only occur when the true */ -/* value would be very small anyway. */ -/* If SENSE = 'N' or 'E', RCONDV is not referenced. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,2*N). */ -/* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', */ -/* LWORK >= max(1,6*N). */ -/* If SENSE = 'E' or 'B', LWORK >= max(1,10*N). */ -/* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (N+6) */ -/* If SENSE = 'E', IWORK is not referenced. */ - -/* BWORK (workspace) LOGICAL array, dimension (N) */ -/* If SENSE = 'N', BWORK is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1,...,N: */ -/* The QZ iteration failed. No eigenvectors have been */ -/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ -/* should be correct for j=INFO+1,...,N. */ -/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */ -/* =N+2: error return from DTGEVC. */ - -/* Further Details */ -/* =============== */ - -/* Balancing a matrix pair (A,B) includes, first, permuting rows and */ -/* columns to isolate eigenvalues, second, applying diagonal similarity */ -/* transformation to the rows and columns to make the rows and columns */ -/* as close in norm as possible. The computed reciprocal condition */ -/* numbers correspond to the balanced matrix. Permuting rows and columns */ -/* will not change the condition numbers (in exact arithmetic) but */ -/* diagonal scaling will. For further explanation of balancing, see */ -/* section 4.11.1.2 of LAPACK Users' Guide. */ - -/* An approximate error bound on the chordal distance between the i-th */ -/* computed generalized eigenvalue w and the corresponding exact */ -/* eigenvalue lambda is */ - -/* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */ - -/* An approximate error bound for the angle between the i-th computed */ -/* eigenvector VL(i) or VR(i) is given by */ - -/* EPS * norm(ABNRM, BBNRM) / DIF(i). */ - -/* For further explanation of the reciprocal condition numbers RCONDE */ -/* and RCONDV, see section 4.11 of LAPACK User's Guide. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alphar; - --alphai; - --beta; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --lscale; - --rscale; - --rconde; - --rcondv; - --work; - --iwork; - --bwork; - - /* Function Body */ - if (lsame_(jobvl, "N")) { - ijobvl = 1; - ilvl = false; - } else if (lsame_(jobvl, "V")) { - ijobvl = 2; - ilvl = true; - } else { - ijobvl = -1; - ilvl = false; - } - - if (lsame_(jobvr, "N")) { - ijobvr = 1; - ilvr = false; - } else if (lsame_(jobvr, "V")) { - ijobvr = 2; - ilvr = true; - } else { - ijobvr = -1; - ilvr = false; - } - ilv = ilvl || ilvr; - - noscl = lsame_(balanc, "N") || lsame_(balanc, "P"); - wantsn = lsame_(sense, "N"); - wantse = lsame_(sense, "E"); - wantsv = lsame_(sense, "V"); - wantsb = lsame_(sense, "B"); - -/* Test the input arguments */ - - *info = 0; - lquery = *lwork == -1; - if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") - || lsame_(balanc, "B"))) { - *info = -1; - } else if (ijobvl <= 0) { - *info = -2; - } else if (ijobvr <= 0) { - *info = -3; - } else if (! (wantsn || wantse || wantsb || wantsv)) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldvl < 1 || ilvl && *ldvl < *n) { - *info = -14; - } else if (*ldvr < 1 || ilvr && *ldvr < *n) { - *info = -16; - } - -/* Compute workspace */ -/* (Note: Comments in the code beginning "Workspace:" describe the */ -/* minimal amount of workspace needed at that point in the code, */ -/* as well as the preferred amount for good performance. */ -/* NB refers to the optimal block size for the immediately */ -/* following subroutine, as returned by ILAENV. The workspace is */ -/* computed assuming ILO = 1 and IHI = N, the worst case.) */ - - if (*info == 0) { - if (*n == 0) { - minwrk = 1; - maxwrk = 1; - } else { - if (noscl && ! ilv) { - minwrk = *n << 1; - } else { - minwrk = *n * 6; - } - if (wantse || wantsb) { - minwrk = *n * 10; - } - if (wantsv || wantsb) { -/* Computing MAX */ - i__1 = minwrk, i__2 = (*n << 1) * (*n + 4) + 16; - minwrk = std::max(i__1,i__2); - } - maxwrk = minwrk; -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & - c__1, n, &c__0); - maxwrk = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORMQR", " ", n, & - c__1, n, &c__0); - maxwrk = std::max(i__1,i__2); - if (ilvl) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", - " ", n, &c__1, n, &c__0); - maxwrk = std::max(i__1,i__2); - } - } - work[1] = (double) maxwrk; - - if (*lwork < minwrk && ! lquery) { - *info = -26; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGEVX", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - smlnum = sqrt(smlnum) / eps; - bignum = 1. / smlnum; - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); - ilascl = false; - if (anrm > 0. && anrm < smlnum) { - anrmto = smlnum; - ilascl = true; - } else if (anrm > bignum) { - anrmto = bignum; - ilascl = true; - } - if (ilascl) { - dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & - ierr); - } - -/* Scale B if max element outside range [SMLNUM,BIGNUM] */ - - bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); - ilbscl = false; - if (bnrm > 0. && bnrm < smlnum) { - bnrmto = smlnum; - ilbscl = true; - } else if (bnrm > bignum) { - bnrmto = bignum; - ilbscl = true; - } - if (ilbscl) { - dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & - ierr); - } - -/* Permute and/or balance the matrix pair (A,B) */ -/* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */ - - dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, & - lscale[1], &rscale[1], &work[1], &ierr); - -/* Compute ABNRM and BBNRM */ - - *abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]); - if (ilascl) { - work[1] = *abnrm; - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], & - c__1, &ierr); - *abnrm = work[1]; - } - - *bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]); - if (ilbscl) { - work[1] = *bbnrm; - dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], & - c__1, &ierr); - *bbnrm = work[1]; - } - -/* Reduce B to triangular form (QR decomposition of B) */ -/* (Workspace: need N, prefer N*NB ) */ - - irows = *ihi + 1 - *ilo; - if (ilv || ! wantsn) { - icols = *n + 1 - *ilo; - } else { - icols = irows; - } - itau = 1; - iwrk = itau + irows; - i__1 = *lwork + 1 - iwrk; - dgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[ - iwrk], &i__1, &ierr); - -/* Apply the orthogonal transformation to A */ -/* (Workspace: need N, prefer N*NB) */ - - i__1 = *lwork + 1 - iwrk; - dormqr_("L", "T", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, & - work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, & - ierr); - -/* Initialize VL and/or VR */ -/* (Workspace: need N, prefer N*NB) */ - - if (ilvl) { - dlaset_("Full", n, n, &c_b59, &c_b60, &vl[vl_offset], ldvl) - ; - if (irows > 1) { - i__1 = irows - 1; - i__2 = irows - 1; - dlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[ - *ilo + 1 + *ilo * vl_dim1], ldvl); - } - i__1 = *lwork + 1 - iwrk; - dorgqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, & - work[itau], &work[iwrk], &i__1, &ierr); - } - - if (ilvr) { - dlaset_("Full", n, n, &c_b59, &c_b60, &vr[vr_offset], ldvr) - ; - } - -/* Reduce to generalized Hessenberg form */ -/* (Workspace: none needed) */ - - if (ilv || ! wantsn) { - -/* Eigenvectors requested -- work on whole matrix. */ - - dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], - ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); - } else { - dgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1], - lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ - vr_offset], ldvr, &ierr); - } - -/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */ -/* Schur forms and Schur vectors) */ -/* (Workspace: need N) */ - - if (ilv || ! wantsn) { - *(unsigned char *)chtemp = 'S'; - } else { - *(unsigned char *)chtemp = 'E'; - } - - dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset] -, ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, & - vr[vr_offset], ldvr, &work[1], lwork, &ierr); - if (ierr != 0) { - if (ierr > 0 && ierr <= *n) { - *info = ierr; - } else if (ierr > *n && ierr <= *n << 1) { - *info = ierr - *n; - } else { - *info = *n + 1; - } - goto L130; - } - -/* Compute Eigenvectors and estimate condition numbers if desired */ -/* (Workspace: DTGEVC: need 6*N */ -/* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', */ -/* need N otherwise ) */ - - if (ilv || ! wantsn) { - if (ilv) { - if (ilvl) { - if (ilvr) { - *(unsigned char *)chtemp = 'B'; - } else { - *(unsigned char *)chtemp = 'L'; - } - } else { - *(unsigned char *)chtemp = 'R'; - } - - dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], - ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, & - work[1], &ierr); - if (ierr != 0) { - *info = *n + 2; - goto L130; - } - } - - if (! wantsn) { - -/* compute eigenvectors (DTGEVC) and estimate condition */ -/* numbers (DTGSNA). Note that the definition of the condition */ -/* number is not invariant under transformation (u,v) to */ -/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */ -/* Schur form (S,T), Q and Z are orthogonal matrices. In order */ -/* to avoid using extra 2*N*N workspace, we have to recalculate */ -/* eigenvectors and estimate one condition numbers at a time. */ - - pair = false; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - - if (pair) { - pair = false; - goto L20; - } - mm = 1; - if (i__ < *n) { - if (a[i__ + 1 + i__ * a_dim1] != 0.) { - pair = true; - mm = 2; - } - } - - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - bwork[j] = false; -/* L10: */ - } - if (mm == 1) { - bwork[i__] = true; - } else if (mm == 2) { - bwork[i__] = true; - bwork[i__ + 1] = true; - } - - iwrk = mm * *n + 1; - iwrk1 = iwrk + mm * *n; - -/* Compute a pair of left and right eigenvectors. */ -/* (compute workspace: need up to 4*N + 6*N) */ - - if (wantse || wantsb) { - dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[ - b_offset], ldb, &work[1], n, &work[iwrk], n, &mm, - &m, &work[iwrk1], &ierr); - if (ierr != 0) { - *info = *n + 2; - goto L130; - } - } - - i__2 = *lwork - iwrk1 + 1; - dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[ - b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[ - i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, & - iwork[1], &ierr); - -L20: - ; - } - } - } - -/* Undo balancing on VL and VR and normalization */ -/* (Workspace: none needed) */ - - if (ilvl) { - dggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[ - vl_offset], ldvl, &ierr); - - i__1 = *n; - for (jc = 1; jc <= i__1; ++jc) { - if (alphai[jc] < 0.) { - goto L70; - } - temp = 0.; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], abs( - d__1)); - temp = std::max(d__2,d__3); -/* L30: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], abs( - d__1)) + (d__2 = vl[jr + (jc + 1) * vl_dim1], abs( - d__2)); - temp = std::max(d__3,d__4); -/* L40: */ - } - } - if (temp < smlnum) { - goto L70; - } - temp = 1. / temp; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vl[jr + jc * vl_dim1] *= temp; -/* L50: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vl[jr + jc * vl_dim1] *= temp; - vl[jr + (jc + 1) * vl_dim1] *= temp; -/* L60: */ - } - } -L70: - ; - } - } - if (ilvr) { - dggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[ - vr_offset], ldvr, &ierr); - i__1 = *n; - for (jc = 1; jc <= i__1; ++jc) { - if (alphai[jc] < 0.) { - goto L120; - } - temp = 0.; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], abs( - d__1)); - temp = std::max(d__2,d__3); -/* L80: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { -/* Computing MAX */ - d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], abs( - d__1)) + (d__2 = vr[jr + (jc + 1) * vr_dim1], abs( - d__2)); - temp = std::max(d__3,d__4); -/* L90: */ - } - } - if (temp < smlnum) { - goto L120; - } - temp = 1. / temp; - if (alphai[jc] == 0.) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + jc * vr_dim1] *= temp; -/* L100: */ - } - } else { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + jc * vr_dim1] *= temp; - vr[jr + (jc + 1) * vr_dim1] *= temp; -/* L110: */ - } - } -L120: - ; - } - } - -/* Undo scaling if necessary */ - - if (ilascl) { - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & - ierr); - dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & - ierr); - } - - if (ilbscl) { - dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & - ierr); - } - -L130: - work[1] = (double) maxwrk; - - return 0; - -/* End of DGGEVX */ - -} /* dggevx_ */ diff --git a/external/clapack/lapack/dggglm.cpp b/external/clapack/lapack/dggglm.cpp deleted file mode 100644 index 70881280..00000000 --- a/external/clapack/lapack/dggglm.cpp +++ /dev/null @@ -1,301 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b32 = -1.; -static double c_b34 = 1.; - -/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, double * - a, integer *lda, double *b, integer *ldb, double *d__, - double *x, double *y, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, nb, np, nb1, nb2, nb3, nb4, lopt; - integer lwkmin; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGGLM solves a general Gauss-Markov linear model (GLM) problem: */ - -/* minimize || y ||_2 subject to d = A*x + B*y */ -/* x */ - -/* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */ -/* given N-vector. It is assumed that M <= N <= M+P, and */ - -/* rank(A) = M and rank( A B ) = N. */ - -/* Under these assumptions, the constrained equation is always */ -/* consistent, and there is a unique solution x and a minimal 2-norm */ -/* solution y, which is obtained using a generalized QR factorization */ -/* of the matrices (A, B) given by */ - -/* A = Q*(R), B = Q*T*Z. */ -/* (0) */ - -/* In particular, if matrix B is square nonsingular, then the problem */ -/* GLM is equivalent to the following weighted linear least squares */ -/* problem */ - -/* minimize || inv(B)*(d-A*x) ||_2 */ -/* x */ - -/* where inv(B) denotes the inverse of B. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of rows of the matrices A and B. N >= 0. */ - -/* M (input) INTEGER */ -/* The number of columns of the matrix A. 0 <= M <= N. */ - -/* P (input) INTEGER */ -/* The number of columns of the matrix B. P >= N-M. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) */ -/* On entry, the N-by-M matrix A. */ -/* On exit, the upper triangular part of the array A contains */ -/* the M-by-M upper triangular matrix R. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,P) */ -/* On entry, the N-by-P matrix B. */ -/* On exit, if N <= P, the upper triangle of the subarray */ -/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */ -/* if N > P, the elements on and above the (N-P)th subdiagonal */ -/* contain the N-by-P upper trapezoidal matrix T. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, D is the left hand side of the GLM equation. */ -/* On exit, D is destroyed. */ - -/* X (output) DOUBLE PRECISION array, dimension (M) */ -/* Y (output) DOUBLE PRECISION array, dimension (P) */ -/* On exit, X and Y are the solutions of the GLM problem. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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+M+P). */ -/* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, */ -/* where NB is an upper bound for the optimal blocksizes for */ -/* DGEQRF, SGERQF, DORMQR and SORMRQ. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1: the upper triangular factor R associated with A in the */ -/* generalized QR factorization of the pair (A, B) is */ -/* singular, so that rank(A) < M; the least squares */ -/* solution could not be computed. */ -/* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */ -/* factor T associated with B in the generalized QR */ -/* factorization of the pair (A, B) is singular, so that */ -/* rank( A B ) < N; the least squares solution could not */ -/* be computed. */ - -/* =================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --d__; - --x; - --y; - --work; - - /* Function Body */ - *info = 0; - np = std::min(*n,*p); - lquery = *lwork == -1; - if (*n < 0) { - *info = -1; - } else if (*m < 0 || *m > *n) { - *info = -2; - } else if (*p < 0 || *p < *n - *m) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - -/* Calculate workspace */ - - if (*info == 0) { - if (*n == 0) { - lwkmin = 1; - lwkopt = 1; - } else { - nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1); - nb2 = ilaenv_(&c__1, "DGERQF", " ", n, m, &c_n1, &c_n1); - nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1); - nb4 = ilaenv_(&c__1, "DORMRQ", " ", n, m, p, &c_n1); -/* Computing MAX */ - i__1 = std::max(nb1,nb2), i__1 = std::max(i__1,nb3); - nb = std::max(i__1,nb4); - lwkmin = *m + *n + *p; - lwkopt = *m + np + std::max(*n,*p) * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < lwkmin && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGGLM", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Compute the GQR factorization of matrices A and B: */ - -/* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */ -/* ( 0 ) N-M ( 0 T22 ) N-M */ -/* M M+P-N N-M */ - -/* where R11 and T22 are upper triangular, and Q and Z are */ -/* orthogonal. */ - - i__1 = *lwork - *m - np; - dggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m - + 1], &work[*m + np + 1], &i__1, info); - lopt = (integer) work[*m + np + 1]; - -/* Update left-hand-side vector d = Q'*d = ( d1 ) M */ -/* ( d2 ) N-M */ - - i__1 = std::max(1_integer,*n); - i__2 = *lwork - *m - np; - dormqr_("Left", "Transpose", n, &c__1, m, &a[a_offset], lda, &work[1], & - d__[1], &i__1, &work[*m + np + 1], &i__2, info); -/* Computing MAX */ - i__1 = lopt, i__2 = (integer) work[*m + np + 1]; - lopt = std::max(i__1,i__2); - -/* Solve T22*y2 = d2 for y2 */ - - if (*n > *m) { - i__1 = *n - *m; - i__2 = *n - *m; - dtrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1 - + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2, - info); - - if (*info > 0) { - *info = 1; - return 0; - } - - i__1 = *n - *m; - dcopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1); - } - -/* Set y1 = 0 */ - - i__1 = *m + *p - *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - -/* Update d1 = d1 - T12*y2 */ - - i__1 = *n - *m; - dgemv_("No transpose", m, &i__1, &c_b32, &b[(*m + *p - *n + 1) * b_dim1 + - 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b34, &d__[1], &c__1); - -/* Solve triangular system: R11*x = d1 */ - - if (*m > 0) { - dtrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset], - lda, &d__[1], m, info); - - if (*info > 0) { - *info = 2; - return 0; - } - -/* Copy D to X */ - - dcopy_(m, &d__[1], &c__1, &x[1], &c__1); - } - -/* Backward transformation y = Z'*y */ - -/* Computing MAX */ - i__1 = 1, i__2 = *n - *p + 1; - i__3 = std::max(1_integer,*p); - i__4 = *lwork - *m - np; - dormrq_("Left", "Transpose", p, &c__1, &np, &b[std::max(i__1, i__2)+ b_dim1], - ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &i__4, info); -/* Computing MAX */ - i__1 = lopt, i__2 = (integer) work[*m + np + 1]; - work[1] = (double) (*m + np + std::max(i__1,i__2)); - - return 0; - -/* End of DGGGLM */ - -} /* dggglm_ */ diff --git a/external/clapack/lapack/dgghrd.cpp b/external/clapack/lapack/dgghrd.cpp deleted file mode 100644 index 7daa0b69..00000000 --- a/external/clapack/lapack/dgghrd.cpp +++ /dev/null @@ -1,310 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b10 = 0.; -static double c_b11 = 1.; -static integer c__1 = 1; - -/* Subroutine */ int dgghrd_(const char *compq, const char *compz, integer *n, integer * - ilo, integer *ihi, double *a, integer *lda, double *b, - integer *ldb, double *q, integer *ldq, double *z__, integer * - ldz, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, - z_offset, i__1, i__2, i__3; - - /* Local variables */ - double c__, s; - bool ilq, ilz; - integer jcol; - double temp; - integer jrow; - integer icompq, icompz; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGHRD reduces a pair of real matrices (A,B) to generalized upper */ -/* Hessenberg form using orthogonal transformations, where A is a */ -/* general matrix and B is upper triangular. The form of the */ -/* generalized eigenvalue problem is */ -/* A*x = lambda*B*x, */ -/* and B is typically made upper triangular by computing its QR */ -/* factorization and moving the orthogonal matrix Q to the left side */ -/* of the equation. */ - -/* This subroutine simultaneously reduces A to a Hessenberg matrix H: */ -/* Q**T*A*Z = H */ -/* and transforms B to another upper triangular matrix T: */ -/* Q**T*B*Z = T */ -/* in order to reduce the problem to its standard form */ -/* H*y = lambda*T*y */ -/* where y = Z**T*x. */ - -/* The orthogonal matrices Q and Z are determined as products of Givens */ -/* rotations. They may either be formed explicitly, or they may be */ -/* postmultiplied into input matrices Q1 and Z1, so that */ - -/* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T */ - -/* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T */ - -/* If Q1 is the orthogonal matrix from the QR factorization of B in the */ -/* original equation A*x = lambda*B*x, then DGGHRD reduces the original */ -/* problem to generalized Hessenberg form. */ - -/* Arguments */ -/* ========= */ - -/* COMPQ (input) CHARACTER*1 */ -/* = 'N': do not compute Q; */ -/* = 'I': Q is initialized to the unit matrix, and the */ -/* orthogonal matrix Q is returned; */ -/* = 'V': Q must contain an orthogonal matrix Q1 on entry, */ -/* and the product Q1*Q is returned. */ - -/* COMPZ (input) CHARACTER*1 */ -/* = 'N': do not compute Z; */ -/* = 'I': Z is initialized to the unit matrix, and the */ -/* orthogonal matrix Z is returned; */ -/* = 'V': Z must contain an orthogonal matrix Z1 on entry, */ -/* and the product Z1*Z is returned. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* ILO and IHI mark the rows and columns of A which are to be */ -/* reduced. It is assumed that A is already upper triangular */ -/* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are */ -/* normally set by a previous call to SGGBAL; otherwise they */ -/* should be set to 1 and N respectively. */ -/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the N-by-N general matrix to be reduced. */ -/* On exit, the upper triangle and the first subdiagonal of A */ -/* are overwritten with the upper Hessenberg matrix H, and the */ -/* rest is set to zero. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the N-by-N upper triangular matrix B. */ -/* On exit, the upper triangular matrix T = Q**T B Z. The */ -/* elements below the diagonal are set to zero. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ -/* On entry, if COMPQ = 'V', the orthogonal matrix Q1, */ -/* typically from the QR factorization of B. */ -/* On exit, if COMPQ='I', the orthogonal matrix Q, and if */ -/* COMPQ = 'V', the product Q1*Q. */ -/* Not referenced if COMPQ='N'. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. */ -/* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* On entry, if COMPZ = 'V', the orthogonal matrix Z1. */ -/* On exit, if COMPZ='I', the orthogonal matrix Z, and if */ -/* COMPZ = 'V', the product Z1*Z. */ -/* Not referenced if COMPZ='N'. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. */ -/* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* This routine reduces A to Hessenberg and B to triangular form by */ -/* an unblocked reduction, as described in _Matrix_Computations_, */ -/* by Golub and Van Loan (Johns Hopkins Press.) */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode COMPQ */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - - /* Function Body */ - if (lsame_(compq, "N")) { - ilq = false; - icompq = 1; - } else if (lsame_(compq, "V")) { - ilq = true; - icompq = 2; - } else if (lsame_(compq, "I")) { - ilq = true; - icompq = 3; - } else { - icompq = 0; - } - -/* Decode COMPZ */ - - if (lsame_(compz, "N")) { - ilz = false; - icompz = 1; - } else if (lsame_(compz, "V")) { - ilz = true; - icompz = 2; - } else if (lsame_(compz, "I")) { - ilz = true; - icompz = 3; - } else { - icompz = 0; - } - -/* Test the input parameters. */ - - *info = 0; - if (icompq <= 0) { - *info = -1; - } else if (icompz <= 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ilo < 1) { - *info = -4; - } else if (*ihi > *n || *ihi < *ilo - 1) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (ilq && *ldq < *n || *ldq < 1) { - *info = -11; - } else if (ilz && *ldz < *n || *ldz < 1) { - *info = -13; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGHRD", &i__1); - return 0; - } - -/* Initialize Q and Z if desired. */ - - if (icompq == 3) { - dlaset_("Full", n, n, &c_b10, &c_b11, &q[q_offset], ldq); - } - if (icompz == 3) { - dlaset_("Full", n, n, &c_b10, &c_b11, &z__[z_offset], ldz); - } - -/* Quick return if possible */ - - if (*n <= 1) { - return 0; - } - -/* Zero out lower triangle of B */ - - i__1 = *n - 1; - for (jcol = 1; jcol <= i__1; ++jcol) { - i__2 = *n; - for (jrow = jcol + 1; jrow <= i__2; ++jrow) { - b[jrow + jcol * b_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - -/* Reduce A and B */ - - i__1 = *ihi - 2; - for (jcol = *ilo; jcol <= i__1; ++jcol) { - - i__2 = jcol + 2; - for (jrow = *ihi; jrow >= i__2; --jrow) { - -/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */ - - temp = a[jrow - 1 + jcol * a_dim1]; - dlartg_(&temp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 + - jcol * a_dim1]); - a[jrow + jcol * a_dim1] = 0.; - i__3 = *n - jcol; - drot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + ( - jcol + 1) * a_dim1], lda, &c__, &s); - i__3 = *n + 2 - jrow; - drot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + ( - jrow - 1) * b_dim1], ldb, &c__, &s); - if (ilq) { - drot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1 - + 1], &c__1, &c__, &s); - } - -/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */ - - temp = b[jrow + jrow * b_dim1]; - dlartg_(&temp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow - + jrow * b_dim1]); - b[jrow + (jrow - 1) * b_dim1] = 0.; - drot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 + - 1], &c__1, &c__, &s); - i__3 = jrow - 1; - drot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1 - + 1], &c__1, &c__, &s); - if (ilz) { - drot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) * - z_dim1 + 1], &c__1, &c__, &s); - } -/* L30: */ - } -/* L40: */ - } - - return 0; - -/* End of DGGHRD */ - -} /* dgghrd_ */ diff --git a/external/clapack/lapack/dgglse.cpp b/external/clapack/lapack/dgglse.cpp deleted file mode 100644 index 84301afb..00000000 --- a/external/clapack/lapack/dgglse.cpp +++ /dev/null @@ -1,307 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b31 = -1.; -static double c_b33 = 1.; - -/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, double * - a, integer *lda, double *b, integer *ldb, double *c__, - double *d__, double *x, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - - /* Local variables */ - integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt; - integer lwkmin; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGLSE solves the linear equality-constrained least squares (LSE) */ -/* problem: */ - -/* minimize || c - A*x ||_2 subject to B*x = d */ - -/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */ -/* M-vector, and d is a given P-vector. It is assumed that */ -/* P <= N <= M+P, and */ - -/* rank(B) = P and rank( (A) ) = N. */ -/* ( (B) ) */ - -/* These conditions ensure that the LSE problem has a unique solution, */ -/* which is obtained using a generalized RQ factorization of the */ -/* matrices (B, A) given by */ - -/* B = (0 R)*Q, A = Z*T*Q. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrices A and B. N >= 0. */ - -/* P (input) INTEGER */ -/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */ - -/* 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 T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ -/* On entry, the P-by-N matrix B. */ -/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */ -/* contains the P-by-P upper triangular matrix R. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,P). */ - -/* C (input/output) DOUBLE PRECISION array, dimension (M) */ -/* On entry, C contains the right hand side vector for the */ -/* least squares part of the LSE problem. */ -/* On exit, the residual sum of squares for the solution */ -/* is given by the sum of squares of elements N-P+1 to M of */ -/* vector C. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (P) */ -/* On entry, D contains the right hand side vector for the */ -/* constrained equation. */ -/* On exit, D is destroyed. */ - -/* X (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, X is the solution of the LSE problem. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,M+N+P). */ -/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */ -/* where NB is an upper bound for the optimal blocksizes for */ -/* DGEQRF, SGERQF, DORMQR and SORMRQ. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1: the upper triangular factor R associated with B in the */ -/* generalized RQ factorization of the pair (B, A) is */ -/* singular, so that rank(B) < P; the least squares */ -/* solution could not be computed. */ -/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */ -/* T associated with A in the generalized RQ factorization */ -/* of the pair (B, A) is singular, so that */ -/* rank( (A) ) < N; the least squares solution could not */ -/* ( (B) ) */ -/* be computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --c__; - --d__; - --x; - --work; - - /* Function Body */ - *info = 0; - mn = std::min(*m,*n); - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*p < 0 || *p > *n || *p < *n - *m) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*p)) { - *info = -7; - } - -/* Calculate workspace */ - - if (*info == 0) { - if (*n == 0) { - lwkmin = 1; - lwkopt = 1; - } else { - nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); - nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); - nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, p, &c_n1); - nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1); -/* Computing MAX */ - i__1 = std::max(nb1,nb2), i__1 = std::max(i__1,nb3); - nb = std::max(i__1,nb4); - lwkmin = *m + *n + *p; - lwkopt = *p + mn + std::max(*m,*n) * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < lwkmin && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGLSE", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Compute the GRQ factorization of matrices B and A: */ - -/* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P */ -/* N-P P ( 0 R22 ) M+P-N */ -/* N-P P */ - -/* where T12 and R11 are upper triangular, and Q and Z are */ -/* orthogonal. */ - - i__1 = *lwork - *p - mn; - dggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p - + 1], &work[*p + mn + 1], &i__1, info); - lopt = (integer) work[*p + mn + 1]; - -/* Update c = Z'*c = ( c1 ) N-P */ -/* ( c2 ) M+P-N */ - - i__1 = std::max(1_integer,*m); - i__2 = *lwork - *p - mn; - dormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p + - 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info); -/* Computing MAX */ - i__1 = lopt, i__2 = (integer) work[*p + mn + 1]; - lopt = std::max(i__1,i__2); - -/* Solve T12*x2 = d for x2 */ - - if (*p > 0) { - dtrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p + - 1) * b_dim1 + 1], ldb, &d__[1], p, info); - - if (*info > 0) { - *info = 1; - return 0; - } - -/* Put the solution in X */ - - dcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1); - -/* Update c1 */ - - i__1 = *n - *p; - dgemv_("No transpose", &i__1, p, &c_b31, &a[(*n - *p + 1) * a_dim1 + - 1], lda, &d__[1], &c__1, &c_b33, &c__[1], &c__1); - } - -/* Solve R11*x1 = c1 for x1 */ - - if (*n > *p) { - i__1 = *n - *p; - i__2 = *n - *p; - dtrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[ - a_offset], lda, &c__[1], &i__2, info); - - if (*info > 0) { - *info = 2; - return 0; - } - -/* Put the solutions in X */ - - i__1 = *n - *p; - dcopy_(&i__1, &c__[1], &c__1, &x[1], &c__1); - } - -/* Compute the residual vector: */ - - if (*m < *n) { - nr = *m + *p - *n; - if (nr > 0) { - i__1 = *n - *m; - dgemv_("No transpose", &nr, &i__1, &c_b31, &a[*n - *p + 1 + (*m + - 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b33, &c__[*n - - *p + 1], &c__1); - } - } else { - nr = *p; - } - if (nr > 0) { - dtrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n - - *p + 1) * a_dim1], lda, &d__[1], &c__1); - daxpy_(&nr, &c_b31, &d__[1], &c__1, &c__[*n - *p + 1], &c__1); - } - -/* Backward transformation x = Q'*x */ - - i__1 = *lwork - *p - mn; - dormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[ - 1], n, &work[*p + mn + 1], &i__1, info); -/* Computing MAX */ - i__1 = lopt, i__2 = (integer) work[*p + mn + 1]; - work[1] = (double) (*p + mn + std::max(i__1,i__2)); - - return 0; - -/* End of DGGLSE */ - -} /* dgglse_ */ diff --git a/external/clapack/lapack/dggqrf.cpp b/external/clapack/lapack/dggqrf.cpp deleted file mode 100644 index 06a4d281..00000000 --- a/external/clapack/lapack/dggqrf.cpp +++ /dev/null @@ -1,246 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dggqrf_(integer *n, integer *m, integer *p, double * - a, integer *lda, double *taua, double *b, integer *ldb, - double *taub, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - - /* Local variables */ - integer nb, nb1, nb2, nb3, lopt; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGQRF computes a generalized QR factorization of an N-by-M matrix A */ -/* and an N-by-P matrix B: */ - -/* A = Q*R, B = Q*T*Z, */ - -/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */ -/* matrix, and R and T assume one of the forms: */ - -/* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, */ -/* ( 0 ) N-M N M-N */ -/* M */ - -/* where R11 is upper triangular, and */ - -/* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, */ -/* P-N N ( T21 ) P */ -/* P */ - -/* where T12 or T21 is upper triangular. */ - -/* In particular, if B is square and nonsingular, the GQR factorization */ -/* of A and B implicitly gives the QR factorization of inv(B)*A: */ - -/* inv(B)*A = Z'*(inv(T)*R) */ - -/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */ -/* transpose of the matrix Z. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of rows of the matrices A and B. N >= 0. */ - -/* M (input) INTEGER */ -/* The number of columns of the matrix A. M >= 0. */ - -/* P (input) INTEGER */ -/* The number of columns of the matrix B. P >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) */ -/* On entry, the N-by-M matrix A. */ -/* On exit, the elements on and above the diagonal of the array */ -/* contain the min(N,M)-by-M upper trapezoidal matrix R (R is */ -/* upper triangular if N >= M); the elements below the diagonal, */ -/* with the array TAUA, represent the orthogonal matrix Q as a */ -/* product of min(N,M) elementary reflectors (see Further */ -/* Details). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* TAUA (output) DOUBLE PRECISION array, dimension (min(N,M)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Q (see Further Details). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,P) */ -/* On entry, the N-by-P matrix B. */ -/* On exit, if N <= P, the upper triangle of the subarray */ -/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */ -/* if N > P, the elements on and above the (N-P)-th subdiagonal */ -/* contain the N-by-P upper trapezoidal matrix T; the remaining */ -/* elements, with the array TAUB, represent the orthogonal */ -/* matrix Z as a product of elementary reflectors (see Further */ -/* Details). */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* TAUB (output) DOUBLE PRECISION array, dimension (min(N,P)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Z (see Further Details). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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,M,P). */ -/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */ -/* where NB1 is the optimal blocksize for the QR factorization */ -/* of an N-by-M matrix, NB2 is the optimal blocksize for the */ -/* RQ factorization of an N-by-P matrix, and NB3 is the optimal */ -/* blocksize for a call of DORMQR. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* 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(n,m). */ - -/* Each H(i) has the form */ - -/* H(i) = I - taua * v * v' */ - -/* where taua is a real scalar, and v is a real vector with */ -/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ -/* and taua in TAUA(i). */ -/* To form Q explicitly, use LAPACK subroutine DORGQR. */ -/* To use Q to update another matrix, use LAPACK subroutine DORMQR. */ - -/* The matrix Z is represented as a product of elementary reflectors */ - -/* Z = H(1) H(2) . . . H(k), where k = min(n,p). */ - -/* Each H(i) has the form */ - -/* H(i) = I - taub * v * v' */ - -/* where taub is a real scalar, and v is a real vector with */ -/* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in */ -/* B(n-k+i,1:p-k+i-1), and taub in TAUB(i). */ -/* To form Z explicitly, use LAPACK subroutine DORGRQ. */ -/* To use Z to update another matrix, use LAPACK subroutine DORMRQ. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --taua; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --taub; - --work; - - /* Function Body */ - *info = 0; - nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1); - nb2 = ilaenv_(&c__1, "DGERQF", " ", n, p, &c_n1, &c_n1); - nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1); -/* Computing MAX */ - i__1 = std::max(nb1,nb2); - nb = std::max(i__1,nb3); -/* Computing MAX */ - i__1 = std::max(*n,*m); - lwkopt = std::max(i__1,*p) * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*n < 0) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*p < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = std::max(1_integer,*n), i__1 = std::max(i__1,*m); - if (*lwork < std::max(i__1,*p) && ! lquery) { - *info = -11; - } - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGQRF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* QR factorization of N-by-M matrix A: A = Q*R */ - - dgeqrf_(n, m, &a[a_offset], lda, &taua[1], &work[1], lwork, info); - lopt = (integer) work[1]; - -/* Update B := Q'*B. */ - - i__1 = std::min(*n,*m); - dormqr_("Left", "Transpose", n, p, &i__1, &a[a_offset], lda, &taua[1], &b[ - b_offset], ldb, &work[1], lwork, info); -/* Computing MAX */ - i__1 = lopt, i__2 = (integer) work[1]; - lopt = std::max(i__1,i__2); - -/* RQ factorization of N-by-P matrix B: B = T*Z. */ - - dgerqf_(n, p, &b[b_offset], ldb, &taub[1], &work[1], lwork, info); -/* Computing MAX */ - i__1 = lopt, i__2 = (integer) work[1]; - work[1] = (double) std::max(i__1,i__2); - - return 0; - -/* End of DGGQRF */ - -} /* dggqrf_ */ diff --git a/external/clapack/lapack/dggrqf.cpp b/external/clapack/lapack/dggrqf.cpp deleted file mode 100644 index 2ef702ff..00000000 --- a/external/clapack/lapack/dggrqf.cpp +++ /dev/null @@ -1,247 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dggrqf_(integer *m, integer *p, integer *n, double * - a, integer *lda, double *taua, double *b, integer *ldb, - double *taub, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer nb, nb1, nb2, nb3, lopt; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A */ -/* and a P-by-N matrix B: */ - -/* A = R*Q, B = Z*T*Q, */ - -/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */ -/* matrix, and R and T assume one of the forms: */ - -/* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, */ -/* N-M M ( R21 ) N */ -/* N */ - -/* where R12 or R21 is upper triangular, and */ - -/* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, */ -/* ( 0 ) P-N P N-P */ -/* N */ - -/* where T11 is upper triangular. */ - -/* In particular, if B is square and nonsingular, the GRQ factorization */ -/* of A and B implicitly gives the RQ factorization of A*inv(B): */ - -/* A*inv(B) = (R*inv(T))*Z' */ - -/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */ -/* transpose of the matrix Z. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. */ - -/* P (input) INTEGER */ -/* The number of rows of the matrix B. P >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, if M <= N, the upper triangle of the subarray */ -/* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; */ -/* if M > N, the elements on and above the (M-N)-th subdiagonal */ -/* contain the M-by-N upper trapezoidal matrix R; the remaining */ -/* elements, with the array TAUA, 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). */ - -/* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Q (see Further Details). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ -/* On entry, the P-by-N matrix B. */ -/* On exit, the elements on and above the diagonal of the array */ -/* contain the min(P,N)-by-N upper trapezoidal matrix T (T is */ -/* upper triangular if P >= N); the elements below the diagonal, */ -/* with the array TAUB, represent the orthogonal matrix Z as a */ -/* product of elementary reflectors (see Further Details). */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,P). */ - -/* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N)) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Z (see Further Details). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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,M,P). */ -/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */ -/* where NB1 is the optimal blocksize for the RQ factorization */ -/* of an M-by-N matrix, NB2 is the optimal blocksize for the */ -/* QR factorization of a P-by-N matrix, and NB3 is the optimal */ -/* blocksize for a call of DORMRQ. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INF0= -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 - taua * v * v' */ - -/* where taua is a real scalar, and v is a real vector with */ -/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */ -/* A(m-k+i,1:n-k+i-1), and taua in TAUA(i). */ -/* To form Q explicitly, use LAPACK subroutine DORGRQ. */ -/* To use Q to update another matrix, use LAPACK subroutine DORMRQ. */ - -/* The matrix Z is represented as a product of elementary reflectors */ - -/* Z = H(1) H(2) . . . H(k), where k = min(p,n). */ - -/* Each H(i) has the form */ - -/* H(i) = I - taub * v * v' */ - -/* where taub is a real scalar, and v is a real vector with */ -/* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), */ -/* and taub in TAUB(i). */ -/* To form Z explicitly, use LAPACK subroutine DORGQR. */ -/* To use Z to update another matrix, use LAPACK subroutine DORMQR. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --taua; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --taub; - --work; - - /* Function Body */ - *info = 0; - nb1 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); - nb2 = ilaenv_(&c__1, "DGEQRF", " ", p, n, &c_n1, &c_n1); - nb3 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1); -/* Computing MAX */ - i__1 = std::max(nb1,nb2); - nb = std::max(i__1,nb3); -/* Computing MAX */ - i__1 = std::max(*n,*m); - lwkopt = std::max(i__1,*p) * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*p < 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*p)) { - *info = -8; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = std::max(1_integer,*m), i__1 = std::max(i__1,*p); - if (*lwork < std::max(i__1,*n) && ! lquery) { - *info = -11; - } - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGRQF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* RQ factorization of M-by-N matrix A: A = R*Q */ - - dgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info); - lopt = (integer) work[1]; - -/* Update B := B*Q' */ - - i__1 = std::min(*m,*n); -/* Computing MAX */ - i__2 = 1, i__3 = *m - *n + 1; - dormrq_("Right", "Transpose", p, n, &i__1, &a[std::max(i__2, i__3)+ a_dim1], - lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info); -/* Computing MAX */ - i__1 = lopt, i__2 = (integer) work[1]; - lopt = std::max(i__1,i__2); - -/* QR factorization of P-by-N matrix B: B = Z*T */ - - dgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info); -/* Computing MAX */ - i__1 = lopt, i__2 = (integer) work[1]; - work[1] = (double) std::max(i__1,i__2); - - return 0; - -/* End of DGGRQF */ - -} /* dggrqf_ */ diff --git a/external/clapack/lapack/dggsvd.cpp b/external/clapack/lapack/dggsvd.cpp deleted file mode 100644 index 2ad2c307..00000000 --- a/external/clapack/lapack/dggsvd.cpp +++ /dev/null @@ -1,375 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dggsvd_(const char *jobu, const char *jobv, const char *jobq, integer *m, - integer *n, integer *p, integer *k, integer *l, double *a, - integer *lda, double *b, integer *ldb, double *alpha, - double *beta, double *u, integer *ldu, double *v, integer - *ldv, double *q, integer *ldq, double *work, integer *iwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, - u_offset, v_dim1, v_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - double ulp; - integer ibnd; - double tola; - integer isub; - double tolb, unfl, temp, smax; - double anorm, bnorm; - bool wantq, wantu, wantv; - integer ncycle; - -/* -- LAPACK driver routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGSVD computes the generalized singular value decomposition (GSVD) */ -/* of an M-by-N real matrix A and P-by-N real matrix B: */ - -/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ) */ - -/* where U, V and Q are orthogonal matrices, and Z' is the transpose */ -/* of Z. Let K+L = the effective numerical rank of the matrix (A',B')', */ -/* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */ -/* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */ -/* following structures, respectively: */ - -/* If M-K-L >= 0, */ - -/* K L */ -/* D1 = K ( I 0 ) */ -/* L ( 0 C ) */ -/* M-K-L ( 0 0 ) */ - -/* K L */ -/* D2 = L ( 0 S ) */ -/* P-L ( 0 0 ) */ - -/* N-K-L K L */ -/* ( 0 R ) = K ( 0 R11 R12 ) */ -/* L ( 0 0 R22 ) */ - -/* where */ - -/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ -/* S = diag( BETA(K+1), ... , BETA(K+L) ), */ -/* C**2 + S**2 = I. */ - -/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */ - -/* If M-K-L < 0, */ - -/* K M-K K+L-M */ -/* D1 = K ( I 0 0 ) */ -/* M-K ( 0 C 0 ) */ - -/* K M-K K+L-M */ -/* D2 = M-K ( 0 S 0 ) */ -/* K+L-M ( 0 0 I ) */ -/* P-L ( 0 0 0 ) */ - -/* N-K-L K M-K K+L-M */ -/* ( 0 R ) = K ( 0 R11 R12 R13 ) */ -/* M-K ( 0 0 R22 R23 ) */ -/* K+L-M ( 0 0 0 R33 ) */ - -/* where */ - -/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ -/* S = diag( BETA(K+1), ... , BETA(M) ), */ -/* C**2 + S**2 = I. */ - -/* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */ -/* ( 0 R22 R23 ) */ -/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */ - -/* The routine computes C, S, R, and optionally the orthogonal */ -/* transformation matrices U, V and Q. */ - -/* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */ -/* A and B implicitly gives the SVD of A*inv(B): */ -/* A*inv(B) = U*(D1*inv(D2))*V'. */ -/* If ( A',B')' has orthonormal columns, then the GSVD of A and B is */ -/* also equal to the CS decomposition of A and B. Furthermore, the GSVD */ -/* can be used to derive the solution of the eigenvalue problem: */ -/* A'*A x = lambda* B'*B x. */ -/* In some literature, the GSVD of A and B is presented in the form */ -/* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 ) */ -/* where U and V are orthogonal and X is nonsingular, D1 and D2 are */ -/* ``diagonal''. The former GSVD form can be converted to the latter */ -/* form by taking the nonsingular matrix X as */ - -/* X = Q*( I 0 ) */ -/* ( 0 inv(R) ). */ - -/* Arguments */ -/* ========= */ - -/* JOBU (input) CHARACTER*1 */ -/* = 'U': Orthogonal matrix U is computed; */ -/* = 'N': U is not computed. */ - -/* JOBV (input) CHARACTER*1 */ -/* = 'V': Orthogonal matrix V is computed; */ -/* = 'N': V is not computed. */ - -/* JOBQ (input) CHARACTER*1 */ -/* = 'Q': Orthogonal matrix Q is computed; */ -/* = 'N': Q is not computed. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrices A and B. N >= 0. */ - -/* P (input) INTEGER */ -/* The number of rows of the matrix B. P >= 0. */ - -/* K (output) INTEGER */ -/* L (output) INTEGER */ -/* On exit, K and L specify the dimension of the subblocks */ -/* described in the Purpose section. */ -/* K + L = effective numerical rank of (A',B')'. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, A contains the triangular matrix R, or part of R. */ -/* See Purpose for details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ -/* On entry, the P-by-N matrix B. */ -/* On exit, B contains the triangular matrix R if M-K-L < 0. */ -/* See Purpose for details. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,P). */ - -/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */ -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, ALPHA and BETA contain the generalized singular */ -/* value pairs of A and B; */ -/* ALPHA(1:K) = 1, */ -/* BETA(1:K) = 0, */ -/* and if M-K-L >= 0, */ -/* ALPHA(K+1:K+L) = C, */ -/* BETA(K+1:K+L) = S, */ -/* or if M-K-L < 0, */ -/* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */ -/* BETA(K+1:M) =S, BETA(M+1:K+L) =1 */ -/* and */ -/* ALPHA(K+L+1:N) = 0 */ -/* BETA(K+L+1:N) = 0 */ - -/* U (output) DOUBLE PRECISION array, dimension (LDU,M) */ -/* If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */ -/* If JOBU = 'N', U is not referenced. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= max(1,M) if */ -/* JOBU = 'U'; LDU >= 1 otherwise. */ - -/* V (output) DOUBLE PRECISION array, dimension (LDV,P) */ -/* If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */ -/* If JOBV = 'N', V is not referenced. */ - -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. LDV >= max(1,P) if */ -/* JOBV = 'V'; LDV >= 1 otherwise. */ - -/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */ -/* If JOBQ = 'N', Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N) if */ -/* JOBQ = 'Q'; LDQ >= 1 otherwise. */ - -/* WORK (workspace) DOUBLE PRECISION array, */ -/* dimension (max(3*N,M,P)+N) */ - -/* IWORK (workspace/output) INTEGER array, dimension (N) */ -/* On exit, IWORK stores the sorting information. More */ -/* precisely, the following loop will sort ALPHA */ -/* for I = K+1, min(M,K+L) */ -/* swap ALPHA(I) and ALPHA(IWORK(I)) */ -/* endfor */ -/* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, the Jacobi-type procedure failed to */ -/* converge. For further details, see subroutine DTGSJA. */ - -/* Internal Parameters */ -/* =================== */ - -/* TOLA DOUBLE PRECISION */ -/* TOLB DOUBLE PRECISION */ -/* TOLA and TOLB are the thresholds to determine the effective */ -/* rank of (A',B')'. Generally, they are set to */ -/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */ -/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */ -/* The size of TOLA and TOLB may affect the size of backward */ -/* errors of the decomposition. */ - -/* Further Details */ -/* =============== */ - -/* 2-96 Based on modifications by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alpha; - --beta; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --work; - --iwork; - - /* Function Body */ - wantu = lsame_(jobu, "U"); - wantv = lsame_(jobv, "V"); - wantq = lsame_(jobq, "Q"); - - *info = 0; - if (! (wantu || lsame_(jobu, "N"))) { - *info = -1; - } else if (! (wantv || lsame_(jobv, "N"))) { - *info = -2; - } else if (! (wantq || lsame_(jobq, "N"))) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*p < 0) { - *info = -6; - } else if (*lda < std::max(1_integer,*m)) { - *info = -10; - } else if (*ldb < std::max(1_integer,*p)) { - *info = -12; - } else if (*ldu < 1 || wantu && *ldu < *m) { - *info = -16; - } else if (*ldv < 1 || wantv && *ldv < *p) { - *info = -18; - } else if (*ldq < 1 || wantq && *ldq < *n) { - *info = -20; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGSVD", &i__1); - return 0; - } - -/* Compute the Frobenius norm of matrices A and B */ - - anorm = dlange_("1", m, n, &a[a_offset], lda, &work[1]); - bnorm = dlange_("1", p, n, &b[b_offset], ldb, &work[1]); - -/* Get machine precision and set up threshold for determining */ -/* the effective numerical rank of the matrices A and B. */ - - ulp = dlamch_("Precision"); - unfl = dlamch_("Safe Minimum"); - tola = std::max(*m,*n) * std::max(anorm,unfl) * ulp; - tolb = std::max(*p,*n) * std::max(bnorm,unfl) * ulp; - -/* Preprocessing */ - - dggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, & - tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[ - q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], info); - -/* Compute the GSVD of two upper "triangular" matrices */ - - dtgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], - ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[ - v_offset], ldv, &q[q_offset], ldq, &work[1], &ncycle, info); - -/* Sort the singular values and store the pivot indices in IWORK */ -/* Copy ALPHA to WORK, then sort ALPHA in WORK */ - - dcopy_(n, &alpha[1], &c__1, &work[1], &c__1); -/* Computing MIN */ - i__1 = *l, i__2 = *m - *k; - ibnd = std::min(i__1,i__2); - i__1 = ibnd; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Scan for largest ALPHA(K+I) */ - - isub = i__; - smax = work[*k + i__]; - i__2 = ibnd; - for (j = i__ + 1; j <= i__2; ++j) { - temp = work[*k + j]; - if (temp > smax) { - isub = j; - smax = temp; - } -/* L10: */ - } - if (isub != i__) { - work[*k + isub] = work[*k + i__]; - work[*k + i__] = smax; - iwork[*k + i__] = *k + isub; - } else { - iwork[*k + i__] = *k + i__; - } -/* L20: */ - } - - return 0; - -/* End of DGGSVD */ - -} /* dggsvd_ */ diff --git a/external/clapack/lapack/dggsvp.cpp b/external/clapack/lapack/dggsvp.cpp deleted file mode 100644 index e08ee3cc..00000000 --- a/external/clapack/lapack/dggsvp.cpp +++ /dev/null @@ -1,484 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b12 = 0.; -static double c_b22 = 1.; - -/* Subroutine */ int dggsvp_(const char *jobu, const char *jobv, const char *jobq, integer *m, - integer *p, integer *n, double *a, integer *lda, double *b, - integer *ldb, double *tola, double *tolb, integer *k, integer - *l, double *u, integer *ldu, double *v, integer *ldv, - double *q, integer *ldq, integer *iwork, double *tau, - double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, - u_offset, v_dim1, v_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer i__, j; - bool wantq, wantu, wantv; - bool forwrd; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGGSVP computes orthogonal matrices U, V and Q such that */ - -/* N-K-L K L */ -/* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */ -/* L ( 0 0 A23 ) */ -/* M-K-L ( 0 0 0 ) */ - -/* N-K-L K L */ -/* = K ( 0 A12 A13 ) if M-K-L < 0; */ -/* M-K ( 0 0 A23 ) */ - -/* N-K-L K L */ -/* V'*B*Q = L ( 0 0 B13 ) */ -/* P-L ( 0 0 0 ) */ - -/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ -/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ -/* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */ -/* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the */ -/* transpose of Z. */ - -/* This decomposition is the preprocessing step for computing the */ -/* Generalized Singular Value Decomposition (GSVD), see subroutine */ -/* DGGSVD. */ - -/* Arguments */ -/* ========= */ - -/* JOBU (input) CHARACTER*1 */ -/* = 'U': Orthogonal matrix U is computed; */ -/* = 'N': U is not computed. */ - -/* JOBV (input) CHARACTER*1 */ -/* = 'V': Orthogonal matrix V is computed; */ -/* = 'N': V is not computed. */ - -/* JOBQ (input) CHARACTER*1 */ -/* = 'Q': Orthogonal matrix Q is computed; */ -/* = 'N': Q is not computed. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. */ - -/* P (input) INTEGER */ -/* The number of rows of the matrix B. P >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, A contains the triangular (or trapezoidal) matrix */ -/* described in the Purpose section. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ -/* On entry, the P-by-N matrix B. */ -/* On exit, B contains the triangular matrix described in */ -/* the Purpose section. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,P). */ - -/* TOLA (input) DOUBLE PRECISION */ -/* TOLB (input) DOUBLE PRECISION */ -/* TOLA and TOLB are the thresholds to determine the effective */ -/* numerical rank of matrix B and a subblock of A. Generally, */ -/* they are set to */ -/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */ -/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */ -/* The size of TOLA and TOLB may affect the size of backward */ -/* errors of the decomposition. */ - -/* K (output) INTEGER */ -/* L (output) INTEGER */ -/* On exit, K and L specify the dimension of the subblocks */ -/* described in Purpose. */ -/* K + L = effective numerical rank of (A',B')'. */ - -/* U (output) DOUBLE PRECISION array, dimension (LDU,M) */ -/* If JOBU = 'U', U contains the orthogonal matrix U. */ -/* If JOBU = 'N', U is not referenced. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= max(1,M) if */ -/* JOBU = 'U'; LDU >= 1 otherwise. */ - -/* V (output) DOUBLE PRECISION array, dimension (LDV,M) */ -/* If JOBV = 'V', V contains the orthogonal matrix V. */ -/* If JOBV = 'N', V is not referenced. */ - -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. LDV >= max(1,P) if */ -/* JOBV = 'V'; LDV >= 1 otherwise. */ - -/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* If JOBQ = 'Q', Q contains the orthogonal matrix Q. */ -/* If JOBQ = 'N', Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N) if */ -/* JOBQ = 'Q'; LDQ >= 1 otherwise. */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* TAU (workspace) DOUBLE PRECISION array, dimension (N) */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P)) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - - -/* Further Details */ -/* =============== */ - -/* The subroutine uses LAPACK subroutine DGEQPF for the QR factorization */ -/* with column pivoting to detect the effective numerical rank of the */ -/* a matrix. It may be replaced by a better rank determination strategy. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --iwork; - --tau; - --work; - - /* Function Body */ - wantu = lsame_(jobu, "U"); - wantv = lsame_(jobv, "V"); - wantq = lsame_(jobq, "Q"); - forwrd = true; - - *info = 0; - if (! (wantu || lsame_(jobu, "N"))) { - *info = -1; - } else if (! (wantv || lsame_(jobv, "N"))) { - *info = -2; - } else if (! (wantq || lsame_(jobq, "N"))) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*p < 0) { - *info = -5; - } else if (*n < 0) { - *info = -6; - } else if (*lda < std::max(1_integer,*m)) { - *info = -8; - } else if (*ldb < std::max(1_integer,*p)) { - *info = -10; - } else if (*ldu < 1 || wantu && *ldu < *m) { - *info = -16; - } else if (*ldv < 1 || wantv && *ldv < *p) { - *info = -18; - } else if (*ldq < 1 || wantq && *ldq < *n) { - *info = -20; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGGSVP", &i__1); - return 0; - } - -/* QR with column pivoting of B: B*P = V*( S11 S12 ) */ -/* ( 0 0 ) */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - iwork[i__] = 0; -/* L10: */ - } - dgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info); - -/* Update A := A*P */ - - dlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); - -/* Determine the effective rank of matrix B. */ - - *l = 0; - i__1 = std::min(*p,*n); - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) > *tolb) { - ++(*l); - } -/* L20: */ - } - - if (wantv) { - -/* Copy the details of V, and form V. */ - - dlaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv); - if (*p > 1) { - i__1 = *p - 1; - dlacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], - ldv); - } - i__1 = std::min(*p,*n); - dorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); - } - -/* Clean up B */ - - i__1 = *l - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *l; - for (i__ = j + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - if (*p > *l) { - i__1 = *p - *l; - dlaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb); - } - - if (wantq) { - -/* Set Q = I and Update Q := Q*P */ - - dlaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq); - dlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); - } - - if (*p >= *l && *n != *l) { - -/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */ - - dgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); - -/* Update A := A*Z' */ - - dormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[ - a_offset], lda, &work[1], info); - - if (wantq) { - -/* Update Q := Q*Z' */ - - dormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1], - &q[q_offset], ldq, &work[1], info); - } - -/* Clean up B */ - - i__1 = *n - *l; - dlaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb); - i__1 = *n; - for (j = *n - *l + 1; j <= i__1; ++j) { - i__2 = *l; - for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L50: */ - } -/* L60: */ - } - - } - -/* Let N-L L */ -/* A = ( A11 A12 ) M, */ - -/* then the following does the complete QR decomposition of A11: */ - -/* A11 = U*( 0 T12 )*P1' */ -/* ( 0 0 ) */ - - i__1 = *n - *l; - for (i__ = 1; i__ <= i__1; ++i__) { - iwork[i__] = 0; -/* L70: */ - } - i__1 = *n - *l; - dgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info); - -/* Determine the effective rank of A11 */ - - *k = 0; -/* Computing MIN */ - i__2 = *m, i__3 = *n - *l; - i__1 = std::min(i__2,i__3); - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) > *tola) { - ++(*k); - } -/* L80: */ - } - -/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) */ - -/* Computing MIN */ - i__2 = *m, i__3 = *n - *l; - i__1 = std::min(i__2,i__3); - dorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[( - *n - *l + 1) * a_dim1 + 1], lda, &work[1], info); - - if (wantu) { - -/* Copy the details of U, and form U */ - - dlaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu); - if (*m > 1) { - i__1 = *m - 1; - i__2 = *n - *l; - dlacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] -, ldu); - } -/* Computing MIN */ - i__2 = *m, i__3 = *n - *l; - i__1 = std::min(i__2,i__3); - dorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); - } - - if (wantq) { - -/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ - - i__1 = *n - *l; - dlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); - } - -/* Clean up A: set the strictly lower triangular part of */ -/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ - - i__1 = *k - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L90: */ - } -/* L100: */ - } - if (*m > *k) { - i__1 = *m - *k; - i__2 = *n - *l; - dlaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1], - lda); - } - - if (*n - *l > *k) { - -/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ - - i__1 = *n - *l; - dgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); - - if (wantq) { - -/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */ - - i__1 = *n - *l; - dormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, & - tau[1], &q[q_offset], ldq, &work[1], info); - } - -/* Clean up A */ - - i__1 = *n - *l - *k; - dlaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda); - i__1 = *n - *l; - for (j = *n - *l - *k + 1; j <= i__1; ++j) { - i__2 = *k; - for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L110: */ - } -/* L120: */ - } - - } - - if (*m > *k) { - -/* QR factorization of A( K+1:M,N-L+1:N ) */ - - i__1 = *m - *k; - dgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & - work[1], info); - - if (wantu) { - -/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ - - i__1 = *m - *k; -/* Computing MIN */ - i__3 = *m - *k; - i__2 = std::min(i__3,*l); - dorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n - - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + - 1], ldu, &work[1], info); - } - -/* Clean up */ - - i__1 = *n; - for (j = *n - *l + 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L130: */ - } -/* L140: */ - } - - } - - return 0; - -/* End of DGGSVP */ - -} /* dggsvp_ */ diff --git a/external/clapack/lapack/dgtcon.cpp b/external/clapack/lapack/dgtcon.cpp deleted file mode 100644 index 284f2490..00000000 --- a/external/clapack/lapack/dgtcon.cpp +++ /dev/null @@ -1,189 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgtcon_(const char *norm, integer *n, double *dl, - double *d__, double *du, double *du2, integer *ipiv, - double *anorm, double *rcond, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, kase, kase1; - integer isave[3]; - double ainvnm; - bool onenrm; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGTCON estimates the reciprocal of the condition number of a real */ -/* tridiagonal matrix A using the LU factorization as computed by */ -/* DGTTRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) multipliers that define the matrix L from the */ -/* LU factorization of A as computed by DGTTRF. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the upper triangular matrix U from */ -/* the LU factorization of A. */ - -/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) elements of the first superdiagonal of U. */ - -/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */ -/* The (n-2) elements of the second superdiagonal of U. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ -/* interchanged with row IPIV(i). IPIV(i) will always be either */ -/* i or i+1; IPIV(i) = i indicates a row interchange was not */ -/* required. */ - -/* ANORM (input) DOUBLE PRECISION */ -/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ -/* If NORM = 'I', the infinity-norm of the original matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ -/* estimate of the 1-norm of inv(A) computed in this routine. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments. */ - - /* Parameter adjustments */ - --iwork; - --work; - --ipiv; - --du2; - --du; - --d__; - --dl; - - /* Function Body */ - *info = 0; - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); - if (! onenrm && ! lsame_(norm, "I")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*anorm < 0.) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGTCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - -/* Check that D(1:N) is non-zero. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] == 0.) { - return 0; - } -/* L10: */ - } - - ainvnm = 0.; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kase = 0; -L20: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(U)*inv(L). */ - - dgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1] -, &ipiv[1], &work[1], n, info); - } else { - -/* Multiply by inv(L')*inv(U'). */ - - dgttrs_("Transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1], & - ipiv[1], &work[1], n, info); - } - goto L20; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - - return 0; - -/* End of DGTCON */ - -} /* dgtcon_ */ diff --git a/external/clapack/lapack/dgtrfs.cpp b/external/clapack/lapack/dgtrfs.cpp deleted file mode 100644 index f4078910..00000000 --- a/external/clapack/lapack/dgtrfs.cpp +++ /dev/null @@ -1,425 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b18 = -1.; -static double c_b19 = 1.; - -/* Subroutine */ int dgtrfs_(const char *trans, integer *n, integer *nrhs, - double *dl, double *d__, double *du, double *dlf, - double *df, double *duf, double *du2, integer *ipiv, - double *b, integer *ldb, double *x, integer *ldx, double * - ferr, double *berr, double *work, integer *iwork, integer * - info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer i__, j; - double s; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - integer count; - double safmin; - bool notran; - char transn[1]; - char transt[1]; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGTRFS improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is tridiagonal, and provides */ -/* error bounds and backward error estimates for the solution. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of A. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of A. */ - -/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) superdiagonal elements of A. */ - -/* DLF (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) multipliers that define the matrix L from the */ -/* LU factorization of A as computed by DGTTRF. */ - -/* DF (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the upper triangular matrix U from */ -/* the LU factorization of A. */ - -/* DUF (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) elements of the first superdiagonal of U. */ - -/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */ -/* The (n-2) elements of the second superdiagonal of U. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ -/* interchanged with row IPIV(i). IPIV(i) will always be either */ -/* i or i+1; IPIV(i) = i indicates a row interchange was not */ -/* required. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DGTTRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --dl; - --d__; - --du; - --dlf; - --df; - --duf; - --du2; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T") && ! lsame_( - trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -13; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -15; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGTRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - - if (notran) { - *(unsigned char *)transn = 'N'; - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transn = 'T'; - *(unsigned char *)transt = 'N'; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = 4; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - op(A) * X, */ -/* where op(A) = A, A**T, or A**H, depending on TRANS. */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dlagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j * - x_dim1 + 1], ldx, &c_b19, &work[*n + 1], n); - -/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward */ -/* error bound. */ - - if (notran) { - if (*n == 1) { - work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ - 1] * x[j * x_dim1 + 1], abs(d__2)); - } else { - work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ - 1] * x[j * x_dim1 + 1], abs(d__2)) + (d__3 = du[1] * - x[j * x_dim1 + 2], abs(d__3)); - i__2 = *n - 1; - for (i__ = 2; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)) + ( - d__2 = dl[i__ - 1] * x[i__ - 1 + j * x_dim1], abs( - d__2)) + (d__3 = d__[i__] * x[i__ + j * x_dim1], - abs(d__3)) + (d__4 = du[i__] * x[i__ + 1 + j * - x_dim1], abs(d__4)); -/* L30: */ - } - work[*n] = (d__1 = b[*n + j * b_dim1], abs(d__1)) + (d__2 = - dl[*n - 1] * x[*n - 1 + j * x_dim1], abs(d__2)) + ( - d__3 = d__[*n] * x[*n + j * x_dim1], abs(d__3)); - } - } else { - if (*n == 1) { - work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ - 1] * x[j * x_dim1 + 1], abs(d__2)); - } else { - work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ - 1] * x[j * x_dim1 + 1], abs(d__2)) + (d__3 = dl[1] * - x[j * x_dim1 + 2], abs(d__3)); - i__2 = *n - 1; - for (i__ = 2; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)) + ( - d__2 = du[i__ - 1] * x[i__ - 1 + j * x_dim1], abs( - d__2)) + (d__3 = d__[i__] * x[i__ + j * x_dim1], - abs(d__3)) + (d__4 = dl[i__] * x[i__ + 1 + j * - x_dim1], abs(d__4)); -/* L40: */ - } - work[*n] = (d__1 = b[*n + j * b_dim1], abs(d__1)) + (d__2 = - du[*n - 1] * x[*n - 1 + j * x_dim1], abs(d__2)) + ( - d__3 = d__[*n] * x[*n + j * x_dim1], abs(d__3)); - } - } - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L50: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[ - 1], &work[*n + 1], n, info); - daxpy_(n, &c_b19, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(op(A)))* */ -/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(op(A)) is the inverse of op(A) */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(op(A)) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L60: */ - } - - kase = 0; -L70: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(op(A)**T). */ - - dgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], & - ipiv[1], &work[*n + 1], n, info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L80: */ - } - } else { - -/* Multiply by inv(op(A))*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L90: */ - } - dgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], & - ipiv[1], &work[*n + 1], n, info); - } - goto L70; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L100: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L110: */ - } - - return 0; - -/* End of DGTRFS */ - -} /* dgtrfs_ */ diff --git a/external/clapack/lapack/dgtsv.cpp b/external/clapack/lapack/dgtsv.cpp deleted file mode 100644 index cef2d3c2..00000000 --- a/external/clapack/lapack/dgtsv.cpp +++ /dev/null @@ -1,302 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgtsv_(integer *n, integer *nrhs, double *dl, - double *d__, double *du, double *b, integer *ldb, integer - *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double fact, temp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGTSV solves the equation */ - -/* A*X = B, */ - -/* where A is an n by n tridiagonal matrix, by Gaussian elimination with */ -/* partial pivoting. */ - -/* Note that the equation A'*X = B may be solved by interchanging the */ -/* order of the arguments DU and DL. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* DL (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, DL must contain the (n-1) sub-diagonal elements of */ -/* A. */ - -/* On exit, DL is overwritten by the (n-2) elements of the */ -/* second super-diagonal of the upper triangular matrix U from */ -/* the LU factorization of A, in DL(1), ..., DL(n-2). */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, D must contain the diagonal elements of A. */ - -/* On exit, D is overwritten by the n diagonal elements of U. */ - -/* DU (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, DU must contain the (n-1) super-diagonal elements */ -/* of A. */ - -/* On exit, DU is overwritten by the (n-1) elements of the first */ -/* super-diagonal of U. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N by NRHS matrix of right hand side matrix B. */ -/* On exit, if INFO = 0, the N by NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, U(i,i) is exactly zero, and the solution */ -/* has not been computed. The factorization has not been */ -/* completed unless i = N. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --dl; - --d__; - --du; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*nrhs < 0) { - *info = -2; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGTSV ", &i__1); - return 0; - } - - if (*n == 0) { - return 0; - } - - if (*nrhs == 1) { - i__1 = *n - 2; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { - -/* No row interchange required */ - - if (d__[i__] != 0.) { - fact = dl[i__] / d__[i__]; - d__[i__ + 1] -= fact * du[i__]; - b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1]; - } else { - *info = i__; - return 0; - } - dl[i__] = 0.; - } else { - -/* Interchange rows I and I+1 */ - - fact = d__[i__] / dl[i__]; - d__[i__] = dl[i__]; - temp = d__[i__ + 1]; - d__[i__ + 1] = du[i__] - fact * temp; - dl[i__] = du[i__ + 1]; - du[i__ + 1] = -fact * dl[i__]; - du[i__] = temp; - temp = b[i__ + b_dim1]; - b[i__ + b_dim1] = b[i__ + 1 + b_dim1]; - b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1]; - } -/* L10: */ - } - if (*n > 1) { - i__ = *n - 1; - if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { - if (d__[i__] != 0.) { - fact = dl[i__] / d__[i__]; - d__[i__ + 1] -= fact * du[i__]; - b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1]; - } else { - *info = i__; - return 0; - } - } else { - fact = d__[i__] / dl[i__]; - d__[i__] = dl[i__]; - temp = d__[i__ + 1]; - d__[i__ + 1] = du[i__] - fact * temp; - du[i__] = temp; - temp = b[i__ + b_dim1]; - b[i__ + b_dim1] = b[i__ + 1 + b_dim1]; - b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1]; - } - } - if (d__[*n] == 0.) { - *info = *n; - return 0; - } - } else { - i__1 = *n - 2; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { - -/* No row interchange required */ - - if (d__[i__] != 0.) { - fact = dl[i__] / d__[i__]; - d__[i__ + 1] -= fact * du[i__]; - i__2 = *nrhs; - for (j = 1; j <= i__2; ++j) { - b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1]; -/* L20: */ - } - } else { - *info = i__; - return 0; - } - dl[i__] = 0.; - } else { - -/* Interchange rows I and I+1 */ - - fact = d__[i__] / dl[i__]; - d__[i__] = dl[i__]; - temp = d__[i__ + 1]; - d__[i__ + 1] = du[i__] - fact * temp; - dl[i__] = du[i__ + 1]; - du[i__ + 1] = -fact * dl[i__]; - du[i__] = temp; - i__2 = *nrhs; - for (j = 1; j <= i__2; ++j) { - temp = b[i__ + j * b_dim1]; - b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; - b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j * - b_dim1]; -/* L30: */ - } - } -/* L40: */ - } - if (*n > 1) { - i__ = *n - 1; - if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { - if (d__[i__] != 0.) { - fact = dl[i__] / d__[i__]; - d__[i__ + 1] -= fact * du[i__]; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1]; -/* L50: */ - } - } else { - *info = i__; - return 0; - } - } else { - fact = d__[i__] / dl[i__]; - d__[i__] = dl[i__]; - temp = d__[i__ + 1]; - d__[i__ + 1] = du[i__] - fact * temp; - du[i__] = temp; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - temp = b[i__ + j * b_dim1]; - b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; - b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j * - b_dim1]; -/* L60: */ - } - } - } - if (d__[*n] == 0.) { - *info = *n; - return 0; - } - } - -/* Back solve with the matrix U from the factorization. */ - - if (*nrhs <= 2) { - j = 1; -L70: - b[*n + j * b_dim1] /= d__[*n]; - if (*n > 1) { - b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] * b[ - *n + j * b_dim1]) / d__[*n - 1]; - } - for (i__ = *n - 2; i__ >= 1; --i__) { - b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + 1 - + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1]) / d__[ - i__]; -/* L80: */ - } - if (j < *nrhs) { - ++j; - goto L70; - } - } else { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - b[*n + j * b_dim1] /= d__[*n]; - if (*n > 1) { - b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] - * b[*n + j * b_dim1]) / d__[*n - 1]; - } - for (i__ = *n - 2; i__ >= 1; --i__) { - b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ - + 1 + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1]) - / d__[i__]; -/* L90: */ - } -/* L100: */ - } - } - - return 0; - -/* End of DGTSV */ - -} /* dgtsv_ */ diff --git a/external/clapack/lapack/dgtsvx.cpp b/external/clapack/lapack/dgtsvx.cpp deleted file mode 100644 index 2f457d8f..00000000 --- a/external/clapack/lapack/dgtsvx.cpp +++ /dev/null @@ -1,318 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgtsvx_(const char *fact, const char *trans, integer *n, integer * - nrhs, double *dl, double *d__, double *du, double * - dlf, double *df, double *duf, double *du2, integer *ipiv, - double *b, integer *ldb, double *x, integer *ldx, double * - rcond, double *ferr, double *berr, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1; - - /* Local variables */ - char norm[1]; - double anorm; - bool nofact; - bool notran; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGTSVX uses the LU factorization to compute the solution to a real */ -/* system of linear equations A * X = B or A**T * X = B, */ -/* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */ -/* matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */ -/* as A = L * U, where L is a product of permutation and unit lower */ -/* bidiagonal matrices and U is upper triangular with nonzeros in */ -/* only the main diagonal and first two superdiagonals. */ - -/* 2. If some U(i,i)=0, so that U is exactly singular, then the routine */ -/* returns with INFO = i. Otherwise, the factored form of A is used */ -/* to estimate the condition number of the matrix A. If the */ -/* reciprocal of the condition number is less than machine precision, */ -/* INFO = N+1 is returned as a warning, but the routine still goes on */ -/* to solve for X and compute error bounds as described below. */ - -/* 3. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 4. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of A has been */ -/* supplied on entry. */ -/* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored */ -/* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV */ -/* will not be modified. */ -/* = 'N': The matrix will be copied to DLF, DF, and DUF */ -/* and factored. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of A. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of A. */ - -/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) superdiagonal elements of A. */ - -/* DLF (input or output) DOUBLE PRECISION array, dimension (N-1) */ -/* If FACT = 'F', then DLF is an input argument and on entry */ -/* contains the (n-1) multipliers that define the matrix L from */ -/* the LU factorization of A as computed by DGTTRF. */ - -/* If FACT = 'N', then DLF is an output argument and on exit */ -/* contains the (n-1) multipliers that define the matrix L from */ -/* the LU factorization of A. */ - -/* DF (input or output) DOUBLE PRECISION array, dimension (N) */ -/* If FACT = 'F', then DF is an input argument and on entry */ -/* contains the n diagonal elements of the upper triangular */ -/* matrix U from the LU factorization of A. */ - -/* If FACT = 'N', then DF is an output argument and on exit */ -/* contains the n diagonal elements of the upper triangular */ -/* matrix U from the LU factorization of A. */ - -/* DUF (input or output) DOUBLE PRECISION array, dimension (N-1) */ -/* If FACT = 'F', then DUF is an input argument and on entry */ -/* contains the (n-1) elements of the first superdiagonal of U. */ - -/* If FACT = 'N', then DUF is an output argument and on exit */ -/* contains the (n-1) elements of the first superdiagonal of U. */ - -/* DU2 (input or output) DOUBLE PRECISION array, dimension (N-2) */ -/* If FACT = 'F', then DU2 is an input argument and on entry */ -/* contains the (n-2) elements of the second superdiagonal of */ -/* U. */ - -/* If FACT = 'N', then DU2 is an output argument and on exit */ -/* contains the (n-2) elements of the second superdiagonal of */ -/* U. */ - -/* IPIV (input or output) INTEGER array, dimension (N) */ -/* If FACT = 'F', then IPIV is an input argument and on entry */ -/* contains the pivot indices from the LU factorization of A as */ -/* computed by DGTTRF. */ - -/* If FACT = 'N', then IPIV is an output argument and on exit */ -/* contains the pivot indices from the LU factorization of A; */ -/* row i of the matrix was interchanged with row IPIV(i). */ -/* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */ -/* a row interchange was not required. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The N-by-NRHS right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The estimate of the reciprocal condition number of the matrix */ -/* A. If RCOND is less than the machine precision (in */ -/* particular, if RCOND = 0), the matrix is singular to working */ -/* precision. This condition is indicated by a return code of */ -/* INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= N: U(i,i) is exactly zero. The factorization */ -/* has not been completed unless i = N, but the */ -/* factor U is exactly singular, so the solution */ -/* and error bounds could not be computed. */ -/* RCOND = 0 is returned. */ -/* = N+1: U is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --dl; - --d__; - --du; - --dlf; - --df; - --duf; - --du2; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - notran = lsame_(trans, "N"); - if (! nofact && ! lsame_(fact, "F")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -14; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -16; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGTSVX", &i__1); - return 0; - } - - if (nofact) { - -/* Compute the LU factorization of A. */ - - dcopy_(n, &d__[1], &c__1, &df[1], &c__1); - if (*n > 1) { - i__1 = *n - 1; - dcopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1); - i__1 = *n - 1; - dcopy_(&i__1, &du[1], &c__1, &duf[1], &c__1); - } - dgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A. */ - - if (notran) { - *(unsigned char *)norm = '1'; - } else { - *(unsigned char *)norm = 'I'; - } - anorm = dlangt_(norm, n, &dl[1], &d__[1], &du[1]); - -/* Compute the reciprocal of the condition number of A. */ - - dgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm, - rcond, &work[1], &iwork[1], info); - -/* Compute the solution vectors X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[ - x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solutions and */ -/* compute error bounds and backward error estimates for them. */ - - dgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1], - &du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1] -, &berr[1], &work[1], &iwork[1], info); - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - - return 0; - -/* End of DGTSVX */ - -} /* dgtsvx_ */ diff --git a/external/clapack/lapack/dgttrf.cpp b/external/clapack/lapack/dgttrf.cpp deleted file mode 100644 index cd58a2ac..00000000 --- a/external/clapack/lapack/dgttrf.cpp +++ /dev/null @@ -1,190 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgttrf_(integer *n, double *dl, double *d__, - double *du, double *du2, integer *ipiv, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - integer i__; - double fact, temp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGTTRF computes an LU factorization of a real tridiagonal matrix A */ -/* using elimination with partial pivoting and row interchanges. */ - -/* The factorization has the form */ -/* A = L * U */ -/* where L is a product of permutation and unit lower bidiagonal */ -/* matrices and U is upper triangular with nonzeros in only the main */ -/* diagonal and first two superdiagonals. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* DL (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, DL must contain the (n-1) sub-diagonal elements of */ -/* A. */ - -/* On exit, DL is overwritten by the (n-1) multipliers that */ -/* define the matrix L from the LU factorization of A. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, D must contain the diagonal elements of A. */ - -/* On exit, D is overwritten by the n diagonal elements of the */ -/* upper triangular matrix U from the LU factorization of A. */ - -/* DU (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, DU must contain the (n-1) super-diagonal elements */ -/* of A. */ - -/* On exit, DU is overwritten by the (n-1) elements of the first */ -/* super-diagonal of U. */ - -/* DU2 (output) DOUBLE PRECISION array, dimension (N-2) */ -/* On exit, DU2 is overwritten by the (n-2) elements of the */ -/* second super-diagonal of U. */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ -/* interchanged with row IPIV(i). IPIV(i) will always be either */ -/* i or i+1; IPIV(i) = i indicates a row interchange was not */ -/* required. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly */ -/* singular, and division by zero will occur if it is used */ -/* to solve a system of equations. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --ipiv; - --du2; - --du; - --d__; - --dl; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - i__1 = -(*info); - xerbla_("DGTTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Initialize IPIV(i) = i and DU2(I) = 0 */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - ipiv[i__] = i__; -/* L10: */ - } - i__1 = *n - 2; - for (i__ = 1; i__ <= i__1; ++i__) { - du2[i__] = 0.; -/* L20: */ - } - - i__1 = *n - 2; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { - -/* No row interchange required, eliminate DL(I) */ - - if (d__[i__] != 0.) { - fact = dl[i__] / d__[i__]; - dl[i__] = fact; - d__[i__ + 1] -= fact * du[i__]; - } - } else { - -/* Interchange rows I and I+1, eliminate DL(I) */ - - fact = d__[i__] / dl[i__]; - d__[i__] = dl[i__]; - dl[i__] = fact; - temp = du[i__]; - du[i__] = d__[i__ + 1]; - d__[i__ + 1] = temp - fact * d__[i__ + 1]; - du2[i__] = du[i__ + 1]; - du[i__ + 1] = -fact * du[i__ + 1]; - ipiv[i__] = i__ + 1; - } -/* L30: */ - } - if (*n > 1) { - i__ = *n - 1; - if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { - if (d__[i__] != 0.) { - fact = dl[i__] / d__[i__]; - dl[i__] = fact; - d__[i__ + 1] -= fact * du[i__]; - } - } else { - fact = d__[i__] / dl[i__]; - d__[i__] = dl[i__]; - dl[i__] = fact; - temp = du[i__]; - du[i__] = d__[i__ + 1]; - d__[i__ + 1] = temp - fact * d__[i__ + 1]; - ipiv[i__] = i__ + 1; - } - } - -/* Check for a zero on the diagonal of U. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] == 0.) { - *info = i__; - goto L50; - } -/* L40: */ - } -L50: - - return 0; - -/* End of DGTTRF */ - -} /* dgttrf_ */ diff --git a/external/clapack/lapack/dgttrs.cpp b/external/clapack/lapack/dgttrs.cpp deleted file mode 100644 index 70d98119..00000000 --- a/external/clapack/lapack/dgttrs.cpp +++ /dev/null @@ -1,172 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dgttrs_(const char *trans, integer *n, integer *nrhs, - double *dl, double *d__, double *du, double *du2, - integer *ipiv, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer j, jb, nb; - integer itrans; - bool notran; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGTTRS solves one of the systems of equations */ -/* A*X = B or A'*X = B, */ -/* with a tridiagonal matrix A using the LU factorization computed */ -/* by DGTTRF. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations. */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A'* X = B (Transpose) */ -/* = 'C': A'* X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) multipliers that define the matrix L from the */ -/* LU factorization of A. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the upper triangular matrix U from */ -/* the LU factorization of A. */ - -/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) elements of the first super-diagonal of U. */ - -/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */ -/* The (n-2) elements of the second super-diagonal of U. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ -/* interchanged with row IPIV(i). IPIV(i) will always be either */ -/* i or i+1; IPIV(i) = i indicates a row interchange was not */ -/* required. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the matrix of right hand side vectors B. */ -/* On exit, B is overwritten by the solution vectors X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --dl; - --d__; - --du; - --du2; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - notran = *(unsigned char *)trans == 'N' || *(unsigned char *)trans == 'n'; - if (! notran && ! (*(unsigned char *)trans == 'T' || *(unsigned char *) - trans == 't') && ! (*(unsigned char *)trans == 'C' || *(unsigned - char *)trans == 'c')) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(*n,1_integer)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGTTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - -/* Decode TRANS */ - - if (notran) { - itrans = 0; - } else { - itrans = 1; - } - -/* Determine the number of right-hand sides to solve at a time. */ - - if (*nrhs == 1) { - nb = 1; - } else { -/* Computing MAX */ - i__1 = 1, i__2 = ilaenv_(&c__1, "DGTTRS", trans, n, nrhs, &c_n1, & - c_n1); - nb = std::max(i__1,i__2); - } - - if (nb >= *nrhs) { - dgtts2_(&itrans, n, nrhs, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[1], - &b[b_offset], ldb); - } else { - i__1 = *nrhs; - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nrhs - j + 1; - jb = std::min(i__3,nb); - dgtts2_(&itrans, n, &jb, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[ - 1], &b[j * b_dim1 + 1], ldb); -/* L10: */ - } - } - -/* End of DGTTRS */ - - return 0; -} /* dgttrs_ */ diff --git a/external/clapack/lapack/dgtts2.cpp b/external/clapack/lapack/dgtts2.cpp deleted file mode 100644 index cb61c3cd..00000000 --- a/external/clapack/lapack/dgtts2.cpp +++ /dev/null @@ -1,249 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dgtts2_(integer *itrans, integer *n, integer *nrhs, - double *dl, double *d__, double *du, double *du2, - integer *ipiv, double *b, integer *ldb) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ip; - double temp; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGTTS2 solves one of the systems of equations */ -/* A*X = B or A'*X = B, */ -/* with a tridiagonal matrix A using the LU factorization computed */ -/* by DGTTRF. */ - -/* Arguments */ -/* ========= */ - -/* ITRANS (input) INTEGER */ -/* Specifies the form of the system of equations. */ -/* = 0: A * X = B (No transpose) */ -/* = 1: A'* X = B (Transpose) */ -/* = 2: A'* X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) multipliers that define the matrix L from the */ -/* LU factorization of A. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the upper triangular matrix U from */ -/* the LU factorization of A. */ - -/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) elements of the first super-diagonal of U. */ - -/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */ -/* The (n-2) elements of the second super-diagonal of U. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ -/* interchanged with row IPIV(i). IPIV(i) will always be either */ -/* i or i+1; IPIV(i) = i indicates a row interchange was not */ -/* required. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the matrix of right hand side vectors B. */ -/* On exit, B is overwritten by the solution vectors X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - --dl; - --d__; - --du; - --du2; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (*itrans == 0) { - -/* Solve A*X = B using the LU factorization of A, */ -/* overwriting each right hand side vector with its solution. */ - - if (*nrhs <= 1) { - j = 1; -L10: - -/* Solve L*x = b. */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - ip = ipiv[i__]; - temp = b[i__ + 1 - ip + i__ + j * b_dim1] - dl[i__] * b[ip + - j * b_dim1]; - b[i__ + j * b_dim1] = b[ip + j * b_dim1]; - b[i__ + 1 + j * b_dim1] = temp; -/* L20: */ - } - -/* Solve U*x = b. */ - - b[*n + j * b_dim1] /= d__[*n]; - if (*n > 1) { - b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] - * b[*n + j * b_dim1]) / d__[*n - 1]; - } - for (i__ = *n - 2; i__ >= 1; --i__) { - b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ - + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j * b_dim1] - ) / d__[i__]; -/* L30: */ - } - if (j < *nrhs) { - ++j; - goto L10; - } - } else { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Solve L*x = b. */ - - i__2 = *n - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - if (ipiv[i__] == i__) { - b[i__ + 1 + j * b_dim1] -= dl[i__] * b[i__ + j * - b_dim1]; - } else { - temp = b[i__ + j * b_dim1]; - b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; - b[i__ + 1 + j * b_dim1] = temp - dl[i__] * b[i__ + j * - b_dim1]; - } -/* L40: */ - } - -/* Solve U*x = b. */ - - b[*n + j * b_dim1] /= d__[*n]; - if (*n > 1) { - b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - - 1] * b[*n + j * b_dim1]) / d__[*n - 1]; - } - for (i__ = *n - 2; i__ >= 1; --i__) { - b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[ - i__ + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j * - b_dim1]) / d__[i__]; -/* L50: */ - } -/* L60: */ - } - } - } else { - -/* Solve A' * X = B. */ - - if (*nrhs <= 1) { - -/* Solve U'*x = b. */ - - j = 1; -L70: - b[j * b_dim1 + 1] /= d__[1]; - if (*n > 1) { - b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j * b_dim1 - + 1]) / d__[2]; - } - i__1 = *n; - for (i__ = 3; i__ <= i__1; ++i__) { - b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] * b[ - i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ - 2 + j * - b_dim1]) / d__[i__]; -/* L80: */ - } - -/* Solve L'*x = b. */ - - for (i__ = *n - 1; i__ >= 1; --i__) { - ip = ipiv[i__]; - temp = b[i__ + j * b_dim1] - dl[i__] * b[i__ + 1 + j * b_dim1] - ; - b[i__ + j * b_dim1] = b[ip + j * b_dim1]; - b[ip + j * b_dim1] = temp; -/* L90: */ - } - if (j < *nrhs) { - ++j; - goto L70; - } - - } else { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Solve U'*x = b. */ - - b[j * b_dim1 + 1] /= d__[1]; - if (*n > 1) { - b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j * - b_dim1 + 1]) / d__[2]; - } - i__2 = *n; - for (i__ = 3; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] * - b[i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ - - 2 + j * b_dim1]) / d__[i__]; -/* L100: */ - } - for (i__ = *n - 1; i__ >= 1; --i__) { - if (ipiv[i__] == i__) { - b[i__ + j * b_dim1] -= dl[i__] * b[i__ + 1 + j * - b_dim1]; - } else { - temp = b[i__ + 1 + j * b_dim1]; - b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - dl[ - i__] * temp; - b[i__ + j * b_dim1] = temp; - } -/* L110: */ - } -/* L120: */ - } - } - } - -/* End of DGTTS2 */ - - return 0; -} /* dgtts2_ */ diff --git a/external/clapack/lapack/dhgeqz.cpp b/external/clapack/lapack/dhgeqz.cpp deleted file mode 100644 index 6c8dc858..00000000 --- a/external/clapack/lapack/dhgeqz.cpp +++ /dev/null @@ -1,1461 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b12 = 0.; -static double c_b13 = 1.; -static integer c__1 = 1; -static integer c__3 = 3; - -/* Subroutine */ int dhgeqz_(const char *job, const char *compq, const char *compz, integer *n, - integer *ilo, integer *ihi, double *h__, integer *ldh, double - *t, integer *ldt, double *alphar, double *alphai, double * - beta, double *q, integer *ldq, double *z__, integer *ldz, - double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1, - z_offset, i__1, i__2, i__3, i__4; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - double c__; - integer j; - double s, v[3], s1, s2, t1, u1, u2, a11, a12, a21, a22, b11, b22, c12, - c21; - integer jc; - double an, bn, cl, cq, cr; - integer in; - double u12, w11, w12, w21; - integer jr; - double cz, w22, sl, wi, sr, vs, wr, b1a, b2a, a1i, a2i, b1i, b2i, a1r, - a2r, b1r, b2r, wr2, ad11, ad12, ad21, ad22, c11i, c22i; - integer jch; - double c11r, c22r; - bool ilq; - double u12l, tau, sqi; - bool ilz; - double ulp, sqr, szi, szr, ad11l, ad12l, ad21l, ad22l, ad32l, wabs, - atol, btol, temp; - double temp2, s1inv, scale; - integer iiter, ilast, jiter; - double anorm, bnorm; - integer maxit; - double tempi, tempr; - bool ilazr2; - double ascale, bscale; - double safmin; - double safmax; - double eshift; - bool ilschr; - integer icompq, ilastm, ischur; - bool ilazro; - integer icompz, ifirst, ifrstm, istart; - bool ilpivt, lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), */ -/* where H is an upper Hessenberg matrix and T is upper triangular, */ -/* using the double-shift QZ method. */ -/* Matrix pairs of this type are produced by the reduction to */ -/* generalized upper Hessenberg form of a real matrix pair (A,B): */ - -/* A = Q1*H*Z1**T, B = Q1*T*Z1**T, */ - -/* as computed by DGGHRD. */ - -/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */ -/* also reduced to generalized Schur form, */ - -/* H = Q*S*Z**T, T = Q*P*Z**T, */ - -/* where Q and Z are orthogonal matrices, P is an upper triangular */ -/* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 */ -/* diagonal blocks. */ - -/* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair */ -/* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of */ -/* eigenvalues. */ - -/* Additionally, the 2-by-2 upper triangular diagonal blocks of P */ -/* corresponding to 2-by-2 blocks of S are reduced to positive diagonal */ -/* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, */ -/* P(j,j) > 0, and P(j+1,j+1) > 0. */ - -/* Optionally, the orthogonal matrix Q from the generalized Schur */ -/* factorization may be postmultiplied into an input matrix Q1, and the */ -/* orthogonal matrix Z may be postmultiplied into an input matrix Z1. */ -/* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced */ -/* the matrix pair (A,B) to generalized upper Hessenberg form, then the */ -/* output matrices Q1*Q and Z1*Z are the orthogonal factors from the */ -/* generalized Schur factorization of (A,B): */ - -/* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. */ - -/* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, */ -/* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is */ -/* complex and beta real. */ -/* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the */ -/* generalized nonsymmetric eigenvalue problem (GNEP) */ -/* A*x = lambda*B*x */ -/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */ -/* alternate form of the GNEP */ -/* mu*A*y = B*y. */ -/* Real eigenvalues can be read directly from the generalized Schur */ -/* form: */ -/* alpha = S(i,i), beta = P(i,i). */ - -/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */ -/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */ -/* pp. 241--256. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* = 'E': Compute eigenvalues only; */ -/* = 'S': Compute eigenvalues and the Schur form. */ - -/* COMPQ (input) CHARACTER*1 */ -/* = 'N': Left Schur vectors (Q) are not computed; */ -/* = 'I': Q is initialized to the unit matrix and the matrix Q */ -/* of left Schur vectors of (H,T) is returned; */ -/* = 'V': Q must contain an orthogonal matrix Q1 on entry and */ -/* the product Q1*Q is returned. */ - -/* COMPZ (input) CHARACTER*1 */ -/* = 'N': Right Schur vectors (Z) are not computed; */ -/* = 'I': Z is initialized to the unit matrix and the matrix Z */ -/* of right Schur vectors of (H,T) is returned; */ -/* = 'V': Z must contain an orthogonal matrix Z1 on entry and */ -/* the product Z1*Z is returned. */ - -/* N (input) INTEGER */ -/* The order of the matrices H, T, Q, and Z. N >= 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* ILO and IHI mark the rows and columns of H which are in */ -/* Hessenberg form. It is assumed that A is already upper */ -/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */ -/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */ - -/* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) */ -/* On entry, the N-by-N upper Hessenberg matrix H. */ -/* On exit, if JOB = 'S', H contains the upper quasi-triangular */ -/* matrix S from the generalized Schur factorization; */ -/* 2-by-2 diagonal blocks (corresponding to complex conjugate */ -/* pairs of eigenvalues) are returned in standard form, with */ -/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. */ -/* If JOB = 'E', the diagonal blocks of H match those of S, but */ -/* the rest of H is unspecified. */ - -/* LDH (input) INTEGER */ -/* The leading dimension of the array H. LDH >= max( 1, N ). */ - -/* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) */ -/* On entry, the N-by-N upper triangular matrix T. */ -/* On exit, if JOB = 'S', T contains the upper triangular */ -/* matrix P from the generalized Schur factorization; */ -/* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S */ -/* are reduced to positive diagonal form, i.e., if H(j+1,j) is */ -/* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and */ -/* T(j+1,j+1) > 0. */ -/* If JOB = 'E', the diagonal blocks of T match those of P, but */ -/* the rest of T is unspecified. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= max( 1, N ). */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ -/* The real parts of each scalar alpha defining an eigenvalue */ -/* of GNEP. */ - -/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ -/* The imaginary parts of each scalar alpha defining an */ -/* eigenvalue of GNEP. */ -/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ -/* positive, then the j-th and (j+1)-st eigenvalues are a */ -/* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). */ - -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* The scalars beta that define the eigenvalues of GNEP. */ -/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ -/* beta = BETA(j) represent the j-th eigenvalue of the matrix */ -/* pair (A,B), in one of the forms lambda = alpha/beta or */ -/* mu = beta/alpha. Since either lambda or mu may overflow, */ -/* they should not, in general, be computed. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ -/* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in */ -/* the reduction of (A,B) to generalized Hessenberg form. */ -/* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur */ -/* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix */ -/* of left Schur vectors of (A,B). */ -/* Not referenced if COMPZ = 'N'. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= 1. */ -/* If COMPQ='V' or 'I', then LDQ >= N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in */ -/* the reduction of (A,B) to generalized Hessenberg form. */ -/* On exit, if COMPZ = 'I', the orthogonal matrix of */ -/* right Schur vectors of (H,T), and if COMPZ = 'V', the */ -/* orthogonal matrix of right Schur vectors of (A,B). */ -/* Not referenced if COMPZ = 'N'. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1. */ -/* If COMPZ='V' or 'I', then LDZ >= N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */ -/* in Schur form, but ALPHAR(i), ALPHAI(i), and */ -/* BETA(i), i=INFO+1,...,N should be correct. */ -/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */ -/* in Schur form, but ALPHAR(i), ALPHAI(i), and */ -/* BETA(i), i=INFO-N+1,...,N should be correct. */ - -/* Further Details */ -/* =============== */ - -/* Iteration counters: */ - -/* JITER -- counts iterations. */ -/* IITER -- counts iterations run since ILAST was last */ -/* changed. This is therefore reset only when a 1-by-1 or */ -/* 2-by-2 block deflates off the bottom. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* $ SAFETY = 1.0E+0 ) */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode JOB, COMPQ, COMPZ */ - - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - --alphar; - --alphai; - --beta; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - if (lsame_(job, "E")) { - ilschr = false; - ischur = 1; - } else if (lsame_(job, "S")) { - ilschr = true; - ischur = 2; - } else { - ischur = 0; - } - - if (lsame_(compq, "N")) { - ilq = false; - icompq = 1; - } else if (lsame_(compq, "V")) { - ilq = true; - icompq = 2; - } else if (lsame_(compq, "I")) { - ilq = true; - icompq = 3; - } else { - icompq = 0; - } - - if (lsame_(compz, "N")) { - ilz = false; - icompz = 1; - } else if (lsame_(compz, "V")) { - ilz = true; - icompz = 2; - } else if (lsame_(compz, "I")) { - ilz = true; - icompz = 3; - } else { - icompz = 0; - } - -/* Check Argument Values */ - - *info = 0; - work[1] = (double) std::max(1_integer,*n); - lquery = *lwork == -1; - if (ischur == 0) { - *info = -1; - } else if (icompq == 0) { - *info = -2; - } else if (icompz == 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*ilo < 1) { - *info = -5; - } else if (*ihi > *n || *ihi < *ilo - 1) { - *info = -6; - } else if (*ldh < *n) { - *info = -8; - } else if (*ldt < *n) { - *info = -10; - } else if (*ldq < 1 || ilq && *ldq < *n) { - *info = -15; - } else if (*ldz < 1 || ilz && *ldz < *n) { - *info = -17; - } else if (*lwork < std::max(1_integer,*n) && ! lquery) { - *info = -19; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DHGEQZ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - work[1] = 1.; - return 0; - } - -/* Initialize Q and Z */ - - if (icompq == 3) { - dlaset_("Full", n, n, &c_b12, &c_b13, &q[q_offset], ldq); - } - if (icompz == 3) { - dlaset_("Full", n, n, &c_b12, &c_b13, &z__[z_offset], ldz); - } - -/* Machine Constants */ - - in = *ihi + 1 - *ilo; - safmin = dlamch_("S"); - safmax = 1. / safmin; - ulp = dlamch_("E") * dlamch_("B"); - anorm = dlanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &work[1]); - bnorm = dlanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &work[1]); -/* Computing MAX */ - d__1 = safmin, d__2 = ulp * anorm; - atol = std::max(d__1,d__2); -/* Computing MAX */ - d__1 = safmin, d__2 = ulp * bnorm; - btol = std::max(d__1,d__2); - ascale = 1. / std::max(safmin,anorm); - bscale = 1. / std::max(safmin,bnorm); - -/* Set Eigenvalues IHI+1:N */ - - i__1 = *n; - for (j = *ihi + 1; j <= i__1; ++j) { - if (t[j + j * t_dim1] < 0.) { - if (ilschr) { - i__2 = j; - for (jr = 1; jr <= i__2; ++jr) { - h__[jr + j * h_dim1] = -h__[jr + j * h_dim1]; - t[jr + j * t_dim1] = -t[jr + j * t_dim1]; -/* L10: */ - } - } else { - h__[j + j * h_dim1] = -h__[j + j * h_dim1]; - t[j + j * t_dim1] = -t[j + j * t_dim1]; - } - if (ilz) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - z__[jr + j * z_dim1] = -z__[jr + j * z_dim1]; -/* L20: */ - } - } - } - alphar[j] = h__[j + j * h_dim1]; - alphai[j] = 0.; - beta[j] = t[j + j * t_dim1]; -/* L30: */ - } - -/* If IHI < ILO, skip QZ steps */ - - if (*ihi < *ilo) { - goto L380; - } - -/* MAIN QZ ITERATION LOOP */ - -/* Initialize dynamic indices */ - -/* Eigenvalues ILAST+1:N have been found. */ -/* Column operations modify rows IFRSTM:whatever. */ -/* Row operations modify columns whatever:ILASTM. */ - -/* If only eigenvalues are being computed, then */ -/* IFRSTM is the row of the last splitting row above row ILAST; */ -/* this is always at least ILO. */ -/* IITER counts iterations since the last eigenvalue was found, */ -/* to tell when to use an extraordinary shift. */ -/* MAXIT is the maximum number of QZ sweeps allowed. */ - - ilast = *ihi; - if (ilschr) { - ifrstm = 1; - ilastm = *n; - } else { - ifrstm = *ilo; - ilastm = *ihi; - } - iiter = 0; - eshift = 0.; - maxit = (*ihi - *ilo + 1) * 30; - - i__1 = maxit; - for (jiter = 1; jiter <= i__1; ++jiter) { - -/* Split the matrix if possible. */ - -/* Two tests: */ -/* 1: H(j,j-1)=0 or j=ILO */ -/* 2: T(j,j)=0 */ - - if (ilast == *ilo) { - -/* Special case: j=ILAST */ - - goto L80; - } else { - if ((d__1 = h__[ilast + (ilast - 1) * h_dim1], abs(d__1)) <= atol) - { - h__[ilast + (ilast - 1) * h_dim1] = 0.; - goto L80; - } - } - - if ((d__1 = t[ilast + ilast * t_dim1], abs(d__1)) <= btol) { - t[ilast + ilast * t_dim1] = 0.; - goto L70; - } - -/* General case: j= i__2; --j) { - -/* Test 1: for H(j,j-1)=0 or j=ILO */ - - if (j == *ilo) { - ilazro = true; - } else { - if ((d__1 = h__[j + (j - 1) * h_dim1], abs(d__1)) <= atol) { - h__[j + (j - 1) * h_dim1] = 0.; - ilazro = true; - } else { - ilazro = false; - } - } - -/* Test 2: for T(j,j)=0 */ - - if ((d__1 = t[j + j * t_dim1], abs(d__1)) < btol) { - t[j + j * t_dim1] = 0.; - -/* Test 1a: Check for 2 consecutive small subdiagonals in A */ - - ilazr2 = false; - if (! ilazro) { - temp = (d__1 = h__[j + (j - 1) * h_dim1], abs(d__1)); - temp2 = (d__1 = h__[j + j * h_dim1], abs(d__1)); - tempr = std::max(temp,temp2); - if (tempr < 1. && tempr != 0.) { - temp /= tempr; - temp2 /= tempr; - } - if (temp * (ascale * (d__1 = h__[j + 1 + j * h_dim1], abs( - d__1))) <= temp2 * (ascale * atol)) { - ilazr2 = true; - } - } - -/* If both tests pass (1 & 2), i.e., the leading diagonal */ -/* element of B in the block is zero, split a 1x1 block off */ -/* at the top. (I.e., at the J-th row/column) The leading */ -/* diagonal element of the remainder can also be zero, so */ -/* this may have to be done repeatedly. */ - - if (ilazro || ilazr2) { - i__3 = ilast - 1; - for (jch = j; jch <= i__3; ++jch) { - temp = h__[jch + jch * h_dim1]; - dlartg_(&temp, &h__[jch + 1 + jch * h_dim1], &c__, &s, - &h__[jch + jch * h_dim1]); - h__[jch + 1 + jch * h_dim1] = 0.; - i__4 = ilastm - jch; - drot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, & - h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__, - &s); - i__4 = ilastm - jch; - drot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[ - jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s); - if (ilq) { - drot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1) - * q_dim1 + 1], &c__1, &c__, &s); - } - if (ilazr2) { - h__[jch + (jch - 1) * h_dim1] *= c__; - } - ilazr2 = false; - if ((d__1 = t[jch + 1 + (jch + 1) * t_dim1], abs(d__1) - ) >= btol) { - if (jch + 1 >= ilast) { - goto L80; - } else { - ifirst = jch + 1; - goto L110; - } - } - t[jch + 1 + (jch + 1) * t_dim1] = 0.; -/* L40: */ - } - goto L70; - } else { - -/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */ -/* Then process as in the case T(ILAST,ILAST)=0 */ - - i__3 = ilast - 1; - for (jch = j; jch <= i__3; ++jch) { - temp = t[jch + (jch + 1) * t_dim1]; - dlartg_(&temp, &t[jch + 1 + (jch + 1) * t_dim1], &c__, - &s, &t[jch + (jch + 1) * t_dim1]); - t[jch + 1 + (jch + 1) * t_dim1] = 0.; - if (jch < ilastm - 1) { - i__4 = ilastm - jch - 1; - drot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, & - t[jch + 1 + (jch + 2) * t_dim1], ldt, & - c__, &s); - } - i__4 = ilastm - jch + 2; - drot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, & - h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__, - &s); - if (ilq) { - drot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1) - * q_dim1 + 1], &c__1, &c__, &s); - } - temp = h__[jch + 1 + jch * h_dim1]; - dlartg_(&temp, &h__[jch + 1 + (jch - 1) * h_dim1], & - c__, &s, &h__[jch + 1 + jch * h_dim1]); - h__[jch + 1 + (jch - 1) * h_dim1] = 0.; - i__4 = jch + 1 - ifrstm; - drot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[ - ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s) - ; - i__4 = jch - ifrstm; - drot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[ - ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s) - ; - if (ilz) { - drot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch - - 1) * z_dim1 + 1], &c__1, &c__, &s); - } -/* L50: */ - } - goto L70; - } - } else if (ilazro) { - -/* Only test 1 passed -- work on J:ILAST */ - - ifirst = j; - goto L110; - } - -/* Neither test passed -- try next J */ - -/* L60: */ - } - -/* (Drop-through is "impossible") */ - - *info = *n + 1; - goto L420; - -/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */ -/* 1x1 block. */ - -L70: - temp = h__[ilast + ilast * h_dim1]; - dlartg_(&temp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[ - ilast + ilast * h_dim1]); - h__[ilast + (ilast - 1) * h_dim1] = 0.; - i__2 = ilast - ifrstm; - drot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + ( - ilast - 1) * h_dim1], &c__1, &c__, &s); - i__2 = ilast - ifrstm; - drot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast - - 1) * t_dim1], &c__1, &c__, &s); - if (ilz) { - drot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) * - z_dim1 + 1], &c__1, &c__, &s); - } - -/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, */ -/* and BETA */ - -L80: - if (t[ilast + ilast * t_dim1] < 0.) { - if (ilschr) { - i__2 = ilast; - for (j = ifrstm; j <= i__2; ++j) { - h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1]; - t[j + ilast * t_dim1] = -t[j + ilast * t_dim1]; -/* L90: */ - } - } else { - h__[ilast + ilast * h_dim1] = -h__[ilast + ilast * h_dim1]; - t[ilast + ilast * t_dim1] = -t[ilast + ilast * t_dim1]; - } - if (ilz) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1]; -/* L100: */ - } - } - } - alphar[ilast] = h__[ilast + ilast * h_dim1]; - alphai[ilast] = 0.; - beta[ilast] = t[ilast + ilast * t_dim1]; - -/* Go to next block -- exit if finished. */ - - --ilast; - if (ilast < *ilo) { - goto L380; - } - -/* Reset counters */ - - iiter = 0; - eshift = 0.; - if (! ilschr) { - ilastm = ilast; - if (ifrstm > ilast) { - ifrstm = *ilo; - } - } - goto L350; - -/* QZ step */ - -/* This iteration only involves rows/columns IFIRST:ILAST. We */ -/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */ - -L110: - ++iiter; - if (! ilschr) { - ifrstm = ifirst; - } - -/* Compute single shifts. */ - -/* At this point, IFIRST < ILAST, and the diagonal elements of */ -/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */ -/* magnitude) */ - - if (iiter / 10 * 10 == iiter) { - -/* Exceptional shift. Chosen for no particularly good reason. */ -/* (Single shift only.) */ - - if ((double) maxit * safmin * (d__1 = h__[ilast - 1 + ilast * - h_dim1], abs(d__1)) < (d__2 = t[ilast - 1 + (ilast - 1) * - t_dim1], abs(d__2))) { - eshift += h__[ilast - 1 + ilast * h_dim1] / t[ilast - 1 + ( - ilast - 1) * t_dim1]; - } else { - eshift += 1. / (safmin * (double) maxit); - } - s1 = 1.; - wr = eshift; - - } else { - -/* Shifts based on the generalized eigenvalues of the */ -/* bottom-right 2x2 block of A and B. The first eigenvalue */ -/* returned by DLAG2 is the Wilkinson shift (AEP p.512), */ - - d__1 = safmin * 100.; - dlag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1 - + (ilast - 1) * t_dim1], ldt, &d__1, &s1, &s2, &wr, &wr2, - &wi); - -/* Computing MAX */ -/* Computing MAX */ - d__3 = 1., d__4 = abs(wr), d__3 = std::max(d__3,d__4), d__4 = abs(wi); - d__1 = s1, d__2 = safmin * std::max(d__3,d__4); - temp = std::max(d__1,d__2); - if (wi != 0.) { - goto L200; - } - } - -/* Fiddle with shift to avoid overflow */ - - temp = std::min(ascale,1.) * (safmax * .5); - if (s1 > temp) { - scale = temp / s1; - } else { - scale = 1.; - } - - temp = std::min(bscale,1.) * (safmax * .5); - if (abs(wr) > temp) { -/* Computing MIN */ - d__1 = scale, d__2 = temp / abs(wr); - scale = std::min(d__1,d__2); - } - s1 = scale * s1; - wr = scale * wr; - -/* Now check for two consecutive small subdiagonals. */ - - i__2 = ifirst + 1; - for (j = ilast - 1; j >= i__2; --j) { - istart = j; - temp = (d__1 = s1 * h__[j + (j - 1) * h_dim1], abs(d__1)); - temp2 = (d__1 = s1 * h__[j + j * h_dim1] - wr * t[j + j * t_dim1], - abs(d__1)); - tempr = std::max(temp,temp2); - if (tempr < 1. && tempr != 0.) { - temp /= tempr; - temp2 /= tempr; - } - if ((d__1 = ascale * h__[j + 1 + j * h_dim1] * temp, abs(d__1)) <= - ascale * atol * temp2) { - goto L130; - } -/* L120: */ - } - - istart = ifirst; -L130: - -/* Do an implicit single-shift QZ sweep. */ - -/* Initial Q */ - - temp = s1 * h__[istart + istart * h_dim1] - wr * t[istart + istart * - t_dim1]; - temp2 = s1 * h__[istart + 1 + istart * h_dim1]; - dlartg_(&temp, &temp2, &c__, &s, &tempr); - -/* Sweep */ - - i__2 = ilast - 1; - for (j = istart; j <= i__2; ++j) { - if (j > istart) { - temp = h__[j + (j - 1) * h_dim1]; - dlartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[ - j + (j - 1) * h_dim1]); - h__[j + 1 + (j - 1) * h_dim1] = 0.; - } - - i__3 = ilastm; - for (jc = j; jc <= i__3; ++jc) { - temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc * - h_dim1]; - h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ * - h__[j + 1 + jc * h_dim1]; - h__[j + jc * h_dim1] = temp; - temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1]; - t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j - + 1 + jc * t_dim1]; - t[j + jc * t_dim1] = temp2; -/* L140: */ - } - if (ilq) { - i__3 = *n; - for (jr = 1; jr <= i__3; ++jr) { - temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) * - q_dim1]; - q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ * - q[jr + (j + 1) * q_dim1]; - q[jr + j * q_dim1] = temp; -/* L150: */ - } - } - - temp = t[j + 1 + (j + 1) * t_dim1]; - dlartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j + - 1) * t_dim1]); - t[j + 1 + j * t_dim1] = 0.; - -/* Computing MIN */ - i__4 = j + 2; - i__3 = std::min(i__4,ilast); - for (jr = ifrstm; jr <= i__3; ++jr) { - temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j * - h_dim1]; - h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ * - h__[jr + j * h_dim1]; - h__[jr + (j + 1) * h_dim1] = temp; -/* L160: */ - } - i__3 = j; - for (jr = ifrstm; jr <= i__3; ++jr) { - temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1] - ; - t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[ - jr + j * t_dim1]; - t[jr + (j + 1) * t_dim1] = temp; -/* L170: */ - } - if (ilz) { - i__3 = *n; - for (jr = 1; jr <= i__3; ++jr) { - temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j * - z_dim1]; - z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] + - c__ * z__[jr + j * z_dim1]; - z__[jr + (j + 1) * z_dim1] = temp; -/* L180: */ - } - } -/* L190: */ - } - - goto L350; - -/* Use Francis double-shift */ - -/* Note: the Francis double-shift should work with real shifts, */ -/* but only if the block is at least 3x3. */ -/* This code may break if this point is reached with */ -/* a 2x2 block with real eigenvalues. */ - -L200: - if (ifirst + 1 == ilast) { - -/* Special case -- 2x2 block with complex eigenvectors */ - -/* Step 1: Standardize, that is, rotate so that */ - -/* ( B11 0 ) */ -/* B = ( ) with B11 non-negative. */ -/* ( 0 B22 ) */ - - dlasv2_(&t[ilast - 1 + (ilast - 1) * t_dim1], &t[ilast - 1 + - ilast * t_dim1], &t[ilast + ilast * t_dim1], &b22, &b11, & - sr, &cr, &sl, &cl); - - if (b11 < 0.) { - cr = -cr; - sr = -sr; - b11 = -b11; - b22 = -b22; - } - - i__2 = ilastm + 1 - ifirst; - drot_(&i__2, &h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &h__[ - ilast + (ilast - 1) * h_dim1], ldh, &cl, &sl); - i__2 = ilast + 1 - ifrstm; - drot_(&i__2, &h__[ifrstm + (ilast - 1) * h_dim1], &c__1, &h__[ - ifrstm + ilast * h_dim1], &c__1, &cr, &sr); - - if (ilast < ilastm) { - i__2 = ilastm - ilast; - drot_(&i__2, &t[ilast - 1 + (ilast + 1) * t_dim1], ldt, &t[ - ilast + (ilast + 1) * t_dim1], ldh, &cl, &sl); - } - if (ifrstm < ilast - 1) { - i__2 = ifirst - ifrstm; - drot_(&i__2, &t[ifrstm + (ilast - 1) * t_dim1], &c__1, &t[ - ifrstm + ilast * t_dim1], &c__1, &cr, &sr); - } - - if (ilq) { - drot_(n, &q[(ilast - 1) * q_dim1 + 1], &c__1, &q[ilast * - q_dim1 + 1], &c__1, &cl, &sl); - } - if (ilz) { - drot_(n, &z__[(ilast - 1) * z_dim1 + 1], &c__1, &z__[ilast * - z_dim1 + 1], &c__1, &cr, &sr); - } - - t[ilast - 1 + (ilast - 1) * t_dim1] = b11; - t[ilast - 1 + ilast * t_dim1] = 0.; - t[ilast + (ilast - 1) * t_dim1] = 0.; - t[ilast + ilast * t_dim1] = b22; - -/* If B22 is negative, negate column ILAST */ - - if (b22 < 0.) { - i__2 = ilast; - for (j = ifrstm; j <= i__2; ++j) { - h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1]; - t[j + ilast * t_dim1] = -t[j + ilast * t_dim1]; -/* L210: */ - } - - if (ilz) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1]; -/* L220: */ - } - } - } - -/* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.) */ - -/* Recompute shift */ - - d__1 = safmin * 100.; - dlag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1 - + (ilast - 1) * t_dim1], ldt, &d__1, &s1, &temp, &wr, & - temp2, &wi); - -/* If standardization has perturbed the shift onto real line, */ -/* do another (real single-shift) QR step. */ - - if (wi == 0.) { - goto L350; - } - s1inv = 1. / s1; - -/* Do EISPACK (QZVAL) computation of alpha and beta */ - - a11 = h__[ilast - 1 + (ilast - 1) * h_dim1]; - a21 = h__[ilast + (ilast - 1) * h_dim1]; - a12 = h__[ilast - 1 + ilast * h_dim1]; - a22 = h__[ilast + ilast * h_dim1]; - -/* Compute complex Givens rotation on right */ -/* (Assume some element of C = (sA - wB) > unfl ) */ -/* __ */ -/* (sA - wB) ( CZ -SZ ) */ -/* ( SZ CZ ) */ - - c11r = s1 * a11 - wr * b11; - c11i = -wi * b11; - c12 = s1 * a12; - c21 = s1 * a21; - c22r = s1 * a22 - wr * b22; - c22i = -wi * b22; - - if (abs(c11r) + abs(c11i) + abs(c12) > abs(c21) + abs(c22r) + abs( - c22i)) { - t1 = dlapy3_(&c12, &c11r, &c11i); - cz = c12 / t1; - szr = -c11r / t1; - szi = -c11i / t1; - } else { - cz = dlapy2_(&c22r, &c22i); - if (cz <= safmin) { - cz = 0.; - szr = 1.; - szi = 0.; - } else { - tempr = c22r / cz; - tempi = c22i / cz; - t1 = dlapy2_(&cz, &c21); - cz /= t1; - szr = -c21 * tempr / t1; - szi = c21 * tempi / t1; - } - } - -/* Compute Givens rotation on left */ - -/* ( CQ SQ ) */ -/* ( __ ) A or B */ -/* ( -SQ CQ ) */ - - an = abs(a11) + abs(a12) + abs(a21) + abs(a22); - bn = abs(b11) + abs(b22); - wabs = abs(wr) + abs(wi); - if (s1 * an > wabs * bn) { - cq = cz * b11; - sqr = szr * b22; - sqi = -szi * b22; - } else { - a1r = cz * a11 + szr * a12; - a1i = szi * a12; - a2r = cz * a21 + szr * a22; - a2i = szi * a22; - cq = dlapy2_(&a1r, &a1i); - if (cq <= safmin) { - cq = 0.; - sqr = 1.; - sqi = 0.; - } else { - tempr = a1r / cq; - tempi = a1i / cq; - sqr = tempr * a2r + tempi * a2i; - sqi = tempi * a2r - tempr * a2i; - } - } - t1 = dlapy3_(&cq, &sqr, &sqi); - cq /= t1; - sqr /= t1; - sqi /= t1; - -/* Compute diagonal elements of QBZ */ - - tempr = sqr * szr - sqi * szi; - tempi = sqr * szi + sqi * szr; - b1r = cq * cz * b11 + tempr * b22; - b1i = tempi * b22; - b1a = dlapy2_(&b1r, &b1i); - b2r = cq * cz * b22 + tempr * b11; - b2i = -tempi * b11; - b2a = dlapy2_(&b2r, &b2i); - -/* Normalize so beta > 0, and Im( alpha1 ) > 0 */ - - beta[ilast - 1] = b1a; - beta[ilast] = b2a; - alphar[ilast - 1] = wr * b1a * s1inv; - alphai[ilast - 1] = wi * b1a * s1inv; - alphar[ilast] = wr * b2a * s1inv; - alphai[ilast] = -(wi * b2a) * s1inv; - -/* Step 3: Go to next block -- exit if finished. */ - - ilast = ifirst - 1; - if (ilast < *ilo) { - goto L380; - } - -/* Reset counters */ - - iiter = 0; - eshift = 0.; - if (! ilschr) { - ilastm = ilast; - if (ifrstm > ilast) { - ifrstm = *ilo; - } - } - goto L350; - } else { - -/* Usual case: 3x3 or larger block, using Francis implicit */ -/* double-shift */ - -/* 2 */ -/* Eigenvalue equation is w - c w + d = 0, */ - -/* -1 2 -1 */ -/* so compute 1st column of (A B ) - c A B + d */ -/* using the formula in QZIT (from EISPACK) */ - -/* We assume that the block is at least 3x3 */ - - ad11 = ascale * h__[ilast - 1 + (ilast - 1) * h_dim1] / (bscale * - t[ilast - 1 + (ilast - 1) * t_dim1]); - ad21 = ascale * h__[ilast + (ilast - 1) * h_dim1] / (bscale * t[ - ilast - 1 + (ilast - 1) * t_dim1]); - ad12 = ascale * h__[ilast - 1 + ilast * h_dim1] / (bscale * t[ - ilast + ilast * t_dim1]); - ad22 = ascale * h__[ilast + ilast * h_dim1] / (bscale * t[ilast + - ilast * t_dim1]); - u12 = t[ilast - 1 + ilast * t_dim1] / t[ilast + ilast * t_dim1]; - ad11l = ascale * h__[ifirst + ifirst * h_dim1] / (bscale * t[ - ifirst + ifirst * t_dim1]); - ad21l = ascale * h__[ifirst + 1 + ifirst * h_dim1] / (bscale * t[ - ifirst + ifirst * t_dim1]); - ad12l = ascale * h__[ifirst + (ifirst + 1) * h_dim1] / (bscale * - t[ifirst + 1 + (ifirst + 1) * t_dim1]); - ad22l = ascale * h__[ifirst + 1 + (ifirst + 1) * h_dim1] / ( - bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]); - ad32l = ascale * h__[ifirst + 2 + (ifirst + 1) * h_dim1] / ( - bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]); - u12l = t[ifirst + (ifirst + 1) * t_dim1] / t[ifirst + 1 + (ifirst - + 1) * t_dim1]; - - v[0] = (ad11 - ad11l) * (ad22 - ad11l) - ad12 * ad21 + ad21 * u12 - * ad11l + (ad12l - ad11l * u12l) * ad21l; - v[1] = (ad22l - ad11l - ad21l * u12l - (ad11 - ad11l) - (ad22 - - ad11l) + ad21 * u12) * ad21l; - v[2] = ad32l * ad21l; - - istart = ifirst; - - dlarfg_(&c__3, v, &v[1], &c__1, &tau); - v[0] = 1.; - -/* Sweep */ - - i__2 = ilast - 2; - for (j = istart; j <= i__2; ++j) { - -/* All but last elements: use 3x3 Householder transforms. */ - -/* Zero (j-1)st column of A */ - - if (j > istart) { - v[0] = h__[j + (j - 1) * h_dim1]; - v[1] = h__[j + 1 + (j - 1) * h_dim1]; - v[2] = h__[j + 2 + (j - 1) * h_dim1]; - - dlarfg_(&c__3, &h__[j + (j - 1) * h_dim1], &v[1], &c__1, & - tau); - v[0] = 1.; - h__[j + 1 + (j - 1) * h_dim1] = 0.; - h__[j + 2 + (j - 1) * h_dim1] = 0.; - } - - i__3 = ilastm; - for (jc = j; jc <= i__3; ++jc) { - temp = tau * (h__[j + jc * h_dim1] + v[1] * h__[j + 1 + - jc * h_dim1] + v[2] * h__[j + 2 + jc * h_dim1]); - h__[j + jc * h_dim1] -= temp; - h__[j + 1 + jc * h_dim1] -= temp * v[1]; - h__[j + 2 + jc * h_dim1] -= temp * v[2]; - temp2 = tau * (t[j + jc * t_dim1] + v[1] * t[j + 1 + jc * - t_dim1] + v[2] * t[j + 2 + jc * t_dim1]); - t[j + jc * t_dim1] -= temp2; - t[j + 1 + jc * t_dim1] -= temp2 * v[1]; - t[j + 2 + jc * t_dim1] -= temp2 * v[2]; -/* L230: */ - } - if (ilq) { - i__3 = *n; - for (jr = 1; jr <= i__3; ++jr) { - temp = tau * (q[jr + j * q_dim1] + v[1] * q[jr + (j + - 1) * q_dim1] + v[2] * q[jr + (j + 2) * q_dim1] - ); - q[jr + j * q_dim1] -= temp; - q[jr + (j + 1) * q_dim1] -= temp * v[1]; - q[jr + (j + 2) * q_dim1] -= temp * v[2]; -/* L240: */ - } - } - -/* Zero j-th column of B (see DLAGBC for details) */ - -/* Swap rows to pivot */ - - ilpivt = false; -/* Computing MAX */ - d__3 = (d__1 = t[j + 1 + (j + 1) * t_dim1], abs(d__1)), d__4 = - (d__2 = t[j + 1 + (j + 2) * t_dim1], abs(d__2)); - temp = std::max(d__3,d__4); -/* Computing MAX */ - d__3 = (d__1 = t[j + 2 + (j + 1) * t_dim1], abs(d__1)), d__4 = - (d__2 = t[j + 2 + (j + 2) * t_dim1], abs(d__2)); - temp2 = std::max(d__3,d__4); - if (std::max(temp,temp2) < safmin) { - scale = 0.; - u1 = 1.; - u2 = 0.; - goto L250; - } else if (temp >= temp2) { - w11 = t[j + 1 + (j + 1) * t_dim1]; - w21 = t[j + 2 + (j + 1) * t_dim1]; - w12 = t[j + 1 + (j + 2) * t_dim1]; - w22 = t[j + 2 + (j + 2) * t_dim1]; - u1 = t[j + 1 + j * t_dim1]; - u2 = t[j + 2 + j * t_dim1]; - } else { - w21 = t[j + 1 + (j + 1) * t_dim1]; - w11 = t[j + 2 + (j + 1) * t_dim1]; - w22 = t[j + 1 + (j + 2) * t_dim1]; - w12 = t[j + 2 + (j + 2) * t_dim1]; - u2 = t[j + 1 + j * t_dim1]; - u1 = t[j + 2 + j * t_dim1]; - } - -/* Swap columns if nec. */ - - if (abs(w12) > abs(w11)) { - ilpivt = true; - temp = w12; - temp2 = w22; - w12 = w11; - w22 = w21; - w11 = temp; - w21 = temp2; - } - -/* LU-factor */ - - temp = w21 / w11; - u2 -= temp * u1; - w22 -= temp * w12; - w21 = 0.; - -/* Compute SCALE */ - - scale = 1.; - if (abs(w22) < safmin) { - scale = 0.; - u2 = 1.; - u1 = -w12 / w11; - goto L250; - } - if (abs(w22) < abs(u2)) { - scale = (d__1 = w22 / u2, abs(d__1)); - } - if (abs(w11) < abs(u1)) { -/* Computing MIN */ - d__2 = scale, d__3 = (d__1 = w11 / u1, abs(d__1)); - scale = std::min(d__2,d__3); - } - -/* Solve */ - - u2 = scale * u2 / w22; - u1 = (scale * u1 - w12 * u2) / w11; - -L250: - if (ilpivt) { - temp = u2; - u2 = u1; - u1 = temp; - } - -/* Compute Householder Vector */ - -/* Computing 2nd power */ - d__1 = scale; -/* Computing 2nd power */ - d__2 = u1; -/* Computing 2nd power */ - d__3 = u2; - t1 = sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); - tau = scale / t1 + 1.; - vs = -1. / (scale + t1); - v[0] = 1.; - v[1] = vs * u1; - v[2] = vs * u2; - -/* Apply transformations from the right. */ - -/* Computing MIN */ - i__4 = j + 3; - i__3 = std::min(i__4,ilast); - for (jr = ifrstm; jr <= i__3; ++jr) { - temp = tau * (h__[jr + j * h_dim1] + v[1] * h__[jr + (j + - 1) * h_dim1] + v[2] * h__[jr + (j + 2) * h_dim1]); - h__[jr + j * h_dim1] -= temp; - h__[jr + (j + 1) * h_dim1] -= temp * v[1]; - h__[jr + (j + 2) * h_dim1] -= temp * v[2]; -/* L260: */ - } - i__3 = j + 2; - for (jr = ifrstm; jr <= i__3; ++jr) { - temp = tau * (t[jr + j * t_dim1] + v[1] * t[jr + (j + 1) * - t_dim1] + v[2] * t[jr + (j + 2) * t_dim1]); - t[jr + j * t_dim1] -= temp; - t[jr + (j + 1) * t_dim1] -= temp * v[1]; - t[jr + (j + 2) * t_dim1] -= temp * v[2]; -/* L270: */ - } - if (ilz) { - i__3 = *n; - for (jr = 1; jr <= i__3; ++jr) { - temp = tau * (z__[jr + j * z_dim1] + v[1] * z__[jr + ( - j + 1) * z_dim1] + v[2] * z__[jr + (j + 2) * - z_dim1]); - z__[jr + j * z_dim1] -= temp; - z__[jr + (j + 1) * z_dim1] -= temp * v[1]; - z__[jr + (j + 2) * z_dim1] -= temp * v[2]; -/* L280: */ - } - } - t[j + 1 + j * t_dim1] = 0.; - t[j + 2 + j * t_dim1] = 0.; -/* L290: */ - } - -/* Last elements: Use Givens rotations */ - -/* Rotations from the left */ - - j = ilast - 1; - temp = h__[j + (j - 1) * h_dim1]; - dlartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[j + - (j - 1) * h_dim1]); - h__[j + 1 + (j - 1) * h_dim1] = 0.; - - i__2 = ilastm; - for (jc = j; jc <= i__2; ++jc) { - temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc * - h_dim1]; - h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ * - h__[j + 1 + jc * h_dim1]; - h__[j + jc * h_dim1] = temp; - temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1]; - t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j - + 1 + jc * t_dim1]; - t[j + jc * t_dim1] = temp2; -/* L300: */ - } - if (ilq) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) * - q_dim1]; - q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ * - q[jr + (j + 1) * q_dim1]; - q[jr + j * q_dim1] = temp; -/* L310: */ - } - } - -/* Rotations from the right. */ - - temp = t[j + 1 + (j + 1) * t_dim1]; - dlartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j + - 1) * t_dim1]); - t[j + 1 + j * t_dim1] = 0.; - - i__2 = ilast; - for (jr = ifrstm; jr <= i__2; ++jr) { - temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j * - h_dim1]; - h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ * - h__[jr + j * h_dim1]; - h__[jr + (j + 1) * h_dim1] = temp; -/* L320: */ - } - i__2 = ilast - 1; - for (jr = ifrstm; jr <= i__2; ++jr) { - temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1] - ; - t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[ - jr + j * t_dim1]; - t[jr + (j + 1) * t_dim1] = temp; -/* L330: */ - } - if (ilz) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j * - z_dim1]; - z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] + - c__ * z__[jr + j * z_dim1]; - z__[jr + (j + 1) * z_dim1] = temp; -/* L340: */ - } - } - -/* End of Double-Shift code */ - - } - - goto L350; - -/* End of iteration loop */ - -L350: -/* L360: */ - ; - } - -/* Drop-through = non-convergence */ - - *info = ilast; - goto L420; - -/* Successful completion of all QZ steps */ - -L380: - -/* Set Eigenvalues 1:ILO-1 */ - - i__1 = *ilo - 1; - for (j = 1; j <= i__1; ++j) { - if (t[j + j * t_dim1] < 0.) { - if (ilschr) { - i__2 = j; - for (jr = 1; jr <= i__2; ++jr) { - h__[jr + j * h_dim1] = -h__[jr + j * h_dim1]; - t[jr + j * t_dim1] = -t[jr + j * t_dim1]; -/* L390: */ - } - } else { - h__[j + j * h_dim1] = -h__[j + j * h_dim1]; - t[j + j * t_dim1] = -t[j + j * t_dim1]; - } - if (ilz) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - z__[jr + j * z_dim1] = -z__[jr + j * z_dim1]; -/* L400: */ - } - } - } - alphar[j] = h__[j + j * h_dim1]; - alphai[j] = 0.; - beta[j] = t[j + j * t_dim1]; -/* L410: */ - } - -/* Normal Termination */ - - *info = 0; - -/* Exit (other than argument error) -- return optimal workspace size */ - -L420: - work[1] = (double) (*n); - return 0; - -/* End of DHGEQZ */ - -} /* dhgeqz_ */ diff --git a/external/clapack/lapack/dhsein.cpp b/external/clapack/lapack/dhsein.cpp deleted file mode 100644 index 7ff68bea..00000000 --- a/external/clapack/lapack/dhsein.cpp +++ /dev/null @@ -1,470 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static bool c_false = false; -static bool c_true = true; - -/* Subroutine */ int dhsein_(const char *side, const char *eigsrc, const char *initv, bool * - select, integer *n, double *h__, integer *ldh, double *wr, - double *wi, double *vl, integer *ldvl, double *vr, - integer *ldvr, integer *mm, integer *m, double *work, integer * - ifaill, integer *ifailr, integer *info) -{ - /* System generated locals */ - integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, - i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, k, kl, kr, kln, ksi; - double wki; - integer ksr; - double ulp, wkr, eps3; - bool pair; - double unfl; - integer iinfo; - bool leftv, bothv; - double hnorm; - double bignum; - bool noinit; - integer ldwork; - bool rightv, fromqr; - double smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DHSEIN uses inverse iteration to find specified right and/or left */ -/* eigenvectors of a real upper Hessenberg matrix H. */ - -/* The right eigenvector x and the left eigenvector y of the matrix H */ -/* corresponding to an eigenvalue w are defined by: */ - -/* H * x = w * x, y**h * H = w * y**h */ - -/* where y**h denotes the conjugate transpose of the vector y. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'R': compute right eigenvectors only; */ -/* = 'L': compute left eigenvectors only; */ -/* = 'B': compute both right and left eigenvectors. */ - -/* EIGSRC (input) CHARACTER*1 */ -/* Specifies the source of eigenvalues supplied in (WR,WI): */ -/* = 'Q': the eigenvalues were found using DHSEQR; thus, if */ -/* H has zero subdiagonal elements, and so is */ -/* block-triangular, then the j-th eigenvalue can be */ -/* assumed to be an eigenvalue of the block containing */ -/* the j-th row/column. This property allows DHSEIN to */ -/* perform inverse iteration on just one diagonal block. */ -/* = 'N': no assumptions are made on the correspondence */ -/* between eigenvalues and diagonal blocks. In this */ -/* case, DHSEIN must always perform inverse iteration */ -/* using the whole matrix H. */ - -/* INITV (input) CHARACTER*1 */ -/* = 'N': no initial vectors are supplied; */ -/* = 'U': user-supplied initial vectors are stored in the arrays */ -/* VL and/or VR. */ - -/* SELECT (input/output) LOGICAL array, dimension (N) */ -/* Specifies the eigenvectors to be computed. To select the */ -/* real eigenvector corresponding to a real eigenvalue WR(j), */ -/* SELECT(j) must be set to .TRUE.. To select the complex */ -/* eigenvector corresponding to a complex eigenvalue */ -/* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)), */ -/* either SELECT(j) or SELECT(j+1) or both must be set to */ -/* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is */ -/* .FALSE.. */ - -/* N (input) INTEGER */ -/* The order of the matrix H. N >= 0. */ - -/* H (input) DOUBLE PRECISION array, dimension (LDH,N) */ -/* The upper Hessenberg matrix H. */ - -/* LDH (input) INTEGER */ -/* The leading dimension of the array H. LDH >= max(1,N). */ - -/* WR (input/output) DOUBLE PRECISION array, dimension (N) */ -/* WI (input) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the real and imaginary parts of the eigenvalues of */ -/* H; a complex conjugate pair of eigenvalues must be stored in */ -/* consecutive elements of WR and WI. */ -/* On exit, WR may have been altered since close eigenvalues */ -/* are perturbed slightly in searching for independent */ -/* eigenvectors. */ - -/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */ -/* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must */ -/* contain starting vectors for the inverse iteration for the */ -/* left eigenvectors; the starting vector for each eigenvector */ -/* must be in the same column(s) in which the eigenvector will */ -/* be stored. */ -/* On exit, if SIDE = 'L' or 'B', the left eigenvectors */ -/* specified by SELECT will be stored consecutively in the */ -/* columns of VL, in the same order as their eigenvalues. A */ -/* complex eigenvector corresponding to a complex eigenvalue is */ -/* stored in two consecutive columns, the first holding the real */ -/* part and the second the imaginary part. */ -/* If SIDE = 'R', VL is not referenced. */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the array VL. */ -/* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */ - -/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */ -/* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must */ -/* contain starting vectors for the inverse iteration for the */ -/* right eigenvectors; the starting vector for each eigenvector */ -/* must be in the same column(s) in which the eigenvector will */ -/* be stored. */ -/* On exit, if SIDE = 'R' or 'B', the right eigenvectors */ -/* specified by SELECT will be stored consecutively in the */ -/* columns of VR, in the same order as their eigenvalues. A */ -/* complex eigenvector corresponding to a complex eigenvalue is */ -/* stored in two consecutive columns, the first holding the real */ -/* part and the second the imaginary part. */ -/* If SIDE = 'L', VR is not referenced. */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the array VR. */ -/* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */ - -/* MM (input) INTEGER */ -/* The number of columns in the arrays VL and/or VR. MM >= M. */ - -/* M (output) INTEGER */ -/* The number of columns in the arrays VL and/or VR required to */ -/* store the eigenvectors; each selected real eigenvector */ -/* occupies one column and each selected complex eigenvector */ -/* occupies two columns. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N) */ - -/* IFAILL (output) INTEGER array, dimension (MM) */ -/* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left */ -/* eigenvector in the i-th column of VL (corresponding to the */ -/* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the */ -/* eigenvector converged satisfactorily. If the i-th and (i+1)th */ -/* columns of VL hold a complex eigenvector, then IFAILL(i) and */ -/* IFAILL(i+1) are set to the same value. */ -/* If SIDE = 'R', IFAILL is not referenced. */ - -/* IFAILR (output) INTEGER array, dimension (MM) */ -/* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right */ -/* eigenvector in the i-th column of VR (corresponding to the */ -/* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the */ -/* eigenvector converged satisfactorily. If the i-th and (i+1)th */ -/* columns of VR hold a complex eigenvector, then IFAILR(i) and */ -/* IFAILR(i+1) are set to the same value. */ -/* If SIDE = 'L', IFAILR is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, i is the number of eigenvectors which */ -/* failed to converge; see IFAILL and IFAILR for further */ -/* details. */ - -/* Further Details */ -/* =============== */ - -/* Each eigenvector is normalized so that the element of largest */ -/* magnitude has magnitude 1; here the magnitude of a complex number */ -/* (x,y) is taken to be |x|+|y|. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test the input parameters. */ - - /* Parameter adjustments */ - --select; - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - --wr; - --wi; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --work; - --ifaill; - --ifailr; - - /* Function Body */ - bothv = lsame_(side, "B"); - rightv = lsame_(side, "R") || bothv; - leftv = lsame_(side, "L") || bothv; - - fromqr = lsame_(eigsrc, "Q"); - - noinit = lsame_(initv, "N"); - -/* Set M to the number of columns required to store the selected */ -/* eigenvectors, and standardize the array SELECT. */ - - *m = 0; - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (pair) { - pair = false; - select[k] = false; - } else { - if (wi[k] == 0.) { - if (select[k]) { - ++(*m); - } - } else { - pair = true; - if (select[k] || select[k + 1]) { - select[k] = true; - *m += 2; - } - } - } -/* L10: */ - } - - *info = 0; - if (! rightv && ! leftv) { - *info = -1; - } else if (! fromqr && ! lsame_(eigsrc, "N")) { - *info = -2; - } else if (! noinit && ! lsame_(initv, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -5; - } else if (*ldh < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldvl < 1 || leftv && *ldvl < *n) { - *info = -11; - } else if (*ldvr < 1 || rightv && *ldvr < *n) { - *info = -13; - } else if (*mm < *m) { - *info = -14; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DHSEIN", &i__1); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - -/* Set machine-dependent constants. */ - - unfl = dlamch_("Safe minimum"); - ulp = dlamch_("Precision"); - smlnum = unfl * (*n / ulp); - bignum = (1. - ulp) / smlnum; - - ldwork = *n + 1; - - kl = 1; - kln = 0; - if (fromqr) { - kr = 0; - } else { - kr = *n; - } - ksr = 1; - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (select[k]) { - -/* Compute eigenvector(s) corresponding to W(K). */ - - if (fromqr) { - -/* If affiliation of eigenvalues is known, check whether */ -/* the matrix splits. */ - -/* Determine KL and KR such that 1 <= KL <= K <= KR <= N */ -/* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or */ -/* KR = N). */ - -/* Then inverse iteration can be performed with the */ -/* submatrix H(KL:N,KL:N) for a left eigenvector, and with */ -/* the submatrix H(1:KR,1:KR) for a right eigenvector. */ - - i__2 = kl + 1; - for (i__ = k; i__ >= i__2; --i__) { - if (h__[i__ + (i__ - 1) * h_dim1] == 0.) { - goto L30; - } -/* L20: */ - } -L30: - kl = i__; - if (k > kr) { - i__2 = *n - 1; - for (i__ = k; i__ <= i__2; ++i__) { - if (h__[i__ + 1 + i__ * h_dim1] == 0.) { - goto L50; - } -/* L40: */ - } -L50: - kr = i__; - } - } - - if (kl != kln) { - kln = kl; - -/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it */ -/* has not ben computed before. */ - - i__2 = kr - kl + 1; - hnorm = dlanhs_("I", &i__2, &h__[kl + kl * h_dim1], ldh, & - work[1]); - if (hnorm > 0.) { - eps3 = hnorm * ulp; - } else { - eps3 = smlnum; - } - } - -/* Perturb eigenvalue if it is close to any previous */ -/* selected eigenvalues affiliated to the submatrix */ -/* H(KL:KR,KL:KR). Close roots are modified by EPS3. */ - - wkr = wr[k]; - wki = wi[k]; -L60: - i__2 = kl; - for (i__ = k - 1; i__ >= i__2; --i__) { - if (select[i__] && (d__1 = wr[i__] - wkr, abs(d__1)) + (d__2 = - wi[i__] - wki, abs(d__2)) < eps3) { - wkr += eps3; - goto L60; - } -/* L70: */ - } - wr[k] = wkr; - - pair = wki != 0.; - if (pair) { - ksi = ksr + 1; - } else { - ksi = ksr; - } - if (leftv) { - -/* Compute left eigenvector. */ - - i__2 = *n - kl + 1; - dlaein_(&c_false, &noinit, &i__2, &h__[kl + kl * h_dim1], ldh, - &wkr, &wki, &vl[kl + ksr * vl_dim1], &vl[kl + ksi * - vl_dim1], &work[1], &ldwork, &work[*n * *n + *n + 1], - &eps3, &smlnum, &bignum, &iinfo); - if (iinfo > 0) { - if (pair) { - *info += 2; - } else { - ++(*info); - } - ifaill[ksr] = k; - ifaill[ksi] = k; - } else { - ifaill[ksr] = 0; - ifaill[ksi] = 0; - } - i__2 = kl - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - vl[i__ + ksr * vl_dim1] = 0.; -/* L80: */ - } - if (pair) { - i__2 = kl - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - vl[i__ + ksi * vl_dim1] = 0.; -/* L90: */ - } - } - } - if (rightv) { - -/* Compute right eigenvector. */ - - dlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wkr, & - wki, &vr[ksr * vr_dim1 + 1], &vr[ksi * vr_dim1 + 1], & - work[1], &ldwork, &work[*n * *n + *n + 1], &eps3, & - smlnum, &bignum, &iinfo); - if (iinfo > 0) { - if (pair) { - *info += 2; - } else { - ++(*info); - } - ifailr[ksr] = k; - ifailr[ksi] = k; - } else { - ifailr[ksr] = 0; - ifailr[ksi] = 0; - } - i__2 = *n; - for (i__ = kr + 1; i__ <= i__2; ++i__) { - vr[i__ + ksr * vr_dim1] = 0.; -/* L100: */ - } - if (pair) { - i__2 = *n; - for (i__ = kr + 1; i__ <= i__2; ++i__) { - vr[i__ + ksi * vr_dim1] = 0.; -/* L110: */ - } - } - } - - if (pair) { - ksr += 2; - } else { - ++ksr; - } - } -/* L120: */ - } - - return 0; - -/* End of DHSEIN */ - -} /* dhsein_ */ diff --git a/external/clapack/lapack/dhseqr.cpp b/external/clapack/lapack/dhseqr.cpp deleted file mode 100644 index 3ccd8a94..00000000 --- a/external/clapack/lapack/dhseqr.cpp +++ /dev/null @@ -1,458 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b11 = 0.; -static double c_b12 = 1.; -static integer c__12 = 12; -static integer c__2 = 2; -static integer c__49 = 49; - -int dhseqr_(const char *job, const char *compz, integer *n, integer *ilo, integer *ihi, double *h__, - integer *ldh, double *wr, double *wi, double *z__, integer *ldz, double *work, - integer *lwork, integer *info) -{ - /* System generated locals */ - char *a__1[2]; - integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3; - double d__1; - char ch__1[3]; - - /* Local variables */ - integer i__; - double hl[2401] /* was [49][49] */; - integer kbot, nmin; - bool initz; - double workl[49]; - bool wantt, wantz; - bool lquery; - - -/* -- LAPACK driver routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ -/* Purpose */ -/* ======= */ - -/* DHSEQR computes the eigenvalues of a Hessenberg matrix H */ -/* and, optionally, the matrices T and Z from the Schur decomposition */ -/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ -/* Schur form), and Z is the orthogonal matrix of Schur vectors. */ - -/* Optionally Z may be postmultiplied into an input orthogonal */ -/* matrix Q so that this routine can give the Schur factorization */ -/* of a matrix A which has been reduced to the Hessenberg form H */ -/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* = 'E': compute eigenvalues only; */ -/* = 'S': compute eigenvalues and the Schur form T. */ - -/* COMPZ (input) CHARACTER*1 */ -/* = 'N': no Schur vectors are computed; */ -/* = 'I': Z is initialized to the unit matrix and the matrix Z */ -/* of Schur vectors of H is returned; */ -/* = 'V': Z must contain an orthogonal matrix Q on entry, and */ -/* the product Q*Z is returned. */ - -/* N (input) INTEGER */ -/* The order of the matrix H. N .GE. 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* It is assumed that H is already upper triangular in rows */ -/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ -/* set by a previous call to DGEBAL, and then passed to DGEHRD */ -/* when the matrix output by DGEBAL is reduced to Hessenberg */ -/* form. Otherwise ILO and IHI should be set to 1 and N */ -/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ -/* If N = 0, then ILO = 1 and IHI = 0. */ - -/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ -/* On entry, the upper Hessenberg matrix H. */ -/* On exit, if INFO = 0 and JOB = 'S', then H contains the */ -/* upper quasi-triangular matrix T from the Schur decomposition */ -/* (the Schur form); 2-by-2 diagonal blocks (corresponding to */ -/* complex conjugate pairs of eigenvalues) are returned in */ -/* standard form, with H(i,i) = H(i+1,i+1) and */ -/* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the */ -/* contents of H are unspecified on exit. (The output value of */ -/* H when INFO.GT.0 is given under the description of INFO */ -/* below.) */ - -/* Unlike earlier versions of DHSEQR, this subroutine may */ -/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */ -/* or j = IHI+1, IHI+2, ... N. */ - -/* LDH (input) INTEGER */ -/* The leading dimension of the array H. LDH .GE. max(1,N). */ - -/* WR (output) DOUBLE PRECISION array, dimension (N) */ -/* WI (output) DOUBLE PRECISION array, dimension (N) */ -/* The real and imaginary parts, respectively, of the computed */ -/* eigenvalues. If two eigenvalues are computed as a complex */ -/* conjugate pair, they are stored in consecutive elements of */ -/* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and */ -/* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in */ -/* the same order as on the diagonal of the Schur form returned */ -/* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */ -/* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ -/* WI(i+1) = -WI(i). */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* If COMPZ = 'N', Z is not referenced. */ -/* If COMPZ = 'I', on entry Z need not be set and on exit, */ -/* if INFO = 0, Z contains the orthogonal matrix Z of the Schur */ -/* vectors of H. If COMPZ = 'V', on entry Z must contain an */ -/* N-by-N matrix Q, which is assumed to be equal to the unit */ -/* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */ -/* if INFO = 0, Z contains Q*Z. */ -/* Normally Q is the orthogonal matrix generated by DORGHR */ -/* after the call to DGEHRD which formed the Hessenberg matrix */ -/* H. (The output value of Z when INFO.GT.0 is given under */ -/* the description of INFO below.) */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. if COMPZ = 'I' or */ -/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ -/* On exit, if INFO = 0, WORK(1) returns an estimate of */ -/* the optimal value for LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK .GE. max(1,N) */ -/* is sufficient and delivers very good and sometimes */ -/* optimal performance. However, LWORK as large as 11*N */ -/* may be required for optimal performance. A workspace */ -/* query is recommended to determine the optimal workspace */ -/* size. */ - -/* If LWORK = -1, then DHSEQR does a workspace query. */ -/* In this case, DHSEQR checks the input parameters and */ -/* estimates the optimal workspace size for the given */ -/* values of N, ILO and IHI. The estimate is returned */ -/* in WORK(1). No error message related to LWORK is */ -/* issued by XERBLA. Neither H nor Z are accessed. */ - - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* .LT. 0: if INFO = -i, the i-th argument had an illegal */ -/* value */ -/* .GT. 0: if INFO = i, DHSEQR failed to compute all of */ -/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ -/* and WI contain those eigenvalues which have been */ -/* successfully computed. (Failures are rare.) */ - -/* If INFO .GT. 0 and JOB = 'E', then on exit, the */ -/* remaining unconverged eigenvalues are the eigen- */ -/* values of the upper Hessenberg matrix rows and */ -/* columns ILO through INFO of the final, output */ -/* value of H. */ - -/* If INFO .GT. 0 and JOB = 'S', then on exit */ - -/* (*) (initial value of H)*U = U*(final value of H) */ - -/* where U is an orthogonal matrix. The final */ -/* value of H is upper Hessenberg and quasi-triangular */ -/* in rows and columns INFO+1 through IHI. */ - -/* If INFO .GT. 0 and COMPZ = 'V', then on exit */ - -/* (final value of Z) = (initial value of Z)*U */ - -/* where U is the orthogonal matrix in (*) (regard- */ -/* less of the value of JOB.) */ - -/* If INFO .GT. 0 and COMPZ = 'I', then on exit */ -/* (final value of Z) = U */ -/* where U is the orthogonal matrix in (*) (regard- */ -/* less of the value of JOB.) */ - -/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */ -/* accessed. */ - -/* ================================================================ */ -/* Default values supplied by */ -/* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */ -/* It is suggested that these defaults be adjusted in order */ -/* to attain best performance in each particular */ -/* computational environment. */ - -/* ISPEC=12: The DLAHQR vs DLAQR0 crossover point. */ -/* Default: 75. (Must be at least 11.) */ - -/* ISPEC=13: Recommended deflation window size. */ -/* This depends on ILO, IHI and NS. NS is the */ -/* number of simultaneous shifts returned */ -/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */ -/* The default for (IHI-ILO+1).LE.500 is NS. */ -/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */ - -/* ISPEC=14: Nibble crossover point. (See IPARMQ for */ -/* details.) Default: 14% of deflation window */ -/* size. */ - -/* ISPEC=15: Number of simultaneous shifts in a multishift */ -/* QR iteration. */ - -/* If IHI-ILO+1 is ... */ - -/* greater than ...but less ... the */ -/* or equal to ... than default is */ - -/* 1 30 NS = 2(+) */ -/* 30 60 NS = 4(+) */ -/* 60 150 NS = 10(+) */ -/* 150 590 NS = ** */ -/* 590 3000 NS = 64 */ -/* 3000 6000 NS = 128 */ -/* 6000 infinity NS = 256 */ - -/* (+) By default some or all matrices of this order */ -/* are passed to the implicit double shift routine */ -/* DLAHQR and this parameter is ignored. See */ -/* ISPEC=12 above and comments in IPARMQ for */ -/* details. */ - -/* (**) The asterisks (**) indicate an ad-hoc */ -/* function of N increasing from 10 to 64. */ - -/* ISPEC=16: Select structured matrix multiply. */ -/* If the number of simultaneous shifts (specified */ -/* by ISPEC=15) is less than 14, then the default */ -/* for ISPEC=16 is 0. Otherwise the default for */ -/* ISPEC=16 is 2. */ - -/* ================================================================ */ -/* Based on contributions by */ -/* Karen Braman and Ralph Byers, Department of Mathematics, */ -/* University of Kansas, USA */ - -/* ================================================================ */ -/* References: */ -/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ -/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ -/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ -/* 929--947, 2002. */ - -/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ -/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ -/* of Matrix Analysis, volume 23, pages 948--973, 2002. */ - -/* ================================================================ */ -/* .. Parameters .. */ - -/* ==== Matrices of order NTINY or smaller must be processed by */ -/* . DLAHQR because of insufficient subdiagonal scratch space. */ -/* . (This is a hard limit.) ==== */ - -/* ==== NL allocates some local workspace to help small matrices */ -/* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is */ -/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */ -/* . mended. (The default value of NMIN is 75.) Using NL = 49 */ -/* . allows up to six simultaneous shifts and a 16-by-16 */ -/* . deflation window. ==== */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* ==== Decode and check the input parameters. ==== */ - - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - --wr; - --wi; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - wantt = lsame_(job, "S"); - initz = lsame_(compz, "I"); - wantz = initz || lsame_(compz, "V"); - work[1] = (double)std::max(1_integer,*n); - lquery = *lwork == -1; - - *info = 0; - if (! lsame_(job, "E") && ! wantt) { - *info = -1; - } else if (! lsame_(compz, "N") && ! wantz) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ilo < 1 || *ilo >std::max(1_integer,*n)) { - *info = -4; - } else if (*ihi *n) { - *info = -5; - } else if (*ldh (job); - i__2[1] = 1, a__1[1] = const_cast(compz); - s_cat(ch__1, a__1, i__2, &c__2, 2_integer); - ch__1 [2] = '\0'; - nmin = ilaenv_(&c__12, "DHSEQR", ch__1, n, ilo, ihi, lwork); - nmin =std::max(11_integer,nmin); - -/* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== */ - - if (*n > nmin) { - dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], - &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, - info); - } else { - -/* ==== Small matrix ==== */ - - dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], - &wi[1], ilo, ihi, &z__[z_offset], ldz, info); - - if (*info > 0) { - -/* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds */ -/* . when DLAHQR fails. ==== */ - - kbot = *info; - - if (*n >= 49) { - -/* ==== Larger matrices have enough subdiagonal scratch */ -/* . space to call DLAQR0 directly. ==== */ - - dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], - ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], - ldz, &work[1], lwork, info); - - } else { - -/* ==== Tiny matrices don't have enough subdiagonal */ -/* . scratch space to benefit from DLAQR0. Hence, */ -/* . tiny matrices must be copied into a larger */ -/* . array before calling DLAQR0. ==== */ - - dlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49); - hl[*n + 1 + *n * 49 - 50] = 0.; - i__1 = 49 - *n; - dlaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * - 49 - 49], &c__49); - dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, & - wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, - workl, &c__49, info); - if (wantt || *info != 0) { - dlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh); - } - } - } - } - -/* ==== Clear out the trash, if necessary. ==== */ - - if ((wantt || *info != 0) && *n > 2) { - i__1 = *n - 2; - i__3 = *n - 2; - dlaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh); - } - -/* ==== Ensure reported workspace size is backward-compatible with */ -/* . previous LAPACK versions. ==== */ - -/* Computing MAX */ - d__1 = (double)std::max(1_integer,*n); - work[1] =std::max(d__1,work[1]); - } - -/* ==== End of DHSEQR ==== */ - - return 0; -} /* dhseqr_ */ diff --git a/external/clapack/lapack/disnan.cpp b/external/clapack/lapack/disnan.cpp deleted file mode 100644 index 43d9f398..00000000 --- a/external/clapack/lapack/disnan.cpp +++ /dev/null @@ -1,38 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -bool disnan_(double *din) -{ - /* System generated locals */ - bool ret_val; - - /* Local variables */ - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DISNAN returns .TRUE. if its argument is NaN, and .FALSE. */ -/* otherwise. To be replaced by the Fortran 2003 intrinsic in the */ -/* future. */ - -/* Arguments */ -/* ========= */ - -/* DIN (input) DOUBLE PRECISION */ -/* Input to test for NaN. */ - -/* ===================================================================== */ - -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - ret_val = dlaisnan_(din, din); - return ret_val; -} /* disnan_ */ diff --git a/external/clapack/lapack/dla_gbrcond.cpp b/external/clapack/lapack/dla_gbrcond.cpp deleted file mode 100644 index 04bb3f50..00000000 --- a/external/clapack/lapack/dla_gbrcond.cpp +++ /dev/null @@ -1,326 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dla_gbrcond__(const char *trans, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, double *afb, integer *ldafb, - integer *ipiv, integer *cmode, double *c__, integer *info, - double *work, integer *iwork, integer trans_len) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; - double ret_val, d__1; - - /* Local variables */ - integer i__, j, kd, ke; - double tmp; - integer kase; - integer isave[3]; - double ainvnm; - bool notrans; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLA_GERCOND Estimates the Skeel condition number of op(A) * op2(C) */ -/* where op2 is determined by CMODE as follows */ -/* CMODE = 1 op2(C) = C */ -/* CMODE = 0 op2(C) = I */ -/* CMODE = -1 op2(C) = inv(C) */ -/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */ -/* is computed by computing scaling factors R such that */ -/* diag(R)*A*op2(C) is row equilibrated and computing the standard */ -/* infinity-norm condition number. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ -/* Details of the LU factorization of the band matrix A, as */ -/* computed by DGBTRF. U is stored as an upper triangular */ -/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ -/* and the multipliers used during the factorization are stored */ -/* in rows KL+KU+2 to 2*KL+KU+1. */ - -/* LDAFB (input) INTEGER */ -/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from the factorization A = P*L*U */ -/* as computed by DGBTRF; row i of the matrix was interchanged */ -/* with row IPIV(i). */ - -/* CMODE (input) INTEGER */ -/* Determines op2(C) in the formula op(A) * op2(C) as follows: */ -/* CMODE = 1 op2(C) = C */ -/* CMODE = 0 op2(C) = I */ -/* CMODE = -1 op2(C) = inv(C) */ - -/* C (input) DOUBLE PRECISION array, dimension (N) */ -/* The vector C in the formula op(A) * op2(C). */ - -/* INFO (output) INTEGER */ -/* = 0: Successful exit. */ -/* i > 0: The ith argument is invalid. */ - -/* WORK (input) DOUBLE PRECISION array, dimension (5*N). */ -/* Workspace. */ - -/* IWORK (input) INTEGER array, dimension (N). */ -/* Workspace. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - --ipiv; - --c__; - --work; - --iwork; - - /* Function Body */ - ret_val = 0.; - - *info = 0; - notrans = lsame_(trans, "N"); - if (! notrans && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0 || *kl > *n - 1) { - *info = -3; - } else if (*ku < 0 || *ku > *n - 1) { - *info = -4; - } else if (*ldab < *kl + *ku + 1) { - *info = -6; - } else if (*ldafb < (*kl << 1) + *ku + 1) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLA_GBRCOND", &i__1); - return ret_val; - } - if (*n == 0) { - ret_val = 1.; - return ret_val; - } - -/* Compute the equilibration matrix R such that */ -/* inv(R)*A*C has unit 1-norm. */ - - kd = *ku + 1; - ke = *kl + 1; - if (notrans) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - tmp = 0.; - if (*cmode == 1) { -/* Computing MAX */ - i__2 = i__ - *kl; -/* Computing MIN */ - i__4 = i__ + *ku; - i__3 = std::min(i__4,*n); - for (j = std::max(i__2,1_integer); j <= i__3; ++j) { - tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1] * c__[j], - abs(d__1)); - } - } else if (*cmode == 0) { -/* Computing MAX */ - i__3 = i__ - *kl; -/* Computing MIN */ - i__4 = i__ + *ku; - i__2 = std::min(i__4,*n); - for (j = std::max(i__3,1_integer); j <= i__2; ++j) { - tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(d__1)); - } - } else { -/* Computing MAX */ - i__2 = i__ - *kl; -/* Computing MIN */ - i__4 = i__ + *ku; - i__3 = std::min(i__4,*n); - for (j = std::max(i__2,1_integer); j <= i__3; ++j) { - tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1] / c__[j], - abs(d__1)); - } - } - work[(*n << 1) + i__] = tmp; - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - tmp = 0.; - if (*cmode == 1) { -/* Computing MAX */ - i__3 = i__ - *kl; -/* Computing MIN */ - i__4 = i__ + *ku; - i__2 = std::min(i__4,*n); - for (j = std::max(i__3,1_integer); j <= i__2; ++j) { - tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1] * c__[j], - abs(d__1)); - } - } else if (*cmode == 0) { -/* Computing MAX */ - i__2 = i__ - *kl; -/* Computing MIN */ - i__4 = i__ + *ku; - i__3 = std::min(i__4,*n); - for (j = std::max(i__2,1_integer); j <= i__3; ++j) { - tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1], abs(d__1) - ); - } - } else { -/* Computing MAX */ - i__3 = i__ - *kl; -/* Computing MIN */ - i__4 = i__ + *ku; - i__2 = std::min(i__4,*n); - for (j = std::max(i__3,1_integer); j <= i__2; ++j) { - tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1] / c__[j], - abs(d__1)); - } - } - work[(*n << 1) + i__] = tmp; - } - } - -/* Estimate the norm of inv(op(A)). */ - - ainvnm = 0.; - kase = 0; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (kase == 2) { - -/* Multiply by R. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] *= work[(*n << 1) + i__]; - } - if (notrans) { - dgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], - ldafb, &ipiv[1], &work[1], n, info); - } else { - dgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset], - ldafb, &ipiv[1], &work[1], n, info); - } - -/* Multiply by inv(C). */ - - if (*cmode == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] /= c__[i__]; - } - } else if (*cmode == -1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] *= c__[i__]; - } - } - } else { - -/* Multiply by inv(C'). */ - - if (*cmode == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] /= c__[i__]; - } - } else if (*cmode == -1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] *= c__[i__]; - } - } - if (notrans) { - dgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset], - ldafb, &ipiv[1], &work[1], n, info); - } else { - dgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], - ldafb, &ipiv[1], &work[1], n, info); - } - -/* Multiply by R. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] *= work[(*n << 1) + i__]; - } - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - ret_val = 1. / ainvnm; - } - - return ret_val; - -} /* dla_gbrcond__ */ diff --git a/external/clapack/lapack/dla_gbrfsx_extended.cpp b/external/clapack/lapack/dla_gbrfsx_extended.cpp deleted file mode 100644 index 7a82530b..00000000 --- a/external/clapack/lapack/dla_gbrfsx_extended.cpp +++ /dev/null @@ -1,593 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b6 = -1.; -static double c_b8 = 1.; - -/* Subroutine */ int dla_gbrfsx_extended__(integer *prec_type__, integer * - trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs, - double *ab, integer *ldab, double *afb, integer *ldafb, - integer *ipiv, bool *colequ, double *c__, double *b, - integer *ldb, double *y, integer *ldy, double *berr_out__, - integer *n_norms__, double *err_bnds_norm__, double * - err_bnds_comp__, double *res, double *ayb, double *dy, - double *y_tail__, double *rcond, integer *ithresh, double - *rthresh, double *dz_ub__, bool *ignore_cwise__, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, - y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, - err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3; - double d__1, d__2; - char ch__1[1]; - - /* Local variables */ - double dxratmax, dzratmax; - integer i__, j, m; - bool incr_prec__; - double prev_dz_z__, yk, final_dx_x__; - double final_dz_z__, prevnormdx; - integer cnt; - double dyk, eps, incr_thresh__, dx_x__, dz_z__; - double ymin; - integer y_prec_state__; - double dxrat, dzrat; - char trans[1]; - double normx, normy; - double normdx; - double hugeval; - integer x_state__, z_state__; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLA_GBRFSX_EXTENDED improves the computed solution to a system of */ -/* linear equations by performing extra-precise iterative refinement */ -/* and provides error bounds and backward error estimates for the solution. */ -/* This subroutine is called by DGBRFSX to perform iterative refinement. */ -/* In addition to normwise error bound, the code provides maximum */ -/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */ -/* and ERR_BNDS_COMP for details of the error bounds. Note that this */ -/* subroutine is only resonsible for setting the second fields of */ -/* ERR_BNDS_NORM and ERR_BNDS_COMP. */ - -/* Arguments */ -/* ========= */ - -/* PREC_TYPE (input) INTEGER */ -/* Specifies the intermediate precision to be used in refinement. */ -/* The value is defined by ILAPREC(P) where P is a CHARACTER and */ -/* P = 'S': Single */ -/* = 'D': Double */ -/* = 'I': Indigenous */ -/* = 'X', 'E': Extra */ - -/* TRANS_TYPE (input) INTEGER */ -/* Specifies the transposition operation on A. */ -/* The value is defined by ILATRANS(T) where T is a CHARACTER and */ -/* T = 'N': No transpose */ -/* = 'T': Transpose */ -/* = 'C': Conjugate transpose */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0 */ - -/* NRHS (input) INTEGER */ -/* The number of right-hand-sides, i.e., the number of columns of the */ -/* matrix B. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the N-by-N matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* The factors L and U from the factorization */ -/* A = P*L*U as computed by DGBTRF. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from the factorization A = P*L*U */ -/* as computed by DGBTRF; row i of the matrix was interchanged */ -/* with row IPIV(i). */ - -/* COLEQU (input) LOGICAL */ -/* If .TRUE. then column equilibration was done to A before calling */ -/* this routine. This is needed to compute the solution and error */ -/* bounds correctly. */ - -/* C (input) DOUBLE PRECISION array, dimension (N) */ -/* The column scale factors for A. If COLEQU = .FALSE., C */ -/* is not accessed. If C is input, each element of C should be a power */ -/* of the radix to ensure a reliable solution and error estimates. */ -/* Scaling by powers of the radix does not cause rounding errors unless */ -/* the result underflows or overflows. Rounding errors during scaling */ -/* lead to refining with a matrix that is not equivalent to the */ -/* input matrix, producing error estimates that may not be */ -/* reliable. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right-hand-side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* Y (input/output) DOUBLE PRECISION array, dimension */ -/* (LDY,NRHS) */ -/* On entry, the solution matrix X, as computed by DGBTRS. */ -/* On exit, the improved solution matrix Y. */ - -/* LDY (input) INTEGER */ -/* The leading dimension of the array Y. LDY >= max(1,N). */ - -/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* On exit, BERR_OUT(j) contains the componentwise relative backward */ -/* error for right-hand-side j from the formula */ -/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. This is computed by DLA_LIN_BERR. */ - -/* N_NORMS (input) INTEGER */ -/* Determines which error bounds to return (see ERR_BNDS_NORM */ -/* and ERR_BNDS_COMP). */ -/* If N_NORMS >= 1 return normwise error bounds. */ -/* If N_NORMS >= 2 return componentwise error bounds. */ - -/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */ -/* (NRHS, N_ERR_BNDS) */ -/* For each right-hand side, this array contains information about */ -/* various error bounds and condition numbers corresponding to the */ -/* normwise relative error, which is defined as follows: */ - -/* Normwise relative error in the ith solution vector: */ -/* max_j (abs(XTRUE(j,i) - X(j,i))) */ -/* ------------------------------ */ -/* max_j abs(X(j,i)) */ - -/* The array is indexed by the type of error information as described */ -/* below. There currently are up to three pieces of information */ -/* returned. */ - -/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ -/* right-hand side. */ - -/* The second index in ERR_BNDS_NORM(:,err) contains the following */ -/* three fields: */ -/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ -/* reciprocal condition number is less than the threshold */ -/* sqrt(n) * slamch('Epsilon'). */ - -/* err = 2 "Guaranteed" error bound: The estimated forward error, */ -/* almost certainly within a factor of 10 of the true error */ -/* so long as the next entry is greater than the threshold */ -/* sqrt(n) * slamch('Epsilon'). This error bound should only */ -/* be trusted if the previous boolean is true. */ - -/* err = 3 Reciprocal condition number: Estimated normwise */ -/* reciprocal condition number. Compared with the threshold */ -/* sqrt(n) * slamch('Epsilon') to determine if the error */ -/* estimate is "guaranteed". These reciprocal condition */ -/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ -/* appropriately scaled matrix Z. */ -/* Let Z = S*A, where S scales each row by a power of the */ -/* radix so all absolute row sums of Z are approximately 1. */ - -/* This subroutine is only responsible for setting the second field */ -/* above. */ -/* See Lapack Working Note 165 for further details and extra */ -/* cautions. */ - -/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */ -/* (NRHS, N_ERR_BNDS) */ -/* For each right-hand side, this array contains information about */ -/* various error bounds and condition numbers corresponding to the */ -/* componentwise relative error, which is defined as follows: */ - -/* Componentwise relative error in the ith solution vector: */ -/* abs(XTRUE(j,i) - X(j,i)) */ -/* max_j ---------------------- */ -/* abs(X(j,i)) */ - -/* The array is indexed by the right-hand side i (on which the */ -/* componentwise relative error depends), and the type of error */ -/* information as described below. There currently are up to three */ -/* pieces of information returned for each right-hand side. If */ -/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ -/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ -/* the first (:,N_ERR_BNDS) entries are returned. */ - -/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ -/* right-hand side. */ - -/* The second index in ERR_BNDS_COMP(:,err) contains the following */ -/* three fields: */ -/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ -/* reciprocal condition number is less than the threshold */ -/* sqrt(n) * slamch('Epsilon'). */ - -/* err = 2 "Guaranteed" error bound: The estimated forward error, */ -/* almost certainly within a factor of 10 of the true error */ -/* so long as the next entry is greater than the threshold */ -/* sqrt(n) * slamch('Epsilon'). This error bound should only */ -/* be trusted if the previous boolean is true. */ - -/* err = 3 Reciprocal condition number: Estimated componentwise */ -/* reciprocal condition number. Compared with the threshold */ -/* sqrt(n) * slamch('Epsilon') to determine if the error */ -/* estimate is "guaranteed". These reciprocal condition */ -/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ -/* appropriately scaled matrix Z. */ -/* Let Z = S*(A*diag(x)), where x is the solution for the */ -/* current right-hand side and S scales each row of */ -/* A*diag(x) by a power of the radix so all absolute row */ -/* sums of Z are approximately 1. */ - -/* This subroutine is only responsible for setting the second field */ -/* above. */ -/* See Lapack Working Note 165 for further details and extra */ -/* cautions. */ - -/* RES (input) DOUBLE PRECISION array, dimension (N) */ -/* Workspace to hold the intermediate residual. */ - -/* AYB (input) DOUBLE PRECISION array, dimension (N) */ -/* Workspace. This can be the same workspace passed for Y_TAIL. */ - -/* DY (input) DOUBLE PRECISION array, dimension (N) */ -/* Workspace to hold the intermediate solution. */ - -/* Y_TAIL (input) DOUBLE PRECISION array, dimension (N) */ -/* Workspace to hold the trailing bits of the intermediate solution. */ - -/* RCOND (input) DOUBLE PRECISION */ -/* Reciprocal scaled condition number. This is an estimate of the */ -/* reciprocal Skeel condition number of the matrix A after */ -/* equilibration (if done). If this is less than the machine */ -/* precision (in particular, if it is zero), the matrix is singular */ -/* to working precision. Note that the error may still be small even */ -/* if this number is very small and the matrix appears ill- */ -/* conditioned. */ - -/* ITHRESH (input) INTEGER */ -/* The maximum number of residual computations allowed for */ -/* refinement. The default is 10. For 'aggressive' set to 100 to */ -/* permit convergence using approximate factorizations or */ -/* factorizations other than LU. If the factorization uses a */ -/* technique other than Gaussian elimination, the guarantees in */ -/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ - -/* RTHRESH (input) DOUBLE PRECISION */ -/* Determines when to stop refinement if the error estimate stops */ -/* decreasing. Refinement will stop when the next solution no longer */ -/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ -/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ -/* default value is 0.5. For 'aggressive' set to 0.9 to permit */ -/* convergence on extremely ill-conditioned matrices. See LAWN 165 */ -/* for more details. */ - -/* DZ_UB (input) DOUBLE PRECISION */ -/* Determines when to start considering componentwise convergence. */ -/* Componentwise convergence is only considered after each component */ -/* of the solution Y is stable, which we definte as the relative */ -/* change in each component being less than DZ_UB. The default value */ -/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */ -/* more details. */ - -/* IGNORE_CWISE (input) LOGICAL */ -/* If .TRUE. then ignore componentwise convergence. Default value */ -/* is .FALSE.. */ - -/* INFO (output) INTEGER */ -/* = 0: Successful exit. */ -/* < 0: if INFO = -i, the ith argument to DGBTRS had an illegal */ -/* value */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Parameters .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - err_bnds_comp_dim1 = *nrhs; - err_bnds_comp_offset = 1 + err_bnds_comp_dim1; - err_bnds_comp__ -= err_bnds_comp_offset; - err_bnds_norm_dim1 = *nrhs; - err_bnds_norm_offset = 1 + err_bnds_norm_dim1; - err_bnds_norm__ -= err_bnds_norm_offset; - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - --ipiv; - --c__; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - y_dim1 = *ldy; - y_offset = 1 + y_dim1; - y -= y_offset; - --berr_out__; - --res; - --ayb; - --dy; - --y_tail__; - - /* Function Body */ - if (*info != 0) { - return 0; - } - chla_transtype__(ch__1, 1_integer, trans_type__); - *(unsigned char *)trans = *(unsigned char *)&ch__1[0]; - eps = dlamch_("Epsilon"); - hugeval = dlamch_("Overflow"); -/* Force HUGEVAL to Inf */ - hugeval *= hugeval; -/* Using HUGEVAL may lead to spurious underflows. */ - incr_thresh__ = (double) (*n) * eps; - m = *kl + *ku + 1; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - y_prec_state__ = 1; - if (y_prec_state__ == 2) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - y_tail__[i__] = 0.; - } - } - dxrat = 0.; - dxratmax = 0.; - dzrat = 0.; - dzratmax = 0.; - final_dx_x__ = hugeval; - final_dz_z__ = hugeval; - prevnormdx = hugeval; - prev_dz_z__ = hugeval; - dz_z__ = hugeval; - dx_x__ = hugeval; - x_state__ = 1; - z_state__ = 0; - incr_prec__ = false; - i__2 = *ithresh; - for (cnt = 1; cnt <= i__2; ++cnt) { - -/* Compute residual RES = B_s - op(A_s) * Y, */ -/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); - if (y_prec_state__ == 0) { - dgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[ - j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); - } else if (y_prec_state__ == 1) { - blas_dgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ - ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, & - res[1], &c__1, prec_type__); - } else { - blas_dgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ - ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], & - c__1, &c_b8, &res[1], &c__1, prec_type__); - } -/* XXX: RES is no longer needed. */ - dcopy_(n, &res[1], &c__1, &dy[1], &c__1); - dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] -, &dy[1], n, info); - -/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ - - normx = 0.; - normy = 0.; - normdx = 0.; - dz_z__ = 0.; - ymin = hugeval; - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - yk = (d__1 = y[i__ + j * y_dim1], abs(d__1)); - dyk = (d__1 = dy[i__], abs(d__1)); - if (yk != 0.) { -/* Computing MAX */ - d__1 = dz_z__, d__2 = dyk / yk; - dz_z__ = std::max(d__1,d__2); - } else if (dyk != 0.) { - dz_z__ = hugeval; - } - ymin = std::min(ymin,yk); - normy = std::max(normy,yk); - if (*colequ) { -/* Computing MAX */ - d__1 = normx, d__2 = yk * c__[i__]; - normx = std::max(d__1,d__2); -/* Computing MAX */ - d__1 = normdx, d__2 = dyk * c__[i__]; - normdx = std::max(d__1,d__2); - } else { - normx = normy; - normdx = std::max(normdx,dyk); - } - } - if (normx != 0.) { - dx_x__ = normdx / normx; - } else if (normdx == 0.) { - dx_x__ = 0.; - } else { - dx_x__ = hugeval; - } - dxrat = normdx / prevnormdx; - dzrat = dz_z__ / prev_dz_z__; - -/* Check termination criteria. */ - - if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy - && y_prec_state__ < 2) { - incr_prec__ = true; - } - if (x_state__ == 3 && dxrat <= *rthresh) { - x_state__ = 1; - } - if (x_state__ == 1) { - if (dx_x__ <= eps) { - x_state__ = 2; - } else if (dxrat > *rthresh) { - if (y_prec_state__ != 2) { - incr_prec__ = true; - } else { - x_state__ = 3; - } - } else { - if (dxrat > dxratmax) { - dxratmax = dxrat; - } - } - if (x_state__ > 1) { - final_dx_x__ = dx_x__; - } - } - if (z_state__ == 0 && dz_z__ <= *dz_ub__) { - z_state__ = 1; - } - if (z_state__ == 3 && dzrat <= *rthresh) { - z_state__ = 1; - } - if (z_state__ == 1) { - if (dz_z__ <= eps) { - z_state__ = 2; - } else if (dz_z__ > *dz_ub__) { - z_state__ = 0; - dzratmax = 0.; - final_dz_z__ = hugeval; - } else if (dzrat > *rthresh) { - if (y_prec_state__ != 2) { - incr_prec__ = true; - } else { - z_state__ = 3; - } - } else { - if (dzrat > dzratmax) { - dzratmax = dzrat; - } - } - if (z_state__ > 1) { - final_dz_z__ = dz_z__; - } - } - -/* Exit if both normwise and componentwise stopped working, */ -/* but if componentwise is unstable, let it go at least two */ -/* iterations. */ - - if (x_state__ != 1) { - if (*ignore_cwise__) { - goto L666; - } - if (z_state__ == 3 || z_state__ == 2) { - goto L666; - } - if (z_state__ == 0 && cnt > 1) { - goto L666; - } - } - if (incr_prec__) { - incr_prec__ = false; - ++y_prec_state__; - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - y_tail__[i__] = 0.; - } - } - prevnormdx = normdx; - prev_dz_z__ = dz_z__; - -/* Update soluton. */ - - if (y_prec_state__ < 2) { - daxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); - } else { - dla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); - } - } -/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */ -L666: - -/* Set final_* when cnt hits ithresh. */ - - if (x_state__ == 1) { - final_dx_x__ = dx_x__; - } - if (z_state__ == 1) { - final_dz_z__ = dz_z__; - } - -/* Compute error bounds. */ - - if (*n_norms__ >= 1) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( - 1 - dxratmax); - } - if (*n_norms__ >= 2) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( - 1 - dzratmax); - } - -/* Compute componentwise relative backward error from formula */ -/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. */ - -/* Compute residual RES = B_s - op(A_s) * Y, */ -/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); - dgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j * - y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); - } - -/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ - - dla_gbamv__(trans_type__, n, n, kl, ku, &c_b8, &ab[ab_offset], ldab, & - y[j * y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1); - dla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); - -/* End of loop for each RHS */ - - } - - return 0; -} /* dla_gbrfsx_extended__ */ diff --git a/external/clapack/lapack/dla_gbrpvgrw.cpp b/external/clapack/lapack/dla_gbrpvgrw.cpp deleted file mode 100644 index bd5f7fc1..00000000 --- a/external/clapack/lapack/dla_gbrpvgrw.cpp +++ /dev/null @@ -1,123 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -double dla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer * - ncols, double *ab, integer *ldab, double *afb, integer *ldafb) { - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; - double ret_val, d__1, d__2; - - /* Local variables */ - integer i__, j, kd; - double amax, umax, rpvgrw; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLA_GBRPVGRW computes the reciprocal pivot growth factor */ -/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */ -/* much less than 1, the stability of the LU factorization of the */ -/* (equilibrated) matrix A could be poor. This also means that the */ -/* solution X, estimated condition numbers, and error bounds could be */ -/* unreliable. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* NCOLS (input) INTEGER */ -/* The number of columns of the matrix A. NCOLS >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ -/* Details of the LU factorization of the band matrix A, as */ -/* computed by DGBTRF. U is stored as an upper triangular */ -/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ -/* and the multipliers used during the factorization are stored */ -/* in rows KL+KU+2 to 2*KL+KU+1. */ - -/* LDAFB (input) INTEGER */ -/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - - /* Function Body */ - rpvgrw = 1.; - kd = *ku + 1; - i__1 = *ncols; - for (j = 1; j <= i__1; ++j) { - amax = 0.; - umax = 0.; -/* Computing MAX */ - i__2 = j - *ku; -/* Computing MIN */ - i__4 = j + *kl; - i__3 = std::min(i__4,*n); - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(d__1)); - amax = std::max(d__2,amax); - } -/* Computing MAX */ - i__3 = j - *ku; - i__2 = j; - for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = (d__1 = afb[kd + i__ - j + j * afb_dim1], abs(d__1)); - umax = std::max(d__2,umax); - } - if (umax != 0.) { -/* Computing MIN */ - d__1 = amax / umax; - rpvgrw = std::min(d__1,rpvgrw); - } - } - ret_val = rpvgrw; - return ret_val; -} /* dla_gbrpvgrw__ */ diff --git a/external/clapack/lapack/dla_porcond.cpp b/external/clapack/lapack/dla_porcond.cpp deleted file mode 100644 index 7ab006de..00000000 --- a/external/clapack/lapack/dla_porcond.cpp +++ /dev/null @@ -1,291 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dla_porcond__(const char *uplo, integer *n, double *a, integer *lda, - double *af, integer *ldaf, integer *cmode, double *c__, - integer *info, double *work, integer *iwork, integer uplo_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; - double ret_val, d__1; - - /* Local variables */ - integer i__, j; - bool up; - double tmp; - integer kase; - integer isave[3]; - double ainvnm; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) */ -/* where op2 is determined by CMODE as follows */ -/* CMODE = 1 op2(C) = C */ -/* CMODE = 0 op2(C) = I */ -/* CMODE = -1 op2(C) = inv(C) */ -/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */ -/* is computed by computing scaling factors R such that */ -/* diag(R)*A*op2(C) is row equilibrated and computing the standard */ -/* infinity-norm condition number. */ - -/* Arguments */ -/* ========== */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* A (input) REAL array, dimension (LDA,N) */ -/* On entry, the N-by-N matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* CMODE (input) INTEGER */ -/* Determines op2(C) in the formula op(A) * op2(C) as follows: */ -/* CMODE = 1 op2(C) = C */ -/* CMODE = 0 op2(C) = I */ -/* CMODE = -1 op2(C) = inv(C) */ - -/* C (input) DOUBLE PRECISION array, dimension (N) */ -/* The vector C in the formula op(A) * op2(C). */ - -/* INFO (output) INTEGER */ -/* = 0: Successful exit. */ -/* i > 0: The ith argument is invalid. */ - -/* WORK (input) DOUBLE PRECISION array, dimension (3*N). */ -/* Workspace. */ - -/* IWORK (input) INTEGER array, dimension (N). */ -/* Workspace. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --c__; - --work; - --iwork; - - /* Function Body */ - ret_val = 0.; - - *info = 0; - if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLA_PORCOND", &i__1); - return ret_val; - } - if (*n == 0) { - ret_val = 1.; - return ret_val; - } - up = false; - if (lsame_(uplo, "U")) { - up = true; - } - -/* Compute the equilibration matrix R such that */ -/* inv(R)*A*C has unit 1-norm. */ - - if (up) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - tmp = 0.; - if (*cmode == 1) { - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); - } - } else if (*cmode == 0) { - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); - } - } else { - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); - } - } - work[(*n << 1) + i__] = tmp; - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - tmp = 0.; - if (*cmode == 1) { - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); - } - } else if (*cmode == 0) { - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); - } - } else { - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); - } - } - work[(*n << 1) + i__] = tmp; - } - } - -/* Estimate the norm of inv(op(A)). */ - - ainvnm = 0.; - kase = 0; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (kase == 2) { - -/* Multiply by R. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] *= work[(*n << 1) + i__]; - } - if (up) { - dpotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n, - info); - } else { - dpotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n, - info); - } - -/* Multiply by inv(C). */ - - if (*cmode == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] /= c__[i__]; - } - } else if (*cmode == -1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] *= c__[i__]; - } - } - } else { - -/* Multiply by inv(C'). */ - - if (*cmode == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] /= c__[i__]; - } - } else if (*cmode == -1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] *= c__[i__]; - } - } - if (up) { - dpotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n, - info); - } else { - dpotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n, - info); - } - -/* Multiply by R. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] *= work[(*n << 1) + i__]; - } - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - ret_val = 1. / ainvnm; - } - - return ret_val; - -} /* dla_porcond__ */ diff --git a/external/clapack/lapack/dla_wwaddw.cpp b/external/clapack/lapack/dla_wwaddw.cpp deleted file mode 100644 index 06336baf..00000000 --- a/external/clapack/lapack/dla_wwaddw.cpp +++ /dev/null @@ -1,67 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dla_wwaddw__(integer *n, double *x, double *y, double *w) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__; - double s; - - -/* -- LAPACK routine (version 3.2) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLA_WWADDW adds a vector W into a doubled-single vector (X, Y). */ - -/* This works for all extant IBM's hex and binary floating point */ -/* arithmetics, but not for decimal. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The length of vectors X, Y, and W. */ - -/* X, Y (input/output) DOUBLE PRECISION array, length N */ -/* The doubled-single accumulation vector. */ - -/* W (input) DOUBLE PRECISION array, length N */ -/* The vector to be added. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --w; - --y; - --x; - - /* Function Body */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - s = x[i__] + w[i__]; - s = s + s - s; - y[i__] = x[i__] - s + w[i__] + y[i__]; - x[i__] = s; -/* L10: */ - } - return 0; -} /* dla_wwaddw__ */ diff --git a/external/clapack/lapack/dlabad.cpp b/external/clapack/lapack/dlabad.cpp deleted file mode 100644 index 1a497dab..00000000 --- a/external/clapack/lapack/dlabad.cpp +++ /dev/null @@ -1,60 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlabad_(double *small, double *large) -{ - /* Builtin functions - double d_lg10(double *), sqrt(double);*/ - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLABAD takes as input the values computed by DLAMCH for underflow and */ -/* overflow, and returns the square root of each of these values if the */ -/* log of LARGE is sufficiently large. This subroutine is intended to */ -/* identify machines with a large exponent range, such as the Crays, and */ -/* redefine the underflow and overflow limits to be the square roots of */ -/* the values computed by DLAMCH. This subroutine is needed because */ -/* DLAMCH does not compensate for poor arithmetic in the upper half of */ -/* the exponent range, as is found on a Cray. */ - -/* Arguments */ -/* ========= */ - -/* SMALL (input/output) DOUBLE PRECISION */ -/* On entry, the underflow threshold as computed by DLAMCH. */ -/* On exit, if LOG10(LARGE) is sufficiently large, the square */ -/* root of SMALL, otherwise unchanged. */ - -/* LARGE (input/output) DOUBLE PRECISION */ -/* On entry, the overflow threshold as computed by DLAMCH. */ -/* On exit, if LOG10(LARGE) is sufficiently large, the square */ -/* root of LARGE, otherwise unchanged. */ - -/* ===================================================================== */ - -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* If it looks like we're on a Cray, take the square root of */ -/* SMALL and LARGE to avoid overflow and underflow problems. */ - - if (d_lg10(large) > 2e3) { - *small = sqrt(*small); - *large = sqrt(*large); - } - - return 0; - -/* End of DLABAD */ - -} /* dlabad_ */ diff --git a/external/clapack/lapack/dlabrd.cpp b/external/clapack/lapack/dlabrd.cpp deleted file mode 100644 index 28d65fd2..00000000 --- a/external/clapack/lapack/dlabrd.cpp +++ /dev/null @@ -1,416 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b4 = -1.; -static double c_b5 = 1.; -static integer c__1 = 1; -static double c_b16 = 0.; - -/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, double * - a, integer *lda, double *d__, double *e, double *tauq, - double *taup, double *x, integer *ldx, double *y, integer - *ldy) -{ - /* System generated locals */ - integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, - i__3; - - /* Local variables */ - integer i__; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLABRD reduces the first NB rows and columns of a real general */ -/* m by n matrix A to upper or lower bidiagonal form by an orthogonal */ -/* transformation Q' * A * P, and returns the matrices X and Y which */ -/* are needed to apply the transformation to the unreduced part of A. */ - -/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */ -/* bidiagonal form. */ - -/* This is an auxiliary routine called by DGEBRD */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows in the matrix A. */ - -/* N (input) INTEGER */ -/* The number of columns in the matrix A. */ - -/* NB (input) INTEGER */ -/* The number of leading rows and columns of A to be reduced. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the m by n general matrix to be reduced. */ -/* On exit, the first NB rows and columns of the matrix are */ -/* overwritten; the rest of the array is unchanged. */ -/* If m >= n, elements on and below the diagonal in the first NB */ -/* columns, with the array TAUQ, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors; and */ -/* elements above the diagonal in the first NB rows, with the */ -/* array TAUP, represent the orthogonal matrix P as a product */ -/* of elementary reflectors. */ -/* If m < n, elements below the diagonal in the first NB */ -/* columns, with the array TAUQ, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors, and */ -/* elements on and above the diagonal in the first NB rows, */ -/* with the array TAUP, represent the orthogonal matrix P as */ -/* a product of elementary reflectors. */ -/* See Further Details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* D (output) DOUBLE PRECISION array, dimension (NB) */ -/* The diagonal elements of the first NB rows and columns of */ -/* the reduced matrix. D(i) = A(i,i). */ - -/* E (output) DOUBLE PRECISION array, dimension (NB) */ -/* The off-diagonal elements of the first NB rows and columns of */ -/* the reduced matrix. */ - -/* TAUQ (output) DOUBLE PRECISION array dimension (NB) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix Q. See Further Details. */ - -/* TAUP (output) DOUBLE PRECISION array, dimension (NB) */ -/* The scalar factors of the elementary reflectors which */ -/* represent the orthogonal matrix P. See Further Details. */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NB) */ -/* The m-by-nb matrix X required to update the unreduced part */ -/* of A. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= M. */ - -/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */ -/* The n-by-nb matrix Y required to update the unreduced part */ -/* of A. */ - -/* LDY (input) INTEGER */ -/* The leading dimension of the array Y. LDY >= N. */ - -/* Further Details */ -/* =============== */ - -/* The matrices Q and P are represented as products of elementary */ -/* reflectors: */ - -/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */ - -/* Each H(i) and G(i) has the form: */ - -/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ - -/* where tauq and taup are real scalars, and v and u are real vectors. */ - -/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */ -/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */ -/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ - -/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */ -/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */ -/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ - -/* The elements of the vectors v and u together form the m-by-nb matrix */ -/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */ -/* the transformation to the unreduced part of the matrix, using a block */ -/* update of the form: A := A - V*Y' - X*U'. */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with nb = 2: */ - -/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ - -/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */ -/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */ -/* ( v1 v2 a a a ) ( v1 1 a a a a ) */ -/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */ -/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */ -/* ( v1 v2 a a a ) */ - -/* where a denotes an element of the original matrix which is unchanged, */ -/* vi denotes an element of the vector defining H(i), and ui an element */ -/* of the vector defining G(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --d__; - --e; - --tauq; - --taup; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - y_dim1 = *ldy; - y_offset = 1 + y_dim1; - y -= y_offset; - - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } - - if (*m >= *n) { - -/* Reduce to upper bidiagonal form */ - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Update A(i:m,i) */ - - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda, - &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], & - c__1); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx, - &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ * - a_dim1], &c__1); - -/* Generate reflection Q(i) to annihilate A(i+1:m,i) */ - - i__2 = *m - i__ + 1; -/* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[std::min(i__3, *m)+ i__ * - a_dim1], &c__1, &tauq[i__]); - d__[i__] = a[i__ + i__ * a_dim1]; - if (i__ < *n) { - a[i__ + i__ * a_dim1] = 1.; - -/* Compute Y(i+1:n,i) */ - - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) * - a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, & - y[i__ + 1 + i__ * y_dim1], &c__1); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], - lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * - y_dim1 + 1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + - y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ - i__ + 1 + i__ * y_dim1], &c__1); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1], - ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * - y_dim1 + 1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * - a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, - &y[i__ + 1 + i__ * y_dim1], &c__1); - i__2 = *n - i__; - dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); - -/* Update A(i,i+1:n) */ - - i__2 = *n - i__; - dgemv_("No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + - y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + ( - i__ + 1) * a_dim1], lda); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * - a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[ - i__ + (i__ + 1) * a_dim1], lda); - -/* Generate reflection P(i) to annihilate A(i,i+2:n) */ - - i__2 = *n - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + std::min( - i__3, *n)* a_dim1], lda, &taup[i__]); - e[i__] = a[i__ + (i__ + 1) * a_dim1]; - a[i__ + (i__ + 1) * a_dim1] = 1.; - -/* Compute X(i+1:m,i) */ - - i__2 = *m - i__; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ - + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], - lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1); - i__2 = *n - i__; - dgemv_("Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], - ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[ - i__ * x_dim1 + 1], &c__1); - i__2 = *m - i__; - dgemv_("No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 + - a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ - i__ + 1 + i__ * x_dim1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & - c_b16, &x[i__ * x_dim1 + 1], &c__1); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + - x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ - i__ + 1 + i__ * x_dim1], &c__1); - i__2 = *m - i__; - dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); - } -/* L10: */ - } - } else { - -/* Reduce to lower bidiagonal form */ - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Update A(i,i:n) */ - - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy, - &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1], - lda); - i__2 = i__ - 1; - i__3 = *n - i__ + 1; - dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1], - lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1], - lda); - -/* Generate reflection P(i) to annihilate A(i,i+1:n) */ - - i__2 = *n - i__ + 1; -/* Computing MIN */ - i__3 = i__ + 1; - dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + std::min(i__3, *n)* - a_dim1], lda, &taup[i__]); - d__[i__] = a[i__ + i__ * a_dim1]; - if (i__ < *m) { - a[i__ + i__ * a_dim1] = 1.; - -/* Compute X(i+1:m,i) */ - - i__2 = *m - i__; - i__3 = *n - i__ + 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ * - a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, & - x[i__ + 1 + i__ * x_dim1], &c__1); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], - ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * - x_dim1 + 1], &c__1); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + - a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ - i__ + 1 + i__ * x_dim1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__ + 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 + - 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * - x_dim1 + 1], &c__1); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + - x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ - i__ + 1 + i__ * x_dim1], &c__1); - i__2 = *m - i__; - dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); - -/* Update A(i+1:m,i) */ - - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + - a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + - 1 + i__ * a_dim1], &c__1); - i__2 = *m - i__; - dgemv_("No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 + - x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[ - i__ + 1 + i__ * a_dim1], &c__1); - -/* Generate reflection Q(i) to annihilate A(i+2:m,i) */ - - i__2 = *m - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *m)+ - i__ * a_dim1], &c__1, &tauq[i__]); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.; - -/* Compute Y(i+1:n,i) */ - - i__2 = *m - i__; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + - 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, - &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ - i__ * y_dim1 + 1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + - y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ - i__ + 1 + i__ * y_dim1], &c__1); - i__2 = *m - i__; - dgemv_("Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1], - ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ - i__ * y_dim1 + 1], &c__1); - i__2 = *n - i__; - dgemv_("Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1 - + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ - + 1 + i__ * y_dim1], &c__1); - i__2 = *n - i__; - dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); - } -/* L20: */ - } - } - return 0; - -/* End of DLABRD */ - -} /* dlabrd_ */ diff --git a/external/clapack/lapack/dlacn2.cpp b/external/clapack/lapack/dlacn2.cpp deleted file mode 100644 index 8dd4329b..00000000 --- a/external/clapack/lapack/dlacn2.cpp +++ /dev/null @@ -1,247 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b11 = 1.; - -/* Subroutine */ int dlacn2_(integer *n, double *v, double *x, - integer *isgn, double *est, integer *kase, integer *isave) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer i__; - double temp; - integer jlast; - double altsgn, estold; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLACN2 estimates the 1-norm of a square, real matrix A. */ -/* Reverse communication is used for evaluating matrix-vector products. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 1. */ - -/* V (workspace) DOUBLE PRECISION array, dimension (N) */ -/* On the final return, V = A*W, where EST = norm(V)/norm(W) */ -/* (W is not returned). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On an intermediate return, X should be overwritten by */ -/* A * X, if KASE=1, */ -/* A' * X, if KASE=2, */ -/* and DLACN2 must be re-called with all the other parameters */ -/* unchanged. */ - -/* ISGN (workspace) INTEGER array, dimension (N) */ - -/* EST (input/output) DOUBLE PRECISION */ -/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */ -/* unchanged from the previous call to DLACN2. */ -/* On exit, EST is an estimate (a lower bound) for norm(A). */ - -/* KASE (input/output) INTEGER */ -/* On the initial call to DLACN2, KASE should be 0. */ -/* On an intermediate return, KASE will be 1 or 2, indicating */ -/* whether X should be overwritten by A * X or A' * X. */ -/* On the final return from DLACN2, KASE will again be 0. */ - -/* ISAVE (input/output) INTEGER array, dimension (3) */ -/* ISAVE is used to save variables between calls to DLACN2 */ - -/* Further Details */ -/* ======= ======= */ - -/* Contributed by Nick Higham, University of Manchester. */ -/* Originally named SONEST, dated March 16, 1988. */ - -/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */ -/* a real or complex matrix, with applications to condition estimation", */ -/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ - -/* This is a thread safe version of DLACON, which uses the array ISAVE */ -/* in place of a SAVE statement, as follows: */ - -/* DLACON DLACN2 */ -/* JUMP ISAVE(1) */ -/* J ISAVE(2) */ -/* ITER ISAVE(3) */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --isave; - --isgn; - --x; - --v; - - /* Function Body */ - if (*kase == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = 1. / (double) (*n); -/* L10: */ - } - *kase = 1; - isave[1] = 1; - return 0; - } - - switch (isave[1]) { - case 1: goto L20; - case 2: goto L40; - case 3: goto L70; - case 4: goto L110; - case 5: goto L140; - } - -/* ................ ENTRY (ISAVE( 1 ) = 1) */ -/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ - -L20: - if (*n == 1) { - v[1] = x[1]; - *est = abs(v[1]); -/* ... QUIT */ - goto L150; - } - *est = dasum_(n, &x[1], &c__1); - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = d_sign(&c_b11, &x[i__]); - isgn[i__] = i_dnnt(&x[i__]); -/* L30: */ - } - *kase = 2; - isave[1] = 2; - return 0; - -/* ................ ENTRY (ISAVE( 1 ) = 2) */ -/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ - -L40: - isave[2] = idamax_(n, &x[1], &c__1); - isave[3] = 2; - -/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ - -L50: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = 0.; -/* L60: */ - } - x[isave[2]] = 1.; - *kase = 1; - isave[1] = 3; - return 0; - -/* ................ ENTRY (ISAVE( 1 ) = 3) */ -/* X HAS BEEN OVERWRITTEN BY A*X. */ - -L70: - dcopy_(n, &x[1], &c__1, &v[1], &c__1); - estold = *est; - *est = dasum_(n, &v[1], &c__1); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = d_sign(&c_b11, &x[i__]); - if (i_dnnt(&d__1) != isgn[i__]) { - goto L90; - } -/* L80: */ - } -/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ - goto L120; - -L90: -/* TEST FOR CYCLING. */ - if (*est <= estold) { - goto L120; - } - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = d_sign(&c_b11, &x[i__]); - isgn[i__] = i_dnnt(&x[i__]); -/* L100: */ - } - *kase = 2; - isave[1] = 4; - return 0; - -/* ................ ENTRY (ISAVE( 1 ) = 4) */ -/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ - -L110: - jlast = isave[2]; - isave[2] = idamax_(n, &x[1], &c__1); - if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) { - ++isave[3]; - goto L50; - } - -/* ITERATION COMPLETE. FINAL STAGE. */ - -L120: - altsgn = 1.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = altsgn * ((double) (i__ - 1) / (double) (*n - 1) + - 1.); - altsgn = -altsgn; -/* L130: */ - } - *kase = 1; - isave[1] = 5; - return 0; - -/* ................ ENTRY (ISAVE( 1 ) = 5) */ -/* X HAS BEEN OVERWRITTEN BY A*X. */ - -L140: - temp = dasum_(n, &x[1], &c__1) / (double) (*n * 3) * 2.; - if (temp > *est) { - dcopy_(n, &x[1], &c__1, &v[1], &c__1); - *est = temp; - } - -L150: - *kase = 0; - return 0; - -/* End of DLACN2 */ - -} /* dlacn2_ */ diff --git a/external/clapack/lapack/dlacon.cpp b/external/clapack/lapack/dlacon.cpp deleted file mode 100644 index 415d703b..00000000 --- a/external/clapack/lapack/dlacon.cpp +++ /dev/null @@ -1,242 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b11 = 1.; - -/* Subroutine */ int dlacon_(integer *n, double *v, double *x, - integer *isgn, double *est, integer *kase) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Builtin functions - double d_sign(double *, double *); - integer i_dnnt(double *); */ - - /* Local variables */ - static integer i__, j, iter; - static double temp; - static integer jump; - static integer jlast; - static double altsgn, estold; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLACON estimates the 1-norm of a square, real matrix A. */ -/* Reverse communication is used for evaluating matrix-vector products. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 1. */ - -/* V (workspace) DOUBLE PRECISION array, dimension (N) */ -/* On the final return, V = A*W, where EST = norm(V)/norm(W) */ -/* (W is not returned). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On an intermediate return, X should be overwritten by */ -/* A * X, if KASE=1, */ -/* A' * X, if KASE=2, */ -/* and DLACON must be re-called with all the other parameters */ -/* unchanged. */ - -/* ISGN (workspace) INTEGER array, dimension (N) */ - -/* EST (input/output) DOUBLE PRECISION */ -/* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */ -/* unchanged from the previous call to DLACON. */ -/* On exit, EST is an estimate (a lower bound) for norm(A). */ - -/* KASE (input/output) INTEGER */ -/* On the initial call to DLACON, KASE should be 0. */ -/* On an intermediate return, KASE will be 1 or 2, indicating */ -/* whether X should be overwritten by A * X or A' * X. */ -/* On the final return from DLACON, KASE will again be 0. */ - -/* Further Details */ -/* ======= ======= */ - -/* Contributed by Nick Higham, University of Manchester. */ -/* Originally named SONEST, dated March 16, 1988. */ - -/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */ -/* a real or complex matrix, with applications to condition estimation", */ -/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --isgn; - --x; - --v; - - /* Function Body */ - if (*kase == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = 1. / (double) (*n); -/* L10: */ - } - *kase = 1; - jump = 1; - return 0; - } - - switch (jump) { - case 1: goto L20; - case 2: goto L40; - case 3: goto L70; - case 4: goto L110; - case 5: goto L140; - } - -/* ................ ENTRY (JUMP = 1) */ -/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ - -L20: - if (*n == 1) { - v[1] = x[1]; - *est = abs(v[1]); -/* ... QUIT */ - goto L150; - } - *est = dasum_(n, &x[1], &c__1); - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = d_sign(&c_b11, &x[i__]); - isgn[i__] = i_dnnt(&x[i__]); -/* L30: */ - } - *kase = 2; - jump = 2; - return 0; - -/* ................ ENTRY (JUMP = 2) */ -/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ - -L40: - j = idamax_(n, &x[1], &c__1); - iter = 2; - -/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ - -L50: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = 0.; -/* L60: */ - } - x[j] = 1.; - *kase = 1; - jump = 3; - return 0; - -/* ................ ENTRY (JUMP = 3) */ -/* X HAS BEEN OVERWRITTEN BY A*X. */ - -L70: - dcopy_(n, &x[1], &c__1, &v[1], &c__1); - estold = *est; - *est = dasum_(n, &v[1], &c__1); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = d_sign(&c_b11, &x[i__]); - if (i_dnnt(&d__1) != isgn[i__]) { - goto L90; - } -/* L80: */ - } -/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ - goto L120; - -L90: -/* TEST FOR CYCLING. */ - if (*est <= estold) { - goto L120; - } - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = d_sign(&c_b11, &x[i__]); - isgn[i__] = i_dnnt(&x[i__]); -/* L100: */ - } - *kase = 2; - jump = 4; - return 0; - -/* ................ ENTRY (JUMP = 4) */ -/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ - -L110: - jlast = j; - j = idamax_(n, &x[1], &c__1); - if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) { - ++iter; - goto L50; - } - -/* ITERATION COMPLETE. FINAL STAGE. */ - -L120: - altsgn = 1.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = altsgn * ((double) (i__ - 1) / (double) (*n - 1) + - 1.); - altsgn = -altsgn; -/* L130: */ - } - *kase = 1; - jump = 5; - return 0; - -/* ................ ENTRY (JUMP = 5) */ -/* X HAS BEEN OVERWRITTEN BY A*X. */ - -L140: - temp = dasum_(n, &x[1], &c__1) / (double) (*n * 3) * 2.; - if (temp > *est) { - dcopy_(n, &x[1], &c__1, &v[1], &c__1); - *est = temp; - } - -L150: - *kase = 0; - return 0; - -/* End of DLACON */ - -} /* dlacon_ */ diff --git a/external/clapack/lapack/dlacpy.cpp b/external/clapack/lapack/dlacpy.cpp deleted file mode 100644 index 8f90df5b..00000000 --- a/external/clapack/lapack/dlacpy.cpp +++ /dev/null @@ -1,113 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlacpy_(const char *uplo, integer *m, integer *n, double * - a, integer *lda, double *b, integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLACPY copies all or part of a two-dimensional matrix A to another */ -/* matrix B. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies the part of the matrix A to be copied to B. */ -/* = 'U': Upper triangular part */ -/* = 'L': Lower triangular part */ -/* Otherwise: All of the matrix A */ - -/* 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) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The m by n matrix A. If UPLO = 'U', only the upper triangle */ -/* or trapezoid is accessed; if UPLO = 'L', only the lower */ -/* triangle or trapezoid is accessed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (output) DOUBLE PRECISION array, dimension (LDB,N) */ -/* On exit, B = A in the locations specified by UPLO. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,M). */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = std::min(j,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; -/* L10: */ - } -/* L20: */ - } - } else if (lsame_(uplo, "L")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; -/* L30: */ - } -/* L40: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; -/* L50: */ - } -/* L60: */ - } - } - return 0; - -/* End of DLACPY */ - -} /* dlacpy_ */ diff --git a/external/clapack/lapack/dladiv.cpp b/external/clapack/lapack/dladiv.cpp deleted file mode 100644 index a92e4f2f..00000000 --- a/external/clapack/lapack/dladiv.cpp +++ /dev/null @@ -1,66 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dladiv_(double *a, double *b, double *c__, - double *d__, double *p, double *q) -{ - double e, f; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (abs(*d__) < abs(*c__)) { - 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; - } - - return 0; - -/* End of DLADIV */ - -} /* dladiv_ */ diff --git a/external/clapack/lapack/dlae2.cpp b/external/clapack/lapack/dlae2.cpp deleted file mode 100644 index ece1b80f..00000000 --- a/external/clapack/lapack/dlae2.cpp +++ /dev/null @@ -1,130 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlae2_(double *a, double *b, double *c__, - double *rt1, double *rt2) -{ - /* System generated locals */ - double d__1; - - /* Builtin functions - double sqrt(double);*/ - - /* Local variables */ - double ab, df, tb, sm, rt, adf, acmn, acmx; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix */ -/* [ A B ] */ -/* [ B C ]. */ -/* On return, RT1 is the eigenvalue of larger absolute value, and RT2 */ -/* is the eigenvalue of smaller absolute value. */ - -/* Arguments */ -/* ========= */ - -/* A (input) DOUBLE PRECISION */ -/* The (1,1) element of the 2-by-2 matrix. */ - -/* B (input) DOUBLE PRECISION */ -/* The (1,2) and (2,1) elements of the 2-by-2 matrix. */ - -/* C (input) DOUBLE PRECISION */ -/* The (2,2) element of the 2-by-2 matrix. */ - -/* RT1 (output) DOUBLE PRECISION */ -/* The eigenvalue of larger absolute value. */ - -/* RT2 (output) DOUBLE PRECISION */ -/* The eigenvalue of smaller absolute value. */ - -/* Further Details */ -/* =============== */ - -/* RT1 is accurate to a few ulps barring over/underflow. */ - -/* RT2 may be inaccurate if there is massive cancellation in the */ -/* determinant A*C-B*B; higher precision or correctly rounded or */ -/* correctly truncated arithmetic would be needed to compute RT2 */ -/* accurately in all cases. */ - -/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */ -/* Underflow is harmless if the input data is 0 or exceeds */ -/* underflow_threshold / macheps. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Compute the eigenvalues */ - - sm = *a + *c__; - df = *a - *c__; - adf = abs(df); - tb = *b + *b; - ab = abs(tb); - if (abs(*a) > abs(*c__)) { - acmx = *a; - acmn = *c__; - } else { - acmx = *c__; - acmn = *a; - } - if (adf > ab) { -/* Computing 2nd power */ - d__1 = ab / adf; - rt = adf * sqrt(d__1 * d__1 + 1.); - } else if (adf < ab) { -/* Computing 2nd power */ - d__1 = adf / ab; - rt = ab * sqrt(d__1 * d__1 + 1.); - } else { - -/* Includes case AB=ADF=0 */ - - rt = ab * sqrt(2.); - } - if (sm < 0.) { - *rt1 = (sm - rt) * .5; - -/* Order of execution important. */ -/* To get fully accurate smaller eigenvalue, */ -/* next line needs to be executed in higher precision. */ - - *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; - } else if (sm > 0.) { - *rt1 = (sm + rt) * .5; - -/* Order of execution important. */ -/* To get fully accurate smaller eigenvalue, */ -/* next line needs to be executed in higher precision. */ - - *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; - } else { - -/* Includes case RT1 = RT2 = 0 */ - - *rt1 = rt * .5; - *rt2 = rt * -.5; - } - return 0; - -/* End of DLAE2 */ - -} /* dlae2_ */ diff --git a/external/clapack/lapack/dlaebz.cpp b/external/clapack/lapack/dlaebz.cpp deleted file mode 100644 index 7b3c00d3..00000000 --- a/external/clapack/lapack/dlaebz.cpp +++ /dev/null @@ -1,628 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaebz_(integer *ijob, integer *nitmax, integer *n, - integer *mmax, integer *minp, integer *nbmin, double *abstol, - double *reltol, double *pivmin, double *d__, double * - e, double *e2, integer *nval, double *ab, double *c__, - integer *mout, integer *nab, double *work, integer *iwork, - integer *info) -{ - /* System generated locals */ - integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4, - i__5, i__6; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer j, kf, ji, kl, jp, jit; - double tmp1, tmp2; - integer itmp1, itmp2, kfnew, klnew; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAEBZ contains the iteration loops which compute and use the */ -/* function N(w), which is the count of eigenvalues of a symmetric */ -/* tridiagonal matrix T less than or equal to its argument w. It */ -/* performs a choice of two types of loops: */ - -/* IJOB=1, followed by */ -/* IJOB=2: It takes as input a list of intervals and returns a list of */ -/* sufficiently small intervals whose union contains the same */ -/* eigenvalues as the union of the original intervals. */ -/* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. */ -/* The output interval (AB(j,1),AB(j,2)] will contain */ -/* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. */ - -/* IJOB=3: It performs a binary search in each input interval */ -/* (AB(j,1),AB(j,2)] for a point w(j) such that */ -/* N(w(j))=NVAL(j), and uses C(j) as the starting point of */ -/* the search. If such a w(j) is found, then on output */ -/* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output */ -/* (AB(j,1),AB(j,2)] will be a small interval containing the */ -/* point where N(w) jumps through NVAL(j), unless that point */ -/* lies outside the initial interval. */ - -/* Note that the intervals are in all cases half-open intervals, */ -/* i.e., of the form (a,b] , which includes b but not a . */ - -/* To avoid underflow, the matrix should be scaled so that its largest */ -/* element is no greater than overflow**(1/2) * underflow**(1/4) */ -/* in absolute value. To assure the most accurate computation */ -/* of small eigenvalues, the matrix should be scaled to be */ -/* not much smaller than that, either. */ - -/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ -/* Matrix", Report CS41, Computer Science Dept., Stanford */ -/* University, July 21, 1966 */ - -/* Note: the arguments are, in general, *not* checked for unreasonable */ -/* values. */ - -/* Arguments */ -/* ========= */ - -/* IJOB (input) INTEGER */ -/* Specifies what is to be done: */ -/* = 1: Compute NAB for the initial intervals. */ -/* = 2: Perform bisection iteration to find eigenvalues of T. */ -/* = 3: Perform bisection iteration to invert N(w), i.e., */ -/* to find a point which has a specified number of */ -/* eigenvalues of T to its left. */ -/* Other values will cause DLAEBZ to return with INFO=-1. */ - -/* NITMAX (input) INTEGER */ -/* The maximum number of "levels" of bisection to be */ -/* performed, i.e., an interval of width W will not be made */ -/* smaller than 2^(-NITMAX) * W. If not all intervals */ -/* have converged after NITMAX iterations, then INFO is set */ -/* to the number of non-converged intervals. */ - -/* N (input) INTEGER */ -/* The dimension n of the tridiagonal matrix T. It must be at */ -/* least 1. */ - -/* MMAX (input) INTEGER */ -/* The maximum number of intervals. If more than MMAX intervals */ -/* are generated, then DLAEBZ will quit with INFO=MMAX+1. */ - -/* MINP (input) INTEGER */ -/* The initial number of intervals. It may not be greater than */ -/* MMAX. */ - -/* NBMIN (input) INTEGER */ -/* The smallest number of intervals that should be processed */ -/* using a vector loop. If zero, then only the scalar loop */ -/* will be used. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The minimum (absolute) width of an interval. When an */ -/* interval is narrower than ABSTOL, or than RELTOL times the */ -/* larger (in magnitude) endpoint, then it is considered to be */ -/* sufficiently small, i.e., converged. This must be at least */ -/* zero. */ - -/* RELTOL (input) DOUBLE PRECISION */ -/* The minimum relative width of an interval. When an interval */ -/* is narrower than ABSTOL, or than RELTOL times the larger (in */ -/* magnitude) endpoint, then it is considered to be */ -/* sufficiently small, i.e., converged. Note: this should */ -/* always be at least radix*machine epsilon. */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum absolute value of a "pivot" in the Sturm */ -/* sequence loop. This *must* be at least max |e(j)**2| * */ -/* safe_min and at least safe_min, where safe_min is at least */ -/* the smallest number that can divide one without overflow. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T. */ - -/* E (input) DOUBLE PRECISION array, dimension (N) */ -/* The offdiagonal elements of the tridiagonal matrix T in */ -/* positions 1 through N-1. E(N) is arbitrary. */ - -/* E2 (input) DOUBLE PRECISION array, dimension (N) */ -/* The squares of the offdiagonal elements of the tridiagonal */ -/* matrix T. E2(N) is ignored. */ - -/* NVAL (input/output) INTEGER array, dimension (MINP) */ -/* If IJOB=1 or 2, not referenced. */ -/* If IJOB=3, the desired values of N(w). The elements of NVAL */ -/* will be reordered to correspond with the intervals in AB. */ -/* Thus, NVAL(j) on output will not, in general be the same as */ -/* NVAL(j) on input, but it will correspond with the interval */ -/* (AB(j,1),AB(j,2)] on output. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2) */ -/* The endpoints of the intervals. AB(j,1) is a(j), the left */ -/* endpoint of the j-th interval, and AB(j,2) is b(j), the */ -/* right endpoint of the j-th interval. The input intervals */ -/* will, in general, be modified, split, and reordered by the */ -/* calculation. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (MMAX) */ -/* If IJOB=1, ignored. */ -/* If IJOB=2, workspace. */ -/* If IJOB=3, then on input C(j) should be initialized to the */ -/* first search point in the binary search. */ - -/* MOUT (output) INTEGER */ -/* If IJOB=1, the number of eigenvalues in the intervals. */ -/* If IJOB=2 or 3, the number of intervals output. */ -/* If IJOB=3, MOUT will equal MINP. */ - -/* NAB (input/output) INTEGER array, dimension (MMAX,2) */ -/* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). */ -/* If IJOB=2, then on input, NAB(i,j) should be set. It must */ -/* satisfy the condition: */ -/* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), */ -/* which means that in interval i only eigenvalues */ -/* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, */ -/* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with */ -/* IJOB=1. */ -/* On output, NAB(i,j) will contain */ -/* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of */ -/* the input interval that the output interval */ -/* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the */ -/* the input values of NAB(k,1) and NAB(k,2). */ -/* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), */ -/* unless N(w) > NVAL(i) for all search points w , in which */ -/* case NAB(i,1) will not be modified, i.e., the output */ -/* value will be the same as the input value (modulo */ -/* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) */ -/* for all search points w , in which case NAB(i,2) will */ -/* not be modified. Normally, NAB should be set to some */ -/* distinctive value(s) before DLAEBZ is called. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX) */ -/* Workspace. */ - -/* IWORK (workspace) INTEGER array, dimension (MMAX) */ -/* Workspace. */ - -/* INFO (output) INTEGER */ -/* = 0: All intervals converged. */ -/* = 1--MMAX: The last INFO intervals did not converge. */ -/* = MMAX+1: More than MMAX intervals were generated. */ - -/* Further Details */ -/* =============== */ - -/* This routine is intended to be called only by other LAPACK */ -/* routines, thus the interface is less user-friendly. It is intended */ -/* for two purposes: */ - -/* (a) finding eigenvalues. In this case, DLAEBZ should have one or */ -/* more initial intervals set up in AB, and DLAEBZ should be called */ -/* with IJOB=1. This sets up NAB, and also counts the eigenvalues. */ -/* Intervals with no eigenvalues would usually be thrown out at */ -/* this point. Also, if not all the eigenvalues in an interval i */ -/* are desired, NAB(i,1) can be increased or NAB(i,2) decreased. */ -/* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest */ -/* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX */ -/* no smaller than the value of MOUT returned by the call with */ -/* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 */ -/* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the */ -/* tolerance specified by ABSTOL and RELTOL. */ - -/* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). */ -/* In this case, start with a Gershgorin interval (a,b). Set up */ -/* AB to contain 2 search intervals, both initially (a,b). One */ -/* NVAL element should contain f-1 and the other should contain l */ -/* , while C should contain a and b, resp. NAB(i,1) should be -1 */ -/* and NAB(i,2) should be N+1, to flag an error if the desired */ -/* interval does not lie in (a,b). DLAEBZ is then called with */ -/* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- */ -/* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while */ -/* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r */ -/* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and */ -/* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and */ -/* w(l-r)=...=w(l+k) are handled similarly. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Check for Errors */ - - /* Parameter adjustments */ - nab_dim1 = *mmax; - nab_offset = 1 + nab_dim1; - nab -= nab_offset; - ab_dim1 = *mmax; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --d__; - --e; - --e2; - --nval; - --c__; - --work; - --iwork; - - /* Function Body */ - *info = 0; - if (*ijob < 1 || *ijob > 3) { - *info = -1; - return 0; - } - -/* Initialize NAB */ - - if (*ijob == 1) { - -/* Compute the number of eigenvalues in the initial intervals. */ - - *mout = 0; -/* DIR$ NOVECTOR */ - i__1 = *minp; - for (ji = 1; ji <= i__1; ++ji) { - for (jp = 1; jp <= 2; ++jp) { - tmp1 = d__[1] - ab[ji + jp * ab_dim1]; - if (abs(tmp1) < *pivmin) { - tmp1 = -(*pivmin); - } - nab[ji + jp * nab_dim1] = 0; - if (tmp1 <= 0.) { - nab[ji + jp * nab_dim1] = 1; - } - - i__2 = *n; - for (j = 2; j <= i__2; ++j) { - tmp1 = d__[j] - e2[j - 1] / tmp1 - ab[ji + jp * ab_dim1]; - if (abs(tmp1) < *pivmin) { - tmp1 = -(*pivmin); - } - if (tmp1 <= 0.) { - ++nab[ji + jp * nab_dim1]; - } -/* L10: */ - } -/* L20: */ - } - *mout = *mout + nab[ji + (nab_dim1 << 1)] - nab[ji + nab_dim1]; -/* L30: */ - } - return 0; - } - -/* Initialize for loop */ - -/* KF and KL have the following meaning: */ -/* Intervals 1,...,KF-1 have converged. */ -/* Intervals KF,...,KL still need to be refined. */ - - kf = 1; - kl = *minp; - -/* If IJOB=2, initialize C. */ -/* If IJOB=3, use the user-supplied starting point. */ - - if (*ijob == 2) { - i__1 = *minp; - for (ji = 1; ji <= i__1; ++ji) { - c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5; -/* L40: */ - } - } - -/* Iteration loop */ - - i__1 = *nitmax; - for (jit = 1; jit <= i__1; ++jit) { - -/* Loop over intervals */ - - if (kl - kf + 1 >= *nbmin && *nbmin > 0) { - -/* Begin of Parallel Version of the loop */ - - i__2 = kl; - for (ji = kf; ji <= i__2; ++ji) { - -/* Compute N(c), the number of eigenvalues less than c */ - - work[ji] = d__[1] - c__[ji]; - iwork[ji] = 0; - if (work[ji] <= *pivmin) { - iwork[ji] = 1; -/* Computing MIN */ - d__1 = work[ji], d__2 = -(*pivmin); - work[ji] = std::min(d__1,d__2); - } - - i__3 = *n; - for (j = 2; j <= i__3; ++j) { - work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji]; - if (work[ji] <= *pivmin) { - ++iwork[ji]; -/* Computing MIN */ - d__1 = work[ji], d__2 = -(*pivmin); - work[ji] = std::min(d__1,d__2); - } -/* L50: */ - } -/* L60: */ - } - - if (*ijob <= 2) { - -/* IJOB=2: Choose all intervals containing eigenvalues. */ - - klnew = kl; - i__2 = kl; - for (ji = kf; ji <= i__2; ++ji) { - -/* Insure that N(w) is monotone */ - -/* Computing MIN */ -/* Computing MAX */ - i__5 = nab[ji + nab_dim1], i__6 = iwork[ji]; - i__3 = nab[ji + (nab_dim1 << 1)], i__4 = std::max(i__5,i__6); - iwork[ji] = std::min(i__3,i__4); - -/* Update the Queue -- add intervals if both halves */ -/* contain eigenvalues. */ - - if (iwork[ji] == nab[ji + (nab_dim1 << 1)]) { - -/* No eigenvalue in the upper interval: */ -/* just use the lower interval. */ - - ab[ji + (ab_dim1 << 1)] = c__[ji]; - - } else if (iwork[ji] == nab[ji + nab_dim1]) { - -/* No eigenvalue in the lower interval: */ -/* just use the upper interval. */ - - ab[ji + ab_dim1] = c__[ji]; - } else { - ++klnew; - if (klnew <= *mmax) { - -/* Eigenvalue in both intervals -- add upper to */ -/* queue. */ - - ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << - 1)]; - nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 - << 1)]; - ab[klnew + ab_dim1] = c__[ji]; - nab[klnew + nab_dim1] = iwork[ji]; - ab[ji + (ab_dim1 << 1)] = c__[ji]; - nab[ji + (nab_dim1 << 1)] = iwork[ji]; - } else { - *info = *mmax + 1; - } - } -/* L70: */ - } - if (*info != 0) { - return 0; - } - kl = klnew; - } else { - -/* IJOB=3: Binary search. Keep only the interval containing */ -/* w s.t. N(w) = NVAL */ - - i__2 = kl; - for (ji = kf; ji <= i__2; ++ji) { - if (iwork[ji] <= nval[ji]) { - ab[ji + ab_dim1] = c__[ji]; - nab[ji + nab_dim1] = iwork[ji]; - } - if (iwork[ji] >= nval[ji]) { - ab[ji + (ab_dim1 << 1)] = c__[ji]; - nab[ji + (nab_dim1 << 1)] = iwork[ji]; - } -/* L80: */ - } - } - - } else { - -/* End of Parallel Version of the loop */ - -/* Begin of Serial Version of the loop */ - - klnew = kl; - i__2 = kl; - for (ji = kf; ji <= i__2; ++ji) { - -/* Compute N(w), the number of eigenvalues less than w */ - - tmp1 = c__[ji]; - tmp2 = d__[1] - tmp1; - itmp1 = 0; - if (tmp2 <= *pivmin) { - itmp1 = 1; -/* Computing MIN */ - d__1 = tmp2, d__2 = -(*pivmin); - tmp2 = std::min(d__1,d__2); - } - -/* A series of compiler directives to defeat vectorization */ -/* for the next loop */ - -/* $PL$ CMCHAR=' ' */ -/* DIR$ NEXTSCALAR */ -/* $DIR SCALAR */ -/* DIR$ NEXT SCALAR */ -/* VD$L NOVECTOR */ -/* DEC$ NOVECTOR */ -/* VD$ NOVECTOR */ -/* VDIR NOVECTOR */ -/* VOCL LOOP,SCALAR */ -/* IBM PREFER SCALAR */ -/* $PL$ CMCHAR='*' */ - - i__3 = *n; - for (j = 2; j <= i__3; ++j) { - tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1; - if (tmp2 <= *pivmin) { - ++itmp1; -/* Computing MIN */ - d__1 = tmp2, d__2 = -(*pivmin); - tmp2 = std::min(d__1,d__2); - } -/* L90: */ - } - - if (*ijob <= 2) { - -/* IJOB=2: Choose all intervals containing eigenvalues. */ - -/* Insure that N(w) is monotone */ - -/* Computing MIN */ -/* Computing MAX */ - i__5 = nab[ji + nab_dim1]; - i__3 = nab[ji + (nab_dim1 << 1)], i__4 = std::max(i__5,itmp1); - itmp1 = std::min(i__3,i__4); - -/* Update the Queue -- add intervals if both halves */ -/* contain eigenvalues. */ - - if (itmp1 == nab[ji + (nab_dim1 << 1)]) { - -/* No eigenvalue in the upper interval: */ -/* just use the lower interval. */ - - ab[ji + (ab_dim1 << 1)] = tmp1; - - } else if (itmp1 == nab[ji + nab_dim1]) { - -/* No eigenvalue in the lower interval: */ -/* just use the upper interval. */ - - ab[ji + ab_dim1] = tmp1; - } else if (klnew < *mmax) { - -/* Eigenvalue in both intervals -- add upper to queue. */ - - ++klnew; - ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 1)]; - nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 << - 1)]; - ab[klnew + ab_dim1] = tmp1; - nab[klnew + nab_dim1] = itmp1; - ab[ji + (ab_dim1 << 1)] = tmp1; - nab[ji + (nab_dim1 << 1)] = itmp1; - } else { - *info = *mmax + 1; - return 0; - } - } else { - -/* IJOB=3: Binary search. Keep only the interval */ -/* containing w s.t. N(w) = NVAL */ - - if (itmp1 <= nval[ji]) { - ab[ji + ab_dim1] = tmp1; - nab[ji + nab_dim1] = itmp1; - } - if (itmp1 >= nval[ji]) { - ab[ji + (ab_dim1 << 1)] = tmp1; - nab[ji + (nab_dim1 << 1)] = itmp1; - } - } -/* L100: */ - } - kl = klnew; - -/* End of Serial Version of the loop */ - - } - -/* Check for convergence */ - - kfnew = kf; - i__2 = kl; - for (ji = kf; ji <= i__2; ++ji) { - tmp1 = (d__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], abs( - d__1)); -/* Computing MAX */ - d__3 = (d__1 = ab[ji + (ab_dim1 << 1)], abs(d__1)), d__4 = (d__2 = - ab[ji + ab_dim1], abs(d__2)); - tmp2 = std::max(d__3,d__4); -/* Computing MAX */ - d__1 = std::max(*abstol,*pivmin), d__2 = *reltol * tmp2; - if (tmp1 < std::max(d__1,d__2) || nab[ji + nab_dim1] >= nab[ji + ( - nab_dim1 << 1)]) { - -/* Converged -- Swap with position KFNEW, */ -/* then increment KFNEW */ - - if (ji > kfnew) { - tmp1 = ab[ji + ab_dim1]; - tmp2 = ab[ji + (ab_dim1 << 1)]; - itmp1 = nab[ji + nab_dim1]; - itmp2 = nab[ji + (nab_dim1 << 1)]; - ab[ji + ab_dim1] = ab[kfnew + ab_dim1]; - ab[ji + (ab_dim1 << 1)] = ab[kfnew + (ab_dim1 << 1)]; - nab[ji + nab_dim1] = nab[kfnew + nab_dim1]; - nab[ji + (nab_dim1 << 1)] = nab[kfnew + (nab_dim1 << 1)]; - ab[kfnew + ab_dim1] = tmp1; - ab[kfnew + (ab_dim1 << 1)] = tmp2; - nab[kfnew + nab_dim1] = itmp1; - nab[kfnew + (nab_dim1 << 1)] = itmp2; - if (*ijob == 3) { - itmp1 = nval[ji]; - nval[ji] = nval[kfnew]; - nval[kfnew] = itmp1; - } - } - ++kfnew; - } -/* L110: */ - } - kf = kfnew; - -/* Choose Midpoints */ - - i__2 = kl; - for (ji = kf; ji <= i__2; ++ji) { - c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5; -/* L120: */ - } - -/* If no more intervals to refine, quit. */ - - if (kf > kl) { - goto L140; - } -/* L130: */ - } - -/* Converged */ - -L140: -/* Computing MAX */ - i__1 = kl + 1 - kf; - *info = std::max(i__1,0_integer); - *mout = kl; - - return 0; - -/* End of DLAEBZ */ - -} /* dlaebz_ */ diff --git a/external/clapack/lapack/dlaed0.cpp b/external/clapack/lapack/dlaed0.cpp deleted file mode 100644 index 914cfb29..00000000 --- a/external/clapack/lapack/dlaed0.cpp +++ /dev/null @@ -1,404 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__9 = 9; -static integer c__0 = 0; -static integer c__2 = 2; -static double c_b23 = 1.; -static double c_b24 = 0.; -static integer c__1 = 1; - -/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n, - double *d__, double *e, double *q, integer *ldq, - double *qstore, integer *ldqs, double *work, integer *iwork, - integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2; - double temp; - integer curr; - integer iperm; - integer indxq, iwrem; - integer iqptr; - integer tlvls; - integer igivcl; - integer igivnm, submat, curprb, subpbs, igivpt; - integer curlvl, matsiz, iprmpt, smlsiz; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAED0 computes all eigenvalues and corresponding eigenvectors of a */ -/* symmetric tridiagonal matrix using the divide and conquer method. */ - -/* Arguments */ -/* ========= */ - -/* ICOMPQ (input) INTEGER */ -/* = 0: Compute eigenvalues only. */ -/* = 1: Compute eigenvectors of original dense symmetric matrix */ -/* also. On entry, Q contains the orthogonal matrix used */ -/* to reduce the original matrix to tridiagonal form. */ -/* = 2: Compute eigenvalues and eigenvectors of tridiagonal */ -/* matrix. */ - -/* QSIZ (input) INTEGER */ -/* The dimension of the orthogonal matrix used to reduce */ -/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ - -/* N (input) INTEGER */ -/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the main diagonal of the tridiagonal matrix. */ -/* On exit, its eigenvalues. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ -/* On entry, Q must contain an N-by-N orthogonal matrix. */ -/* If ICOMPQ = 0 Q is not referenced. */ -/* If ICOMPQ = 1 On entry, Q is a subset of the columns of the */ -/* orthogonal matrix used to reduce the full */ -/* matrix to tridiagonal form corresponding to */ -/* the subset of the full matrix which is being */ -/* decomposed at this time. */ -/* If ICOMPQ = 2 On entry, Q will be the identity matrix. */ -/* On exit, Q contains the eigenvectors of the */ -/* tridiagonal matrix. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. If eigenvectors are */ -/* desired, then LDQ >= max(1,N). In any case, LDQ >= 1. */ - -/* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N) */ -/* Referenced only when ICOMPQ = 1. Used to store parts of */ -/* the eigenvector matrix when the updating matrix multiplies */ -/* take place. */ - -/* LDQS (input) INTEGER */ -/* The leading dimension of the array QSTORE. If ICOMPQ = 1, */ -/* then LDQS >= max(1,N). In any case, LDQS >= 1. */ - -/* WORK (workspace) DOUBLE PRECISION array, */ -/* If ICOMPQ = 0 or 1, the dimension of WORK must be at least */ -/* 1 + 3*N + 2*N*lg N + 2*N**2 */ -/* ( lg( N ) = smallest integer k */ -/* such that 2^k >= N ) */ -/* If ICOMPQ = 2, the dimension of WORK must be at least */ -/* 4*N + N**2. */ - -/* IWORK (workspace) INTEGER array, */ -/* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least */ -/* 6 + 6*N + 5*N*lg N. */ -/* ( lg( N ) = smallest integer k */ -/* such that 2^k >= N ) */ -/* If ICOMPQ = 2, the dimension of IWORK must be at least */ -/* 3 + 5*N. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: The algorithm failed to compute an eigenvalue while */ -/* working on the submatrix lying in rows and columns */ -/* INFO/(N+1) through mod(INFO,N+1). */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - qstore_dim1 = *ldqs; - qstore_offset = 1 + qstore_dim1; - qstore -= qstore_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - - if (*icompq < 0 || *icompq > 2) { - *info = -1; - } else if (*icompq == 1 && *qsiz < std::max(0_integer,*n)) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ldq < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldqs < std::max(1_integer,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAED0", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - smlsiz = ilaenv_(&c__9, "DLAED0", " ", &c__0, &c__0, &c__0, &c__0); - -/* Determine the size and placement of the submatrices, and save in */ -/* the leading elements of IWORK. */ - - iwork[1] = *n; - subpbs = 1; - tlvls = 0; -L10: - if (iwork[subpbs] > smlsiz) { - for (j = subpbs; j >= 1; --j) { - iwork[j * 2] = (iwork[j] + 1) / 2; - iwork[(j << 1) - 1] = iwork[j] / 2; -/* L20: */ - } - ++tlvls; - subpbs <<= 1; - goto L10; - } - i__1 = subpbs; - for (j = 2; j <= i__1; ++j) { - iwork[j] += iwork[j - 1]; -/* L30: */ - } - -/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */ -/* using rank-1 modifications (cuts). */ - - spm1 = subpbs - 1; - i__1 = spm1; - for (i__ = 1; i__ <= i__1; ++i__) { - submat = iwork[i__] + 1; - smm1 = submat - 1; - d__[smm1] -= (d__1 = e[smm1], abs(d__1)); - d__[submat] -= (d__1 = e[smm1], abs(d__1)); -/* L40: */ - } - - indxq = (*n << 2) + 3; - if (*icompq != 2) { - -/* Set up workspaces for eigenvalues only/accumulate new vectors */ -/* routine */ - - temp = log((double) (*n)) / log(2.); - lgn = (integer) temp; - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - iprmpt = indxq + *n + 1; - iperm = iprmpt + *n * lgn; - iqptr = iperm + *n * lgn; - igivpt = iqptr + *n + 2; - igivcl = igivpt + *n * lgn; - - igivnm = 1; - iq = igivnm + (*n << 1) * lgn; -/* Computing 2nd power */ - i__1 = *n; - iwrem = iq + i__1 * i__1 + 1; - -/* Initialize pointers */ - - i__1 = subpbs; - for (i__ = 0; i__ <= i__1; ++i__) { - iwork[iprmpt + i__] = 1; - iwork[igivpt + i__] = 1; -/* L50: */ - } - iwork[iqptr] = 1; - } - -/* Solve each submatrix eigenproblem at the bottom of the divide and */ -/* conquer tree. */ - - curr = 0; - i__1 = spm1; - for (i__ = 0; i__ <= i__1; ++i__) { - if (i__ == 0) { - submat = 1; - matsiz = iwork[1]; - } else { - submat = iwork[i__] + 1; - matsiz = iwork[i__ + 1] - iwork[i__]; - } - if (*icompq == 2) { - dsteqr_("I", &matsiz, &d__[submat], &e[submat], &q[submat + - submat * q_dim1], ldq, &work[1], info); - if (*info != 0) { - goto L130; - } - } else { - dsteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + - iwork[iqptr + curr]], &matsiz, &work[1], info); - if (*info != 0) { - goto L130; - } - if (*icompq == 1) { - dgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * - q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]], - &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1], - ldqs); - } -/* Computing 2nd power */ - i__2 = matsiz; - iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; - ++curr; - } - k = 1; - i__2 = iwork[i__ + 1]; - for (j = submat; j <= i__2; ++j) { - iwork[indxq + j] = k; - ++k; -/* L60: */ - } -/* L70: */ - } - -/* Successively merge eigensystems of adjacent submatrices */ -/* into eigensystem for the corresponding larger matrix. */ - -/* while ( SUBPBS > 1 ) */ - - curlvl = 1; -L80: - if (subpbs > 1) { - spm2 = subpbs - 2; - i__1 = spm2; - for (i__ = 0; i__ <= i__1; i__ += 2) { - if (i__ == 0) { - submat = 1; - matsiz = iwork[2]; - msd2 = iwork[1]; - curprb = 0; - } else { - submat = iwork[i__] + 1; - matsiz = iwork[i__ + 2] - iwork[i__]; - msd2 = matsiz / 2; - ++curprb; - } - -/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */ -/* into an eigensystem of size MATSIZ. */ -/* DLAED1 is used only for the full eigensystem of a tridiagonal */ -/* matrix. */ -/* DLAED7 handles the cases in which eigenvalues only or eigenvalues */ -/* and eigenvectors of a full symmetric matrix (which was reduced to */ -/* tridiagonal form) are desired. */ - - if (*icompq == 2) { - dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], - ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], & - msd2, &work[1], &iwork[subpbs + 1], info); - } else { - dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[ - submat], &qstore[submat * qstore_dim1 + 1], ldqs, & - iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, & - work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm] -, &iwork[igivpt], &iwork[igivcl], &work[igivnm], & - work[iwrem], &iwork[subpbs + 1], info); - } - if (*info != 0) { - goto L130; - } - iwork[i__ / 2 + 1] = iwork[i__ + 2]; -/* L90: */ - } - subpbs /= 2; - ++curlvl; - goto L80; - } - -/* end while */ - -/* Re-merge the eigenvalues/vectors which were deflated at the final */ -/* merge step. */ - - if (*icompq == 1) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - j = iwork[indxq + i__]; - work[i__] = d__[j]; - dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 - + 1], &c__1); -/* L100: */ - } - dcopy_(n, &work[1], &c__1, &d__[1], &c__1); - } else if (*icompq == 2) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - j = iwork[indxq + i__]; - work[i__] = d__[j]; - dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); -/* L110: */ - } - dcopy_(n, &work[1], &c__1, &d__[1], &c__1); - dlacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq); - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - j = iwork[indxq + i__]; - work[i__] = d__[j]; -/* L120: */ - } - dcopy_(n, &work[1], &c__1, &d__[1], &c__1); - } - goto L140; - -L130: - *info = submat * (*n + 1) + submat + matsiz - 1; - -L140: - return 0; - -/* End of DLAED0 */ - -} /* dlaed0_ */ diff --git a/external/clapack/lapack/dlaed1.cpp b/external/clapack/lapack/dlaed1.cpp deleted file mode 100644 index 6f7e1843..00000000 --- a/external/clapack/lapack/dlaed1.cpp +++ /dev/null @@ -1,226 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dlaed1_(integer *n, double *d__, double *q, - integer *ldq, integer *indxq, double *rho, integer *cutpnt, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, i__1, i__2; - - /* Local variables */ - integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc; - integer indxp; - integer idlmda; - integer coltyp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAED1 computes the updated eigensystem of a diagonal */ -/* matrix after modification by a rank-one symmetric matrix. This */ -/* routine is used only for the eigenproblem which requires all */ -/* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles */ -/* the case in which eigenvalues only or eigenvalues and eigenvectors */ -/* of a full symmetric matrix (which was reduced to tridiagonal form) */ -/* are desired. */ - -/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */ - -/* where Z = Q'u, u is a vector of length N with ones in the */ -/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */ - -/* The eigenvectors of the original matrix are stored in Q, and the */ -/* eigenvalues are in D. The algorithm consists of three stages: */ - -/* The first stage consists of deflating the size of the problem */ -/* when there are multiple eigenvalues or if there is a zero in */ -/* the Z vector. For each such occurence the dimension of the */ -/* secular equation problem is reduced by one. This stage is */ -/* performed by the routine DLAED2. */ - -/* The second stage consists of calculating the updated */ -/* eigenvalues. This is done by finding the roots of the secular */ -/* equation via the routine DLAED4 (as called by DLAED3). */ -/* This routine also calculates the eigenvectors of the current */ -/* problem. */ - -/* The final stage consists of computing the updated eigenvectors */ -/* directly using the updated eigenvalues. The eigenvectors for */ -/* the current problem are multiplied with the eigenvectors from */ -/* the overall problem. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the eigenvalues of the rank-1-perturbed matrix. */ -/* On exit, the eigenvalues of the repaired matrix. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* On entry, the eigenvectors of the rank-1-perturbed matrix. */ -/* On exit, the eigenvectors of the repaired tridiagonal matrix. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N). */ - -/* INDXQ (input/output) INTEGER array, dimension (N) */ -/* On entry, the permutation which separately sorts the two */ -/* subproblems in D into ascending order. */ -/* On exit, the permutation which will reintegrate the */ -/* subproblems back into sorted order, */ -/* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. */ - -/* RHO (input) DOUBLE PRECISION */ -/* The subdiagonal entry used to create the rank-1 modification. */ - -/* CUTPNT (input) INTEGER */ -/* The location of the last eigenvalue in the leading sub-matrix. */ -/* min(1,N) <= CUTPNT <= N/2. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2) */ - -/* IWORK (workspace) INTEGER array, dimension (4*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an eigenvalue did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ -/* Modified by Francoise Tisseur, University of Tennessee. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --indxq; - --work; - --iwork; - - /* Function Body */ - *info = 0; - - if (*n < 0) { - *info = -1; - } else if (*ldq < std::max(1_integer,*n)) { - *info = -4; - } else /* if(complicated condition) */ { -/* Computing MIN */ - i__1 = 1, i__2 = *n / 2; - if (std::min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) { - *info = -7; - } - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAED1", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* The following values are integer pointers which indicate */ -/* the portion of the workspace */ -/* used by a particular array in DLAED2 and DLAED3. */ - - iz = 1; - idlmda = iz + *n; - iw = idlmda + *n; - iq2 = iw + *n; - - indx = 1; - indxc = indx + *n; - coltyp = indxc + *n; - indxp = coltyp + *n; - - -/* Form the z-vector which consists of the last row of Q_1 and the */ -/* first row of Q_2. */ - - dcopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1); - zpp1 = *cutpnt + 1; - i__1 = *n - *cutpnt; - dcopy_(&i__1, &q[zpp1 + zpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1); - -/* Deflate eigenvalues. */ - - dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[ - iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[ - indxc], &iwork[indxp], &iwork[coltyp], info); - - if (*info != 0) { - goto L20; - } - -/* Solve Secular Equation. */ - - if (k != 0) { - is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp + - 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2; - dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], - &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[ - is], info); - if (*info != 0) { - goto L20; - } - -/* Prepare the INDXQ sorting permutation. */ - - n1 = k; - n2 = *n - k; - dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - indxq[i__] = i__; -/* L10: */ - } - } - -L20: - return 0; - -/* End of DLAED1 */ - -} /* dlaed1_ */ diff --git a/external/clapack/lapack/dlaed2.cpp b/external/clapack/lapack/dlaed2.cpp deleted file mode 100644 index ea323a29..00000000 --- a/external/clapack/lapack/dlaed2.cpp +++ /dev/null @@ -1,510 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b3 = -1.; -static integer c__1 = 1; - -/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, double * - d__, double *q, integer *ldq, integer *indxq, double *rho, - double *z__, double *dlamda, double *w, double *q2, - integer *indx, integer *indxc, integer *indxp, integer *coltyp, - integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, i__1, i__2; - double d__1, d__2, d__3, d__4; - - /* Builtin functions - double sqrt(double);*/ - - /* Local variables */ - double c__; - integer i__, j; - double s, t; - integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1; - double eps, tau, tol; - integer psm[4], imax, jmax; - integer ctot[4]; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAED2 merges the two sets of eigenvalues together into a single */ -/* sorted set. Then it tries to deflate the size of the problem. */ -/* There are two ways in which deflation can occur: when two or more */ -/* eigenvalues are close together or if there is a tiny entry in the */ -/* Z vector. For each such occurrence the order of the related secular */ -/* equation problem is reduced by one. */ - -/* Arguments */ -/* ========= */ - -/* K (output) INTEGER */ -/* The number of non-deflated eigenvalues, and the order of the */ -/* related secular equation. 0 <= K <=N. */ - -/* N (input) INTEGER */ -/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ - -/* N1 (input) INTEGER */ -/* The location of the last eigenvalue in the leading sub-matrix. */ -/* min(1,N) <= N1 <= N/2. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, D contains the eigenvalues of the two submatrices to */ -/* be combined. */ -/* On exit, D contains the trailing (N-K) updated eigenvalues */ -/* (those which were deflated) sorted into increasing order. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ -/* On entry, Q contains the eigenvectors of two submatrices in */ -/* the two square blocks with corners at (1,1), (N1,N1) */ -/* and (N1+1, N1+1), (N,N). */ -/* On exit, Q contains the trailing (N-K) updated eigenvectors */ -/* (those which were deflated) in its last N-K columns. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N). */ - -/* INDXQ (input/output) INTEGER array, dimension (N) */ -/* The permutation which separately sorts the two sub-problems */ -/* in D into ascending order. Note that elements in the second */ -/* half of this permutation must first have N1 added to their */ -/* values. Destroyed on exit. */ - -/* RHO (input/output) DOUBLE PRECISION */ -/* On entry, the off-diagonal element associated with the rank-1 */ -/* cut which originally split the two submatrices which are now */ -/* being recombined. */ -/* On exit, RHO has been modified to the value required by */ -/* DLAED3. */ - -/* Z (input) DOUBLE PRECISION array, dimension (N) */ -/* On entry, Z contains the updating vector (the last */ -/* row of the first sub-eigenvector matrix and the first row of */ -/* the second sub-eigenvector matrix). */ -/* On exit, the contents of Z have been destroyed by the updating */ -/* process. */ - -/* DLAMDA (output) DOUBLE PRECISION array, dimension (N) */ -/* A copy of the first K eigenvalues which will be used by */ -/* DLAED3 to form the secular equation. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first k values of the final deflation-altered z-vector */ -/* which will be passed to DLAED3. */ - -/* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) */ -/* A copy of the first K eigenvectors which will be used by */ -/* DLAED3 in a matrix multiply (DGEMM) to solve for the new */ -/* eigenvectors. */ - -/* INDX (workspace) INTEGER array, dimension (N) */ -/* The permutation used to sort the contents of DLAMDA into */ -/* ascending order. */ - -/* INDXC (output) INTEGER array, dimension (N) */ -/* The permutation used to arrange the columns of the deflated */ -/* Q matrix into three groups: the first group contains non-zero */ -/* elements only at and above N1, the second contains */ -/* non-zero elements only below N1, and the third is dense. */ - -/* INDXP (workspace) INTEGER array, dimension (N) */ -/* The permutation used to place deflated values of D at the end */ -/* of the array. INDXP(1:K) points to the nondeflated D-values */ -/* and INDXP(K+1:N) points to the deflated eigenvalues. */ - -/* COLTYP (workspace/output) INTEGER array, dimension (N) */ -/* During execution, a label which will indicate which of the */ -/* following types a column in the Q2 matrix is: */ -/* 1 : non-zero in the upper half only; */ -/* 2 : dense; */ -/* 3 : non-zero in the lower half only; */ -/* 4 : deflated. */ -/* On exit, COLTYP(i) is the number of columns of type i, */ -/* for i=1 to 4 only. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ -/* Modified by Francoise Tisseur, University of Tennessee. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --indxq; - --z__; - --dlamda; - --w; - --q2; - --indx; - --indxc; - --indxp; - --coltyp; - - /* Function Body */ - *info = 0; - - if (*n < 0) { - *info = -2; - } else if (*ldq < std::max(1_integer,*n)) { - *info = -6; - } else /* if(complicated condition) */ { -/* Computing MIN */ - i__1 = 1, i__2 = *n / 2; - if (std::min(i__1,i__2) > *n1 || *n / 2 < *n1) { - *info = -3; - } - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAED2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - n2 = *n - *n1; - n1p1 = *n1 + 1; - - if (*rho < 0.) { - dscal_(&n2, &c_b3, &z__[n1p1], &c__1); - } - -/* Normalize z so that norm(z) = 1. Since z is the concatenation of */ -/* two normalized vectors, norm2(z) = sqrt(2). */ - - t = 1. / sqrt(2.); - dscal_(n, &t, &z__[1], &c__1); - -/* RHO = ABS( norm(z)**2 * RHO ) */ - - *rho = (d__1 = *rho * 2., abs(d__1)); - -/* Sort the eigenvalues into increasing order */ - - i__1 = *n; - for (i__ = n1p1; i__ <= i__1; ++i__) { - indxq[i__] += *n1; -/* L10: */ - } - -/* re-integrate the deflated parts from the last pass */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = d__[indxq[i__]]; -/* L20: */ - } - dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - indx[i__] = indxq[indxc[i__]]; -/* L30: */ - } - -/* Calculate the allowable deflation tolerance */ - - imax = idamax_(n, &z__[1], &c__1); - jmax = idamax_(n, &d__[1], &c__1); - eps = dlamch_("Epsilon"); -/* Computing MAX */ - d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2)) - ; - tol = eps * 8. * std::max(d__3,d__4); - -/* If the rank-1 modifier is small enough, no more needs to be done */ -/* except to reorganize Q so that its columns correspond with the */ -/* elements in D. */ - - if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { - *k = 0; - iq2 = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__ = indx[j]; - dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); - dlamda[j] = d__[i__]; - iq2 += *n; -/* L40: */ - } - dlacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq); - dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1); - goto L190; - } - -/* If there are multiple eigenvalues then the problem deflates. Here */ -/* the number of equal eigenvalues are found. As each equal */ -/* eigenvalue is found, an elementary reflector is computed to rotate */ -/* the corresponding eigensubspace so that the corresponding */ -/* components of Z are zero in this new basis. */ - - i__1 = *n1; - for (i__ = 1; i__ <= i__1; ++i__) { - coltyp[i__] = 1; -/* L50: */ - } - i__1 = *n; - for (i__ = n1p1; i__ <= i__1; ++i__) { - coltyp[i__] = 3; -/* L60: */ - } - - - *k = 0; - k2 = *n + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - nj = indx[j]; - if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - coltyp[nj] = 4; - indxp[k2] = nj; - if (j == *n) { - goto L100; - } - } else { - pj = nj; - goto L80; - } -/* L70: */ - } -L80: - ++j; - nj = indx[j]; - if (j > *n) { - goto L100; - } - if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - coltyp[nj] = 4; - indxp[k2] = nj; - } else { - -/* Check if eigenvalues are close enough to allow deflation. */ - - s = z__[pj]; - c__ = z__[nj]; - -/* Find sqrt(a**2+b**2) without overflow or */ -/* destructive underflow. */ - - tau = dlapy2_(&c__, &s); - t = d__[nj] - d__[pj]; - c__ /= tau; - s = -s / tau; - if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { - -/* Deflation is possible. */ - - z__[nj] = tau; - z__[pj] = 0.; - if (coltyp[nj] != coltyp[pj]) { - coltyp[nj] = 2; - } - coltyp[pj] = 4; - drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, & - c__, &s); -/* Computing 2nd power */ - d__1 = c__; -/* Computing 2nd power */ - d__2 = s; - t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); -/* Computing 2nd power */ - d__1 = s; -/* Computing 2nd power */ - d__2 = c__; - d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); - d__[pj] = t; - --k2; - i__ = 1; -L90: - if (k2 + i__ <= *n) { - if (d__[pj] < d__[indxp[k2 + i__]]) { - indxp[k2 + i__ - 1] = indxp[k2 + i__]; - indxp[k2 + i__] = pj; - ++i__; - goto L90; - } else { - indxp[k2 + i__ - 1] = pj; - } - } else { - indxp[k2 + i__ - 1] = pj; - } - pj = nj; - } else { - ++(*k); - dlamda[*k] = d__[pj]; - w[*k] = z__[pj]; - indxp[*k] = pj; - pj = nj; - } - } - goto L80; -L100: - -/* Record the last eigenvalue. */ - - ++(*k); - dlamda[*k] = d__[pj]; - w[*k] = z__[pj]; - indxp[*k] = pj; - -/* Count up the total number of the various types of columns, then */ -/* form a permutation which positions the four column types into */ -/* four uniform groups (although one or more of these groups may be */ -/* empty). */ - - for (j = 1; j <= 4; ++j) { - ctot[j - 1] = 0; -/* L110: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - ct = coltyp[j]; - ++ctot[ct - 1]; -/* L120: */ - } - -/* PSM(*) = Position in SubMatrix (of types 1 through 4) */ - - psm[0] = 1; - psm[1] = ctot[0] + 1; - psm[2] = psm[1] + ctot[1]; - psm[3] = psm[2] + ctot[2]; - *k = *n - ctot[3]; - -/* Fill out the INDXC array so that the permutation which it induces */ -/* will place all type-1 columns first, all type-2 columns next, */ -/* then all type-3's, and finally all type-4's. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - js = indxp[j]; - ct = coltyp[js]; - indx[psm[ct - 1]] = js; - indxc[psm[ct - 1]] = j; - ++psm[ct - 1]; -/* L130: */ - } - -/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */ -/* and Q2 respectively. The eigenvalues/vectors which were not */ -/* deflated go into the first K slots of DLAMDA and Q2 respectively, */ -/* while those which were deflated go into the last N - K slots. */ - - i__ = 1; - iq1 = 1; - iq2 = (ctot[0] + ctot[1]) * *n1 + 1; - i__1 = ctot[0]; - for (j = 1; j <= i__1; ++j) { - js = indx[i__]; - dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); - z__[i__] = d__[js]; - ++i__; - iq1 += *n1; -/* L140: */ - } - - i__1 = ctot[1]; - for (j = 1; j <= i__1; ++j) { - js = indx[i__]; - dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); - dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); - z__[i__] = d__[js]; - ++i__; - iq1 += *n1; - iq2 += n2; -/* L150: */ - } - - i__1 = ctot[2]; - for (j = 1; j <= i__1; ++j) { - js = indx[i__]; - dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); - z__[i__] = d__[js]; - ++i__; - iq2 += n2; -/* L160: */ - } - - iq1 = iq2; - i__1 = ctot[3]; - for (j = 1; j <= i__1; ++j) { - js = indx[i__]; - dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1); - iq2 += *n; - z__[i__] = d__[js]; - ++i__; -/* L170: */ - } - -/* The deflated eigenvalues and their corresponding vectors go back */ -/* into the last N - K slots of D and Q respectively. */ - - dlacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq); - i__1 = *n - *k; - dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); - -/* Copy CTOT into COLTYP for referencing in DLAED3. */ - - for (j = 1; j <= 4; ++j) { - coltyp[j] = ctot[j - 1]; -/* L180: */ - } - -L190: - return 0; - -/* End of DLAED2 */ - -} /* dlaed2_ */ diff --git a/external/clapack/lapack/dlaed3.cpp b/external/clapack/lapack/dlaed3.cpp deleted file mode 100644 index 9ae45496..00000000 --- a/external/clapack/lapack/dlaed3.cpp +++ /dev/null @@ -1,313 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b22 = 1.; -static double c_b23 = 0.; - -/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, double * - d__, double *q, integer *ldq, double *rho, double *dlamda, - double *q2, integer *indx, integer *ctot, double *w, - double *s, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, i__1, i__2; - double d__1; - - /* Builtin functions - double sqrt(double), d_sign(double *, double *);*/ - - /* Local variables */ - integer i__, j, n2, n12, ii, n23, iq2; - double temp; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAED3 finds the roots of the secular equation, as defined by the */ -/* values in D, W, and RHO, between 1 and K. It makes the */ -/* appropriate calls to DLAED4 and then updates the eigenvectors by */ -/* multiplying the matrix of eigenvectors of the pair of eigensystems */ -/* being combined by the matrix of eigenvectors of the K-by-K system */ -/* which is solved here. */ - -/* This code makes very mild assumptions about floating point */ -/* arithmetic. It will work on machines with a guard digit in */ -/* add/subtract, or on those binary machines without guard digits */ -/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ -/* It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* K (input) INTEGER */ -/* The number of terms in the rational function to be solved by */ -/* DLAED4. K >= 0. */ - -/* N (input) INTEGER */ -/* The number of rows and columns in the Q matrix. */ -/* N >= K (deflation may result in N>K). */ - -/* N1 (input) INTEGER */ -/* The location of the last eigenvalue in the leading submatrix. */ -/* min(1,N) <= N1 <= N/2. */ - -/* D (output) DOUBLE PRECISION array, dimension (N) */ -/* D(I) contains the updated eigenvalues for */ -/* 1 <= I <= K. */ - -/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* Initially the first K columns are used as workspace. */ -/* On output the columns 1 to K contain */ -/* the updated eigenvectors. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N). */ - -/* RHO (input) DOUBLE PRECISION */ -/* The value of the parameter in the rank one update equation. */ -/* RHO >= 0 required. */ - -/* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K) */ -/* The first K elements of this array contain the old roots */ -/* of the deflated updating problem. These are the poles */ -/* of the secular equation. May be changed on output by */ -/* having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */ -/* Cray-2, or Cray C-90, as described above. */ - -/* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N) */ -/* The first K columns of this matrix contain the non-deflated */ -/* eigenvectors for the split problem. */ - -/* INDX (input) INTEGER array, dimension (N) */ -/* The permutation used to arrange the columns of the deflated */ -/* Q matrix into three groups (see DLAED2). */ -/* The rows of the eigenvectors found by DLAED4 must be likewise */ -/* permuted before the matrix multiply can take place. */ - -/* CTOT (input) INTEGER array, dimension (4) */ -/* A count of the total number of the various types of columns */ -/* in Q, as described in INDX. The fourth column type is any */ -/* column which has been deflated. */ - -/* W (input/output) DOUBLE PRECISION array, dimension (K) */ -/* The first K elements of this array contain the components */ -/* of the deflation-adjusted updating vector. Destroyed on */ -/* output. */ - -/* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K */ -/* Will contain the eigenvectors of the repaired matrix which */ -/* will be multiplied by the previously accumulated eigenvectors */ -/* to update the system. */ - -/* LDS (input) INTEGER */ -/* The leading dimension of S. LDS >= max(1,K). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an eigenvalue did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ -/* Modified by Francoise Tisseur, University of Tennessee. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --dlamda; - --q2; - --indx; - --ctot; - --w; - --s; - - /* Function Body */ - *info = 0; - - if (*k < 0) { - *info = -1; - } else if (*n < *k) { - *info = -2; - } else if (*ldq < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAED3", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*k == 0) { - return 0; - } - -/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ -/* be computed with high relative accuracy (barring over/underflow). */ -/* This is a problem on machines without a guard digit in */ -/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ -/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */ -/* which on any of these machines zeros out the bottommost */ -/* bit of DLAMDA(I) if it is 1; this makes the subsequent */ -/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */ -/* occurs. On binary machines with a guard digit (almost all */ -/* machines) it does not change DLAMDA(I) at all. On hexadecimal */ -/* and decimal machines with a guard digit, it slightly */ -/* changes the bottommost bits of DLAMDA(I). It does not account */ -/* for hexadecimal or decimal machines without guard digits */ -/* (we know of none). We use a subroutine call to compute */ -/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */ -/* this code. */ - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; -/* L10: */ - } - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], - info); - -/* If the zero finder fails, the computation is terminated. */ - - if (*info != 0) { - goto L120; - } -/* L20: */ - } - - if (*k == 1) { - goto L110; - } - if (*k == 2) { - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - w[1] = q[j * q_dim1 + 1]; - w[2] = q[j * q_dim1 + 2]; - ii = indx[1]; - q[j * q_dim1 + 1] = w[ii]; - ii = indx[2]; - q[j * q_dim1 + 2] = w[ii]; -/* L30: */ - } - goto L110; - } - -/* Compute updated W. */ - - dcopy_(k, &w[1], &c__1, &s[1], &c__1); - -/* Initialize W(I) = Q(I,I) */ - - i__1 = *ldq + 1; - dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); -/* L40: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); -/* L50: */ - } -/* L60: */ - } - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = sqrt(-w[i__]); - w[i__] = d_sign(&d__1, &s[i__]); -/* L70: */ - } - -/* Compute eigenvectors of the modified rank-1 modification. */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - s[i__] = w[i__] / q[i__ + j * q_dim1]; -/* L80: */ - } - temp = dnrm2_(k, &s[1], &c__1); - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - ii = indx[i__]; - q[i__ + j * q_dim1] = s[ii] / temp; -/* L90: */ - } -/* L100: */ - } - -/* Compute the updated eigenvectors. */ - -L110: - - n2 = *n - *n1; - n12 = ctot[1] + ctot[2]; - n23 = ctot[2] + ctot[3]; - - dlacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23); - iq2 = *n1 * n12 + 1; - if (n23 != 0) { - dgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & - c_b23, &q[*n1 + 1 + q_dim1], ldq); - } else { - dlaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq); - } - - dlacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12); - if (n12 != 0) { - dgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, - &q[q_offset], ldq); - } else { - dlaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq); - } - - -L120: - return 0; - -/* End of DLAED3 */ - -} /* dlaed3_ */ diff --git a/external/clapack/lapack/dlaed4.cpp b/external/clapack/lapack/dlaed4.cpp deleted file mode 100644 index 11a82038..00000000 --- a/external/clapack/lapack/dlaed4.cpp +++ /dev/null @@ -1,934 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaed4_(integer *n, integer *i__, double *d__, - double *z__, double *delta, double *rho, double *dlam, - integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - double a, b, c__; - integer j; - double w; - integer ii; - double dw, zz[3]; - integer ip1; - double del, eta, phi, eps, tau, psi; - integer iim1, iip1; - double dphi, dpsi; - integer iter; - double temp, prew, temp1, dltlb, dltub, midpt; - integer niter; - bool swtch; - bool swtch3; - bool orgati; - double erretm, rhoinv; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This subroutine computes the I-th updated eigenvalue of a symmetric */ -/* rank-one modification to a diagonal matrix whose elements are */ -/* given in the array d, and that */ - -/* D(i) < D(j) for i < j */ - -/* and that RHO > 0. This is arranged by the calling routine, and is */ -/* no loss in generality. The rank-one modified system is thus */ - -/* diag( D ) + RHO * Z * Z_transpose. */ - -/* where we assume the Euclidean norm of Z is 1. */ - -/* The method consists of approximating the rational functions in the */ -/* secular equation by simpler interpolating rational functions. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The length of all arrays. */ - -/* I (input) INTEGER */ -/* The index of the eigenvalue to be computed. 1 <= I <= N. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The original eigenvalues. It is assumed that they are in */ -/* order, D(I) < D(J) for I < J. */ - -/* Z (input) DOUBLE PRECISION array, dimension (N) */ -/* The components of the updating vector. */ - -/* DELTA (output) DOUBLE PRECISION array, dimension (N) */ -/* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th */ -/* component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5 */ -/* for detail. The vector DELTA contains the information necessary */ -/* to construct the eigenvectors by DLAED3 and DLAED9. */ - -/* RHO (input) DOUBLE PRECISION */ -/* The scalar in the symmetric updating formula. */ - -/* DLAM (output) DOUBLE PRECISION */ -/* The computed lambda_I, the I-th updated eigenvalue. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* > 0: if INFO = 1, the updating process failed. */ - -/* Internal Parameters */ -/* =================== */ - -/* Logical variable ORGATI (origin-at-i?) is used for distinguishing */ -/* whether D(i) or D(i+1) is treated as the origin. */ - -/* ORGATI = .true. origin at i */ -/* ORGATI = .false. origin at i+1 */ - -/* Logical variable SWTCH3 (switch-for-3-poles?) is for noting */ -/* if we are working with THREE poles! */ - -/* MAXIT is the maximum number of iterations allowed for each */ -/* eigenvalue. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ren-Cang Li, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Since this routine is called in an inner loop, we do no argument */ -/* checking. */ - -/* Quick return for N=1 and 2. */ - - /* Parameter adjustments */ - --delta; - --z__; - --d__; - - /* Function Body */ - *info = 0; - if (*n == 1) { - -/* Presumably, I=1 upon entry */ - - *dlam = d__[1] + *rho * z__[1] * z__[1]; - delta[1] = 1.; - return 0; - } - if (*n == 2) { - dlaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam); - return 0; - } - -/* Compute machine epsilon */ - - eps = dlamch_("Epsilon"); - rhoinv = 1. / *rho; - -/* The case I = N */ - - if (*i__ == *n) { - -/* Initialize some basic variables */ - - ii = *n - 1; - niter = 1; - -/* Calculate initial guess */ - - midpt = *rho / 2.; - -/* If ||Z||_2 is not one, then TEMP should be set to */ -/* RHO * ||Z||_2^2 / TWO */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - midpt; -/* L10: */ - } - - psi = 0.; - i__1 = *n - 2; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / delta[j]; -/* L20: */ - } - - c__ = rhoinv + psi; - w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[* - n]; - - if (w <= 0.) { - temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho) - + z__[*n] * z__[*n] / *rho; - if (c__ <= temp) { - tau = *rho; - } else { - del = d__[*n] - d__[*n - 1]; - a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n] - ; - b = z__[*n] * z__[*n] * del; - if (a < 0.) { - tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); - } - } - -/* It can be proved that */ -/* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO */ - - dltlb = midpt; - dltub = *rho; - } else { - del = d__[*n] - d__[*n - 1]; - a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; - b = z__[*n] * z__[*n] * del; - if (a < 0.) { - tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); - } - -/* It can be proved that */ -/* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */ - - dltlb = 0.; - dltub = midpt; - } - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - tau; -/* L30: */ - } - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L40: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi - + dphi); - - w = rhoinv + phi + psi; - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - *dlam = d__[*i__] + tau; - goto L250; - } - - if (w <= 0.) { - dltlb = std::max(dltlb,tau); - } else { - dltub = std::min(dltub,tau); - } - -/* Calculate the new step */ - - ++niter; - c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; - a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * ( - dpsi + dphi); - b = delta[*n - 1] * delta[*n] * w; - if (c__ < 0.) { - c__ = abs(c__); - } - if (c__ == 0.) { -/* ETA = B/A */ -/* ETA = RHO - TAU */ - eta = dltub - tau; - } else if (a >= 0.) { - eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ - * 2.); - } else { - eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) - ); - } - -/* Note, eta should be positive if w is negative, and */ -/* eta should be negative otherwise. However, */ -/* if for some reason caused by roundoff, eta*w > 0, */ -/* we simply use one Newton step instead. This way */ -/* will guarantee eta*w < 0. */ - - if (w * eta > 0.) { - eta = -w / (dpsi + dphi); - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.) { - eta = (dltub - tau) / 2.; - } else { - eta = (dltlb - tau) / 2.; - } - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; -/* L50: */ - } - - tau += eta; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L60: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi - + dphi); - - w = rhoinv + phi + psi; - -/* Main loop to update the values of the array DELTA */ - - iter = niter + 1; - - for (niter = iter; niter <= 30; ++niter) { - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - *dlam = d__[*i__] + tau; - goto L250; - } - - if (w <= 0.) { - dltlb = std::max(dltlb,tau); - } else { - dltub = std::min(dltub,tau); - } - -/* Calculate the new step */ - - c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; - a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * - (dpsi + dphi); - b = delta[*n - 1] * delta[*n] * w; - if (a >= 0.) { - eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } - -/* Note, eta should be positive if w is negative, and */ -/* eta should be negative otherwise. However, */ -/* if for some reason caused by roundoff, eta*w > 0, */ -/* we simply use one Newton step instead. This way */ -/* will guarantee eta*w < 0. */ - - if (w * eta > 0.) { - eta = -w / (dpsi + dphi); - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.) { - eta = (dltub - tau) / 2.; - } else { - eta = (dltlb - tau) / 2.; - } - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; -/* L70: */ - } - - tau += eta; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L80: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / delta[*n]; - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * ( - dpsi + dphi); - - w = rhoinv + phi + psi; -/* L90: */ - } - -/* Return with INFO = 1, NITER = MAXIT and not converged */ - - *info = 1; - *dlam = d__[*i__] + tau; - goto L250; - -/* End for the case I = N */ - - } else { - -/* The case for I < N */ - - niter = 1; - ip1 = *i__ + 1; - -/* Calculate initial guess */ - - del = d__[ip1] - d__[*i__]; - midpt = del / 2.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - midpt; -/* L100: */ - } - - psi = 0.; - i__1 = *i__ - 1; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / delta[j]; -/* L110: */ - } - - phi = 0.; - i__1 = *i__ + 2; - for (j = *n; j >= i__1; --j) { - phi += z__[j] * z__[j] / delta[j]; -/* L120: */ - } - c__ = rhoinv + psi + phi; - w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] / - delta[ip1]; - - if (w > 0.) { - -/* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 */ - -/* We choose d(i) as origin. */ - - orgati = true; - a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; - b = z__[*i__] * z__[*i__] * del; - if (a > 0.) { - tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } else { - tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } - dltlb = 0.; - dltub = midpt; - } else { - -/* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) */ - -/* We choose d(i+1) as origin. */ - - orgati = false; - a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; - b = z__[ip1] * z__[ip1] * del; - if (a < 0.) { - tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( - d__1)))); - } else { - tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / - (c__ * 2.); - } - dltlb = -midpt; - dltub = 0.; - } - - if (orgati) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - tau; -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[ip1] - tau; -/* L140: */ - } - } - if (orgati) { - ii = *i__; - } else { - ii = *i__ + 1; - } - iim1 = ii - 1; - iip1 = ii + 1; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L150: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / delta[j]; - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L160: */ - } - - w = rhoinv + phi + psi; - -/* W is the value of the secular function with */ -/* its ii-th element removed. */ - - swtch3 = false; - if (orgati) { - if (w < 0.) { - swtch3 = true; - } - } else { - if (w > 0.) { - swtch3 = true; - } - } - if (ii == 1 || ii == *n) { - swtch3 = false; - } - - temp = z__[ii] / delta[ii]; - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w += temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + - abs(tau) * dw; - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - if (orgati) { - *dlam = d__[*i__] + tau; - } else { - *dlam = d__[ip1] + tau; - } - goto L250; - } - - if (w <= 0.) { - dltlb = std::max(dltlb,tau); - } else { - dltub = std::min(dltub,tau); - } - -/* Calculate the new step */ - - ++niter; - if (! swtch3) { - if (orgati) { -/* Computing 2nd power */ - d__1 = z__[*i__] / delta[*i__]; - c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 * - d__1); - } else { -/* Computing 2nd power */ - d__1 = z__[ip1] / delta[ip1]; - c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 * - d__1); - } - a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * - dw; - b = delta[*i__] * delta[ip1] * w; - if (c__ == 0.) { - if (a == 0.) { - if (orgati) { - a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] * - (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] * - (dpsi + dphi); - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } - } else { - -/* Interpolation using THREE most relevant poles */ - - temp = rhoinv + psi + phi; - if (orgati) { - temp1 = z__[iim1] / delta[iim1]; - temp1 *= temp1; - c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[ - iip1]) * temp1; - zz[0] = z__[iim1] * z__[iim1]; - zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi); - } else { - temp1 = z__[iip1] / delta[iip1]; - temp1 *= temp1; - c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[ - iim1]) * temp1; - zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1)); - zz[2] = z__[iip1] * z__[iip1]; - } - zz[1] = z__[ii] * z__[ii]; - dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info); - if (*info != 0) { - goto L250; - } - } - -/* Note, eta should be positive if w is negative, and */ -/* eta should be negative otherwise. However, */ -/* if for some reason caused by roundoff, eta*w > 0, */ -/* we simply use one Newton step instead. This way */ -/* will guarantee eta*w < 0. */ - - if (w * eta >= 0.) { - eta = -w / dw; - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.) { - eta = (dltub - tau) / 2.; - } else { - eta = (dltlb - tau) / 2.; - } - } - - prew = w; - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; -/* L180: */ - } - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L190: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / delta[j]; - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L200: */ - } - - temp = z__[ii] / delta[ii]; - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + ( - d__1 = tau + eta, abs(d__1)) * dw; - - swtch = false; - if (orgati) { - if (-w > abs(prew) / 10.) { - swtch = true; - } - } else { - if (w > abs(prew) / 10.) { - swtch = true; - } - } - - tau += eta; - -/* Main loop to update the values of the array DELTA */ - - iter = niter + 1; - - for (niter = iter; niter <= 30; ++niter) { - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - if (orgati) { - *dlam = d__[*i__] + tau; - } else { - *dlam = d__[ip1] + tau; - } - goto L250; - } - - if (w <= 0.) { - dltlb = std::max(dltlb,tau); - } else { - dltub = std::min(dltub,tau); - } - -/* Calculate the new step */ - - if (! swtch3) { - if (! swtch) { - if (orgati) { -/* Computing 2nd power */ - d__1 = z__[*i__] / delta[*i__]; - c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * ( - d__1 * d__1); - } else { -/* Computing 2nd power */ - d__1 = z__[ip1] / delta[ip1]; - c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * - (d__1 * d__1); - } - } else { - temp = z__[ii] / delta[ii]; - if (orgati) { - dpsi += temp * temp; - } else { - dphi += temp * temp; - } - c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi; - } - a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] - * dw; - b = delta[*i__] * delta[ip1] * w; - if (c__ == 0.) { - if (a == 0.) { - if (! swtch) { - if (orgati) { - a = z__[*i__] * z__[*i__] + delta[ip1] * - delta[ip1] * (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + delta[*i__] * delta[ - *i__] * (dpsi + dphi); - } - } else { - a = delta[*i__] * delta[*i__] * dpsi + delta[ip1] - * delta[ip1] * dphi; - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) - / (c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, - abs(d__1)))); - } - } else { - -/* Interpolation using THREE most relevant poles */ - - temp = rhoinv + psi + phi; - if (swtch) { - c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi; - zz[0] = delta[iim1] * delta[iim1] * dpsi; - zz[2] = delta[iip1] * delta[iip1] * dphi; - } else { - if (orgati) { - temp1 = z__[iim1] / delta[iim1]; - temp1 *= temp1; - c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - - d__[iip1]) * temp1; - zz[0] = z__[iim1] * z__[iim1]; - zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + - dphi); - } else { - temp1 = z__[iip1] / delta[iip1]; - temp1 *= temp1; - c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - - d__[iim1]) * temp1; - zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - - temp1)); - zz[2] = z__[iip1] * z__[iip1]; - } - } - dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, - info); - if (*info != 0) { - goto L250; - } - } - -/* Note, eta should be positive if w is negative, and */ -/* eta should be negative otherwise. However, */ -/* if for some reason caused by roundoff, eta*w > 0, */ -/* we simply use one Newton step instead. This way */ -/* will guarantee eta*w < 0. */ - - if (w * eta >= 0.) { - eta = -w / dw; - } - temp = tau + eta; - if (temp > dltub || temp < dltlb) { - if (w < 0.) { - eta = (dltub - tau) / 2.; - } else { - eta = (dltlb - tau) / 2.; - } - } - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; -/* L210: */ - } - - tau += eta; - prew = w; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / delta[j]; - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L220: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / delta[j]; - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L230: */ - } - - temp = z__[ii] / delta[ii]; - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. - + abs(tau) * dw; - if (w * prew > 0. && abs(w) > abs(prew) / 10.) { - swtch = ! swtch; - } - -/* L240: */ - } - -/* Return with INFO = 1, NITER = MAXIT and not converged */ - - *info = 1; - if (orgati) { - *dlam = d__[*i__] + tau; - } else { - *dlam = d__[ip1] + tau; - } - - } - -L250: - - return 0; - -/* End of DLAED4 */ - -} /* dlaed4_ */ diff --git a/external/clapack/lapack/dlaed5.cpp b/external/clapack/lapack/dlaed5.cpp deleted file mode 100644 index f08a6bb8..00000000 --- a/external/clapack/lapack/dlaed5.cpp +++ /dev/null @@ -1,136 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaed5_(integer *i__, double *d__, double *z__, - double *delta, double *rho, double *dlam) -{ - /* System generated locals */ - double d__1; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - double b, c__, w, del, tau, temp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This subroutine computes the I-th eigenvalue of a symmetric rank-one */ -/* modification of a 2-by-2 diagonal matrix */ - -/* diag( D ) + RHO * Z * transpose(Z) . */ - -/* The diagonal elements in the array D are assumed to satisfy */ - -/* D(i) < D(j) for i < j . */ - -/* We also assume RHO > 0 and that the Euclidean norm of the vector */ -/* Z is one. */ - -/* Arguments */ -/* ========= */ - -/* I (input) INTEGER */ -/* The index of the eigenvalue to be computed. I = 1 or I = 2. */ - -/* D (input) DOUBLE PRECISION array, dimension (2) */ -/* The original eigenvalues. We assume D(1) < D(2). */ - -/* Z (input) DOUBLE PRECISION array, dimension (2) */ -/* The components of the updating vector. */ - -/* DELTA (output) DOUBLE PRECISION array, dimension (2) */ -/* The vector DELTA contains the information necessary */ -/* to construct the eigenvectors. */ - -/* RHO (input) DOUBLE PRECISION */ -/* The scalar in the symmetric updating formula. */ - -/* DLAM (output) DOUBLE PRECISION */ -/* The computed lambda_I, the I-th updated eigenvalue. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ren-Cang Li, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --delta; - --z__; - --d__; - - /* Function Body */ - del = d__[2] - d__[1]; - if (*i__ == 1) { - w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.; - if (w > 0.) { - b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[1] * z__[1] * del; - -/* B > ZERO, always */ - - tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); - *dlam = d__[1] + tau; - delta[1] = -z__[1] / tau; - delta[2] = z__[2] / (del - tau); - } else { - b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[2] * z__[2] * del; - if (b > 0.) { - tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); - } else { - tau = (b - sqrt(b * b + c__ * 4.)) / 2.; - } - *dlam = d__[2] + tau; - delta[1] = -z__[1] / (del + tau); - delta[2] = -z__[2] / tau; - } - temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); - delta[1] /= temp; - delta[2] /= temp; - } else { - -/* Now I=2 */ - - b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[2] * z__[2] * del; - if (b > 0.) { - tau = (b + sqrt(b * b + c__ * 4.)) / 2.; - } else { - tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); - } - *dlam = d__[2] + tau; - delta[1] = -z__[1] / (del + tau); - delta[2] = -z__[2] / tau; - temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); - delta[1] /= temp; - delta[2] /= temp; - } - return 0; - -/* End OF DLAED5 */ - -} /* dlaed5_ */ diff --git a/external/clapack/lapack/dlaed6.cpp b/external/clapack/lapack/dlaed6.cpp deleted file mode 100644 index 04b530d3..00000000 --- a/external/clapack/lapack/dlaed6.cpp +++ /dev/null @@ -1,359 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaed6_(integer *kniter, bool *orgati, double * - rho, double *d__, double *z__, double *finit, double * - tau, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - double a, b, c__, f; - integer i__; - double fc, df, ddf, lbd, eta, ubd, eps, base; - integer iter; - double temp, temp1, temp2, temp3, temp4; - bool scale; - integer niter; - double small1, small2, sminv1, sminv2; - - double dscale[3], sclfac, zscale[3], erretm, sclinv; - - -/* -- LAPACK routine (version 3.1.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* February 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAED6 computes the positive or negative root (closest to the origin) */ -/* of */ -/* z(1) z(2) z(3) */ -/* f(x) = rho + --------- + ---------- + --------- */ -/* d(1)-x d(2)-x d(3)-x */ - -/* It is assumed that */ - -/* if ORGATI = .true. the root is between d(2) and d(3); */ -/* otherwise it is between d(1) and d(2) */ - -/* This routine will be called by DLAED4 when necessary. In most cases, */ -/* the root sought is the smallest in magnitude, though it might not be */ -/* in some extremely rare situations. */ - -/* Arguments */ -/* ========= */ - -/* KNITER (input) INTEGER */ -/* Refer to DLAED4 for its significance. */ - -/* ORGATI (input) LOGICAL */ -/* If ORGATI is true, the needed root is between d(2) and */ -/* d(3); otherwise it is between d(1) and d(2). See */ -/* DLAED4 for further details. */ - -/* RHO (input) DOUBLE PRECISION */ -/* Refer to the equation f(x) above. */ - -/* D (input) DOUBLE PRECISION array, dimension (3) */ -/* D satisfies d(1) < d(2) < d(3). */ - -/* Z (input) DOUBLE PRECISION array, dimension (3) */ -/* Each of the elements in z must be positive. */ - -/* FINIT (input) DOUBLE PRECISION */ -/* The value of f at 0. It is more accurate than the one */ -/* evaluated inside this routine (if someone wants to do */ -/* so). */ - -/* TAU (output) DOUBLE PRECISION */ -/* The root of the equation f(x). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* > 0: if INFO = 1, failure to converge */ - -/* Further Details */ -/* =============== */ - -/* 30/06/99: Based on contributions by */ -/* Ren-Cang Li, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* 10/02/03: This version has a few statements commented out for thread */ -/* safety (machine parameters are computed on each entry). SJH. */ - -/* 05/10/06: Modified from a new version of Ren-Cang Li, use */ -/* Gragg-Thornton-Warner cubic convergent scheme for better stability. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --z__; - --d__; - - /* Function Body */ - *info = 0; - - if (*orgati) { - lbd = d__[2]; - ubd = d__[3]; - } else { - lbd = d__[1]; - ubd = d__[2]; - } - if (*finit < 0.) { - lbd = 0.; - } else { - ubd = 0.; - } - - niter = 1; - *tau = 0.; - if (*kniter == 2) { - if (*orgati) { - temp = (d__[3] - d__[2]) / 2.; - c__ = *rho + z__[1] / (d__[1] - d__[2] - temp); - a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3]; - b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2]; - } else { - temp = (d__[1] - d__[2]) / 2.; - c__ = *rho + z__[3] / (d__[3] - d__[2] - temp); - a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2]; - b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1]; - } -/* Computing MAX */ - d__1 = abs(a), d__2 = abs(b), d__1 = std::max(d__1,d__2), d__2 = abs(c__); - temp = std::max(d__1,d__2); - a /= temp; - b /= temp; - c__ /= temp; - if (c__ == 0.) { - *tau = b / a; - } else if (a <= 0.) { - *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)) - )); - } - if (*tau < lbd || *tau > ubd) { - *tau = (lbd + ubd) / 2.; - } - if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { - *tau = 0.; - } else { - temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau - * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / ( - d__[3] * (d__[3] - *tau)); - if (temp <= 0.) { - lbd = *tau; - } else { - ubd = *tau; - } - if (abs(*finit) <= abs(temp)) { - *tau = 0.; - } - } - } - -/* get machine parameters for possible scaling to avoid overflow */ - -/* modified by Sven: parameters SMALL1, SMINV1, SMALL2, */ -/* SMINV2, EPS are not SAVEd anymore between one call to the */ -/* others but recomputed at each call */ - - eps = dlamch_("Epsilon"); - base = dlamch_("Base"); - i__1 = (integer) (log(dlamch_("SafMin")) / log(base) / 3.); - small1 = pow_di(&base, &i__1); - sminv1 = 1. / small1; - small2 = small1 * small1; - sminv2 = sminv1 * sminv1; - -/* Determine if scaling of inputs necessary to avoid overflow */ -/* when computing 1/TEMP**3 */ - - if (*orgati) { -/* Computing MIN */ - d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - * - tau, abs(d__2)); - temp = std::min(d__3,d__4); - } else { -/* Computing MIN */ - d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - * - tau, abs(d__2)); - temp = std::min(d__3,d__4); - } - scale = false; - if (temp <= small1) { - scale = true; - if (temp <= small2) { - -/* Scale up by power of radix nearest 1/SAFMIN**(2/3) */ - - sclfac = sminv2; - sclinv = small2; - } else { - -/* Scale up by power of radix nearest 1/SAFMIN**(1/3) */ - - sclfac = sminv1; - sclinv = small1; - } - -/* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */ - - for (i__ = 1; i__ <= 3; ++i__) { - dscale[i__ - 1] = d__[i__] * sclfac; - zscale[i__ - 1] = z__[i__] * sclfac; -/* L10: */ - } - *tau *= sclfac; - lbd *= sclfac; - ubd *= sclfac; - } else { - -/* Copy D and Z to DSCALE and ZSCALE */ - - for (i__ = 1; i__ <= 3; ++i__) { - dscale[i__ - 1] = d__[i__]; - zscale[i__ - 1] = z__[i__]; -/* L20: */ - } - } - - fc = 0.; - df = 0.; - ddf = 0.; - for (i__ = 1; i__ <= 3; ++i__) { - temp = 1. / (dscale[i__ - 1] - *tau); - temp1 = zscale[i__ - 1] * temp; - temp2 = temp1 * temp; - temp3 = temp2 * temp; - fc += temp1 / dscale[i__ - 1]; - df += temp2; - ddf += temp3; -/* L30: */ - } - f = *finit + *tau * fc; - - if (abs(f) <= 0.) { - goto L60; - } - if (f <= 0.) { - lbd = *tau; - } else { - ubd = *tau; - } - -/* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */ -/* scheme */ - -/* It is not hard to see that */ - -/* 1) Iterations will go up monotonically */ -/* if FINIT < 0; */ - -/* 2) Iterations will go down monotonically */ -/* if FINIT > 0. */ - - iter = niter + 1; - - for (niter = iter; niter <= 40; ++niter) { - - if (*orgati) { - temp1 = dscale[1] - *tau; - temp2 = dscale[2] - *tau; - } else { - temp1 = dscale[0] - *tau; - temp2 = dscale[1] - *tau; - } - a = (temp1 + temp2) * f - temp1 * temp2 * df; - b = temp1 * temp2 * f; - c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf; -/* Computing MAX */ - d__1 = abs(a), d__2 = abs(b), d__1 = std::max(d__1,d__2), d__2 = abs(c__); - temp = std::max(d__1,d__2); - a /= temp; - b /= temp; - c__ /= temp; - if (c__ == 0.) { - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ - * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) - ); - } - if (f * eta >= 0.) { - eta = -f / df; - } - - *tau += eta; - if (*tau < lbd || *tau > ubd) { - *tau = (lbd + ubd) / 2.; - } - - fc = 0.; - erretm = 0.; - df = 0.; - ddf = 0.; - for (i__ = 1; i__ <= 3; ++i__) { - temp = 1. / (dscale[i__ - 1] - *tau); - temp1 = zscale[i__ - 1] * temp; - temp2 = temp1 * temp; - temp3 = temp2 * temp; - temp4 = temp1 / dscale[i__ - 1]; - fc += temp4; - erretm += abs(temp4); - df += temp2; - ddf += temp3; -/* L40: */ - } - f = *finit + *tau * fc; - erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df; - if (abs(f) <= eps * erretm) { - goto L60; - } - if (f <= 0.) { - lbd = *tau; - } else { - ubd = *tau; - } -/* L50: */ - } - *info = 1; -L60: - -/* Undo scaling */ - - if (scale) { - *tau *= sclinv; - } - return 0; - -/* End of DLAED6 */ - -} /* dlaed6_ */ diff --git a/external/clapack/lapack/dlaed7.cpp b/external/clapack/lapack/dlaed7.cpp deleted file mode 100644 index 5ebda5c8..00000000 --- a/external/clapack/lapack/dlaed7.cpp +++ /dev/null @@ -1,323 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__2 = 2; -static integer c__1 = 1; -static double c_b10 = 1.; -static double c_b11 = 0.; -static integer c_n1 = -1; - -/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz, - integer *tlvls, integer *curlvl, integer *curpbm, double *d__, - double *q, integer *ldq, integer *indxq, double *rho, integer - *cutpnt, double *qstore, integer *qptr, integer *prmptr, integer * - perm, integer *givptr, integer *givcol, double *givnum, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, i__1, i__2; - - /* Local variables */ - integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr; - integer indxc, indxp; - integer idlmda; - integer coltyp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAED7 computes the updated eigensystem of a diagonal */ -/* matrix after modification by a rank-one symmetric matrix. This */ -/* routine is used only for the eigenproblem which requires all */ -/* eigenvalues and optionally eigenvectors of a dense symmetric matrix */ -/* that has been reduced to tridiagonal form. DLAED1 handles */ -/* the case in which all eigenvalues and eigenvectors of a symmetric */ -/* tridiagonal matrix are desired. */ - -/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */ - -/* where Z = Q'u, u is a vector of length N with ones in the */ -/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */ - -/* The eigenvectors of the original matrix are stored in Q, and the */ -/* eigenvalues are in D. The algorithm consists of three stages: */ - -/* The first stage consists of deflating the size of the problem */ -/* when there are multiple eigenvalues or if there is a zero in */ -/* the Z vector. For each such occurence the dimension of the */ -/* secular equation problem is reduced by one. This stage is */ -/* performed by the routine DLAED8. */ - -/* The second stage consists of calculating the updated */ -/* eigenvalues. This is done by finding the roots of the secular */ -/* equation via the routine DLAED4 (as called by DLAED9). */ -/* This routine also calculates the eigenvectors of the current */ -/* problem. */ - -/* The final stage consists of computing the updated eigenvectors */ -/* directly using the updated eigenvalues. The eigenvectors for */ -/* the current problem are multiplied with the eigenvectors from */ -/* the overall problem. */ - -/* Arguments */ -/* ========= */ - -/* ICOMPQ (input) INTEGER */ -/* = 0: Compute eigenvalues only. */ -/* = 1: Compute eigenvectors of original dense symmetric matrix */ -/* also. On entry, Q contains the orthogonal matrix used */ -/* to reduce the original matrix to tridiagonal form. */ - -/* N (input) INTEGER */ -/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ - -/* QSIZ (input) INTEGER */ -/* The dimension of the orthogonal matrix used to reduce */ -/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ - -/* TLVLS (input) INTEGER */ -/* The total number of merging levels in the overall divide and */ -/* conquer tree. */ - -/* CURLVL (input) INTEGER */ -/* The current level in the overall merge routine, */ -/* 0 <= CURLVL <= TLVLS. */ - -/* CURPBM (input) INTEGER */ -/* The current problem in the current level in the overall */ -/* merge routine (counting from upper left to lower right). */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the eigenvalues of the rank-1-perturbed matrix. */ -/* On exit, the eigenvalues of the repaired matrix. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ -/* On entry, the eigenvectors of the rank-1-perturbed matrix. */ -/* On exit, the eigenvectors of the repaired tridiagonal matrix. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N). */ - -/* INDXQ (output) INTEGER array, dimension (N) */ -/* The permutation which will reintegrate the subproblem just */ -/* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) */ -/* will be in ascending order. */ - -/* RHO (input) DOUBLE PRECISION */ -/* The subdiagonal element used to create the rank-1 */ -/* modification. */ - -/* CUTPNT (input) INTEGER */ -/* Contains the location of the last eigenvalue in the leading */ -/* sub-matrix. min(1,N) <= CUTPNT <= N. */ - -/* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1) */ -/* Stores eigenvectors of submatrices encountered during */ -/* divide and conquer, packed together. QPTR points to */ -/* beginning of the submatrices. */ - -/* QPTR (input/output) INTEGER array, dimension (N+2) */ -/* List of indices pointing to beginning of submatrices stored */ -/* in QSTORE. The submatrices are numbered starting at the */ -/* bottom left of the divide and conquer tree, from left to */ -/* right and bottom to top. */ - -/* PRMPTR (input) INTEGER array, dimension (N lg N) */ -/* Contains a list of pointers which indicate where in PERM a */ -/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */ -/* indicates the size of the permutation and also the size of */ -/* the full, non-deflated problem. */ - -/* PERM (input) INTEGER array, dimension (N lg N) */ -/* Contains the permutations (from deflation and sorting) to be */ -/* applied to each eigenblock. */ - -/* GIVPTR (input) INTEGER array, dimension (N lg N) */ -/* Contains a list of pointers which indicate where in GIVCOL a */ -/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */ -/* indicates the number of Givens rotations. */ - -/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */ -/* Each pair of numbers indicates a pair of columns to take place */ -/* in a Givens rotation. */ - -/* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */ -/* Each number indicates the S value to be used in the */ -/* corresponding Givens rotation. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N) */ - -/* IWORK (workspace) INTEGER array, dimension (4*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an eigenvalue did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --indxq; - --qstore; - --qptr; - --prmptr; - --perm; - --givptr; - givcol -= 3; - givnum -= 3; - --work; - --iwork; - - /* Function Body */ - *info = 0; - - if (*icompq < 0 || *icompq > 1) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*icompq == 1 && *qsiz < *n) { - *info = -4; - } else if (*ldq < std::max(1_integer,*n)) { - *info = -9; - } else if (std::min(1_integer,*n) > *cutpnt || *n < *cutpnt) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAED7", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* The following values are for bookkeeping purposes only. They are */ -/* integer pointers which indicate the portion of the workspace */ -/* used by a particular array in DLAED8 and DLAED9. */ - - if (*icompq == 1) { - ldq2 = *qsiz; - } else { - ldq2 = *n; - } - - iz = 1; - idlmda = iz + *n; - iw = idlmda + *n; - iq2 = iw + *n; - is = iq2 + *n * ldq2; - - indx = 1; - indxc = indx + *n; - coltyp = indxc + *n; - indxp = coltyp + *n; - -/* Form the z-vector which consists of the last row of Q_1 and the */ -/* first row of Q_2. */ - - ptr = pow_ii(&c__2, tlvls) + 1; - i__1 = *curlvl - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *tlvls - i__; - ptr += pow_ii(&c__2, &i__2); -/* L10: */ - } - curr = ptr + *curpbm; - dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], & - givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz - + *n], info); - -/* When solving the final problem, we no longer need the stored data, */ -/* so we will overwrite the data from this level onto the previously */ -/* used storage space. */ - - if (*curlvl == *tlvls) { - qptr[curr] = 1; - prmptr[curr] = 1; - givptr[curr] = 1; - } - -/* Sort and Deflate eigenvalues. */ - - dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, - cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], & - perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1) - + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[ - indx], info); - prmptr[curr + 1] = prmptr[curr] + *n; - givptr[curr + 1] += givptr[curr]; - -/* Solve Secular Equation. */ - - if (k != 0) { - dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], - &work[iw], &qstore[qptr[curr]], &k, info); - if (*info != 0) { - goto L30; - } - if (*icompq == 1) { - dgemm_("N", "N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[ - qptr[curr]], &k, &c_b11, &q[q_offset], ldq); - } -/* Computing 2nd power */ - i__1 = k; - qptr[curr + 1] = qptr[curr] + i__1 * i__1; - -/* Prepare the INDXQ sorting permutation. */ - - n1 = k; - n2 = *n - k; - dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); - } else { - qptr[curr + 1] = qptr[curr]; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - indxq[i__] = i__; -/* L20: */ - } - } - -L30: - return 0; - -/* End of DLAED7 */ - -} /* dlaed7_ */ diff --git a/external/clapack/lapack/dlaed8.cpp b/external/clapack/lapack/dlaed8.cpp deleted file mode 100644 index b73907f4..00000000 --- a/external/clapack/lapack/dlaed8.cpp +++ /dev/null @@ -1,450 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b3 = -1.; -static integer c__1 = 1; - -/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer - *qsiz, double *d__, double *q, integer *ldq, integer *indxq, - double *rho, integer *cutpnt, double *z__, double *dlamda, - double *q2, integer *ldq2, double *w, integer *perm, integer - *givptr, integer *givcol, double *givnum, integer *indxp, integer - *indx, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; - double d__1; - - /* Local variables */ - double c__; - integer i__, j; - double s, t; - integer k2, n1, n2, jp, n1p1; - double eps, tau, tol; - integer jlam, imax, jmax; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAED8 merges the two sets of eigenvalues together into a single */ -/* sorted set. Then it tries to deflate the size of the problem. */ -/* There are two ways in which deflation can occur: when two or more */ -/* eigenvalues are close together or if there is a tiny element in the */ -/* Z vector. For each such occurrence the order of the related secular */ -/* equation problem is reduced by one. */ - -/* Arguments */ -/* ========= */ - -/* ICOMPQ (input) INTEGER */ -/* = 0: Compute eigenvalues only. */ -/* = 1: Compute eigenvectors of original dense symmetric matrix */ -/* also. On entry, Q contains the orthogonal matrix used */ -/* to reduce the original matrix to tridiagonal form. */ - -/* K (output) INTEGER */ -/* The number of non-deflated eigenvalues, and the order of the */ -/* related secular equation. */ - -/* N (input) INTEGER */ -/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ - -/* QSIZ (input) INTEGER */ -/* The dimension of the orthogonal matrix used to reduce */ -/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the eigenvalues of the two submatrices to be */ -/* combined. On exit, the trailing (N-K) updated eigenvalues */ -/* (those which were deflated) sorted into increasing order. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* If ICOMPQ = 0, Q is not referenced. Otherwise, */ -/* on entry, Q contains the eigenvectors of the partially solved */ -/* system which has been previously updated in matrix */ -/* multiplies with other partially solved eigensystems. */ -/* On exit, Q contains the trailing (N-K) updated eigenvectors */ -/* (those which were deflated) in its last N-K columns. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N). */ - -/* INDXQ (input) INTEGER array, dimension (N) */ -/* The permutation which separately sorts the two sub-problems */ -/* in D into ascending order. Note that elements in the second */ -/* half of this permutation must first have CUTPNT added to */ -/* their values in order to be accurate. */ - -/* RHO (input/output) DOUBLE PRECISION */ -/* On entry, the off-diagonal element associated with the rank-1 */ -/* cut which originally split the two submatrices which are now */ -/* being recombined. */ -/* On exit, RHO has been modified to the value required by */ -/* DLAED3. */ - -/* CUTPNT (input) INTEGER */ -/* The location of the last eigenvalue in the leading */ -/* sub-matrix. min(1,N) <= CUTPNT <= N. */ - -/* Z (input) DOUBLE PRECISION array, dimension (N) */ -/* On entry, Z contains the updating vector (the last row of */ -/* the first sub-eigenvector matrix and the first row of the */ -/* second sub-eigenvector matrix). */ -/* On exit, the contents of Z are destroyed by the updating */ -/* process. */ - -/* DLAMDA (output) DOUBLE PRECISION array, dimension (N) */ -/* A copy of the first K eigenvalues which will be used by */ -/* DLAED3 to form the secular equation. */ - -/* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N) */ -/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */ -/* a copy of the first K eigenvectors which will be used by */ -/* DLAED7 in a matrix multiply (DGEMM) to update the new */ -/* eigenvectors. */ - -/* LDQ2 (input) INTEGER */ -/* The leading dimension of the array Q2. LDQ2 >= max(1,N). */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first k values of the final deflation-altered z-vector and */ -/* will be passed to DLAED3. */ - -/* PERM (output) INTEGER array, dimension (N) */ -/* The permutations (from deflation and sorting) to be applied */ -/* to each eigenblock. */ - -/* GIVPTR (output) INTEGER */ -/* The number of Givens rotations which took place in this */ -/* subproblem. */ - -/* GIVCOL (output) INTEGER array, dimension (2, N) */ -/* Each pair of numbers indicates a pair of columns to take place */ -/* in a Givens rotation. */ - -/* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N) */ -/* Each number indicates the S value to be used in the */ -/* corresponding Givens rotation. */ - -/* INDXP (workspace) INTEGER array, dimension (N) */ -/* The permutation used to place deflated values of D at the end */ -/* of the array. INDXP(1:K) points to the nondeflated D-values */ -/* and INDXP(K+1:N) points to the deflated eigenvalues. */ - -/* INDX (workspace) INTEGER array, dimension (N) */ -/* The permutation used to sort the contents of D into ascending */ -/* order. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ - -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --indxq; - --z__; - --dlamda; - q2_dim1 = *ldq2; - q2_offset = 1 + q2_dim1; - q2 -= q2_offset; - --w; - --perm; - givcol -= 3; - givnum -= 3; - --indxp; - --indx; - - /* Function Body */ - *info = 0; - - if (*icompq < 0 || *icompq > 1) { - *info = -1; - } else if (*n < 0) { - *info = -3; - } else if (*icompq == 1 && *qsiz < *n) { - *info = -4; - } else if (*ldq < std::max(1_integer,*n)) { - *info = -7; - } else if (*cutpnt < std::min(1_integer,*n) || *cutpnt > *n) { - *info = -10; - } else if (*ldq2 < std::max(1_integer,*n)) { - *info = -14; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAED8", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - n1 = *cutpnt; - n2 = *n - n1; - n1p1 = n1 + 1; - - if (*rho < 0.) { - dscal_(&n2, &c_b3, &z__[n1p1], &c__1); - } - -/* Normalize z so that norm(z) = 1 */ - - t = 1. / sqrt(2.); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - indx[j] = j; -/* L10: */ - } - dscal_(n, &t, &z__[1], &c__1); - *rho = (d__1 = *rho * 2., abs(d__1)); - -/* Sort the eigenvalues into increasing order */ - - i__1 = *n; - for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { - indxq[i__] += *cutpnt; -/* L20: */ - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = d__[indxq[i__]]; - w[i__] = z__[indxq[i__]]; -/* L30: */ - } - i__ = 1; - j = *cutpnt + 1; - dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = dlamda[indx[i__]]; - z__[i__] = w[indx[i__]]; -/* L40: */ - } - -/* Calculate the allowable deflation tolerence */ - - imax = idamax_(n, &z__[1], &c__1); - jmax = idamax_(n, &d__[1], &c__1); - eps = dlamch_("Epsilon"); - tol = eps * 8. * (d__1 = d__[jmax], abs(d__1)); - -/* If the rank-1 modifier is small enough, no more needs to be done */ -/* except to reorganize Q so that its columns correspond with the */ -/* elements in D. */ - - if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { - *k = 0; - if (*icompq == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - perm[j] = indxq[indx[j]]; -/* L50: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - perm[j] = indxq[indx[j]]; - dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 - + 1], &c__1); -/* L60: */ - } - dlacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq); - } - return 0; - } - -/* If there are multiple eigenvalues then the problem deflates. Here */ -/* the number of equal eigenvalues are found. As each equal */ -/* eigenvalue is found, an elementary reflector is computed to rotate */ -/* the corresponding eigensubspace so that the corresponding */ -/* components of Z are zero in this new basis. */ - - *k = 0; - *givptr = 0; - k2 = *n + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - indxp[k2] = j; - if (j == *n) { - goto L110; - } - } else { - jlam = j; - goto L80; - } -/* L70: */ - } -L80: - ++j; - if (j > *n) { - goto L100; - } - if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - indxp[k2] = j; - } else { - -/* Check if eigenvalues are close enough to allow deflation. */ - - s = z__[jlam]; - c__ = z__[j]; - -/* Find sqrt(a**2+b**2) without overflow or */ -/* destructive underflow. */ - - tau = dlapy2_(&c__, &s); - t = d__[j] - d__[jlam]; - c__ /= tau; - s = -s / tau; - if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { - -/* Deflation is possible. */ - - z__[j] = tau; - z__[jlam] = 0.; - -/* Record the appropriate Givens rotation */ - - ++(*givptr); - givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; - givcol[(*givptr << 1) + 2] = indxq[indx[j]]; - givnum[(*givptr << 1) + 1] = c__; - givnum[(*givptr << 1) + 2] = s; - if (*icompq == 1) { - drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[ - indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s); - } - t = d__[jlam] * c__ * c__ + d__[j] * s * s; - d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; - d__[jlam] = t; - --k2; - i__ = 1; -L90: - if (k2 + i__ <= *n) { - if (d__[jlam] < d__[indxp[k2 + i__]]) { - indxp[k2 + i__ - 1] = indxp[k2 + i__]; - indxp[k2 + i__] = jlam; - ++i__; - goto L90; - } else { - indxp[k2 + i__ - 1] = jlam; - } - } else { - indxp[k2 + i__ - 1] = jlam; - } - jlam = j; - } else { - ++(*k); - w[*k] = z__[jlam]; - dlamda[*k] = d__[jlam]; - indxp[*k] = jlam; - jlam = j; - } - } - goto L80; -L100: - -/* Record the last eigenvalue. */ - - ++(*k); - w[*k] = z__[jlam]; - dlamda[*k] = d__[jlam]; - indxp[*k] = jlam; - -L110: - -/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */ -/* and Q2 respectively. The eigenvalues/vectors which were not */ -/* deflated go into the first K slots of DLAMDA and Q2 respectively, */ -/* while those which were deflated go into the last N - K slots. */ - - if (*icompq == 0) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jp = indxp[j]; - dlamda[j] = d__[jp]; - perm[j] = indxq[indx[jp]]; -/* L120: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jp = indxp[j]; - dlamda[j] = d__[jp]; - perm[j] = indxq[indx[jp]]; - dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] -, &c__1); -/* L130: */ - } - } - -/* The deflated eigenvalues and their corresponding vectors go back */ -/* into the last N - K slots of D and Q respectively. */ - - if (*k < *n) { - if (*icompq == 0) { - i__1 = *n - *k; - dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); - } else { - i__1 = *n - *k; - dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); - i__1 = *n - *k; - dlacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* - k + 1) * q_dim1 + 1], ldq); - } - } - - return 0; - -/* End of DLAED8 */ - -} /* dlaed8_ */ diff --git a/external/clapack/lapack/dlaed9.cpp b/external/clapack/lapack/dlaed9.cpp deleted file mode 100644 index d37d3d8a..00000000 --- a/external/clapack/lapack/dlaed9.cpp +++ /dev/null @@ -1,252 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop, - integer *n, double *d__, double *q, integer *ldq, double * - rho, double *dlamda, double *w, double *s, integer *lds, - integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j; - double temp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAED9 finds the roots of the secular equation, as defined by the */ -/* values in D, Z, and RHO, between KSTART and KSTOP. It makes the */ -/* appropriate calls to DLAED4 and then stores the new matrix of */ -/* eigenvectors for use in calculating the next level of Z vectors. */ - -/* Arguments */ -/* ========= */ - -/* K (input) INTEGER */ -/* The number of terms in the rational function to be solved by */ -/* DLAED4. K >= 0. */ - -/* KSTART (input) INTEGER */ -/* KSTOP (input) INTEGER */ -/* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP */ -/* are to be computed. 1 <= KSTART <= KSTOP <= K. */ - -/* N (input) INTEGER */ -/* The number of rows and columns in the Q matrix. */ -/* N >= K (delation may result in N > K). */ - -/* D (output) DOUBLE PRECISION array, dimension (N) */ -/* D(I) contains the updated eigenvalues */ -/* for KSTART <= I <= KSTOP. */ - -/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N) */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max( 1, N ). */ - -/* RHO (input) DOUBLE PRECISION */ -/* The value of the parameter in the rank one update equation. */ -/* RHO >= 0 required. */ - -/* DLAMDA (input) DOUBLE PRECISION array, dimension (K) */ -/* The first K elements of this array contain the old roots */ -/* of the deflated updating problem. These are the poles */ -/* of the secular equation. */ - -/* W (input) DOUBLE PRECISION array, dimension (K) */ -/* The first K elements of this array contain the components */ -/* of the deflation-adjusted updating vector. */ - -/* S (output) DOUBLE PRECISION array, dimension (LDS, K) */ -/* Will contain the eigenvectors of the repaired matrix which */ -/* will be stored for subsequent Z vector calculation and */ -/* multiplied by the previously accumulated eigenvectors */ -/* to update the system. */ - -/* LDS (input) INTEGER */ -/* The leading dimension of S. LDS >= max( 1, K ). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an eigenvalue did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --dlamda; - --w; - s_dim1 = *lds; - s_offset = 1 + s_dim1; - s -= s_offset; - - /* Function Body */ - *info = 0; - - if (*k < 0) { - *info = -1; - } else if (*kstart < 1 || *kstart > std::max(1_integer,*k)) { - *info = -2; - } else if (std::max(1_integer,*kstop) < *kstart || *kstop > std::max(1_integer,*k)) { - *info = -3; - } else if (*n < *k) { - *info = -4; - } else if (*ldq < std::max(1_integer,*k)) { - *info = -7; - } else if (*lds < std::max(1_integer,*k)) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAED9", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*k == 0) { - return 0; - } - -/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ -/* be computed with high relative accuracy (barring over/underflow). */ -/* This is a problem on machines without a guard digit in */ -/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ -/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */ -/* which on any of these machines zeros out the bottommost */ -/* bit of DLAMDA(I) if it is 1; this makes the subsequent */ -/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */ -/* occurs. On binary machines with a guard digit (almost all */ -/* machines) it does not change DLAMDA(I) at all. On hexadecimal */ -/* and decimal machines with a guard digit, it slightly */ -/* changes the bottommost bits of DLAMDA(I). It does not account */ -/* for hexadecimal or decimal machines without guard digits */ -/* (we know of none). We use a subroutine call to compute */ -/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */ -/* this code. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; -/* L10: */ - } - - i__1 = *kstop; - for (j = *kstart; j <= i__1; ++j) { - dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], - info); - -/* If the zero finder fails, the computation is terminated. */ - - if (*info != 0) { - goto L120; - } -/* L20: */ - } - - if (*k == 1 || *k == 2) { - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *k; - for (j = 1; j <= i__2; ++j) { - s[j + i__ * s_dim1] = q[j + i__ * q_dim1]; -/* L30: */ - } -/* L40: */ - } - goto L120; - } - -/* Compute updated W. */ - - dcopy_(k, &w[1], &c__1, &s[s_offset], &c__1); - -/* Initialize W(I) = Q(I,I) */ - - i__1 = *ldq + 1; - dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); -/* L50: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); -/* L60: */ - } -/* L70: */ - } - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = sqrt(-w[i__]); - w[i__] = d_sign(&d__1, &s[i__ + s_dim1]); -/* L80: */ - } - -/* Compute eigenvectors of the modified rank-1 modification. */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1]; -/* L90: */ - } - temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1); - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp; -/* L100: */ - } -/* L110: */ - } - -L120: - return 0; - -/* End of DLAED9 */ - -} /* dlaed9_ */ diff --git a/external/clapack/lapack/dlaeda.cpp b/external/clapack/lapack/dlaeda.cpp deleted file mode 100644 index 33610f6b..00000000 --- a/external/clapack/lapack/dlaeda.cpp +++ /dev/null @@ -1,264 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__2 = 2; -static integer c__1 = 1; -static double c_b24 = 1.; -static double c_b26 = 0.; - -/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl, - integer *curpbm, integer *prmptr, integer *perm, integer *givptr, - integer *givcol, double *givnum, double *q, integer *qptr, - double *z__, double *ztemp, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - - /* Local variables */ - integer i__, k, mid, ptr; - integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAEDA computes the Z vector corresponding to the merge step in the */ -/* CURLVLth step of the merge process with TLVLS steps for the CURPBMth */ -/* problem. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ - -/* TLVLS (input) INTEGER */ -/* The total number of merging levels in the overall divide and */ -/* conquer tree. */ - -/* CURLVL (input) INTEGER */ -/* The current level in the overall merge routine, */ -/* 0 <= curlvl <= tlvls. */ - -/* CURPBM (input) INTEGER */ -/* The current problem in the current level in the overall */ -/* merge routine (counting from upper left to lower right). */ - -/* PRMPTR (input) INTEGER array, dimension (N lg N) */ -/* Contains a list of pointers which indicate where in PERM a */ -/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */ -/* indicates the size of the permutation and incidentally the */ -/* size of the full, non-deflated problem. */ - -/* PERM (input) INTEGER array, dimension (N lg N) */ -/* Contains the permutations (from deflation and sorting) to be */ -/* applied to each eigenblock. */ - -/* GIVPTR (input) INTEGER array, dimension (N lg N) */ -/* Contains a list of pointers which indicate where in GIVCOL a */ -/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */ -/* indicates the number of Givens rotations. */ - -/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */ -/* Each pair of numbers indicates a pair of columns to take place */ -/* in a Givens rotation. */ - -/* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */ -/* Each number indicates the S value to be used in the */ -/* corresponding Givens rotation. */ - -/* Q (input) DOUBLE PRECISION array, dimension (N**2) */ -/* Contains the square eigenblocks from previous levels, the */ -/* starting positions for blocks are given by QPTR. */ - -/* QPTR (input) INTEGER array, dimension (N+2) */ -/* Contains a list of pointers which indicate where in Q an */ -/* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates */ -/* the size of the block. */ - -/* Z (output) DOUBLE PRECISION array, dimension (N) */ -/* On output this vector contains the updating vector (the last */ -/* row of the first sub-eigenvector matrix and the first row of */ -/* the second sub-eigenvector matrix). */ - -/* ZTEMP (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 */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ztemp; - --z__; - --qptr; - --q; - givnum -= 3; - givcol -= 3; - --givptr; - --perm; - --prmptr; - - /* Function Body */ - *info = 0; - - if (*n < 0) { - *info = -1; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAEDA", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine location of first number in second half. */ - - mid = *n / 2 + 1; - -/* Gather last/first rows of appropriate eigenblocks into center of Z */ - - ptr = 1; - -/* Determine location of lowest level subproblem in the full storage */ -/* scheme */ - - i__1 = *curlvl - 1; - curr = ptr + *curpbm * pow_ii(&c__2, curlvl) + pow_ii(&c__2, &i__1) - 1; - -/* Determine size of these matrices. We add HALF to the value of */ -/* the SQRT in case the machine underestimates one of these square */ -/* roots. */ - - bsiz1 = (integer) (sqrt((double) (qptr[curr + 1] - qptr[curr])) + .5); - bsiz2 = (integer) (sqrt((double) (qptr[curr + 2] - qptr[curr + 1])) + - .5); - i__1 = mid - bsiz1 - 1; - for (k = 1; k <= i__1; ++k) { - z__[k] = 0.; -/* L10: */ - } - dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], & - c__1); - dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1); - i__1 = *n; - for (k = mid + bsiz2; k <= i__1; ++k) { - z__[k] = 0.; -/* L20: */ - } - -/* Loop thru remaining levels 1 -> CURLVL applying the Givens */ -/* rotations and permutation and then multiplying the center matrices */ -/* against the current Z. */ - - ptr = pow_ii(&c__2, tlvls) + 1; - i__1 = *curlvl - 1; - for (k = 1; k <= i__1; ++k) { - i__2 = *curlvl - k; - i__3 = *curlvl - k - 1; - curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) - - 1; - psiz1 = prmptr[curr + 1] - prmptr[curr]; - psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; - zptr1 = mid - psiz1; - -/* Apply Givens at CURR and CURR+1 */ - - i__2 = givptr[curr + 1] - 1; - for (i__ = givptr[curr]; i__ <= i__2; ++i__) { - drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, & - z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[( - i__ << 1) + 1], &givnum[(i__ << 1) + 2]); -/* L30: */ - } - i__2 = givptr[curr + 2] - 1; - for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) { - drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[ - mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << - 1) + 1], &givnum[(i__ << 1) + 2]); -/* L40: */ - } - psiz1 = prmptr[curr + 1] - prmptr[curr]; - psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; - i__2 = psiz1 - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1]; -/* L50: */ - } - i__2 = psiz2 - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - - 1]; -/* L60: */ - } - -/* Multiply Blocks at CURR and CURR+1 */ - -/* Determine size of these matrices. We add HALF to the value of */ -/* the SQRT in case the machine underestimates one of these */ -/* square roots. */ - - bsiz1 = (integer) (sqrt((double) (qptr[curr + 1] - qptr[curr])) + - .5); - bsiz2 = (integer) (sqrt((double) (qptr[curr + 2] - qptr[curr + 1]) - ) + .5); - if (bsiz1 > 0) { - dgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, & - ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1); - } - i__2 = psiz1 - bsiz1; - dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); - if (bsiz2 > 0) { - dgemv_("T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, & - ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1); - } - i__2 = psiz2 - bsiz2; - dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], & - c__1); - - i__2 = *tlvls - k; - ptr += pow_ii(&c__2, &i__2); -/* L70: */ - } - - return 0; - -/* End of DLAEDA */ - -} /* dlaeda_ */ diff --git a/external/clapack/lapack/dlaein.cpp b/external/clapack/lapack/dlaein.cpp deleted file mode 100644 index d6cbf2eb..00000000 --- a/external/clapack/lapack/dlaein.cpp +++ /dev/null @@ -1,652 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dlaein_(bool *rightv, bool *noinit, integer *n, - double *h__, integer *ldh, double *wr, double *wi, - double *vr, double *vi, double *b, integer *ldb, - double *work, double *eps3, double *smlnum, double * - bignum, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer i__, j; - double w, x, y; - integer i1, i2, i3; - double w1, ei, ej, xi, xr, rec; - integer its, ierr; - double temp, norm, vmax; - double scale; - char trans[1]; - double vcrit, rootn, vnorm; - double absbii, absbjj; - char normin[1]; - double nrmsml, growto; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAEIN uses inverse iteration to find a right or left eigenvector */ -/* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg */ -/* matrix H. */ - -/* Arguments */ -/* ========= */ - -/* RIGHTV (input) LOGICAL */ -/* = .TRUE. : compute right eigenvector; */ -/* = .FALSE.: compute left eigenvector. */ - -/* NOINIT (input) LOGICAL */ -/* = .TRUE. : no initial vector supplied in (VR,VI). */ -/* = .FALSE.: initial vector supplied in (VR,VI). */ - -/* N (input) INTEGER */ -/* The order of the matrix H. N >= 0. */ - -/* H (input) DOUBLE PRECISION array, dimension (LDH,N) */ -/* The upper Hessenberg matrix H. */ - -/* LDH (input) INTEGER */ -/* The leading dimension of the array H. LDH >= max(1,N). */ - -/* WR (input) DOUBLE PRECISION */ -/* WI (input) DOUBLE PRECISION */ -/* The real and imaginary parts of the eigenvalue of H whose */ -/* corresponding right or left eigenvector is to be computed. */ - -/* VR (input/output) DOUBLE PRECISION array, dimension (N) */ -/* VI (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */ -/* a real starting vector for inverse iteration using the real */ -/* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */ -/* must contain the real and imaginary parts of a complex */ -/* starting vector for inverse iteration using the complex */ -/* eigenvalue (WR,WI); otherwise VR and VI need not be set. */ -/* On exit, if WI = 0.0 (real eigenvalue), VR contains the */ -/* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue), */ -/* VR and VI contain the real and imaginary parts of the */ -/* computed complex eigenvector. The eigenvector is normalized */ -/* so that the component of largest magnitude has magnitude 1; */ -/* here the magnitude of a complex number (x,y) is taken to be */ -/* |x| + |y|. */ -/* VI is not referenced if WI = 0.0. */ - -/* B (workspace) DOUBLE PRECISION array, dimension (LDB,N) */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= N+1. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ - -/* EPS3 (input) DOUBLE PRECISION */ -/* A small machine-dependent value which is used to perturb */ -/* close eigenvalues, and to replace zero pivots. */ - -/* SMLNUM (input) DOUBLE PRECISION */ -/* A machine-dependent value close to the underflow threshold. */ - -/* BIGNUM (input) DOUBLE PRECISION */ -/* A machine-dependent value close to the overflow threshold. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* = 1: inverse iteration did not converge; VR is set to the */ -/* last iterate, and so is VI if WI.ne.0.0. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - --vr; - --vi; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --work; - - /* Function Body */ - *info = 0; - -/* GROWTO is the threshold used in the acceptance test for an */ -/* eigenvector. */ - - rootn = sqrt((double) (*n)); - growto = .1 / rootn; -/* Computing MAX */ - d__1 = 1., d__2 = *eps3 * rootn; - nrmsml = std::max(d__1,d__2) * *smlnum; - -/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */ -/* the imaginary parts of the diagonal elements are not stored). */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = h__[i__ + j * h_dim1]; -/* L10: */ - } - b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr; -/* L20: */ - } - - if (*wi == 0.) { - -/* Real eigenvalue. */ - - if (*noinit) { - -/* Set initial vector. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - vr[i__] = *eps3; -/* L30: */ - } - } else { - -/* Scale supplied initial vector. */ - - vnorm = dnrm2_(n, &vr[1], &c__1); - d__1 = *eps3 * rootn / std::max(vnorm,nrmsml); - dscal_(n, &d__1, &vr[1], &c__1); - } - - if (*rightv) { - -/* LU decomposition with partial pivoting of B, replacing zero */ -/* pivots by EPS3. */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - ei = h__[i__ + 1 + i__ * h_dim1]; - if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) < abs(ei)) { - -/* Interchange rows and eliminate. */ - - x = b[i__ + i__ * b_dim1] / ei; - b[i__ + i__ * b_dim1] = ei; - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - temp = b[i__ + 1 + j * b_dim1]; - b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x * - temp; - b[i__ + j * b_dim1] = temp; -/* L40: */ - } - } else { - -/* Eliminate without interchange. */ - - if (b[i__ + i__ * b_dim1] == 0.) { - b[i__ + i__ * b_dim1] = *eps3; - } - x = ei / b[i__ + i__ * b_dim1]; - if (x != 0.) { - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1] - ; -/* L50: */ - } - } - } -/* L60: */ - } - if (b[*n + *n * b_dim1] == 0.) { - b[*n + *n * b_dim1] = *eps3; - } - - *(unsigned char *)trans = 'N'; - - } else { - -/* UL decomposition with partial pivoting of B, replacing zero */ -/* pivots by EPS3. */ - - for (j = *n; j >= 2; --j) { - ej = h__[j + (j - 1) * h_dim1]; - if ((d__1 = b[j + j * b_dim1], abs(d__1)) < abs(ej)) { - -/* Interchange columns and eliminate. */ - - x = b[j + j * b_dim1] / ej; - b[j + j * b_dim1] = ej; - i__1 = j - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = b[i__ + (j - 1) * b_dim1]; - b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x * - temp; - b[i__ + j * b_dim1] = temp; -/* L70: */ - } - } else { - -/* Eliminate without interchange. */ - - if (b[j + j * b_dim1] == 0.) { - b[j + j * b_dim1] = *eps3; - } - x = ej / b[j + j * b_dim1]; - if (x != 0.) { - i__1 = j - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j * - b_dim1]; -/* L80: */ - } - } - } -/* L90: */ - } - if (b[b_dim1 + 1] == 0.) { - b[b_dim1 + 1] = *eps3; - } - - *(unsigned char *)trans = 'T'; - - } - - *(unsigned char *)normin = 'N'; - i__1 = *n; - for (its = 1; its <= i__1; ++its) { - -/* Solve U*x = scale*v for a right eigenvector */ -/* or U'*x = scale*v for a left eigenvector, */ -/* overwriting x on v. */ - - dlatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, & - vr[1], &scale, &work[1], &ierr); - *(unsigned char *)normin = 'Y'; - -/* Test for sufficient growth in the norm of v. */ - - vnorm = dasum_(n, &vr[1], &c__1); - if (vnorm >= growto * scale) { - goto L120; - } - -/* Choose new orthogonal starting vector and try again. */ - - temp = *eps3 / (rootn + 1.); - vr[1] = *eps3; - i__2 = *n; - for (i__ = 2; i__ <= i__2; ++i__) { - vr[i__] = temp; -/* L100: */ - } - vr[*n - its + 1] -= *eps3 * rootn; -/* L110: */ - } - -/* Failure to find eigenvector in N iterations. */ - - *info = 1; - -L120: - -/* Normalize eigenvector. */ - - i__ = idamax_(n, &vr[1], &c__1); - d__2 = 1. / (d__1 = vr[i__], abs(d__1)); - dscal_(n, &d__2, &vr[1], &c__1); - } else { - -/* Complex eigenvalue. */ - - if (*noinit) { - -/* Set initial vector. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - vr[i__] = *eps3; - vi[i__] = 0.; -/* L130: */ - } - } else { - -/* Scale supplied initial vector. */ - - d__1 = dnrm2_(n, &vr[1], &c__1); - d__2 = dnrm2_(n, &vi[1], &c__1); - norm = dlapy2_(&d__1, &d__2); - rec = *eps3 * rootn / std::max(norm,nrmsml); - dscal_(n, &rec, &vr[1], &c__1); - dscal_(n, &rec, &vi[1], &c__1); - } - - if (*rightv) { - -/* LU decomposition with partial pivoting of B, replacing zero */ -/* pivots by EPS3. */ - -/* The imaginary part of the (i,j)-th element of U is stored in */ -/* B(j+1,i). */ - - b[b_dim1 + 2] = -(*wi); - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - b[i__ + 1 + b_dim1] = 0.; -/* L140: */ - } - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - absbii = dlapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * - b_dim1]); - ei = h__[i__ + 1 + i__ * h_dim1]; - if (absbii < abs(ei)) { - -/* Interchange rows and eliminate. */ - - xr = b[i__ + i__ * b_dim1] / ei; - xi = b[i__ + 1 + i__ * b_dim1] / ei; - b[i__ + i__ * b_dim1] = ei; - b[i__ + 1 + i__ * b_dim1] = 0.; - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - temp = b[i__ + 1 + j * b_dim1]; - b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr * - temp; - b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ * - b_dim1] - xi * temp; - b[i__ + j * b_dim1] = temp; - b[j + 1 + i__ * b_dim1] = 0.; -/* L150: */ - } - b[i__ + 2 + i__ * b_dim1] = -(*wi); - b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi; - b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi; - } else { - -/* Eliminate without interchanging rows. */ - - if (absbii == 0.) { - b[i__ + i__ * b_dim1] = *eps3; - b[i__ + 1 + i__ * b_dim1] = 0.; - absbii = *eps3; - } - ei = ei / absbii / absbii; - xr = b[i__ + i__ * b_dim1] * ei; - xi = -b[i__ + 1 + i__ * b_dim1] * ei; - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] - - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ - * b_dim1]; - b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ * - b_dim1] - xi * b[i__ + j * b_dim1]; -/* L160: */ - } - b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi; - } - -/* Compute 1-norm of offdiagonal elements of i-th row. */ - - i__2 = *n - i__; - i__3 = *n - i__; - work[i__] = dasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb) - + dasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1); -/* L170: */ - } - if (b[*n + *n * b_dim1] == 0. && b[*n + 1 + *n * b_dim1] == 0.) { - b[*n + *n * b_dim1] = *eps3; - } - work[*n] = 0.; - - i1 = *n; - i2 = 1; - i3 = -1; - } else { - -/* UL decomposition with partial pivoting of conjg(B), */ -/* replacing zero pivots by EPS3. */ - -/* The imaginary part of the (i,j)-th element of U is stored in */ -/* B(j+1,i). */ - - b[*n + 1 + *n * b_dim1] = *wi; - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - b[*n + 1 + j * b_dim1] = 0.; -/* L180: */ - } - - for (j = *n; j >= 2; --j) { - ej = h__[j + (j - 1) * h_dim1]; - absbjj = dlapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]); - if (absbjj < abs(ej)) { - -/* Interchange columns and eliminate */ - - xr = b[j + j * b_dim1] / ej; - xi = b[j + 1 + j * b_dim1] / ej; - b[j + j * b_dim1] = ej; - b[j + 1 + j * b_dim1] = 0.; - i__1 = j - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = b[i__ + (j - 1) * b_dim1]; - b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr * - temp; - b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * - temp; - b[i__ + j * b_dim1] = temp; - b[j + 1 + i__ * b_dim1] = 0.; -/* L190: */ - } - b[j + 1 + (j - 1) * b_dim1] = *wi; - b[j - 1 + (j - 1) * b_dim1] += xi * *wi; - b[j + (j - 1) * b_dim1] -= xr * *wi; - } else { - -/* Eliminate without interchange. */ - - if (absbjj == 0.) { - b[j + j * b_dim1] = *eps3; - b[j + 1 + j * b_dim1] = 0.; - absbjj = *eps3; - } - ej = ej / absbjj / absbjj; - xr = b[j + j * b_dim1] * ej; - xi = -b[j + 1 + j * b_dim1] * ej; - i__1 = j - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1] - - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + - i__ * b_dim1]; - b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - - xi * b[i__ + j * b_dim1]; -/* L200: */ - } - b[j + (j - 1) * b_dim1] += *wi; - } - -/* Compute 1-norm of offdiagonal elements of j-th column. */ - - i__1 = j - 1; - i__2 = j - 1; - work[j] = dasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + dasum_(& - i__2, &b[j + 1 + b_dim1], ldb); -/* L210: */ - } - if (b[b_dim1 + 1] == 0. && b[b_dim1 + 2] == 0.) { - b[b_dim1 + 1] = *eps3; - } - work[1] = 0.; - - i1 = 1; - i2 = *n; - i3 = 1; - } - - i__1 = *n; - for (its = 1; its <= i__1; ++its) { - scale = 1.; - vmax = 1.; - vcrit = *bignum; - -/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */ -/* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector, */ -/* overwriting (xr,xi) on (vr,vi). */ - - i__2 = i2; - i__3 = i3; - for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) - { - - if (work[i__] > vcrit) { - rec = 1. / vmax; - dscal_(n, &rec, &vr[1], &c__1); - dscal_(n, &rec, &vi[1], &c__1); - scale *= rec; - vmax = 1.; - vcrit = *bignum; - } - - xr = vr[i__]; - xi = vi[i__]; - if (*rightv) { - i__4 = *n; - for (j = i__ + 1; j <= i__4; ++j) { - xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__ - * b_dim1] * vi[j]; - xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__ - * b_dim1] * vr[j]; -/* L220: */ - } - } else { - i__4 = i__ - 1; - for (j = 1; j <= i__4; ++j) { - xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j - * b_dim1] * vi[j]; - xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j - * b_dim1] * vr[j]; -/* L230: */ - } - } - - w = (d__1 = b[i__ + i__ * b_dim1], abs(d__1)) + (d__2 = b[i__ - + 1 + i__ * b_dim1], abs(d__2)); - if (w > *smlnum) { - if (w < 1.) { - w1 = abs(xr) + abs(xi); - if (w1 > w * *bignum) { - rec = 1. / w1; - dscal_(n, &rec, &vr[1], &c__1); - dscal_(n, &rec, &vi[1], &c__1); - xr = vr[i__]; - xi = vi[i__]; - scale *= rec; - vmax *= rec; - } - } - -/* Divide by diagonal element of B. */ - - dladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 + - i__ * b_dim1], &vr[i__], &vi[i__]); -/* Computing MAX */ - d__3 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__], abs( - d__2)); - vmax = std::max(d__3,vmax); - vcrit = *bignum / vmax; - } else { - i__4 = *n; - for (j = 1; j <= i__4; ++j) { - vr[j] = 0.; - vi[j] = 0.; -/* L240: */ - } - vr[i__] = 1.; - vi[i__] = 1.; - scale = 0.; - vmax = 1.; - vcrit = *bignum; - } -/* L250: */ - } - -/* Test for sufficient growth in the norm of (VR,VI). */ - - vnorm = dasum_(n, &vr[1], &c__1) + dasum_(n, &vi[1], &c__1); - if (vnorm >= growto * scale) { - goto L280; - } - -/* Choose a new orthogonal starting vector and try again. */ - - y = *eps3 / (rootn + 1.); - vr[1] = *eps3; - vi[1] = 0.; - - i__3 = *n; - for (i__ = 2; i__ <= i__3; ++i__) { - vr[i__] = y; - vi[i__] = 0.; -/* L260: */ - } - vr[*n - its + 1] -= *eps3 * rootn; -/* L270: */ - } - -/* Failure to find eigenvector in N iterations */ - - *info = 1; - -L280: - -/* Normalize eigenvector. */ - - vnorm = 0.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__3 = vnorm, d__4 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__] - , abs(d__2)); - vnorm = std::max(d__3,d__4); -/* L290: */ - } - d__1 = 1. / vnorm; - dscal_(n, &d__1, &vr[1], &c__1); - d__1 = 1. / vnorm; - dscal_(n, &d__1, &vi[1], &c__1); - - } - - return 0; - -/* End of DLAEIN */ - -} /* dlaein_ */ diff --git a/external/clapack/lapack/dlaev2.cpp b/external/clapack/lapack/dlaev2.cpp deleted file mode 100644 index a70ab04c..00000000 --- a/external/clapack/lapack/dlaev2.cpp +++ /dev/null @@ -1,176 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaev2_(double *a, double *b, double *c__, - double *rt1, double *rt2, double *cs1, double *sn1) -{ - /* System generated locals */ - double d__1; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - double ab, df, cs, ct, tb, sm, tn, rt, adf, acs; - integer sgn1, sgn2; - double acmn, acmx; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */ -/* [ A B ] */ -/* [ B C ]. */ -/* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */ -/* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */ -/* eigenvector for RT1, giving the decomposition */ - -/* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] */ -/* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. */ - -/* Arguments */ -/* ========= */ - -/* A (input) DOUBLE PRECISION */ -/* The (1,1) element of the 2-by-2 matrix. */ - -/* B (input) DOUBLE PRECISION */ -/* The (1,2) element and the conjugate of the (2,1) element of */ -/* the 2-by-2 matrix. */ - -/* C (input) DOUBLE PRECISION */ -/* The (2,2) element of the 2-by-2 matrix. */ - -/* RT1 (output) DOUBLE PRECISION */ -/* The eigenvalue of larger absolute value. */ - -/* RT2 (output) DOUBLE PRECISION */ -/* The eigenvalue of smaller absolute value. */ - -/* CS1 (output) DOUBLE PRECISION */ -/* SN1 (output) DOUBLE PRECISION */ -/* The vector (CS1, SN1) is a unit right eigenvector for RT1. */ - -/* Further Details */ -/* =============== */ - -/* RT1 is accurate to a few ulps barring over/underflow. */ - -/* RT2 may be inaccurate if there is massive cancellation in the */ -/* determinant A*C-B*B; higher precision or correctly rounded or */ -/* correctly truncated arithmetic would be needed to compute RT2 */ -/* accurately in all cases. */ - -/* CS1 and SN1 are accurate to a few ulps barring over/underflow. */ - -/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */ -/* Underflow is harmless if the input data is 0 or exceeds */ -/* underflow_threshold / macheps. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Compute the eigenvalues */ - - sm = *a + *c__; - df = *a - *c__; - adf = abs(df); - tb = *b + *b; - ab = abs(tb); - if (abs(*a) > abs(*c__)) { - acmx = *a; - acmn = *c__; - } else { - acmx = *c__; - acmn = *a; - } - if (adf > ab) { -/* Computing 2nd power */ - d__1 = ab / adf; - rt = adf * sqrt(d__1 * d__1 + 1.); - } else if (adf < ab) { -/* Computing 2nd power */ - d__1 = adf / ab; - rt = ab * sqrt(d__1 * d__1 + 1.); - } else { - -/* Includes case AB=ADF=0 */ - - rt = ab * sqrt(2.); - } - if (sm < 0.) { - *rt1 = (sm - rt) * .5; - sgn1 = -1; - -/* Order of execution important. */ -/* To get fully accurate smaller eigenvalue, */ -/* next line needs to be executed in higher precision. */ - - *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; - } else if (sm > 0.) { - *rt1 = (sm + rt) * .5; - sgn1 = 1; - -/* Order of execution important. */ -/* To get fully accurate smaller eigenvalue, */ -/* next line needs to be executed in higher precision. */ - - *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; - } else { - -/* Includes case RT1 = RT2 = 0 */ - - *rt1 = rt * .5; - *rt2 = rt * -.5; - sgn1 = 1; - } - -/* Compute the eigenvector */ - - if (df >= 0.) { - cs = df + rt; - sgn2 = 1; - } else { - cs = df - rt; - sgn2 = -1; - } - acs = abs(cs); - if (acs > ab) { - ct = -tb / cs; - *sn1 = 1. / sqrt(ct * ct + 1.); - *cs1 = ct * *sn1; - } else { - if (ab == 0.) { - *cs1 = 1.; - *sn1 = 0.; - } else { - tn = -cs / tb; - *cs1 = 1. / sqrt(tn * tn + 1.); - *sn1 = tn * *cs1; - } - } - if (sgn1 == sgn2) { - tn = *cs1; - *cs1 = -(*sn1); - *sn1 = tn; - } - return 0; - -/* End of DLAEV2 */ - -} /* dlaev2_ */ diff --git a/external/clapack/lapack/dlaexc.cpp b/external/clapack/lapack/dlaexc.cpp deleted file mode 100644 index 916d3a14..00000000 --- a/external/clapack/lapack/dlaexc.cpp +++ /dev/null @@ -1,431 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__4 = 4; -static bool c_false = false; -static integer c_n1 = -1; -static integer c__2 = 2; -static integer c__3 = 3; - -/* Subroutine */ int dlaexc_(bool *wantq, integer *n, double *t, - integer *ldt, double *q, integer *ldq, integer *j1, integer *n1, - integer *n2, double *work, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, t_dim1, t_offset, i__1; - double d__1, d__2, d__3; - - /* Local variables */ - double d__[16] /* was [4][4] */; - integer k; - double u[3], x[4] /* was [2][2] */; - integer j2, j3, j4; - double u1[3], u2[3]; - integer nd; - double cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1, - tau2; - integer ierr; - double temp; - double scale, dnorm, xnorm; - double thresh, smlnum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in */ -/* an upper quasi-triangular matrix T by an orthogonal similarity */ -/* transformation. */ - -/* T must be in Schur canonical form, that is, block upper triangular */ -/* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block */ -/* has its diagonal elemnts equal and its off-diagonal elements of */ -/* opposite sign. */ - -/* Arguments */ -/* ========= */ - -/* WANTQ (input) LOGICAL */ -/* = .TRUE. : accumulate the transformation in the matrix Q; */ -/* = .FALSE.: do not accumulate the transformation. */ - -/* N (input) INTEGER */ -/* The order of the matrix T. N >= 0. */ - -/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */ -/* On entry, the upper quasi-triangular matrix T, in Schur */ -/* canonical form. */ -/* On exit, the updated matrix T, again in Schur canonical form. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= max(1,N). */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* On entry, if WANTQ is .TRUE., the orthogonal matrix Q. */ -/* On exit, if WANTQ is .TRUE., the updated matrix Q. */ -/* If WANTQ is .FALSE., Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. */ -/* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. */ - -/* J1 (input) INTEGER */ -/* The index of the first row of the first block T11. */ - -/* N1 (input) INTEGER */ -/* The order of the first block T11. N1 = 0, 1 or 2. */ - -/* N2 (input) INTEGER */ -/* The order of the second block T22. N2 = 0, 1 or 2. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* = 1: the transformed matrix T would be too far from Schur */ -/* form; the blocks are not swapped and T and Q are */ -/* unchanged. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --work; - - /* Function Body */ - *info = 0; - -/* Quick return if possible */ - - if (*n == 0 || *n1 == 0 || *n2 == 0) { - return 0; - } - if (*j1 + *n1 > *n) { - return 0; - } - - j2 = *j1 + 1; - j3 = *j1 + 2; - j4 = *j1 + 3; - - if (*n1 == 1 && *n2 == 1) { - -/* Swap two 1-by-1 blocks. */ - - t11 = t[*j1 + *j1 * t_dim1]; - t22 = t[j2 + j2 * t_dim1]; - -/* Determine the transformation to perform the interchange. */ - - d__1 = t22 - t11; - dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp); - -/* Apply transformation to the matrix T. */ - - if (j3 <= *n) { - i__1 = *n - *j1 - 1; - drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1], - ldt, &cs, &sn); - } - i__1 = *j1 - 1; - drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1, - &cs, &sn); - - t[*j1 + *j1 * t_dim1] = t22; - t[j2 + j2 * t_dim1] = t11; - - if (*wantq) { - -/* Accumulate transformation in the matrix Q. */ - - drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1, - &cs, &sn); - } - - } else { - -/* Swapping involves at least one 2-by-2 block. */ - -/* Copy the diagonal block of order N1+N2 to the local array D */ -/* and compute its norm. */ - - nd = *n1 + *n2; - dlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4); - dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]); - -/* Compute machine-dependent threshold for test for accepting */ -/* swap. */ - - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; -/* Computing MAX */ - d__1 = eps * 10. * dnorm; - thresh = std::max(d__1,smlnum); - -/* Solve T11*X - X*T22 = scale*T12 for X. */ - - dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 + - (*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, & - scale, x, &c__2, &xnorm, &ierr); - -/* Swap the adjacent diagonal blocks. */ - - k = *n1 + *n1 + *n2 - 3; - switch (k) { - case 1: goto L10; - case 2: goto L20; - case 3: goto L30; - } - -L10: - -/* N1 = 1, N2 = 2: generate elementary reflector H so that: */ - -/* ( scale, X11, X12 ) H = ( 0, 0, * ) */ - - u[0] = scale; - u[1] = x[0]; - u[2] = x[2]; - dlarfg_(&c__3, &u[2], u, &c__1, &tau); - u[2] = 1.; - t11 = t[*j1 + *j1 * t_dim1]; - -/* Perform swap provisionally on diagonal block in D. */ - - dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); - dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); - -/* Test whether to reject swap. */ - -/* Computing MAX */ - d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = std::max(d__2,d__3), d__3 = - (d__1 = d__[10] - t11, abs(d__1)); - if (std::max(d__2,d__3) > thresh) { - goto L50; - } - -/* Accept swap: apply transformation to the entire matrix T. */ - - i__1 = *n - *j1 + 1; - dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, & - work[1]); - dlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); - - t[j3 + *j1 * t_dim1] = 0.; - t[j3 + j2 * t_dim1] = 0.; - t[j3 + j3 * t_dim1] = t11; - - if (*wantq) { - -/* Accumulate transformation in the matrix Q. */ - - dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ - 1]); - } - goto L40; - -L20: - -/* N1 = 2, N2 = 1: generate elementary reflector H so that: */ - -/* H ( -X11 ) = ( * ) */ -/* ( -X21 ) = ( 0 ) */ -/* ( scale ) = ( 0 ) */ - - u[0] = -x[0]; - u[1] = -x[1]; - u[2] = scale; - dlarfg_(&c__3, u, &u[1], &c__1, &tau); - u[0] = 1.; - t33 = t[j3 + j3 * t_dim1]; - -/* Perform swap provisionally on diagonal block in D. */ - - dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); - dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); - -/* Test whether to reject swap. */ - -/* Computing MAX */ - d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = std::max(d__2,d__3), d__3 = - (d__1 = d__[0] - t33, abs(d__1)); - if (std::max(d__2,d__3) > thresh) { - goto L50; - } - -/* Accept swap: apply transformation to the entire matrix T. */ - - dlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); - i__1 = *n - *j1; - dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[ - 1]); - - t[*j1 + *j1 * t_dim1] = t33; - t[j2 + *j1 * t_dim1] = 0.; - t[j3 + *j1 * t_dim1] = 0.; - - if (*wantq) { - -/* Accumulate transformation in the matrix Q. */ - - dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ - 1]); - } - goto L40; - -L30: - -/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so */ -/* that: */ - -/* H(2) H(1) ( -X11 -X12 ) = ( * * ) */ -/* ( -X21 -X22 ) ( 0 * ) */ -/* ( scale 0 ) ( 0 0 ) */ -/* ( 0 scale ) ( 0 0 ) */ - - u1[0] = -x[0]; - u1[1] = -x[1]; - u1[2] = scale; - dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1); - u1[0] = 1.; - - temp = -tau1 * (x[2] + u1[1] * x[3]); - u2[0] = -temp * u1[1] - x[3]; - u2[1] = -temp * u1[2]; - u2[2] = scale; - dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2); - u2[0] = 1.; - -/* Perform swap provisionally on diagonal block in D. */ - - dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1]) - ; - dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1]) - ; - dlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]); - dlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]); - -/* Test whether to reject swap. */ - -/* Computing MAX */ - d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = std::max(d__1,d__2), d__2 = - abs(d__[3]), d__1 = std::max(d__1,d__2), d__2 = abs(d__[7]); - if (std::max(d__1,d__2) > thresh) { - goto L50; - } - -/* Accept swap: apply transformation to the entire matrix T. */ - - i__1 = *n - *j1 + 1; - dlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, & - work[1]); - dlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[ - 1]); - i__1 = *n - *j1 + 1; - dlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, & - work[1]); - dlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1] -); - - t[j3 + *j1 * t_dim1] = 0.; - t[j3 + j2 * t_dim1] = 0.; - t[j4 + *j1 * t_dim1] = 0.; - t[j4 + j2 * t_dim1] = 0.; - - if (*wantq) { - -/* Accumulate transformation in the matrix Q. */ - - dlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, & - work[1]); - dlarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[ - 1]); - } - -L40: - - if (*n2 == 2) { - -/* Standardize new 2-by-2 block T11 */ - - dlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + * - j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, & - wi2, &cs, &sn); - i__1 = *n - *j1 - 1; - drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2) - * t_dim1], ldt, &cs, &sn); - i__1 = *j1 - 1; - drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], & - c__1, &cs, &sn); - if (*wantq) { - drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], & - c__1, &cs, &sn); - } - } - - if (*n1 == 2) { - -/* Standardize new 2-by-2 block T22 */ - - j3 = *j1 + *n2; - j4 = j3 + 1; - dlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 * - t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, & - cs, &sn); - if (j3 + 2 <= *n) { - i__1 = *n - j3 - 1; - drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2) - * t_dim1], ldt, &cs, &sn); - } - i__1 = j3 - 1; - drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], & - c__1, &cs, &sn); - if (*wantq) { - drot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], & - c__1, &cs, &sn); - } - } - - } - return 0; - -/* Exit with INFO = 1 if swap was rejected. */ - -L50: - *info = 1; - return 0; - -/* End of DLAEXC */ - -} /* dlaexc_ */ diff --git a/external/clapack/lapack/dlag2.cpp b/external/clapack/lapack/dlag2.cpp deleted file mode 100644 index b9eb52a6..00000000 --- a/external/clapack/lapack/dlag2.cpp +++ /dev/null @@ -1,344 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlag2_(double *a, integer *lda, double *b, - integer *ldb, double *safmin, double *scale1, double * - scale2, double *wr1, double *wr2, double *wi) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset; - double d__1, d__2, d__3, d__4, d__5, d__6; - - /* Builtin functions - double sqrt(double), d_sign(double *, double *); */ - - /* Local variables */ - double r__, c1, c2, c3, c4, c5, s1, s2, a11, a12, a21, a22, b11, b12, - b22, pp, qq, ss, as11, as12, as22, sum, abi22, diff, bmin, wbig, - wabs, wdet, binv11, binv22, discr, anorm, bnorm, bsize, shift, - rtmin, rtmax, wsize, ascale, bscale, wscale, safmax, wsmall; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue */ -/* problem A - w B, with scaling as necessary to avoid over-/underflow. */ - -/* The scaling factor "s" results in a modified eigenvalue equation */ - -/* s A - w B */ - -/* where s is a non-negative scaling factor chosen so that w, w B, */ -/* and s A do not overflow and, if possible, do not underflow, either. */ - -/* Arguments */ -/* ========= */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA, 2) */ -/* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm */ -/* is less than 1/SAFMIN. Entries less than */ -/* sqrt(SAFMIN)*norm(A) are subject to being treated as zero. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= 2. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB, 2) */ -/* On entry, the 2 x 2 upper triangular matrix B. It is */ -/* assumed that the one-norm of B is less than 1/SAFMIN. The */ -/* diagonals should be at least sqrt(SAFMIN) times the largest */ -/* element of B (in absolute value); if a diagonal is smaller */ -/* than that, then +/- sqrt(SAFMIN) will be used instead of */ -/* that diagonal. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= 2. */ - -/* SAFMIN (input) DOUBLE PRECISION */ -/* The smallest positive number s.t. 1/SAFMIN does not */ -/* overflow. (This should always be DLAMCH('S') -- it is an */ -/* argument in order to avoid having to call DLAMCH frequently.) */ - -/* SCALE1 (output) DOUBLE PRECISION */ -/* A scaling factor used to avoid over-/underflow in the */ -/* eigenvalue equation which defines the first eigenvalue. If */ -/* the eigenvalues are complex, then the eigenvalues are */ -/* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the */ -/* exponent range of the machine), SCALE1=SCALE2, and SCALE1 */ -/* will always be positive. If the eigenvalues are real, then */ -/* the first (real) eigenvalue is WR1 / SCALE1 , but this may */ -/* overflow or underflow, and in fact, SCALE1 may be zero or */ -/* less than the underflow threshhold if the exact eigenvalue */ -/* is sufficiently large. */ - -/* SCALE2 (output) DOUBLE PRECISION */ -/* A scaling factor used to avoid over-/underflow in the */ -/* eigenvalue equation which defines the second eigenvalue. If */ -/* the eigenvalues are complex, then SCALE2=SCALE1. If the */ -/* eigenvalues are real, then the second (real) eigenvalue is */ -/* WR2 / SCALE2 , but this may overflow or underflow, and in */ -/* fact, SCALE2 may be zero or less than the underflow */ -/* threshhold if the exact eigenvalue is sufficiently large. */ - -/* WR1 (output) DOUBLE PRECISION */ -/* If the eigenvalue is real, then WR1 is SCALE1 times the */ -/* eigenvalue closest to the (2,2) element of A B**(-1). If the */ -/* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real */ -/* part of the eigenvalues. */ - -/* WR2 (output) DOUBLE PRECISION */ -/* If the eigenvalue is real, then WR2 is SCALE2 times the */ -/* other eigenvalue. If the eigenvalue is complex, then */ -/* WR1=WR2 is SCALE1 times the real part of the eigenvalues. */ - -/* WI (output) DOUBLE PRECISION */ -/* If the eigenvalue is real, then WI is zero. If the */ -/* eigenvalue is complex, then WI is SCALE1 times the imaginary */ -/* part of the eigenvalues. WI will always be non-negative. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - rtmin = sqrt(*safmin); - rtmax = 1. / rtmin; - safmax = 1. / *safmin; - -/* Scale A */ - -/* Computing MAX */ - d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs( - d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 = - a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = std::max(d__5,d__6); - anorm = std::max(d__5,*safmin); - ascale = 1. / anorm; - a11 = ascale * a[a_dim1 + 1]; - a21 = ascale * a[a_dim1 + 2]; - a12 = ascale * a[(a_dim1 << 1) + 1]; - a22 = ascale * a[(a_dim1 << 1) + 2]; - -/* Perturb B if necessary to insure non-singularity */ - - b11 = b[b_dim1 + 1]; - b12 = b[(b_dim1 << 1) + 1]; - b22 = b[(b_dim1 << 1) + 2]; -/* Computing MAX */ - d__1 = abs(b11), d__2 = abs(b12), d__1 = std::max(d__1,d__2), d__2 = abs(b22), - d__1 = std::max(d__1,d__2); - bmin = rtmin * std::max(d__1,rtmin); - if (abs(b11) < bmin) { - b11 = d_sign(&bmin, &b11); - } - if (abs(b22) < bmin) { - b22 = d_sign(&bmin, &b22); - } - -/* Scale B */ - -/* Computing MAX */ - d__1 = abs(b11), d__2 = abs(b12) + abs(b22), d__1 = std::max(d__1,d__2); - bnorm = std::max(d__1,*safmin); -/* Computing MAX */ - d__1 = abs(b11), d__2 = abs(b22); - bsize = std::max(d__1,d__2); - bscale = 1. / bsize; - b11 *= bscale; - b12 *= bscale; - b22 *= bscale; - -/* Compute larger eigenvalue by method described by C. van Loan */ - -/* ( AS is A shifted by -SHIFT*B ) */ - - binv11 = 1. / b11; - binv22 = 1. / b22; - s1 = a11 * binv11; - s2 = a22 * binv22; - if (abs(s1) <= abs(s2)) { - as12 = a12 - s1 * b12; - as22 = a22 - s1 * b22; - ss = a21 * (binv11 * binv22); - abi22 = as22 * binv22 - ss * b12; - pp = abi22 * .5; - shift = s1; - } else { - as12 = a12 - s2 * b12; - as11 = a11 - s2 * b11; - ss = a21 * (binv11 * binv22); - abi22 = -ss * b12; - pp = (as11 * binv11 + abi22) * .5; - shift = s2; - } - qq = ss * as12; - if ((d__1 = pp * rtmin, abs(d__1)) >= 1.) { -/* Computing 2nd power */ - d__1 = rtmin * pp; - discr = d__1 * d__1 + qq * *safmin; - r__ = sqrt((abs(discr))) * rtmax; - } else { -/* Computing 2nd power */ - d__1 = pp; - if (d__1 * d__1 + abs(qq) <= *safmin) { -/* Computing 2nd power */ - d__1 = rtmax * pp; - discr = d__1 * d__1 + qq * safmax; - r__ = sqrt((abs(discr))) * rtmin; - } else { -/* Computing 2nd power */ - d__1 = pp; - discr = d__1 * d__1 + qq; - r__ = sqrt((abs(discr))); - } - } - -/* Note: the test of R in the following IF is to cover the case when */ -/* DISCR is small and negative and is flushed to zero during */ -/* the calculation of R. On machines which have a consistent */ -/* flush-to-zero threshhold and handle numbers above that */ -/* threshhold correctly, it would not be necessary. */ - - if (discr >= 0. || r__ == 0.) { - sum = pp + d_sign(&r__, &pp); - diff = pp - d_sign(&r__, &pp); - wbig = shift + sum; - -/* Compute smaller eigenvalue */ - - wsmall = shift + diff; -/* Computing MAX */ - d__1 = abs(wsmall); - if (abs(wbig) * .5 > std::max(d__1,*safmin)) { - wdet = (a11 * a22 - a12 * a21) * (binv11 * binv22); - wsmall = wdet / wbig; - } - -/* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) */ -/* for WR1. */ - - if (pp > abi22) { - *wr1 = std::min(wbig,wsmall); - *wr2 = std::max(wbig,wsmall); - } else { - *wr1 = std::max(wbig,wsmall); - *wr2 = std::min(wbig,wsmall); - } - *wi = 0.; - } else { - -/* Complex eigenvalues */ - - *wr1 = shift + pp; - *wr2 = *wr1; - *wi = r__; - } - -/* Further scaling to avoid underflow and overflow in computing */ -/* SCALE1 and overflow in computing w*B. */ - -/* This scale factor (WSCALE) is bounded from above using C1 and C2, */ -/* and from below using C3 and C4. */ -/* C1 implements the condition s A must never overflow. */ -/* C2 implements the condition w B must never overflow. */ -/* C3, with C2, */ -/* implement the condition that s A - w B must never overflow. */ -/* C4 implements the condition s should not underflow. */ -/* C5 implements the condition max(s,|w|) should be at least 2. */ - - c1 = bsize * (*safmin * std::max(1.,ascale)); - c2 = *safmin * std::max(1.,bnorm); - c3 = bsize * *safmin; - if (ascale <= 1. && bsize <= 1.) { -/* Computing MIN */ - d__1 = 1., d__2 = ascale / *safmin * bsize; - c4 = std::min(d__1,d__2); - } else { - c4 = 1.; - } - if (ascale <= 1. || bsize <= 1.) { -/* Computing MIN */ - d__1 = 1., d__2 = ascale * bsize; - c5 = std::min(d__1,d__2); - } else { - c5 = 1.; - } - -/* Scale first eigenvalue */ - - wabs = abs(*wr1) + abs(*wi); -/* Computing MAX */ -/* Computing MIN */ - d__3 = c4, d__4 = std::max(wabs,c5) * .5; - d__1 = std::max(*safmin,c1), d__2 = (wabs * c2 + c3) * 1.0000100000000001, - d__1 = std::max(d__1,d__2), d__2 = std::min(d__3,d__4); - wsize = std::max(d__1,d__2); - if (wsize != 1.) { - wscale = 1. / wsize; - if (wsize > 1.) { - *scale1 = std::max(ascale,bsize) * wscale * std::min(ascale,bsize); - } else { - *scale1 = std::min(ascale,bsize) * wscale * std::max(ascale,bsize); - } - *wr1 *= wscale; - if (*wi != 0.) { - *wi *= wscale; - *wr2 = *wr1; - *scale2 = *scale1; - } - } else { - *scale1 = ascale * bsize; - *scale2 = *scale1; - } - -/* Scale second eigenvalue (if real) */ - - if (*wi == 0.) { -/* Computing MAX */ -/* Computing MIN */ -/* Computing MAX */ - d__5 = abs(*wr2); - d__3 = c4, d__4 = std::max(d__5,c5) * .5; - d__1 = std::max(*safmin,c1), d__2 = (abs(*wr2) * c2 + c3) * - 1.0000100000000001, d__1 = std::max(d__1,d__2), d__2 = std::min(d__3, - d__4); - wsize = std::max(d__1,d__2); - if (wsize != 1.) { - wscale = 1. / wsize; - if (wsize > 1.) { - *scale2 = std::max(ascale,bsize) * wscale * std::min(ascale,bsize); - } else { - *scale2 = std::min(ascale,bsize) * wscale * std::max(ascale,bsize); - } - *wr2 *= wscale; - } else { - *scale2 = ascale * bsize; - } - } - -/* End of DLAG2 */ - - return 0; -} /* dlag2_ */ diff --git a/external/clapack/lapack/dlag2s.cpp b/external/clapack/lapack/dlag2s.cpp deleted file mode 100644 index 49bc0291..00000000 --- a/external/clapack/lapack/dlag2s.cpp +++ /dev/null @@ -1,102 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dlag2s_(integer *m, integer *n, double *a, integer *lda, float *sa, integer *ldsa, integer *info) -{ - /* System generated locals */ - integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - double rmax; - - -/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* August 2007 */ - -/* .. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE */ -/* PRECISION matrix, A. */ - -/* RMAX is the overflow for the SINGLE PRECISION arithmetic */ -/* DLAG2S checks that all the entries of A are between -RMAX and */ -/* RMAX. If not the convertion is aborted and a flag is raised. */ - -/* This is an auxiliary routine so there is no argument checking. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of lines of the matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N coefficient matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* SA (output) REAL array, dimension (LDSA,N) */ -/* On exit, if INFO=0, the M-by-N coefficient matrix SA; if */ -/* INFO>0, the content of SA is unspecified. */ - -/* LDSA (input) INTEGER */ -/* The leading dimension of the array SA. LDSA >= max(1,M). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* = 1: an entry of the matrix A is greater than the SINGLE */ -/* PRECISION overflow threshold, in this case, the content */ -/* of SA in exit is unspecified. */ - -/* ========= */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - sa_dim1 = *ldsa; - sa_offset = 1 + sa_dim1; - sa -= sa_offset; - - /* Function Body */ - rmax = slamch_("O"); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax) { - *info = 1; - goto L30; - } - sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1]; -/* L10: */ - } -/* L20: */ - } - *info = 0; -L30: - return 0; - -/* End of DLAG2S */ - -} /* dlag2s_ */ diff --git a/external/clapack/lapack/dlags2.cpp b/external/clapack/lapack/dlags2.cpp deleted file mode 100644 index b00fbe2e..00000000 --- a/external/clapack/lapack/dlags2.cpp +++ /dev/null @@ -1,275 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlags2_(bool *upper, double *a1, double *a2, - double *a3, double *b1, double *b2, double *b3, - double *csu, double *snu, double *csv, double *snv, - double *csq, double *snq) -{ - /* System generated locals */ - double d__1; - - /* Local variables */ - double a, b, c__, d__, r__, s1, s2, ua11, ua12, ua21, ua22, vb11, - vb12, vb21, vb22, csl, csr, snl, snr, aua11, aua12, aua21, aua22, - avb11, avb12, avb21, avb22, ua11r, ua22r, vb11r, vb22r; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such */ -/* that if ( UPPER ) then */ - -/* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) */ -/* ( 0 A3 ) ( x x ) */ -/* and */ -/* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) */ -/* ( 0 B3 ) ( x x ) */ - -/* or if ( .NOT.UPPER ) then */ - -/* U'*A*Q = U'*( A1 0 )*Q = ( x x ) */ -/* ( A2 A3 ) ( 0 x ) */ -/* and */ -/* V'*B*Q = V'*( B1 0 )*Q = ( x x ) */ -/* ( B2 B3 ) ( 0 x ) */ - -/* The rows of the transformed A and B are parallel, where */ - -/* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) */ -/* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) */ - -/* Z' denotes the transpose of Z. */ - - -/* Arguments */ -/* ========= */ - -/* UPPER (input) LOGICAL */ -/* = .TRUE.: the input matrices A and B are upper triangular. */ -/* = .FALSE.: the input matrices A and B are lower triangular. */ - -/* A1 (input) DOUBLE PRECISION */ -/* A2 (input) DOUBLE PRECISION */ -/* A3 (input) DOUBLE PRECISION */ -/* On entry, A1, A2 and A3 are elements of the input 2-by-2 */ -/* upper (lower) triangular matrix A. */ - -/* B1 (input) DOUBLE PRECISION */ -/* B2 (input) DOUBLE PRECISION */ -/* B3 (input) DOUBLE PRECISION */ -/* On entry, B1, B2 and B3 are elements of the input 2-by-2 */ -/* upper (lower) triangular matrix B. */ - -/* CSU (output) DOUBLE PRECISION */ -/* SNU (output) DOUBLE PRECISION */ -/* The desired orthogonal matrix U. */ - -/* CSV (output) DOUBLE PRECISION */ -/* SNV (output) DOUBLE PRECISION */ -/* The desired orthogonal matrix V. */ - -/* CSQ (output) DOUBLE PRECISION */ -/* SNQ (output) DOUBLE PRECISION */ -/* The desired orthogonal matrix Q. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (*upper) { - -/* Input matrices A and B are upper triangular matrices */ - -/* Form matrix C = A*adj(B) = ( a b ) */ -/* ( 0 d ) */ - - a = *a1 * *b3; - d__ = *a3 * *b1; - b = *a2 * *b1 - *a1 * *b2; - -/* The SVD of real 2-by-2 triangular C */ - -/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */ -/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */ - - dlasv2_(&a, &b, &d__, &s1, &s2, &snr, &csr, &snl, &csl); - - if (abs(csl) >= abs(snl) || abs(csr) >= abs(snr)) { - -/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */ -/* and (1,2) element of |U|'*|A| and |V|'*|B|. */ - - ua11r = csl * *a1; - ua12 = csl * *a2 + snl * *a3; - - vb11r = csr * *b1; - vb12 = csr * *b2 + snr * *b3; - - aua12 = abs(csl) * abs(*a2) + abs(snl) * abs(*a3); - avb12 = abs(csr) * abs(*b2) + abs(snr) * abs(*b3); - -/* zero (1,2) elements of U'*A and V'*B */ - - if (abs(ua11r) + abs(ua12) != 0.) { - if (aua12 / (abs(ua11r) + abs(ua12)) <= avb12 / (abs(vb11r) + - abs(vb12))) { - d__1 = -ua11r; - dlartg_(&d__1, &ua12, csq, snq, &r__); - } else { - d__1 = -vb11r; - dlartg_(&d__1, &vb12, csq, snq, &r__); - } - } else { - d__1 = -vb11r; - dlartg_(&d__1, &vb12, csq, snq, &r__); - } - - *csu = csl; - *snu = -snl; - *csv = csr; - *snv = -snr; - - } else { - -/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */ -/* and (2,2) element of |U|'*|A| and |V|'*|B|. */ - - ua21 = -snl * *a1; - ua22 = -snl * *a2 + csl * *a3; - - vb21 = -snr * *b1; - vb22 = -snr * *b2 + csr * *b3; - - aua22 = abs(snl) * abs(*a2) + abs(csl) * abs(*a3); - avb22 = abs(snr) * abs(*b2) + abs(csr) * abs(*b3); - -/* zero (2,2) elements of U'*A and V'*B, and then swap. */ - - if (abs(ua21) + abs(ua22) != 0.) { - if (aua22 / (abs(ua21) + abs(ua22)) <= avb22 / (abs(vb21) + - abs(vb22))) { - d__1 = -ua21; - dlartg_(&d__1, &ua22, csq, snq, &r__); - } else { - d__1 = -vb21; - dlartg_(&d__1, &vb22, csq, snq, &r__); - } - } else { - d__1 = -vb21; - dlartg_(&d__1, &vb22, csq, snq, &r__); - } - - *csu = snl; - *snu = csl; - *csv = snr; - *snv = csr; - - } - - } else { - -/* Input matrices A and B are lower triangular matrices */ - -/* Form matrix C = A*adj(B) = ( a 0 ) */ -/* ( c d ) */ - - a = *a1 * *b3; - d__ = *a3 * *b1; - c__ = *a2 * *b3 - *a3 * *b2; - -/* The SVD of real 2-by-2 triangular C */ - -/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */ -/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */ - - dlasv2_(&a, &c__, &d__, &s1, &s2, &snr, &csr, &snl, &csl); - - if (abs(csr) >= abs(snr) || abs(csl) >= abs(snl)) { - -/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */ -/* and (2,1) element of |U|'*|A| and |V|'*|B|. */ - - ua21 = -snr * *a1 + csr * *a2; - ua22r = csr * *a3; - - vb21 = -snl * *b1 + csl * *b2; - vb22r = csl * *b3; - - aua21 = abs(snr) * abs(*a1) + abs(csr) * abs(*a2); - avb21 = abs(snl) * abs(*b1) + abs(csl) * abs(*b2); - -/* zero (2,1) elements of U'*A and V'*B. */ - - if (abs(ua21) + abs(ua22r) != 0.) { - if (aua21 / (abs(ua21) + abs(ua22r)) <= avb21 / (abs(vb21) + - abs(vb22r))) { - dlartg_(&ua22r, &ua21, csq, snq, &r__); - } else { - dlartg_(&vb22r, &vb21, csq, snq, &r__); - } - } else { - dlartg_(&vb22r, &vb21, csq, snq, &r__); - } - - *csu = csr; - *snu = -snr; - *csv = csl; - *snv = -snl; - - } else { - -/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */ -/* and (1,1) element of |U|'*|A| and |V|'*|B|. */ - - ua11 = csr * *a1 + snr * *a2; - ua12 = snr * *a3; - - vb11 = csl * *b1 + snl * *b2; - vb12 = snl * *b3; - - aua11 = abs(csr) * abs(*a1) + abs(snr) * abs(*a2); - avb11 = abs(csl) * abs(*b1) + abs(snl) * abs(*b2); - -/* zero (1,1) elements of U'*A and V'*B, and then swap. */ - - if (abs(ua11) + abs(ua12) != 0.) { - if (aua11 / (abs(ua11) + abs(ua12)) <= avb11 / (abs(vb11) + - abs(vb12))) { - dlartg_(&ua12, &ua11, csq, snq, &r__); - } else { - dlartg_(&vb12, &vb11, csq, snq, &r__); - } - } else { - dlartg_(&vb12, &vb11, csq, snq, &r__); - } - - *csu = snr; - *snu = csr; - *csv = snl; - *snv = csl; - - } - - } - - return 0; - -/* End of DLAGS2 */ - -} /* dlags2_ */ diff --git a/external/clapack/lapack/dlagtf.cpp b/external/clapack/lapack/dlagtf.cpp deleted file mode 100644 index 147dfc8d..00000000 --- a/external/clapack/lapack/dlagtf.cpp +++ /dev/null @@ -1,212 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlagtf_(integer *n, double *a, double *lambda, - double *b, double *c__, double *tol, double *d__, - integer *in, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - integer k; - double tl, eps, piv1, piv2, temp, mult, scale1, scale2; - - - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n */ -/* tridiagonal matrix and lambda is a scalar, as */ - -/* T - lambda*I = PLU, */ - -/* where P is a permutation matrix, L is a unit lower tridiagonal matrix */ -/* with at most one non-zero sub-diagonal elements per column and U is */ -/* an upper triangular matrix with at most two non-zero super-diagonal */ -/* elements per column. */ - -/* The factorization is obtained by Gaussian elimination with partial */ -/* pivoting and implicit row scaling. */ - -/* The parameter LAMBDA is included in the routine so that DLAGTF may */ -/* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by */ -/* inverse iteration. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix T. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, A must contain the diagonal elements of T. */ - -/* On exit, A is overwritten by the n diagonal elements of the */ -/* upper triangular matrix U of the factorization of T. */ - -/* LAMBDA (input) DOUBLE PRECISION */ -/* On entry, the scalar lambda. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, B must contain the (n-1) super-diagonal elements of */ -/* T. */ - -/* On exit, B is overwritten by the (n-1) super-diagonal */ -/* elements of the matrix U of the factorization of T. */ - -/* C (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, C must contain the (n-1) sub-diagonal elements of */ -/* T. */ - -/* On exit, C is overwritten by the (n-1) sub-diagonal elements */ -/* of the matrix L of the factorization of T. */ - -/* TOL (input) DOUBLE PRECISION */ -/* On entry, a relative tolerance used to indicate whether or */ -/* not the matrix (T - lambda*I) is nearly singular. TOL should */ -/* normally be chose as approximately the largest relative error */ -/* in the elements of T. For example, if the elements of T are */ -/* correct to about 4 significant figures, then TOL should be */ -/* set to about 5*10**(-4). If TOL is supplied as less than eps, */ -/* where eps is the relative machine precision, then the value */ -/* eps is used in place of TOL. */ - -/* D (output) DOUBLE PRECISION array, dimension (N-2) */ -/* On exit, D is overwritten by the (n-2) second super-diagonal */ -/* elements of the matrix U of the factorization of T. */ - -/* IN (output) INTEGER array, dimension (N) */ -/* On exit, IN contains details of the permutation matrix P. If */ -/* an interchange occurred at the kth step of the elimination, */ -/* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) */ -/* returns the smallest positive integer j such that */ - -/* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, */ - -/* where norm( A(j) ) denotes the sum of the absolute values of */ -/* the jth row of the matrix A. If no such j exists then IN(n) */ -/* is returned as zero. If IN(n) is returned as positive, then a */ -/* diagonal element of U is small, indicating that */ -/* (T - lambda*I) is singular or nearly singular, */ - -/* INFO (output) INTEGER */ -/* = 0 : successful exit */ -/* .lt. 0: if INFO = -k, the kth argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --in; - --d__; - --c__; - --b; - --a; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - i__1 = -(*info); - xerbla_("DLAGTF", &i__1); - return 0; - } - - if (*n == 0) { - return 0; - } - - a[1] -= *lambda; - in[*n] = 0; - if (*n == 1) { - if (a[1] == 0.) { - in[1] = 1; - } - return 0; - } - - eps = dlamch_("Epsilon"); - - tl = std::max(*tol,eps); - scale1 = abs(a[1]) + abs(b[1]); - i__1 = *n - 1; - for (k = 1; k <= i__1; ++k) { - a[k + 1] -= *lambda; - scale2 = (d__1 = c__[k], abs(d__1)) + (d__2 = a[k + 1], abs(d__2)); - if (k < *n - 1) { - scale2 += (d__1 = b[k + 1], abs(d__1)); - } - if (a[k] == 0.) { - piv1 = 0.; - } else { - piv1 = (d__1 = a[k], abs(d__1)) / scale1; - } - if (c__[k] == 0.) { - in[k] = 0; - piv2 = 0.; - scale1 = scale2; - if (k < *n - 1) { - d__[k] = 0.; - } - } else { - piv2 = (d__1 = c__[k], abs(d__1)) / scale2; - if (piv2 <= piv1) { - in[k] = 0; - scale1 = scale2; - c__[k] /= a[k]; - a[k + 1] -= c__[k] * b[k]; - if (k < *n - 1) { - d__[k] = 0.; - } - } else { - in[k] = 1; - mult = a[k] / c__[k]; - a[k] = c__[k]; - temp = a[k + 1]; - a[k + 1] = b[k] - mult * temp; - if (k < *n - 1) { - d__[k] = b[k + 1]; - b[k + 1] = -mult * d__[k]; - } - b[k] = temp; - c__[k] = mult; - } - } - if (std::max(piv1,piv2) <= tl && in[*n] == 0) { - in[*n] = k; - } -/* L10: */ - } - if ((d__1 = a[*n], abs(d__1)) <= scale1 * tl && in[*n] == 0) { - in[*n] = *n; - } - - return 0; - -/* End of DLAGTF */ - -} /* dlagtf_ */ diff --git a/external/clapack/lapack/dlagtm.cpp b/external/clapack/lapack/dlagtm.cpp deleted file mode 100644 index c8cec88e..00000000 --- a/external/clapack/lapack/dlagtm.cpp +++ /dev/null @@ -1,242 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlagtm_(const char *trans, integer *n, integer *nrhs, - double *alpha, double *dl, double *d__, double *du, - double *x, integer *ldx, double *beta, double *b, integer - *ldb) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAGTM performs a matrix-vector product of the form */ - -/* B := alpha * A * X + beta * B */ - -/* where A is a tridiagonal matrix of order N, B and X are N by NRHS */ -/* matrices, and alpha and beta are real scalars, each of which may be */ -/* 0., 1., or -1. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the operation applied to A. */ -/* = 'N': No transpose, B := alpha * A * X + beta * B */ -/* = 'T': Transpose, B := alpha * A'* X + beta * B */ -/* = 'C': Conjugate transpose = Transpose */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices X and B. */ - -/* ALPHA (input) DOUBLE PRECISION */ -/* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */ -/* it is assumed to be 0. */ - -/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) sub-diagonal elements of T. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of T. */ - -/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) super-diagonal elements of T. */ - -/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* The N by NRHS matrix X. */ -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(N,1). */ - -/* BETA (input) DOUBLE PRECISION */ -/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */ -/* it is assumed to be 1. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N by NRHS matrix B. */ -/* On exit, B is overwritten by the matrix expression */ -/* B := alpha * A * X + beta * B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(N,1). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --dl; - --d__; - --du; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - if (*n == 0) { - return 0; - } - -/* Multiply B by BETA if BETA.NE.1. */ - - if (*beta == 0.) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else if (*beta == -1.) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = -b[i__ + j * b_dim1]; -/* L30: */ - } -/* L40: */ - } - } - - if (*alpha == 1.) { - if (lsame_(trans, "N")) { - -/* Compute B := B + A*X */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - if (*n == 1) { - b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1]; - } else { - b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j * - x_dim1 + 1] + du[1] * x[j * x_dim1 + 2]; - b[*n + j * b_dim1] = b[*n + j * b_dim1] + dl[*n - 1] * x[* - n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1] - ; - i__2 = *n - 1; - for (i__ = 2; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + dl[i__ - - 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[ - i__ + j * x_dim1] + du[i__] * x[i__ + 1 + j * - x_dim1]; -/* L50: */ - } - } -/* L60: */ - } - } else { - -/* Compute B := B + A'*X */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - if (*n == 1) { - b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1]; - } else { - b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j * - x_dim1 + 1] + dl[1] * x[j * x_dim1 + 2]; - b[*n + j * b_dim1] = b[*n + j * b_dim1] + du[*n - 1] * x[* - n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1] - ; - i__2 = *n - 1; - for (i__ = 2; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + du[i__ - - 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[ - i__ + j * x_dim1] + dl[i__] * x[i__ + 1 + j * - x_dim1]; -/* L70: */ - } - } -/* L80: */ - } - } - } else if (*alpha == -1.) { - if (lsame_(trans, "N")) { - -/* Compute B := B - A*X */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - if (*n == 1) { - b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1]; - } else { - b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j * - x_dim1 + 1] - du[1] * x[j * x_dim1 + 2]; - b[*n + j * b_dim1] = b[*n + j * b_dim1] - dl[*n - 1] * x[* - n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1] - ; - i__2 = *n - 1; - for (i__ = 2; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - dl[i__ - - 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[ - i__ + j * x_dim1] - du[i__] * x[i__ + 1 + j * - x_dim1]; -/* L90: */ - } - } -/* L100: */ - } - } else { - -/* Compute B := B - A'*X */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - if (*n == 1) { - b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1]; - } else { - b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j * - x_dim1 + 1] - dl[1] * x[j * x_dim1 + 2]; - b[*n + j * b_dim1] = b[*n + j * b_dim1] - du[*n - 1] * x[* - n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1] - ; - i__2 = *n - 1; - for (i__ = 2; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - du[i__ - - 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[ - i__ + j * x_dim1] - dl[i__] * x[i__ + 1 + j * - x_dim1]; -/* L110: */ - } - } -/* L120: */ - } - } - } - return 0; - -/* End of DLAGTM */ - -} /* dlagtm_ */ diff --git a/external/clapack/lapack/dlagts.cpp b/external/clapack/lapack/dlagts.cpp deleted file mode 100644 index 850b6835..00000000 --- a/external/clapack/lapack/dlagts.cpp +++ /dev/null @@ -1,336 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlagts_(integer *job, integer *n, double *a, - double *b, double *c__, double *d__, integer *in, - double *y, double *tol, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2, d__3, d__4, d__5; - - /* Local variables */ - integer k; - double ak, eps, temp, pert, absak, sfmin; - - - double bignum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAGTS may be used to solve one of the systems of equations */ - -/* (T - lambda*I)*x = y or (T - lambda*I)'*x = y, */ - -/* where T is an n by n tridiagonal matrix, for x, following the */ -/* factorization of (T - lambda*I) as */ - -/* (T - lambda*I) = P*L*U , */ - -/* by routine DLAGTF. The choice of equation to be solved is */ -/* controlled by the argument JOB, and in each case there is an option */ -/* to perturb zero or very small diagonal elements of U, this option */ -/* being intended for use in applications such as inverse iteration. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) INTEGER */ -/* Specifies the job to be performed by DLAGTS as follows: */ -/* = 1: The equations (T - lambda*I)x = y are to be solved, */ -/* but diagonal elements of U are not to be perturbed. */ -/* = -1: The equations (T - lambda*I)x = y are to be solved */ -/* and, if overflow would otherwise occur, the diagonal */ -/* elements of U are to be perturbed. See argument TOL */ -/* below. */ -/* = 2: The equations (T - lambda*I)'x = y are to be solved, */ -/* but diagonal elements of U are not to be perturbed. */ -/* = -2: The equations (T - lambda*I)'x = y are to be solved */ -/* and, if overflow would otherwise occur, the diagonal */ -/* elements of U are to be perturbed. See argument TOL */ -/* below. */ - -/* N (input) INTEGER */ -/* The order of the matrix T. */ - -/* A (input) DOUBLE PRECISION array, dimension (N) */ -/* On entry, A must contain the diagonal elements of U as */ -/* returned from DLAGTF. */ - -/* B (input) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, B must contain the first super-diagonal elements of */ -/* U as returned from DLAGTF. */ - -/* C (input) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, C must contain the sub-diagonal elements of L as */ -/* returned from DLAGTF. */ - -/* D (input) DOUBLE PRECISION array, dimension (N-2) */ -/* On entry, D must contain the second super-diagonal elements */ -/* of U as returned from DLAGTF. */ - -/* IN (input) INTEGER array, dimension (N) */ -/* On entry, IN must contain details of the matrix P as returned */ -/* from DLAGTF. */ - -/* Y (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the right hand side vector y. */ -/* On exit, Y is overwritten by the solution vector x. */ - -/* TOL (input/output) DOUBLE PRECISION */ -/* On entry, with JOB .lt. 0, TOL should be the minimum */ -/* perturbation to be made to very small diagonal elements of U. */ -/* TOL should normally be chosen as about eps*norm(U), where eps */ -/* is the relative machine precision, but if TOL is supplied as */ -/* non-positive, then it is reset to eps*max( abs( u(i,j) ) ). */ -/* If JOB .gt. 0 then TOL is not referenced. */ - -/* On exit, TOL is changed as described above, only if TOL is */ -/* non-positive on entry. Otherwise TOL is unchanged. */ - -/* INFO (output) INTEGER */ -/* = 0 : successful exit */ -/* .lt. 0: if INFO = -i, the i-th argument had an illegal value */ -/* .gt. 0: overflow would occur when computing the INFO(th) */ -/* element of the solution vector x. This can only occur */ -/* when JOB is supplied as positive and either means */ -/* that a diagonal element of U is very small, or that */ -/* the elements of the right-hand side vector y are very */ -/* large. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --y; - --in; - --d__; - --c__; - --b; - --a; - - /* Function Body */ - *info = 0; - if (abs(*job) > 2 || *job == 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAGTS", &i__1); - return 0; - } - - if (*n == 0) { - return 0; - } - - eps = dlamch_("Epsilon"); - sfmin = dlamch_("Safe minimum"); - bignum = 1. / sfmin; - - if (*job < 0) { - if (*tol <= 0.) { - *tol = abs(a[1]); - if (*n > 1) { -/* Computing MAX */ - d__1 = *tol, d__2 = abs(a[2]), d__1 = std::max(d__1,d__2), d__2 = - abs(b[1]); - *tol = std::max(d__1,d__2); - } - i__1 = *n; - for (k = 3; k <= i__1; ++k) { -/* Computing MAX */ - d__4 = *tol, d__5 = (d__1 = a[k], abs(d__1)), d__4 = std::max(d__4, - d__5), d__5 = (d__2 = b[k - 1], abs(d__2)), d__4 = - std::max(d__4,d__5), d__5 = (d__3 = d__[k - 2], abs(d__3)); - *tol = std::max(d__4,d__5); -/* L10: */ - } - *tol *= eps; - if (*tol == 0.) { - *tol = eps; - } - } - } - - if (abs(*job) == 1) { - i__1 = *n; - for (k = 2; k <= i__1; ++k) { - if (in[k - 1] == 0) { - y[k] -= c__[k - 1] * y[k - 1]; - } else { - temp = y[k - 1]; - y[k - 1] = y[k]; - y[k] = temp - c__[k - 1] * y[k]; - } -/* L20: */ - } - if (*job == 1) { - for (k = *n; k >= 1; --k) { - if (k <= *n - 2) { - temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2]; - } else if (k == *n - 1) { - temp = y[k] - b[k] * y[k + 1]; - } else { - temp = y[k]; - } - ak = a[k]; - absak = abs(ak); - if (absak < 1.) { - if (absak < sfmin) { - if (absak == 0. || abs(temp) * sfmin > absak) { - *info = k; - return 0; - } else { - temp *= bignum; - ak *= bignum; - } - } else if (abs(temp) > absak * bignum) { - *info = k; - return 0; - } - } - y[k] = temp / ak; -/* L30: */ - } - } else { - for (k = *n; k >= 1; --k) { - if (k <= *n - 2) { - temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2]; - } else if (k == *n - 1) { - temp = y[k] - b[k] * y[k + 1]; - } else { - temp = y[k]; - } - ak = a[k]; - pert = d_sign(tol, &ak); -L40: - absak = abs(ak); - if (absak < 1.) { - if (absak < sfmin) { - if (absak == 0. || abs(temp) * sfmin > absak) { - ak += pert; - pert *= 2; - goto L40; - } else { - temp *= bignum; - ak *= bignum; - } - } else if (abs(temp) > absak * bignum) { - ak += pert; - pert *= 2; - goto L40; - } - } - y[k] = temp / ak; -/* L50: */ - } - } - } else { - -/* Come to here if JOB = 2 or -2 */ - - if (*job == 2) { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (k >= 3) { - temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2]; - } else if (k == 2) { - temp = y[k] - b[k - 1] * y[k - 1]; - } else { - temp = y[k]; - } - ak = a[k]; - absak = abs(ak); - if (absak < 1.) { - if (absak < sfmin) { - if (absak == 0. || abs(temp) * sfmin > absak) { - *info = k; - return 0; - } else { - temp *= bignum; - ak *= bignum; - } - } else if (abs(temp) > absak * bignum) { - *info = k; - return 0; - } - } - y[k] = temp / ak; -/* L60: */ - } - } else { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (k >= 3) { - temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2]; - } else if (k == 2) { - temp = y[k] - b[k - 1] * y[k - 1]; - } else { - temp = y[k]; - } - ak = a[k]; - pert = d_sign(tol, &ak); -L70: - absak = abs(ak); - if (absak < 1.) { - if (absak < sfmin) { - if (absak == 0. || abs(temp) * sfmin > absak) { - ak += pert; - pert *= 2; - goto L70; - } else { - temp *= bignum; - ak *= bignum; - } - } else if (abs(temp) > absak * bignum) { - ak += pert; - pert *= 2; - goto L70; - } - } - y[k] = temp / ak; -/* L80: */ - } - } - - for (k = *n; k >= 2; --k) { - if (in[k - 1] == 0) { - y[k - 1] -= c__[k - 1] * y[k]; - } else { - temp = y[k - 1]; - y[k - 1] = y[k]; - y[k] = temp - c__[k - 1] * y[k]; - } -/* L90: */ - } - } - -/* End of DLAGTS */ - - return 0; -} /* dlagts_ */ diff --git a/external/clapack/lapack/dlagv2.cpp b/external/clapack/lapack/dlagv2.cpp deleted file mode 100644 index 9f43b05c..00000000 --- a/external/clapack/lapack/dlagv2.cpp +++ /dev/null @@ -1,327 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__2 = 2; -static integer c__1 = 1; - -/* Subroutine */ int dlagv2_(double *a, integer *lda, double *b, - integer *ldb, double *alphar, double *alphai, double * - beta, double *csl, double *snl, double *csr, double * - snr) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset; - double d__1, d__2, d__3, d__4, d__5, d__6; - - /* Local variables */ - double r__, t, h1, h2, h3, wi, qq, rr, wr1, wr2, ulp; - double anorm, bnorm, scale1, scale2; - double ascale, bscale; - double safmin; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 */ -/* matrix pencil (A,B) where B is upper triangular. This routine */ -/* computes orthogonal (rotation) matrices given by CSL, SNL and CSR, */ -/* SNR such that */ - -/* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 */ -/* types), then */ - -/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */ -/* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */ - -/* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */ -/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], */ - -/* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, */ -/* then */ - -/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */ -/* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */ - -/* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */ -/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] */ - -/* where b11 >= b22 > 0. */ - - -/* Arguments */ -/* ========= */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, 2) */ -/* On entry, the 2 x 2 matrix A. */ -/* On exit, A is overwritten by the ``A-part'' of the */ -/* generalized Schur form. */ - -/* LDA (input) INTEGER */ -/* THe leading dimension of the array A. LDA >= 2. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, 2) */ -/* On entry, the upper triangular 2 x 2 matrix B. */ -/* On exit, B is overwritten by the ``B-part'' of the */ -/* generalized Schur form. */ - -/* LDB (input) INTEGER */ -/* THe leading dimension of the array B. LDB >= 2. */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (2) */ -/* ALPHAI (output) DOUBLE PRECISION array, dimension (2) */ -/* BETA (output) DOUBLE PRECISION array, dimension (2) */ -/* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the */ -/* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may */ -/* be zero. */ - -/* CSL (output) DOUBLE PRECISION */ -/* The cosine of the left rotation matrix. */ - -/* SNL (output) DOUBLE PRECISION */ -/* The sine of the left rotation matrix. */ - -/* CSR (output) DOUBLE PRECISION */ -/* The cosine of the right rotation matrix. */ - -/* SNR (output) DOUBLE PRECISION */ -/* The sine of the right rotation matrix. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alphar; - --alphai; - --beta; - - /* Function Body */ - safmin = dlamch_("S"); - ulp = dlamch_("P"); - -/* Scale A */ - -/* Computing MAX */ - d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs( - d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 = - a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = std::max(d__5,d__6); - anorm = std::max(d__5,safmin); - ascale = 1. / anorm; - a[a_dim1 + 1] = ascale * a[a_dim1 + 1]; - a[(a_dim1 << 1) + 1] = ascale * a[(a_dim1 << 1) + 1]; - a[a_dim1 + 2] = ascale * a[a_dim1 + 2]; - a[(a_dim1 << 1) + 2] = ascale * a[(a_dim1 << 1) + 2]; - -/* Scale B */ - -/* Computing MAX */ - d__4 = (d__3 = b[b_dim1 + 1], abs(d__3)), d__5 = (d__1 = b[(b_dim1 << 1) - + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 2], abs(d__2)), d__4 - = std::max(d__4,d__5); - bnorm = std::max(d__4,safmin); - bscale = 1. / bnorm; - b[b_dim1 + 1] = bscale * b[b_dim1 + 1]; - b[(b_dim1 << 1) + 1] = bscale * b[(b_dim1 << 1) + 1]; - b[(b_dim1 << 1) + 2] = bscale * b[(b_dim1 << 1) + 2]; - -/* Check if A can be deflated */ - - if ((d__1 = a[a_dim1 + 2], abs(d__1)) <= ulp) { - *csl = 1.; - *snl = 0.; - *csr = 1.; - *snr = 0.; - a[a_dim1 + 2] = 0.; - b[b_dim1 + 2] = 0.; - -/* Check if B is singular */ - - } else if ((d__1 = b[b_dim1 + 1], abs(d__1)) <= ulp) { - dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__); - *csr = 1.; - *snr = 0.; - drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); - drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); - a[a_dim1 + 2] = 0.; - b[b_dim1 + 1] = 0.; - b[b_dim1 + 2] = 0.; - - } else if ((d__1 = b[(b_dim1 << 1) + 2], abs(d__1)) <= ulp) { - dlartg_(&a[(a_dim1 << 1) + 2], &a[a_dim1 + 2], csr, snr, &t); - *snr = -(*snr); - drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, csr, - snr); - drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, csr, - snr); - *csl = 1.; - *snl = 0.; - a[a_dim1 + 2] = 0.; - b[b_dim1 + 2] = 0.; - b[(b_dim1 << 1) + 2] = 0.; - - } else { - -/* B is nonsingular, first compute the eigenvalues of (A,B) */ - - dlag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, & - scale2, &wr1, &wr2, &wi); - - if (wi == 0.) { - -/* two real eigenvalues, compute s*A-w*B */ - - h1 = scale1 * a[a_dim1 + 1] - wr1 * b[b_dim1 + 1]; - h2 = scale1 * a[(a_dim1 << 1) + 1] - wr1 * b[(b_dim1 << 1) + 1]; - h3 = scale1 * a[(a_dim1 << 1) + 2] - wr1 * b[(b_dim1 << 1) + 2]; - - rr = dlapy2_(&h1, &h2); - d__1 = scale1 * a[a_dim1 + 2]; - qq = dlapy2_(&d__1, &h3); - - if (rr > qq) { - -/* find right rotation matrix to zero 1,1 element of */ -/* (sA - wB) */ - - dlartg_(&h2, &h1, csr, snr, &t); - - } else { - -/* find right rotation matrix to zero 2,1 element of */ -/* (sA - wB) */ - - d__1 = scale1 * a[a_dim1 + 2]; - dlartg_(&h3, &d__1, csr, snr, &t); - - } - - *snr = -(*snr); - drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, - csr, snr); - drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, - csr, snr); - -/* compute inf norms of A and B */ - -/* Computing MAX */ - d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[(a_dim1 << 1) - + 1], abs(d__2)), d__6 = (d__3 = a[a_dim1 + 2], abs(d__3) - ) + (d__4 = a[(a_dim1 << 1) + 2], abs(d__4)); - h1 = std::max(d__5,d__6); -/* Computing MAX */ - d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) - + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], abs(d__3) - ) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4)); - h2 = std::max(d__5,d__6); - - if (scale1 * h1 >= abs(wr1) * h2) { - -/* find left rotation matrix Q to zero out B(2,1) */ - - dlartg_(&b[b_dim1 + 1], &b[b_dim1 + 2], csl, snl, &r__); - - } else { - -/* find left rotation matrix Q to zero out A(2,1) */ - - dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__); - - } - - drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); - drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); - - a[a_dim1 + 2] = 0.; - b[b_dim1 + 2] = 0.; - - } else { - -/* a pair of complex conjugate eigenvalues */ -/* first compute the SVD of the matrix B */ - - dlasv2_(&b[b_dim1 + 1], &b[(b_dim1 << 1) + 1], &b[(b_dim1 << 1) + - 2], &r__, &t, snr, csr, snl, csl); - -/* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and */ -/* Z is right rotation matrix computed from DLASV2 */ - - drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); - drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); - drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, - csr, snr); - drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, - csr, snr); - - b[b_dim1 + 2] = 0.; - b[(b_dim1 << 1) + 1] = 0.; - - } - - } - -/* Unscaling */ - - a[a_dim1 + 1] = anorm * a[a_dim1 + 1]; - a[a_dim1 + 2] = anorm * a[a_dim1 + 2]; - a[(a_dim1 << 1) + 1] = anorm * a[(a_dim1 << 1) + 1]; - a[(a_dim1 << 1) + 2] = anorm * a[(a_dim1 << 1) + 2]; - b[b_dim1 + 1] = bnorm * b[b_dim1 + 1]; - b[b_dim1 + 2] = bnorm * b[b_dim1 + 2]; - b[(b_dim1 << 1) + 1] = bnorm * b[(b_dim1 << 1) + 1]; - b[(b_dim1 << 1) + 2] = bnorm * b[(b_dim1 << 1) + 2]; - - if (wi == 0.) { - alphar[1] = a[a_dim1 + 1]; - alphar[2] = a[(a_dim1 << 1) + 2]; - alphai[1] = 0.; - alphai[2] = 0.; - beta[1] = b[b_dim1 + 1]; - beta[2] = b[(b_dim1 << 1) + 2]; - } else { - alphar[1] = anorm * wr1 / scale1 / bnorm; - alphai[1] = anorm * wi / scale1 / bnorm; - alphar[2] = alphar[1]; - alphai[2] = -alphai[1]; - beta[1] = 1.; - beta[2] = 1.; - } - - return 0; - -/* End of DLAGV2 */ - -} /* dlagv2_ */ diff --git a/external/clapack/lapack/dlahqr.cpp b/external/clapack/lapack/dlahqr.cpp deleted file mode 100644 index bf60c212..00000000 --- a/external/clapack/lapack/dlahqr.cpp +++ /dev/null @@ -1,607 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -int dlahqr_(bool *wantt, bool *wantz, integer *n, - integer *ilo, integer *ihi, double *h__, integer *ldh, double - *wr, double *wi, integer *iloz, integer *ihiz, double *z__, - integer *ldz, integer *info) -{ - /* System generated locals */ - integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer i__, j, k, l, m; - double s, v[3]; - integer i1, i2; - double t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs; - integer nh; - double sn; - integer nr; - double tr; - integer nz; - double det, h21s; - integer its; - double ulp, sum, tst, rt1i, rt2i, rt1r, rt2r; - double safmin, safmax, rtdisc, smlnum; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAHQR is an auxiliary routine called by DHSEQR to update the */ -/* eigenvalues and Schur decomposition already computed by DHSEQR, by */ -/* dealing with the Hessenberg submatrix in rows and columns ILO to */ -/* IHI. */ - -/* Arguments */ -/* ========= */ - -/* WANTT (input) LOGICAL */ -/* = .TRUE. : the full Schur form T is required; */ -/* = .FALSE.: only eigenvalues are required. */ - -/* WANTZ (input) LOGICAL */ -/* = .TRUE. : the matrix of Schur vectors Z is required; */ -/* = .FALSE.: Schur vectors are not required. */ - -/* N (input) INTEGER */ -/* The order of the matrix H. N >= 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* It is assumed that H is already upper quasi-triangular in */ -/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */ -/* ILO = 1). DLAHQR works primarily with the Hessenberg */ -/* submatrix in rows and columns ILO to IHI, but applies */ -/* transformations to all of H if WANTT is .TRUE.. */ -/* 1 <= ILO <= max(1,IHI); IHI <= N. */ - -/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ -/* On entry, the upper Hessenberg matrix H. */ -/* On exit, if INFO is zero and if WANTT is .TRUE., H is upper */ -/* quasi-triangular in rows and columns ILO:IHI, with any */ -/* 2-by-2 diagonal blocks in standard form. If INFO is zero */ -/* and WANTT is .FALSE., the contents of H are unspecified on */ -/* exit. The output state of H if INFO is nonzero is given */ -/* below under the description of INFO. */ - -/* LDH (input) INTEGER */ -/* The leading dimension of the array H. LDH >= max(1,N). */ - -/* WR (output) DOUBLE PRECISION array, dimension (N) */ -/* WI (output) DOUBLE PRECISION array, dimension (N) */ -/* The real and imaginary parts, respectively, of the computed */ -/* eigenvalues ILO to IHI are stored in the corresponding */ -/* elements of WR and WI. If two eigenvalues are computed as a */ -/* complex conjugate pair, they are stored in consecutive */ -/* elements of WR and WI, say the i-th and (i+1)th, with */ -/* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */ -/* eigenvalues are stored in the same order as on the diagonal */ -/* of the Schur form returned in H, with WR(i) = H(i,i), and, if */ -/* H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */ -/* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */ - -/* ILOZ (input) INTEGER */ -/* IHIZ (input) INTEGER */ -/* Specify the rows of Z to which transformations must be */ -/* applied if WANTZ is .TRUE.. */ -/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* If WANTZ is .TRUE., on entry Z must contain the current */ -/* matrix Z of transformations accumulated by DHSEQR, and on */ -/* exit Z has been updated; transformations are applied only to */ -/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */ -/* If WANTZ is .FALSE., Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* .GT. 0: If INFO = i, DLAHQR failed to compute all the */ -/* eigenvalues ILO to IHI in a total of 30 iterations */ -/* per eigenvalue; elements i+1:ihi of WR and WI */ -/* contain those eigenvalues which have been */ -/* successfully computed. */ - -/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */ -/* the remaining unconverged eigenvalues are the */ -/* eigenvalues of the upper Hessenberg matrix rows */ -/* and columns ILO thorugh INFO of the final, output */ -/* value of H. */ - -/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */ -/* (*) (initial value of H)*U = U*(final value of H) */ -/* where U is an orthognal matrix. The final */ -/* value of H is upper Hessenberg and triangular in */ -/* rows and columns INFO+1 through IHI. */ - -/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */ -/* (final value of Z) = (initial value of Z)*U */ -/* where U is the orthogonal matrix in (*) */ -/* (regardless of the value of WANTT.) */ - -/* Further Details */ -/* =============== */ - -/* 02-96 Based on modifications by */ -/* David Day, Sandia National Laboratory, USA */ - -/* 12-04 Further modifications by */ -/* Ralph Byers, University of Kansas, USA */ - -/* This is a modified version of DLAHQR from LAPACK version 3.0. */ -/* It is (1) more robust against overflow and underflow and */ -/* (2) adopts the more conservative Ahues & Tisseur stopping */ -/* criterion (LAWN 122, 1997). */ - -/* ========================================================= */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - --wr; - --wi; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - - /* Function Body */ - *info = 0; - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - if (*ilo == *ihi) { - wr[*ilo] = h__[*ilo + *ilo * h_dim1]; - wi[*ilo] = 0.; - return 0; - } - -/* ==== clear out the trash ==== */ - i__1 = *ihi - 3; - for (j = *ilo; j <= i__1; ++j) { - h__[j + 2 + j * h_dim1] = 0.; - h__[j + 3 + j * h_dim1] = 0.; -/* L10: */ - } - if (*ilo <= *ihi - 2) { - h__[*ihi + (*ihi - 2) * h_dim1] = 0.; - } - - nh = *ihi - *ilo + 1; - nz = *ihiz - *iloz + 1; - -/* Set machine-dependent constants for the stopping criterion. */ - - safmin = dlamch_("SAFE MINIMUM"); - safmax = 1. / safmin; - dlabad_(&safmin, &safmax); - ulp = dlamch_("PRECISION"); - smlnum = safmin * ((double) nh / ulp); - -/* I1 and I2 are the indices of the first row and last column of H */ -/* to which transformations must be applied. If eigenvalues only are */ -/* being computed, I1 and I2 are set inside the main loop. */ - - if (*wantt) { - i1 = 1; - i2 = *n; - } - -/* The main loop begins here. I is the loop index and decreases from */ -/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */ -/* with the active submatrix in rows and columns L to I. */ -/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */ -/* H(L,L-1) is negligible so that the matrix splits. */ - - i__ = *ihi; -L20: - l = *ilo; - if (i__ < *ilo) { - goto L160; - } - -/* Perform QR iterations on rows and columns ILO to I until a */ -/* submatrix of order 1 or 2 splits off at the bottom because a */ -/* subdiagonal element has become negligible. */ - - for (its = 0; its <= 30; ++its) { - -/* Look for a single small subdiagonal element. */ - - i__1 = l + 1; - for (k = i__; k >= i__1; --k) { - if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) { - goto L40; - } - tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 = - h__[k + k * h_dim1], abs(d__2)); - if (tst == 0.) { - if (k - 2 >= *ilo) { - tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1)); - } - if (k + 1 <= *ihi) { - tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)); - } - } -/* ==== The following is a conservative small subdiagonal */ -/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */ -/* . 1997). It has better mathematical foundation and */ -/* . improves accuracy in some cases. ==== */ - if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) { -/* Computing MAX */ - d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = ( - d__2 = h__[k - 1 + k * h_dim1], abs(d__2)); - ab = std::max(d__3,d__4); -/* Computing MIN */ - d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = ( - d__2 = h__[k - 1 + k * h_dim1], abs(d__2)); - ba = std::min(d__3,d__4); -/* Computing MAX */ - d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 = - h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], - abs(d__2)); - aa = std::max(d__3,d__4); -/* Computing MIN */ - d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 = - h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], - abs(d__2)); - bb = std::min(d__3,d__4); - s = aa + ab; -/* Computing MAX */ - d__1 = smlnum, d__2 = ulp * (bb * (aa / s)); - if (ba * (ab / s) <= std::max(d__1,d__2)) { - goto L40; - } - } -/* L30: */ - } -L40: - l = k; - if (l > *ilo) { - -/* H(L,L-1) is negligible */ - - h__[l + (l - 1) * h_dim1] = 0.; - } - -/* Exit from loop if a submatrix of order 1 or 2 has split off. */ - - if (l >= i__ - 1) { - goto L150; - } - -/* Now the active submatrix is in rows and columns L to I. If */ -/* eigenvalues only are being computed, only the active submatrix */ -/* need be transformed. */ - - if (! (*wantt)) { - i1 = l; - i2 = i__; - } - - if (its == 10) { - -/* Exceptional shift. */ - - s = (d__1 = h__[l + 1 + l * h_dim1], abs(d__1)) + (d__2 = h__[l + - 2 + (l + 1) * h_dim1], abs(d__2)); - h11 = s * .75 + h__[l + l * h_dim1]; - h12 = s * -.4375; - h21 = s; - h22 = h11; - } else if (its == 20) { - -/* Exceptional shift. */ - - s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 = - h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2)); - h11 = s * .75 + h__[i__ + i__ * h_dim1]; - h12 = s * -.4375; - h21 = s; - h22 = h11; - } else { - -/* Prepare to use Francis' double shift */ -/* (i.e. 2nd degree generalized Rayleigh quotient) */ - h11 = h__[i__ - 1 + (i__ - 1) * h_dim1]; - h21 = h__[i__ + (i__ - 1) * h_dim1]; - h12 = h__[i__ - 1 + i__ * h_dim1]; - h22 = h__[i__ + i__ * h_dim1]; - } - s = abs(h11) + abs(h12) + abs(h21) + abs(h22); - if (s == 0.) { - rt1r = 0.; - rt1i = 0.; - rt2r = 0.; - rt2i = 0.; - } else { - h11 /= s; - h21 /= s; - h12 /= s; - h22 /= s; - tr = (h11 + h22) / 2.; - det = (h11 - tr) * (h22 - tr) - h12 * h21; - rtdisc = sqrt((abs(det))); - if (det >= 0.) { - -/* ==== complex conjugate shifts ==== */ - - rt1r = tr * s; - rt2r = rt1r; - rt1i = rtdisc * s; - rt2i = -rt1i; - } else { - -/* ==== real shifts (use only one of them) ==== */ - - rt1r = tr + rtdisc; - rt2r = tr - rtdisc; - if ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs( - d__2))) { - rt1r *= s; - rt2r = rt1r; - } else { - rt2r *= s; - rt1r = rt2r; - } - rt1i = 0.; - rt2i = 0.; - } - } - -/* Look for two consecutive small subdiagonal elements. */ - - i__1 = l; - for (m = i__ - 2; m >= i__1; --m) { -/* Determine the effect of starting the double-shift QR */ -/* iteration at row M, and see if this would make H(M,M-1) */ -/* negligible. (The following uses scaling to avoid */ -/* overflows and most underflows.) */ - - h21s = h__[m + 1 + m * h_dim1]; - s = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__1)) + abs(rt2i) + - abs(h21s); - h21s = h__[m + 1 + m * h_dim1] / s; - v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] - - rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i - / s); - v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1] - - rt1r - rt2r); - v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1]; - s = abs(v[0]) + abs(v[1]) + abs(v[2]); - v[0] /= s; - v[1] /= s; - v[2] /= s; - if (m == l) { - goto L60; - } - if ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) + - abs(v[2])) <= ulp * abs(v[0]) * ((d__2 = h__[m - 1 + (m - - 1) * h_dim1], abs(d__2)) + (d__3 = h__[m + m * h_dim1], - abs(d__3)) + (d__4 = h__[m + 1 + (m + 1) * h_dim1], abs( - d__4)))) { - goto L60; - } -/* L50: */ - } -L60: - -/* Double-shift QR step */ - - i__1 = i__ - 1; - for (k = m; k <= i__1; ++k) { - -/* The first iteration of this loop determines a reflection G */ -/* from the vector V and applies it from left and right to H, */ -/* thus creating a nonzero bulge below the subdiagonal. */ - -/* Each subsequent iteration determines a reflection G to */ -/* restore the Hessenberg form in the (K-1)th column, and thus */ -/* chases the bulge one step toward the bottom of the active */ -/* submatrix. NR is the order of G. */ - -/* Computing MIN */ - i__2 = 3, i__3 = i__ - k + 1; - nr = std::min(i__2,i__3); - if (k > m) { - dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); - } - dlarfg_(&nr, v, &v[1], &c__1, &t1); - if (k > m) { - h__[k + (k - 1) * h_dim1] = v[0]; - h__[k + 1 + (k - 1) * h_dim1] = 0.; - if (k < i__ - 1) { - h__[k + 2 + (k - 1) * h_dim1] = 0.; - } - } else if (m > l) { -/* ==== Use the following instead of */ -/* . H( K, K-1 ) = -H( K, K-1 ) to */ -/* . avoid a bug when v(2) and v(3) */ -/* . underflow. ==== */ - h__[k + (k - 1) * h_dim1] *= 1. - t1; - } - v2 = v[1]; - t2 = t1 * v2; - if (nr == 3) { - v3 = v[2]; - t3 = t1 * v3; - -/* Apply G from the left to transform the rows of the matrix */ -/* in columns K to I2. */ - - i__2 = i2; - for (j = k; j <= i__2; ++j) { - sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] - + v3 * h__[k + 2 + j * h_dim1]; - h__[k + j * h_dim1] -= sum * t1; - h__[k + 1 + j * h_dim1] -= sum * t2; - h__[k + 2 + j * h_dim1] -= sum * t3; -/* L70: */ - } - -/* Apply G from the right to transform the columns of the */ -/* matrix in rows I1 to min(K+3,I). */ - -/* Computing MIN */ - i__3 = k + 3; - i__2 = std::min(i__3,i__); - for (j = i1; j <= i__2; ++j) { - sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] - + v3 * h__[j + (k + 2) * h_dim1]; - h__[j + k * h_dim1] -= sum * t1; - h__[j + (k + 1) * h_dim1] -= sum * t2; - h__[j + (k + 2) * h_dim1] -= sum * t3; -/* L80: */ - } - - if (*wantz) { - -/* Accumulate transformations in the matrix Z */ - - i__2 = *ihiz; - for (j = *iloz; j <= i__2; ++j) { - sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * - z_dim1] + v3 * z__[j + (k + 2) * z_dim1]; - z__[j + k * z_dim1] -= sum * t1; - z__[j + (k + 1) * z_dim1] -= sum * t2; - z__[j + (k + 2) * z_dim1] -= sum * t3; -/* L90: */ - } - } - } else if (nr == 2) { - -/* Apply G from the left to transform the rows of the matrix */ -/* in columns K to I2. */ - - i__2 = i2; - for (j = k; j <= i__2; ++j) { - sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]; - h__[k + j * h_dim1] -= sum * t1; - h__[k + 1 + j * h_dim1] -= sum * t2; -/* L100: */ - } - -/* Apply G from the right to transform the columns of the */ -/* matrix in rows I1 to min(K+3,I). */ - - i__2 = i__; - for (j = i1; j <= i__2; ++j) { - sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] - ; - h__[j + k * h_dim1] -= sum * t1; - h__[j + (k + 1) * h_dim1] -= sum * t2; -/* L110: */ - } - - if (*wantz) { - -/* Accumulate transformations in the matrix Z */ - - i__2 = *ihiz; - for (j = *iloz; j <= i__2; ++j) { - sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * - z_dim1]; - z__[j + k * z_dim1] -= sum * t1; - z__[j + (k + 1) * z_dim1] -= sum * t2; -/* L120: */ - } - } - } -/* L130: */ - } - -/* L140: */ - } - -/* Failure to converge in remaining number of iterations */ - - *info = i__; - return 0; - -L150: - - if (l == i__) { - -/* H(I,I-1) is negligible: one eigenvalue has converged. */ - - wr[i__] = h__[i__ + i__ * h_dim1]; - wi[i__] = 0.; - } else if (l == i__ - 1) { - -/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */ - -/* Transform the 2-by-2 submatrix to standard Schur form, */ -/* and compute and store the eigenvalues. */ - - dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * - h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * - h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs, - &sn); - - if (*wantt) { - -/* Apply the transformation to the rest of H. */ - - if (i2 > i__) { - i__1 = i2 - i__; - drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[ - i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn); - } - i__1 = i__ - i1 - 1; - drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ * - h_dim1], &c__1, &cs, &sn); - } - if (*wantz) { - -/* Apply the transformation to Z. */ - - drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz + - i__ * z_dim1], &c__1, &cs, &sn); - } - } - -/* return to start of the main loop with new value of I. */ - - i__ = l - 1; - goto L20; - -L160: - return 0; - -/* End of DLAHQR */ - -} /* dlahqr_ */ diff --git a/external/clapack/lapack/dlahr2.cpp b/external/clapack/lapack/dlahr2.cpp deleted file mode 100644 index 32f75a6f..00000000 --- a/external/clapack/lapack/dlahr2.cpp +++ /dev/null @@ -1,287 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b4 = -1.; -static double c_b5 = 1.; -static integer c__1 = 1; -static double c_b38 = 0.; - -/* Subroutine */ int dlahr2_(integer *n, integer *k, integer *nb, double * - a, integer *lda, double *tau, double *t, integer *ldt, - double *y, integer *ldy) -{ - /* System generated locals */ - integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, - i__3; - double d__1; - - /* Local variables */ - integer i__; - double ei; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) */ -/* matrix A so that elements below the k-th subdiagonal are zero. The */ -/* reduction is performed by an orthogonal similarity transformation */ -/* Q' * A * Q. The routine returns the matrices V and T which determine */ -/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */ - -/* This is an auxiliary routine called by DGEHRD. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* K (input) INTEGER */ -/* The offset for the reduction. Elements below the k-th */ -/* subdiagonal in the first NB columns are reduced to zero. */ -/* K < N. */ - -/* NB (input) INTEGER */ -/* The number of columns to be reduced. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */ -/* On entry, the n-by-(n-k+1) general matrix A. */ -/* On exit, the elements on and above the k-th subdiagonal in */ -/* the first NB columns are overwritten with the corresponding */ -/* elements of the reduced matrix; the elements below the k-th */ -/* subdiagonal, with the array TAU, represent the matrix Q as a */ -/* product of elementary reflectors. The other columns of A are */ -/* unchanged. See Further Details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* TAU (output) DOUBLE PRECISION array, dimension (NB) */ -/* The scalar factors of the elementary reflectors. See Further */ -/* Details. */ - -/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */ -/* The upper triangular matrix T. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= NB. */ - -/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */ -/* The n-by-nb matrix Y. */ - -/* LDY (input) INTEGER */ -/* The leading dimension of the array Y. LDY >= N. */ - -/* Further Details */ -/* =============== */ - -/* The matrix Q is represented as a product of nb elementary reflectors */ - -/* Q = H(1) H(2) . . . H(nb). */ - -/* 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */ -/* A(i+k+1:n,i), and tau in TAU(i). */ - -/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */ -/* V which is needed, with T and Y, to apply the transformation to the */ -/* unreduced part of the matrix, using an update of the form: */ -/* A := (I - V*T*V') * (A - Y*V'). */ - -/* The contents of A on exit are illustrated by the following example */ -/* with n = 7, k = 3 and nb = 2: */ - -/* ( a a a a a ) */ -/* ( a a a a a ) */ -/* ( a a a a a ) */ -/* ( h h a a a ) */ -/* ( v1 h a a a ) */ -/* ( v1 v2 a a a ) */ -/* ( v1 v2 a a a ) */ - -/* where a denotes an element of the original matrix A, h denotes a */ -/* modified element of the upper Hessenberg matrix H, and vi denotes an */ -/* element of the vector defining H(i). */ - -/* This file is a slight modification of LAPACK-3.0's DLAHRD */ -/* incorporating improvements proposed by Quintana-Orti and Van de */ -/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */ -/* returned by the original LAPACK routine. This function is */ -/* not backward compatible with LAPACK3.0. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - --tau; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - y_dim1 = *ldy; - y_offset = 1 + y_dim1; - y -= y_offset; - - /* Function Body */ - if (*n <= 1) { - return 0; - } - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - if (i__ > 1) { - -/* Update A(K+1:N,I) */ - -/* Update I-th column of A - Y * V' */ - - i__2 = *n - *k; - i__3 = i__ - 1; - dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], - ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 + - i__ * a_dim1], &c__1); - -/* Apply I - V * T' * V' to this column (call it b) from the */ -/* left, using the last column of T as workspace */ - -/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */ -/* ( V2 ) ( b2 ) */ - -/* where V1 is unit lower triangular */ - -/* w := V1' * b1 */ - - i__2 = i__ - 1; - dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + - 1], &c__1); - i__2 = i__ - 1; - dtrmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1], - lda, &t[*nb * t_dim1 + 1], &c__1); - -/* w := w + V2'*b2 */ - - i__2 = *n - *k - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], - lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * - t_dim1 + 1], &c__1); - -/* w := T'*w */ - - i__2 = i__ - 1; - dtrmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt, - &t[*nb * t_dim1 + 1], &c__1); - -/* b2 := b2 - V2*w */ - - i__2 = *n - *k - i__ + 1; - i__3 = i__ - 1; - dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1], - lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + - i__ * a_dim1], &c__1); - -/* b1 := b1 - V1*w */ - - i__2 = i__ - 1; - dtrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1] -, lda, &t[*nb * t_dim1 + 1], &c__1); - i__2 = i__ - 1; - daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ - * a_dim1], &c__1); - - a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei; - } - -/* Generate the elementary reflector H(I) to annihilate */ -/* A(K+I+1:N,I) */ - - i__2 = *n - *k - i__ + 1; -/* Computing MIN */ - i__3 = *k + i__ + 1; - dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[std::min(i__3, *n)+ i__ * - a_dim1], &c__1, &tau[i__]); - ei = a[*k + i__ + i__ * a_dim1]; - a[*k + i__ + i__ * a_dim1] = 1.; - -/* Compute Y(K+1:N,I) */ - - i__2 = *n - *k; - i__3 = *n - *k - i__ + 1; - dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) * - a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[* - k + 1 + i__ * y_dim1], &c__1); - i__2 = *n - *k - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, & - a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + - 1], &c__1); - i__2 = *n - *k; - i__3 = i__ - 1; - dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy, - &t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1], - &c__1); - i__2 = *n - *k; - dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1); - -/* Compute T(1:I,I) */ - - i__2 = i__ - 1; - d__1 = -tau[i__]; - dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1); - i__2 = i__ - 1; - dtrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt, - &t[i__ * t_dim1 + 1], &c__1) - ; - t[i__ + i__ * t_dim1] = tau[i__]; - -/* L10: */ - } - a[*k + *nb + *nb * a_dim1] = ei; - -/* Compute Y(1:K,1:NB) */ - - dlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy); - dtrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1 - + a_dim1], lda, &y[y_offset], ldy); - if (*n > *k + *nb) { - i__1 = *n - *k - *nb; - dgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb + - 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5, - &y[y_offset], ldy); - } - dtrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[ - t_offset], ldt, &y[y_offset], ldy); - - return 0; - -/* End of DLAHR2 */ - -} /* dlahr2_ */ diff --git a/external/clapack/lapack/dlahrd.cpp b/external/clapack/lapack/dlahrd.cpp deleted file mode 100644 index 529a9555..00000000 --- a/external/clapack/lapack/dlahrd.cpp +++ /dev/null @@ -1,263 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b4 = -1.; -static double c_b5 = 1.; -static integer c__1 = 1; -static double c_b38 = 0.; - -/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, double * - a, integer *lda, double *tau, double *t, integer *ldt, - double *y, integer *ldy) -{ - /* System generated locals */ - integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, - i__3; - double d__1; - - /* Local variables */ - integer i__; - double ei; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */ -/* matrix A so that elements below the k-th subdiagonal are zero. The */ -/* reduction is performed by an orthogonal similarity transformation */ -/* Q' * A * Q. The routine returns the matrices V and T which determine */ -/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */ - -/* This is an OBSOLETE auxiliary routine. */ -/* This routine will be 'deprecated' in a future release. */ -/* Please use the new routine DLAHR2 instead. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* K (input) INTEGER */ -/* The offset for the reduction. Elements below the k-th */ -/* subdiagonal in the first NB columns are reduced to zero. */ - -/* NB (input) INTEGER */ -/* The number of columns to be reduced. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */ -/* On entry, the n-by-(n-k+1) general matrix A. */ -/* On exit, the elements on and above the k-th subdiagonal in */ -/* the first NB columns are overwritten with the corresponding */ -/* elements of the reduced matrix; the elements below the k-th */ -/* subdiagonal, with the array TAU, represent the matrix Q as a */ -/* product of elementary reflectors. The other columns of A are */ -/* unchanged. See Further Details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* TAU (output) DOUBLE PRECISION array, dimension (NB) */ -/* The scalar factors of the elementary reflectors. See Further */ -/* Details. */ - -/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */ -/* The upper triangular matrix T. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= NB. */ - -/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */ -/* The n-by-nb matrix Y. */ - -/* LDY (input) INTEGER */ -/* The leading dimension of the array Y. LDY >= N. */ - -/* Further Details */ -/* =============== */ - -/* The matrix Q is represented as a product of nb elementary reflectors */ - -/* Q = H(1) H(2) . . . H(nb). */ - -/* 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */ -/* A(i+k+1:n,i), and tau in TAU(i). */ - -/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */ -/* V which is needed, with T and Y, to apply the transformation to the */ -/* unreduced part of the matrix, using an update of the form: */ -/* A := (I - V*T*V') * (A - Y*V'). */ - -/* The contents of A on exit are illustrated by the following example */ -/* with n = 7, k = 3 and nb = 2: */ - -/* ( a h a a a ) */ -/* ( a h a a a ) */ -/* ( a h a a a ) */ -/* ( h h a a a ) */ -/* ( v1 h a a a ) */ -/* ( v1 v2 a a a ) */ -/* ( v1 v2 a a a ) */ - -/* where a denotes an element of the original matrix A, h denotes a */ -/* modified element of the upper Hessenberg matrix H, and vi denotes an */ -/* element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - --tau; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - y_dim1 = *ldy; - y_offset = 1 + y_dim1; - y -= y_offset; - - /* Function Body */ - if (*n <= 1) { - return 0; - } - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - if (i__ > 1) { - -/* Update A(1:n,i) */ - -/* Compute i-th column of A - Y * V' */ - - i__2 = i__ - 1; - dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k - + i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], & - c__1); - -/* Apply I - V * T' * V' to this column (call it b) from the */ -/* left, using the last column of T as workspace */ - -/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */ -/* ( V2 ) ( b2 ) */ - -/* where V1 is unit lower triangular */ - -/* w := V1' * b1 */ - - i__2 = i__ - 1; - dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + - 1], &c__1); - i__2 = i__ - 1; - dtrmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1], - lda, &t[*nb * t_dim1 + 1], &c__1); - -/* w := w + V2'*b2 */ - - i__2 = *n - *k - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], - lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * - t_dim1 + 1], &c__1); - -/* w := T'*w */ - - i__2 = i__ - 1; - dtrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt, - &t[*nb * t_dim1 + 1], &c__1); - -/* b2 := b2 - V2*w */ - - i__2 = *n - *k - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1], - lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + - i__ * a_dim1], &c__1); - -/* b1 := b1 - V1*w */ - - i__2 = i__ - 1; - dtrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1] -, lda, &t[*nb * t_dim1 + 1], &c__1); - i__2 = i__ - 1; - daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ - * a_dim1], &c__1); - - a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei; - } - -/* Generate the elementary reflector H(i) to annihilate */ -/* A(k+i+1:n,i) */ - - i__2 = *n - *k - i__ + 1; -/* Computing MIN */ - i__3 = *k + i__ + 1; - dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[std::min(i__3, *n)+ i__ * - a_dim1], &c__1, &tau[i__]); - ei = a[*k + i__ + i__ * a_dim1]; - a[*k + i__ + i__ * a_dim1] = 1.; - -/* Compute Y(1:n,i) */ - - i__2 = *n - *k - i__ + 1; - dgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1], - lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ * - y_dim1 + 1], &c__1); - i__2 = *n - *k - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, & - a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + - 1], &c__1); - i__2 = i__ - 1; - dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ * - t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1); - dscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1); - -/* Compute T(1:i,i) */ - - i__2 = i__ - 1; - d__1 = -tau[i__]; - dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1); - i__2 = i__ - 1; - dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, - &t[i__ * t_dim1 + 1], &c__1) - ; - t[i__ + i__ * t_dim1] = tau[i__]; - -/* L10: */ - } - a[*k + *nb + *nb * a_dim1] = ei; - - return 0; - -/* End of DLAHRD */ - -} /* dlahrd_ */ diff --git a/external/clapack/lapack/dlaic1.cpp b/external/clapack/lapack/dlaic1.cpp deleted file mode 100644 index a3a346af..00000000 --- a/external/clapack/lapack/dlaic1.cpp +++ /dev/null @@ -1,311 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b5 = 1.; - -/* Subroutine */ int dlaic1_(integer *job, integer *j, double *x, - double *sest, double *w, double *gamma, double * - sestpr, double *s, double *c__) -{ - /* System generated locals */ - double d__1, d__2, d__3, d__4; - - /* Builtin functions - double sqrt(double), d_sign(double *, double *); */ - - /* Local variables */ - double b, t, s1, s2, eps, tmp; - double sine, test, zeta1, zeta2, alpha, norma; - double absgam, absalp, cosine, absest; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAIC1 applies one step of incremental condition estimation in */ -/* its simplest version: */ - -/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */ -/* lower triangular matrix L, such that */ -/* twonorm(L*x) = sest */ -/* Then DLAIC1 computes sestpr, s, c such that */ -/* the vector */ -/* [ s*x ] */ -/* xhat = [ c ] */ -/* is an approximate singular vector of */ -/* [ L 0 ] */ -/* Lhat = [ w' gamma ] */ -/* in the sense that */ -/* twonorm(Lhat*xhat) = sestpr. */ - -/* Depending on JOB, an estimate for the largest or smallest singular */ -/* value is computed. */ - -/* Note that [s c]' and sestpr**2 is an eigenpair of the system */ - -/* diag(sest*sest, 0) + [alpha gamma] * [ alpha ] */ -/* [ gamma ] */ - -/* where alpha = x'*w. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) INTEGER */ -/* = 1: an estimate for the largest singular value is computed. */ -/* = 2: an estimate for the smallest singular value is computed. */ - -/* J (input) INTEGER */ -/* Length of X and W */ - -/* X (input) DOUBLE PRECISION array, dimension (J) */ -/* The j-vector x. */ - -/* SEST (input) DOUBLE PRECISION */ -/* Estimated singular value of j by j matrix L */ - -/* W (input) DOUBLE PRECISION array, dimension (J) */ -/* The j-vector w. */ - -/* GAMMA (input) DOUBLE PRECISION */ -/* The diagonal element gamma. */ - -/* SESTPR (output) DOUBLE PRECISION */ -/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */ - -/* S (output) DOUBLE PRECISION */ -/* Sine needed in forming xhat. */ - -/* C (output) DOUBLE PRECISION */ -/* Cosine needed in forming xhat. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --w; - --x; - - /* Function Body */ - eps = dlamch_("Epsilon"); - alpha = ddot_(j, &x[1], &c__1, &w[1], &c__1); - - absalp = abs(alpha); - absgam = abs(*gamma); - absest = abs(*sest); - - if (*job == 1) { - -/* Estimating largest singular value */ - -/* special cases */ - - if (*sest == 0.) { - s1 = std::max(absgam,absalp); - if (s1 == 0.) { - *s = 0.; - *c__ = 1.; - *sestpr = 0.; - } else { - *s = alpha / s1; - *c__ = *gamma / s1; - tmp = sqrt(*s * *s + *c__ * *c__); - *s /= tmp; - *c__ /= tmp; - *sestpr = s1 * tmp; - } - return 0; - } else if (absgam <= eps * absest) { - *s = 1.; - *c__ = 0.; - tmp = std::max(absest,absalp); - s1 = absest / tmp; - s2 = absalp / tmp; - *sestpr = tmp * sqrt(s1 * s1 + s2 * s2); - return 0; - } else if (absalp <= eps * absest) { - s1 = absgam; - s2 = absest; - if (s1 <= s2) { - *s = 1.; - *c__ = 0.; - *sestpr = s2; - } else { - *s = 0.; - *c__ = 1.; - *sestpr = s1; - } - return 0; - } else if (absest <= eps * absalp || absest <= eps * absgam) { - s1 = absgam; - s2 = absalp; - if (s1 <= s2) { - tmp = s1 / s2; - *s = sqrt(tmp * tmp + 1.); - *sestpr = s2 * *s; - *c__ = *gamma / s2 / *s; - *s = d_sign(&c_b5, &alpha) / *s; - } else { - tmp = s2 / s1; - *c__ = sqrt(tmp * tmp + 1.); - *sestpr = s1 * *c__; - *s = alpha / s1 / *c__; - *c__ = d_sign(&c_b5, gamma) / *c__; - } - return 0; - } else { - -/* normal case */ - - zeta1 = alpha / absest; - zeta2 = *gamma / absest; - - b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5; - *c__ = zeta1 * zeta1; - if (b > 0.) { - t = *c__ / (b + sqrt(b * b + *c__)); - } else { - t = sqrt(b * b + *c__) - b; - } - - sine = -zeta1 / t; - cosine = -zeta2 / (t + 1.); - tmp = sqrt(sine * sine + cosine * cosine); - *s = sine / tmp; - *c__ = cosine / tmp; - *sestpr = sqrt(t + 1.) * absest; - return 0; - } - - } else if (*job == 2) { - -/* Estimating smallest singular value */ - -/* special cases */ - - if (*sest == 0.) { - *sestpr = 0.; - if (std::max(absgam,absalp) == 0.) { - sine = 1.; - cosine = 0.; - } else { - sine = -(*gamma); - cosine = alpha; - } -/* Computing MAX */ - d__1 = abs(sine), d__2 = abs(cosine); - s1 = std::max(d__1,d__2); - *s = sine / s1; - *c__ = cosine / s1; - tmp = sqrt(*s * *s + *c__ * *c__); - *s /= tmp; - *c__ /= tmp; - return 0; - } else if (absgam <= eps * absest) { - *s = 0.; - *c__ = 1.; - *sestpr = absgam; - return 0; - } else if (absalp <= eps * absest) { - s1 = absgam; - s2 = absest; - if (s1 <= s2) { - *s = 0.; - *c__ = 1.; - *sestpr = s1; - } else { - *s = 1.; - *c__ = 0.; - *sestpr = s2; - } - return 0; - } else if (absest <= eps * absalp || absest <= eps * absgam) { - s1 = absgam; - s2 = absalp; - if (s1 <= s2) { - tmp = s1 / s2; - *c__ = sqrt(tmp * tmp + 1.); - *sestpr = absest * (tmp / *c__); - *s = -(*gamma / s2) / *c__; - *c__ = d_sign(&c_b5, &alpha) / *c__; - } else { - tmp = s2 / s1; - *s = sqrt(tmp * tmp + 1.); - *sestpr = absest / *s; - *c__ = alpha / s1 / *s; - *s = -d_sign(&c_b5, gamma) / *s; - } - return 0; - } else { - -/* normal case */ - - zeta1 = alpha / absest; - zeta2 = *gamma / absest; - -/* Computing MAX */ - d__3 = zeta1 * zeta1 + 1. + (d__1 = zeta1 * zeta2, abs(d__1)), - d__4 = (d__2 = zeta1 * zeta2, abs(d__2)) + zeta2 * zeta2; - norma = std::max(d__3,d__4); - -/* See if root is closer to zero or to ONE */ - - test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.; - if (test >= 0.) { - -/* root is close to zero, compute directly */ - - b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5; - *c__ = zeta2 * zeta2; - t = *c__ / (b + sqrt((d__1 = b * b - *c__, abs(d__1)))); - sine = zeta1 / (1. - t); - cosine = -zeta2 / t; - *sestpr = sqrt(t + eps * 4. * eps * norma) * absest; - } else { - -/* root is closer to ONE, shift by that amount */ - - b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5; - *c__ = zeta1 * zeta1; - if (b >= 0.) { - t = -(*c__) / (b + sqrt(b * b + *c__)); - } else { - t = b - sqrt(b * b + *c__); - } - sine = -zeta1 / t; - cosine = -zeta2 / (t + 1.); - *sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest; - } - tmp = sqrt(sine * sine + cosine * cosine); - *s = sine / tmp; - *c__ = cosine / tmp; - return 0; - - } - } - return 0; - -/* End of DLAIC1 */ - -} /* dlaic1_ */ diff --git a/external/clapack/lapack/dlaisnan.cpp b/external/clapack/lapack/dlaisnan.cpp deleted file mode 100644 index 0fca5ae6..00000000 --- a/external/clapack/lapack/dlaisnan.cpp +++ /dev/null @@ -1,47 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -bool dlaisnan_(double *din1, double *din2) -{ - /* System generated locals */ - bool ret_val; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This routine is not for general use. It exists solely to avoid */ -/* over-optimization in DISNAN. */ - -/* DLAISNAN checks for NaNs by comparing its two arguments for */ -/* inequality. NaN is the only floating-point value where NaN != NaN */ -/* returns .TRUE. To check for NaNs, pass the same variable as both */ -/* arguments. */ - -/* Strictly speaking, Fortran does not allow aliasing of function */ -/* arguments. So a compiler must assume that the two arguments are */ -/* not the same variable, and the test will not be optimized away. */ -/* Interprocedural or whole-program optimization may delete this */ -/* test. The ISNAN functions will be replaced by the correct */ -/* Fortran 03 intrinsic once the intrinsic is widely available. */ - -/* Arguments */ -/* ========= */ - -/* DIN1 (input) DOUBLE PRECISION */ -/* DIN2 (input) DOUBLE PRECISION */ -/* Two numbers to compare for inequality. */ - -/* ===================================================================== */ - -/* .. Executable Statements .. */ - ret_val = *din1 != *din2; - return ret_val; -} /* dlaisnan_ */ diff --git a/external/clapack/lapack/dlaln2.cpp b/external/clapack/lapack/dlaln2.cpp deleted file mode 100644 index 75ea15c4..00000000 --- a/external/clapack/lapack/dlaln2.cpp +++ /dev/null @@ -1,560 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaln2_(bool *ltrans, integer *na, integer *nw, - double *smin, double *ca, double *a, integer *lda, - double *d1, double *d2, double *b, integer *ldb, - double *wr, double *wi, double *x, integer *ldx, - double *scale, double *xnorm, integer *info) -{ - /* Initialized data */ - - static bool zswap[4] = { false,false,true,true }; - static bool rswap[4] = { false,true,false,true }; - static integer ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2, - 4,3,2,1 }; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset; - double d__1, d__2, d__3, d__4, d__5, d__6; - static double equiv_0[4], equiv_1[4]; - - /* Local variables */ - integer j; -#define ci (equiv_0) -#define cr (equiv_1) - double bi1, bi2, br1, br2, xi1, xi2, xr1, xr2, ci21, ci22, cr21, cr22, - li21, csi, ui11, lr21, ui12, ui22; -#define civ (equiv_0) - double csr, ur11, ur12, ur22; -#define crv (equiv_1) - double bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s, u22abs; - integer icmax; - double bnorm, cnorm, smini; - double bignum, smlnum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLALN2 solves a system of the form (ca A - w D ) X = s B */ -/* or (ca A' - w D) X = s B with possible scaling ("s") and */ -/* perturbation of A. (A' means A-transpose.) */ - -/* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA */ -/* real diagonal matrix, w is a real or complex value, and X and B are */ -/* NA x 1 matrices -- real if w is real, complex if w is complex. NA */ -/* may be 1 or 2. */ - -/* If w is complex, X and B are represented as NA x 2 matrices, */ -/* the first column of each being the real part and the second */ -/* being the imaginary part. */ - -/* "s" is a scaling factor (.LE. 1), computed by DLALN2, which is */ -/* so chosen that X can be computed without overflow. X is further */ -/* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less */ -/* than overflow. */ - -/* If both singular values of (ca A - w D) are less than SMIN, */ -/* SMIN*identity will be used instead of (ca A - w D). If only one */ -/* singular value is less than SMIN, one element of (ca A - w D) will be */ -/* perturbed enough to make the smallest singular value roughly SMIN. */ -/* If both singular values are at least SMIN, (ca A - w D) will not be */ -/* perturbed. In any case, the perturbation will be at most some small */ -/* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values */ -/* are computed by infinity-norm approximations, and thus will only be */ -/* correct to a factor of 2 or so. */ - -/* Note: all input quantities are assumed to be smaller than overflow */ -/* by a reasonable factor. (See BIGNUM.) */ - -/* Arguments */ -/* ========== */ - -/* LTRANS (input) LOGICAL */ -/* =.TRUE.: A-transpose will be used. */ -/* =.FALSE.: A will be used (not transposed.) */ - -/* NA (input) INTEGER */ -/* The size of the matrix A. It may (only) be 1 or 2. */ - -/* NW (input) INTEGER */ -/* 1 if "w" is real, 2 if "w" is complex. It may only be 1 */ -/* or 2. */ - -/* SMIN (input) DOUBLE PRECISION */ -/* The desired lower bound on the singular values of A. This */ -/* should be a safe distance away from underflow or overflow, */ -/* say, between (underflow/machine precision) and (machine */ -/* precision * overflow ). (See BIGNUM and ULP.) */ - -/* CA (input) DOUBLE PRECISION */ -/* The coefficient c, which A is multiplied by. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,NA) */ -/* The NA x NA matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of A. It must be at least NA. */ - -/* D1 (input) DOUBLE PRECISION */ -/* The 1,1 element in the diagonal matrix D. */ - -/* D2 (input) DOUBLE PRECISION */ -/* The 2,2 element in the diagonal matrix D. Not used if NW=1. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NW) */ -/* The NA x NW matrix B (right-hand side). If NW=2 ("w" is */ -/* complex), column 1 contains the real part of B and column 2 */ -/* contains the imaginary part. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B. It must be at least NA. */ - -/* WR (input) DOUBLE PRECISION */ -/* The real part of the scalar "w". */ - -/* WI (input) DOUBLE PRECISION */ -/* The imaginary part of the scalar "w". Not used if NW=1. */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NW) */ -/* The NA x NW matrix X (unknowns), as computed by DLALN2. */ -/* If NW=2 ("w" is complex), on exit, column 1 will contain */ -/* the real part of X and column 2 will contain the imaginary */ -/* part. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of X. It must be at least NA. */ - -/* SCALE (output) DOUBLE PRECISION */ -/* The scale factor that B must be multiplied by to insure */ -/* that overflow does not occur when computing X. Thus, */ -/* (ca A - w D) X will be SCALE*B, not B (ignoring */ -/* perturbations of A.) It will be at most 1. */ - -/* XNORM (output) DOUBLE PRECISION */ -/* The infinity-norm of X, when X is regarded as an NA x NW */ -/* real matrix. */ - -/* INFO (output) INTEGER */ -/* An error flag. It will be set to zero if no error occurs, */ -/* a negative number if an argument is in error, or a positive */ -/* number if ca A - w D had to be perturbed. */ -/* The possible values are: */ -/* = 0: No error occurred, and (ca A - w D) did not have to be */ -/* perturbed. */ -/* = 1: (ca A - w D) had to be perturbed to make its smallest */ -/* (or only) singular value greater than SMIN. */ -/* NOTE: In the interests of speed, this routine does not */ -/* check the inputs for errors. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Equivalences .. */ -/* .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - - /* Function Body */ -/* .. */ -/* .. Executable Statements .. */ - -/* Compute BIGNUM */ - - smlnum = 2. * dlamch_("Safe minimum"); - bignum = 1. / smlnum; - smini = std::max(*smin,smlnum); - -/* Don't check for input errors */ - - *info = 0; - -/* Standard Initializations */ - - *scale = 1.; - - if (*na == 1) { - -/* 1 x 1 (i.e., scalar) system C X = B */ - - if (*nw == 1) { - -/* Real 1x1 system. */ - -/* C = ca A - w D */ - - csr = *ca * a[a_dim1 + 1] - *wr * *d1; - cnorm = abs(csr); - -/* If | C | < SMINI, use C = SMINI */ - - if (cnorm < smini) { - csr = smini; - cnorm = smini; - *info = 1; - } - -/* Check scaling for X = B / C */ - - bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)); - if (cnorm < 1. && bnorm > 1.) { - if (bnorm > bignum * cnorm) { - *scale = 1. / bnorm; - } - } - -/* Compute X */ - - x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr; - *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)); - } else { - -/* Complex 1x1 system (w is complex) */ - -/* C = ca A - w D */ - - csr = *ca * a[a_dim1 + 1] - *wr * *d1; - csi = -(*wi) * *d1; - cnorm = abs(csr) + abs(csi); - -/* If | C | < SMINI, use C = SMINI */ - - if (cnorm < smini) { - csr = smini; - csi = 0.; - cnorm = smini; - *info = 1; - } - -/* Check scaling for X = B / C */ - - bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << - 1) + 1], abs(d__2)); - if (cnorm < 1. && bnorm > 1.) { - if (bnorm > bignum * cnorm) { - *scale = 1. / bnorm; - } - } - -/* Compute X */ - - d__1 = *scale * b[b_dim1 + 1]; - d__2 = *scale * b[(b_dim1 << 1) + 1]; - dladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1) - + 1]); - *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << - 1) + 1], abs(d__2)); - } - - } else { - -/* 2x2 System */ - -/* Compute the real part of C = ca A - w D (or ca A' - w D ) */ - - cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1; - cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2; - if (*ltrans) { - cr[2] = *ca * a[a_dim1 + 2]; - cr[1] = *ca * a[(a_dim1 << 1) + 1]; - } else { - cr[1] = *ca * a[a_dim1 + 2]; - cr[2] = *ca * a[(a_dim1 << 1) + 1]; - } - - if (*nw == 1) { - -/* Real 2x2 system (w is real) */ - -/* Find the largest element in C */ - - cmax = 0.; - icmax = 0; - - for (j = 1; j <= 4; ++j) { - if ((d__1 = crv[j - 1], abs(d__1)) > cmax) { - cmax = (d__1 = crv[j - 1], abs(d__1)); - icmax = j; - } -/* L10: */ - } - -/* If norm(C) < SMINI, use SMINI*identity. */ - - if (cmax < smini) { -/* Computing MAX */ - d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[ - b_dim1 + 2], abs(d__2)); - bnorm = std::max(d__3,d__4); - if (smini < 1. && bnorm > 1.) { - if (bnorm > bignum * smini) { - *scale = 1. / bnorm; - } - } - temp = *scale / smini; - x[x_dim1 + 1] = temp * b[b_dim1 + 1]; - x[x_dim1 + 2] = temp * b[b_dim1 + 2]; - *xnorm = temp * bnorm; - *info = 1; - return 0; - } - -/* Gaussian elimination with complete pivoting. */ - - ur11 = crv[icmax - 1]; - cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; - ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; - cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; - ur11r = 1. / ur11; - lr21 = ur11r * cr21; - ur22 = cr22 - ur12 * lr21; - -/* If smaller pivot < SMINI, use SMINI */ - - if (abs(ur22) < smini) { - ur22 = smini; - *info = 1; - } - if (rswap[icmax - 1]) { - br1 = b[b_dim1 + 2]; - br2 = b[b_dim1 + 1]; - } else { - br1 = b[b_dim1 + 1]; - br2 = b[b_dim1 + 2]; - } - br2 -= lr21 * br1; -/* Computing MAX */ - d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2); - bbnd = std::max(d__2,d__3); - if (bbnd > 1. && abs(ur22) < 1.) { - if (bbnd >= bignum * abs(ur22)) { - *scale = 1. / bbnd; - } - } - - xr2 = br2 * *scale / ur22; - xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12); - if (zswap[icmax - 1]) { - x[x_dim1 + 1] = xr2; - x[x_dim1 + 2] = xr1; - } else { - x[x_dim1 + 1] = xr1; - x[x_dim1 + 2] = xr2; - } -/* Computing MAX */ - d__1 = abs(xr1), d__2 = abs(xr2); - *xnorm = std::max(d__1,d__2); - -/* Further scaling if norm(A) norm(X) > overflow */ - - if (*xnorm > 1. && cmax > 1.) { - if (*xnorm > bignum / cmax) { - temp = cmax / bignum; - x[x_dim1 + 1] = temp * x[x_dim1 + 1]; - x[x_dim1 + 2] = temp * x[x_dim1 + 2]; - *xnorm = temp * *xnorm; - *scale = temp * *scale; - } - } - } else { - -/* Complex 2x2 system (w is complex) */ - -/* Find the largest element in C */ - - ci[0] = -(*wi) * *d1; - ci[1] = 0.; - ci[2] = 0.; - ci[3] = -(*wi) * *d2; - cmax = 0.; - icmax = 0; - - for (j = 1; j <= 4; ++j) { - if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs( - d__2)) > cmax) { - cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1] - , abs(d__2)); - icmax = j; - } -/* L20: */ - } - -/* If norm(C) < SMINI, use SMINI*identity. */ - - if (cmax < smini) { -/* Computing MAX */ - d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 - << 1) + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], - abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4)); - bnorm = std::max(d__5,d__6); - if (smini < 1. && bnorm > 1.) { - if (bnorm > bignum * smini) { - *scale = 1. / bnorm; - } - } - temp = *scale / smini; - x[x_dim1 + 1] = temp * b[b_dim1 + 1]; - x[x_dim1 + 2] = temp * b[b_dim1 + 2]; - x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1]; - x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2]; - *xnorm = temp * bnorm; - *info = 1; - return 0; - } - -/* Gaussian elimination with complete pivoting. */ - - ur11 = crv[icmax - 1]; - ui11 = civ[icmax - 1]; - cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; - ci21 = civ[ipivot[(icmax << 2) - 3] - 1]; - ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; - ui12 = civ[ipivot[(icmax << 2) - 2] - 1]; - cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; - ci22 = civ[ipivot[(icmax << 2) - 1] - 1]; - if (icmax == 1 || icmax == 4) { - -/* Code when off-diagonals of pivoted C are real */ - - if (abs(ur11) > abs(ui11)) { - temp = ui11 / ur11; -/* Computing 2nd power */ - d__1 = temp; - ur11r = 1. / (ur11 * (d__1 * d__1 + 1.)); - ui11r = -temp * ur11r; - } else { - temp = ur11 / ui11; -/* Computing 2nd power */ - d__1 = temp; - ui11r = -1. / (ui11 * (d__1 * d__1 + 1.)); - ur11r = -temp * ui11r; - } - lr21 = cr21 * ur11r; - li21 = cr21 * ui11r; - ur12s = ur12 * ur11r; - ui12s = ur12 * ui11r; - ur22 = cr22 - ur12 * lr21; - ui22 = ci22 - ur12 * li21; - } else { - -/* Code when diagonals of pivoted C are real */ - - ur11r = 1. / ur11; - ui11r = 0.; - lr21 = cr21 * ur11r; - li21 = ci21 * ur11r; - ur12s = ur12 * ur11r; - ui12s = ui12 * ur11r; - ur22 = cr22 - ur12 * lr21 + ui12 * li21; - ui22 = -ur12 * li21 - ui12 * lr21; - } - u22abs = abs(ur22) + abs(ui22); - -/* If smaller pivot < SMINI, use SMINI */ - - if (u22abs < smini) { - ur22 = smini; - ui22 = 0.; - *info = 1; - } - if (rswap[icmax - 1]) { - br2 = b[b_dim1 + 1]; - br1 = b[b_dim1 + 2]; - bi2 = b[(b_dim1 << 1) + 1]; - bi1 = b[(b_dim1 << 1) + 2]; - } else { - br1 = b[b_dim1 + 1]; - br2 = b[b_dim1 + 2]; - bi1 = b[(b_dim1 << 1) + 1]; - bi2 = b[(b_dim1 << 1) + 2]; - } - br2 = br2 - lr21 * br1 + li21 * bi1; - bi2 = bi2 - li21 * br1 - lr21 * bi1; -/* Computing MAX */ - d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r)) - ), d__2 = abs(br2) + abs(bi2); - bbnd = std::max(d__1,d__2); - if (bbnd > 1. && u22abs < 1.) { - if (bbnd >= bignum * u22abs) { - *scale = 1. / bbnd; - br1 = *scale * br1; - bi1 = *scale * bi1; - br2 = *scale * br2; - bi2 = *scale * bi2; - } - } - - dladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2); - xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2; - xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2; - if (zswap[icmax - 1]) { - x[x_dim1 + 1] = xr2; - x[x_dim1 + 2] = xr1; - x[(x_dim1 << 1) + 1] = xi2; - x[(x_dim1 << 1) + 2] = xi1; - } else { - x[x_dim1 + 1] = xr1; - x[x_dim1 + 2] = xr2; - x[(x_dim1 << 1) + 1] = xi1; - x[(x_dim1 << 1) + 2] = xi2; - } -/* Computing MAX */ - d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2); - *xnorm = std::max(d__1,d__2); - -/* Further scaling if norm(A) norm(X) > overflow */ - - if (*xnorm > 1. && cmax > 1.) { - if (*xnorm > bignum / cmax) { - temp = cmax / bignum; - x[x_dim1 + 1] = temp * x[x_dim1 + 1]; - x[x_dim1 + 2] = temp * x[x_dim1 + 2]; - x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1]; - x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2]; - *xnorm = temp * *xnorm; - *scale = temp * *scale; - } - } - } - } - - return 0; - -/* End of DLALN2 */ - -} /* dlaln2_ */ - -#undef crv -#undef civ -#undef cr -#undef ci diff --git a/external/clapack/lapack/dlals0.cpp b/external/clapack/lapack/dlals0.cpp deleted file mode 100644 index d4ea7f0b..00000000 --- a/external/clapack/lapack/dlals0.cpp +++ /dev/null @@ -1,446 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b5 = -1.; -static integer c__1 = 1; -static double c_b11 = 1.; -static double c_b13 = 0.; -static integer c__0 = 0; - -/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *nrhs, double *b, integer *ldb, double - *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, - integer *ldgcol, double *givnum, integer *ldgnum, double * - poles, double *difl, double *difr, double *z__, integer * - k, double *c__, double *s, double *work, integer *info) -{ - /* System generated locals */ - integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, - difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1, - poles_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j, m, n; - double dj; - integer nlp1; - double temp; - double diflj, difrj, dsigj; - double dsigjp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLALS0 applies back the multiplying factors of either the left or the */ -/* right singular vector matrix of a diagonal matrix appended by a row */ -/* to the right hand side matrix B in solving the least squares problem */ -/* using the divide-and-conquer SVD approach. */ - -/* For the left singular vector matrix, three types of orthogonal */ -/* matrices are involved: */ - -/* (1L) Givens rotations: the number of such rotations is GIVPTR; the */ -/* pairs of columns/rows they were applied to are stored in GIVCOL; */ -/* and the C- and S-values of these rotations are stored in GIVNUM. */ - -/* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */ -/* row, and for J=2:N, PERM(J)-th row of B is to be moved to the */ -/* J-th row. */ - -/* (3L) The left singular vector matrix of the remaining matrix. */ - -/* For the right singular vector matrix, four types of orthogonal */ -/* matrices are involved: */ - -/* (1R) The right singular vector matrix of the remaining matrix. */ - -/* (2R) If SQRE = 1, one extra Givens rotation to generate the right */ -/* null space. */ - -/* (3R) The inverse transformation of (2L). */ - -/* (4R) The inverse transformation of (1L). */ - -/* Arguments */ -/* ========= */ - -/* ICOMPQ (input) INTEGER */ -/* Specifies whether singular vectors are to be computed in */ -/* factored form: */ -/* = 0: Left singular vector matrix. */ -/* = 1: Right singular vector matrix. */ - -/* NL (input) INTEGER */ -/* The row dimension of the upper block. NL >= 1. */ - -/* NR (input) INTEGER */ -/* The row dimension of the lower block. NR >= 1. */ - -/* SQRE (input) INTEGER */ -/* = 0: the lower block is an NR-by-NR square matrix. */ -/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ - -/* The bidiagonal matrix has row dimension N = NL + NR + 1, */ -/* and column dimension M = N + SQRE. */ - -/* NRHS (input) INTEGER */ -/* The number of columns of B and BX. NRHS must be at least 1. */ - -/* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) */ -/* On input, B contains the right hand sides of the least */ -/* squares problem in rows 1 through M. On output, B contains */ -/* the solution X in rows 1 through N. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B. LDB must be at least */ -/* max(1,MAX( M, N ) ). */ - -/* BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */ - -/* LDBX (input) INTEGER */ -/* The leading dimension of BX. */ - -/* PERM (input) INTEGER array, dimension ( N ) */ -/* The permutations (from deflation and sorting) applied */ -/* to the two blocks. */ - -/* GIVPTR (input) INTEGER */ -/* The number of Givens rotations which took place in this */ -/* subproblem. */ - -/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) */ -/* Each pair of numbers indicates a pair of rows/columns */ -/* involved in a Givens rotation. */ - -/* LDGCOL (input) INTEGER */ -/* The leading dimension of GIVCOL, must be at least N. */ - -/* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ -/* Each number indicates the C or S value used in the */ -/* corresponding Givens rotation. */ - -/* LDGNUM (input) INTEGER */ -/* The leading dimension of arrays DIFR, POLES and */ -/* GIVNUM, must be at least K. */ - -/* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ -/* On entry, POLES(1:K, 1) contains the new singular */ -/* values obtained from solving the secular equation, and */ -/* POLES(1:K, 2) is an array containing the poles in the secular */ -/* equation. */ - -/* DIFL (input) DOUBLE PRECISION array, dimension ( K ). */ -/* On entry, DIFL(I) is the distance between I-th updated */ -/* (undeflated) singular value and the I-th (undeflated) old */ -/* singular value. */ - -/* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). */ -/* On entry, DIFR(I, 1) contains the distances between I-th */ -/* updated (undeflated) singular value and the I+1-th */ -/* (undeflated) old singular value. And DIFR(I, 2) is the */ -/* normalizing factor for the I-th right singular vector. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( K ) */ -/* Contain the components of the deflation-adjusted updating row */ -/* vector. */ - -/* K (input) INTEGER */ -/* Contains the dimension of the non-deflated matrix, */ -/* This is the order of the related secular equation. 1 <= K <=N. */ - -/* C (input) DOUBLE PRECISION */ -/* C contains garbage if SQRE =0 and the C-value of a Givens */ -/* rotation related to the right null space if SQRE = 1. */ - -/* S (input) DOUBLE PRECISION */ -/* S contains garbage if SQRE =0 and the S-value of a Givens */ -/* rotation related to the right null space if SQRE = 1. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension ( K ) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */ -/* California at Berkeley, USA */ -/* Osni Marques, LBNL/NERSC, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - bx_dim1 = *ldbx; - bx_offset = 1 + bx_dim1; - bx -= bx_offset; - --perm; - givcol_dim1 = *ldgcol; - givcol_offset = 1 + givcol_dim1; - givcol -= givcol_offset; - difr_dim1 = *ldgnum; - difr_offset = 1 + difr_dim1; - difr -= difr_offset; - poles_dim1 = *ldgnum; - poles_offset = 1 + poles_dim1; - poles -= poles_offset; - givnum_dim1 = *ldgnum; - givnum_offset = 1 + givnum_dim1; - givnum -= givnum_offset; - --difl; - --z__; - --work; - - /* Function Body */ - *info = 0; - - if (*icompq < 0 || *icompq > 1) { - *info = -1; - } else if (*nl < 1) { - *info = -2; - } else if (*nr < 1) { - *info = -3; - } else if (*sqre < 0 || *sqre > 1) { - *info = -4; - } - - n = *nl + *nr + 1; - - if (*nrhs < 1) { - *info = -5; - } else if (*ldb < n) { - *info = -7; - } else if (*ldbx < n) { - *info = -9; - } else if (*givptr < 0) { - *info = -11; - } else if (*ldgcol < n) { - *info = -13; - } else if (*ldgnum < n) { - *info = -15; - } else if (*k < 1) { - *info = -20; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLALS0", &i__1); - return 0; - } - - m = n + *sqre; - nlp1 = *nl + 1; - - if (*icompq == 0) { - -/* Apply back orthogonal transformations from the left. */ - -/* Step (1L): apply back the Givens rotations performed. */ - - i__1 = *givptr; - for (i__ = 1; i__ <= i__1; ++i__) { - drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & - b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + - (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]); -/* L10: */ - } - -/* Step (2L): permute rows of B. */ - - dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], - ldbx); -/* L20: */ - } - -/* Step (3L): apply the inverse of the left singular vector */ -/* matrix to BX. */ - - if (*k == 1) { - dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); - if (z__[1] < 0.) { - dscal_(nrhs, &c_b5, &b[b_offset], ldb); - } - } else { - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - diflj = difl[j]; - dj = poles[j + poles_dim1]; - dsigj = -poles[j + (poles_dim1 << 1)]; - if (j < *k) { - difrj = -difr[j + difr_dim1]; - dsigjp = -poles[j + 1 + (poles_dim1 << 1)]; - } - if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) { - work[j] = 0.; - } else { - work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj / - (poles[j + (poles_dim1 << 1)] + dj); - } - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == - 0.) { - work[i__] = 0.; - } else { - work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] - / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & - dsigj) - diflj) / (poles[i__ + (poles_dim1 << - 1)] + dj); - } -/* L30: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == - 0.) { - work[i__] = 0.; - } else { - work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] - / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & - dsigjp) + difrj) / (poles[i__ + (poles_dim1 << - 1)] + dj); - } -/* L40: */ - } - work[1] = -1.; - temp = dnrm2_(k, &work[1], &c__1); - dgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], & - c__1, &c_b13, &b[j + b_dim1], ldb); - dlascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j + - b_dim1], ldb, info); -/* L50: */ - } - } - -/* Move the deflated rows of BX to B also. */ - - if (*k < std::max(m,n)) { - i__1 = n - *k; - dlacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 - + b_dim1], ldb); - } - } else { - -/* Apply back the right orthogonal transformations. */ - -/* Step (1R): apply back the new right singular vector matrix */ -/* to B. */ - - if (*k == 1) { - dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); - } else { - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dsigj = poles[j + (poles_dim1 << 1)]; - if (z__[j] == 0.) { - work[j] = 0.; - } else { - work[j] = -z__[j] / difl[j] / (dsigj + poles[j + - poles_dim1]) / difr[j + (difr_dim1 << 1)]; - } - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - if (z__[j] == 0.) { - work[i__] = 0.; - } else { - d__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; - work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[ - i__ + difr_dim1]) / (dsigj + poles[i__ + - poles_dim1]) / difr[i__ + (difr_dim1 << 1)]; - } -/* L60: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - if (z__[j] == 0.) { - work[i__] = 0.; - } else { - d__1 = -poles[i__ + (poles_dim1 << 1)]; - work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[ - i__]) / (dsigj + poles[i__ + poles_dim1]) / - difr[i__ + (difr_dim1 << 1)]; - } -/* L70: */ - } - dgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], & - c__1, &c_b13, &bx[j + bx_dim1], ldbx); -/* L80: */ - } - } - -/* Step (2R): if SQRE = 1, apply back the rotation that is */ -/* related to the right null space of the subproblem. */ - - if (*sqre == 1) { - dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); - drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, - s); - } - if (*k < std::max(m,n)) { - i__1 = n - *k; - dlacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + - bx_dim1], ldbx); - } - -/* Step (3R): permute rows of B. */ - - dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); - if (*sqre == 1) { - dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); - } - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], - ldb); -/* L90: */ - } - -/* Step (4R): apply back the Givens rotations performed. */ - - for (i__ = *givptr; i__ >= 1; --i__) { - d__1 = -givnum[i__ + givnum_dim1]; - drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & - b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + - (givnum_dim1 << 1)], &d__1); -/* L100: */ - } - } - - return 0; - -/* End of DLALS0 */ - -} /* dlals0_ */ diff --git a/external/clapack/lapack/dlalsa.cpp b/external/clapack/lapack/dlalsa.cpp deleted file mode 100644 index fb811d70..00000000 --- a/external/clapack/lapack/dlalsa.cpp +++ /dev/null @@ -1,430 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b7 = 1.; -static double c_b8 = 0.; -static integer c__2 = 2; - -/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n, - integer *nrhs, double *b, integer *ldb, double *bx, integer * - ldbx, double *u, integer *ldu, double *vt, integer *k, - double *difl, double *difr, double *z__, double * - poles, integer *givptr, integer *givcol, integer *ldgcol, integer * - perm, double *givnum, double *c__, double *s, double * - work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, - b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1, - difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, - u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1, - i__2; - - /* Local variables */ - integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1, - nlp1, lvl2, nrp1, nlvl, sqre; - integer inode, ndiml, ndimr; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLALSA is an itermediate step in solving the least squares problem */ -/* by computing the SVD of the coefficient matrix in compact form (The */ -/* singular vectors are computed as products of simple orthorgonal */ -/* matrices.). */ - -/* If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector */ -/* matrix of an upper bidiagonal matrix to the right hand side; and if */ -/* ICOMPQ = 1, DLALSA applies the right singular vector matrix to the */ -/* right hand side. The singular vector matrices were generated in */ -/* compact form by DLALSA. */ - -/* Arguments */ -/* ========= */ - - -/* ICOMPQ (input) INTEGER */ -/* Specifies whether the left or the right singular vector */ -/* matrix is involved. */ -/* = 0: Left singular vector matrix */ -/* = 1: Right singular vector matrix */ - -/* SMLSIZ (input) INTEGER */ -/* The maximum size of the subproblems at the bottom of the */ -/* computation tree. */ - -/* N (input) INTEGER */ -/* The row and column dimensions of the upper bidiagonal matrix. */ - -/* NRHS (input) INTEGER */ -/* The number of columns of B and BX. NRHS must be at least 1. */ - -/* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) */ -/* On input, B contains the right hand sides of the least */ -/* squares problem in rows 1 through M. */ -/* On output, B contains the solution X in rows 1 through N. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B in the calling subprogram. */ -/* LDB must be at least max(1,MAX( M, N ) ). */ - -/* BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */ -/* On exit, the result of applying the left or right singular */ -/* vector matrix to B. */ - -/* LDBX (input) INTEGER */ -/* The leading dimension of BX. */ - -/* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). */ -/* On entry, U contains the left singular vector matrices of all */ -/* subproblems at the bottom level. */ - -/* LDU (input) INTEGER, LDU = > N. */ -/* The leading dimension of arrays U, VT, DIFL, DIFR, */ -/* POLES, GIVNUM, and Z. */ - -/* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). */ -/* On entry, VT' contains the right singular vector matrices of */ -/* all subproblems at the bottom level. */ - -/* K (input) INTEGER array, dimension ( N ). */ - -/* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */ -/* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */ - -/* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ -/* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */ -/* distances between singular values on the I-th level and */ -/* singular values on the (I -1)-th level, and DIFR(*, 2 * I) */ -/* record the normalizing factors of the right singular vectors */ -/* matrices of subproblems on I-th level. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */ -/* On entry, Z(1, I) contains the components of the deflation- */ -/* adjusted updating row vector for subproblems on the I-th */ -/* level. */ - -/* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ -/* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */ -/* singular values involved in the secular equations on the I-th */ -/* level. */ - -/* GIVPTR (input) INTEGER array, dimension ( N ). */ -/* On entry, GIVPTR( I ) records the number of Givens */ -/* rotations performed on the I-th problem on the computation */ -/* tree. */ - -/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */ -/* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */ -/* locations of Givens rotations performed on the I-th level on */ -/* the computation tree. */ - -/* LDGCOL (input) INTEGER, LDGCOL = > N. */ -/* The leading dimension of arrays GIVCOL and PERM. */ - -/* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). */ -/* On entry, PERM(*, I) records permutations done on the I-th */ -/* level of the computation tree. */ - -/* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ -/* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */ -/* values of Givens rotations performed on the I-th level on the */ -/* computation tree. */ - -/* C (input) DOUBLE PRECISION array, dimension ( N ). */ -/* On entry, if the I-th subproblem is not square, */ -/* C( I ) contains the C-value of a Givens rotation related to */ -/* the right null space of the I-th subproblem. */ - -/* S (input) DOUBLE PRECISION array, dimension ( N ). */ -/* On entry, if the I-th subproblem is not square, */ -/* S( I ) contains the S-value of a Givens rotation related to */ -/* the right null space of the I-th subproblem. */ - -/* WORK (workspace) DOUBLE PRECISION array. */ -/* The dimension must be at least N. */ - -/* IWORK (workspace) INTEGER array. */ -/* The dimension must be at least 3 * N */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */ -/* California at Berkeley, USA */ -/* Osni Marques, LBNL/NERSC, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - bx_dim1 = *ldbx; - bx_offset = 1 + bx_dim1; - bx -= bx_offset; - givnum_dim1 = *ldu; - givnum_offset = 1 + givnum_dim1; - givnum -= givnum_offset; - poles_dim1 = *ldu; - poles_offset = 1 + poles_dim1; - poles -= poles_offset; - z_dim1 = *ldu; - z_offset = 1 + z_dim1; - z__ -= z_offset; - difr_dim1 = *ldu; - difr_offset = 1 + difr_dim1; - difr -= difr_offset; - difl_dim1 = *ldu; - difl_offset = 1 + difl_dim1; - difl -= difl_offset; - vt_dim1 = *ldu; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - --k; - --givptr; - perm_dim1 = *ldgcol; - perm_offset = 1 + perm_dim1; - perm -= perm_offset; - givcol_dim1 = *ldgcol; - givcol_offset = 1 + givcol_dim1; - givcol -= givcol_offset; - --c__; - --s; - --work; - --iwork; - - /* Function Body */ - *info = 0; - - if (*icompq < 0 || *icompq > 1) { - *info = -1; - } else if (*smlsiz < 3) { - *info = -2; - } else if (*n < *smlsiz) { - *info = -3; - } else if (*nrhs < 1) { - *info = -4; - } else if (*ldb < *n) { - *info = -6; - } else if (*ldbx < *n) { - *info = -8; - } else if (*ldu < *n) { - *info = -10; - } else if (*ldgcol < *n) { - *info = -19; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLALSA", &i__1); - return 0; - } - -/* Book-keeping and setting up the computation tree. */ - - inode = 1; - ndiml = inode + *n; - ndimr = ndiml + *n; - - dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], - smlsiz); - -/* The following code applies back the left singular vector factors. */ -/* For applying back the right singular vector factors, go to 50. */ - - if (*icompq == 1) { - goto L50; - } - -/* The nodes on the bottom level of the tree were solved */ -/* by DLASDQ. The corresponding left and right singular vector */ -/* matrices are in explicit form. First apply back the left */ -/* singular vector matrices. */ - - ndb1 = (nd + 1) / 2; - i__1 = nd; - for (i__ = ndb1; i__ <= i__1; ++i__) { - -/* IC : center row of each node */ -/* NL : number of rows of left subproblem */ -/* NR : number of rows of right subproblem */ -/* NLF: starting row of the left subproblem */ -/* NRF: starting row of the right subproblem */ - - i1 = i__ - 1; - ic = iwork[inode + i1]; - nl = iwork[ndiml + i1]; - nr = iwork[ndimr + i1]; - nlf = ic - nl; - nrf = ic + 1; - dgemm_("T", "N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf - + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); - dgemm_("T", "N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf - + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx); -/* L10: */ - } - -/* Next copy the rows of B that correspond to unchanged rows */ -/* in the bidiagonal matrix to BX. */ - - i__1 = nd; - for (i__ = 1; i__ <= i__1; ++i__) { - ic = iwork[inode + i__ - 1]; - dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx); -/* L20: */ - } - -/* Finally go through the left singular vector matrices of all */ -/* the other subproblems bottom-up on the tree. */ - - j = pow_ii(&c__2, &nlvl); - sqre = 0; - - for (lvl = nlvl; lvl >= 1; --lvl) { - lvl2 = (lvl << 1) - 1; - -/* find the first node LF and last node LL on */ -/* the current level LVL */ - - if (lvl == 1) { - lf = 1; - ll = 1; - } else { - i__1 = lvl - 1; - lf = pow_ii(&c__2, &i__1); - ll = (lf << 1) - 1; - } - i__1 = ll; - for (i__ = lf; i__ <= i__1; ++i__) { - im1 = i__ - 1; - ic = iwork[inode + im1]; - nl = iwork[ndiml + im1]; - nr = iwork[ndimr + im1]; - nlf = ic - nl; - nrf = ic + 1; - --j; - dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, & - b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], & - givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & - givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * - poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + - lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ - j], &s[j], &work[1], info); -/* L30: */ - } -/* L40: */ - } - goto L90; - -/* ICOMPQ = 1: applying back the right singular vector factors. */ - -L50: - -/* First now go through the right singular vector matrices of all */ -/* the tree nodes top-down. */ - - j = 0; - i__1 = nlvl; - for (lvl = 1; lvl <= i__1; ++lvl) { - lvl2 = (lvl << 1) - 1; - -/* Find the first node LF and last node LL on */ -/* the current level LVL. */ - - if (lvl == 1) { - lf = 1; - ll = 1; - } else { - i__2 = lvl - 1; - lf = pow_ii(&c__2, &i__2); - ll = (lf << 1) - 1; - } - i__2 = lf; - for (i__ = ll; i__ >= i__2; --i__) { - im1 = i__ - 1; - ic = iwork[inode + im1]; - nl = iwork[ndiml + im1]; - nr = iwork[ndimr + im1]; - nlf = ic - nl; - nrf = ic + 1; - if (i__ == ll) { - sqre = 0; - } else { - sqre = 1; - } - ++j; - dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[ - nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], & - givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & - givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * - poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + - lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ - j], &s[j], &work[1], info); -/* L60: */ - } -/* L70: */ - } - -/* The nodes on the bottom level of the tree were solved */ -/* by DLASDQ. The corresponding right singular vector */ -/* matrices are in explicit form. Apply them back. */ - - ndb1 = (nd + 1) / 2; - i__1 = nd; - for (i__ = ndb1; i__ <= i__1; ++i__) { - i1 = i__ - 1; - ic = iwork[inode + i1]; - nl = iwork[ndiml + i1]; - nr = iwork[ndimr + i1]; - nlp1 = nl + 1; - if (i__ == nd) { - nrp1 = nr; - } else { - nrp1 = nr + 1; - } - nlf = ic - nl; - nrf = ic + 1; - dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, & - b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); - dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, & - b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx); -/* L80: */ - } - -L90: - - return 0; - -/* End of DLALSA */ - -} /* dlalsa_ */ diff --git a/external/clapack/lapack/dlalsd.cpp b/external/clapack/lapack/dlalsd.cpp deleted file mode 100644 index a61d9003..00000000 --- a/external/clapack/lapack/dlalsd.cpp +++ /dev/null @@ -1,481 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b6 = 0.; -static integer c__0 = 0; -static double c_b11 = 1.; - -/* Subroutine */ int dlalsd_(const char *uplo, integer *smlsiz, integer *n, integer - *nrhs, double *d__, double *e, double *b, integer *ldb, - double *rcond, integer *rank, double *work, integer *iwork, - integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer c__, i__, j, k; - double r__; - integer s, u, z__; - double cs; - integer bx; - double sn; - integer st, vt, nm1, st1; - double eps; - integer iwk; - double tol; - integer difl, difr; - double rcnd; - integer perm, nsub; - integer nlvl, sqre, bxst; - integer poles, sizei, nsize, nwork, icmpq1, icmpq2; - integer givcol; - double orgnrm; - integer givnum, givptr, smlszp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLALSD uses the singular value decomposition of A to solve the least */ -/* squares problem of finding X to minimize the Euclidean norm of each */ -/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */ -/* are N-by-NRHS. The solution X overwrites B. */ - -/* The singular values of A smaller than RCOND times the largest */ -/* singular value are treated as zero in solving the least squares */ -/* problem; in this case a minimum norm solution is returned. */ -/* The actual singular values are returned in D in ascending order. */ - -/* This code makes very mild assumptions about floating point */ -/* arithmetic. It will work on machines with a guard digit in */ -/* add/subtract, or on those binary machines without guard digits */ -/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */ -/* It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': D and E define an upper bidiagonal matrix. */ -/* = 'L': D and E define a lower bidiagonal matrix. */ - -/* SMLSIZ (input) INTEGER */ -/* The maximum size of the subproblems at the bottom of the */ -/* computation tree. */ - -/* N (input) INTEGER */ -/* The dimension of the bidiagonal matrix. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of columns of B. NRHS must be at least 1. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry D contains the main diagonal of the bidiagonal */ -/* matrix. On exit, if INFO = 0, D contains its singular values. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* Contains the super-diagonal entries of the bidiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On input, B contains the right hand sides of the least */ -/* squares problem. On output, B contains the solution X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of B in the calling subprogram. */ -/* LDB must be at least max(1,N). */ - -/* RCOND (input) DOUBLE PRECISION */ -/* The singular values of A less than or equal to RCOND times */ -/* the largest singular value are treated as zero in solving */ -/* the least squares problem. If RCOND is negative, */ -/* machine precision is used instead. */ -/* For example, if diag(S)*X=B were the least squares problem, */ -/* where diag(S) is a diagonal matrix of singular values, the */ -/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */ -/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */ -/* RCOND*max(S). */ - -/* RANK (output) INTEGER */ -/* The number of singular values of A greater than RCOND times */ -/* the largest singular value. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension at least */ -/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */ -/* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */ - -/* IWORK (workspace) INTEGER array, dimension at least */ -/* (3*N*NLVL + 11*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: The algorithm failed to compute an singular value while */ -/* working on the submatrix lying in rows and columns */ -/* INFO/(N+1) through MOD(INFO,N+1). */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */ -/* California at Berkeley, USA */ -/* Osni Marques, LBNL/NERSC, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - - if (*n < 0) { - *info = -3; - } else if (*nrhs < 1) { - *info = -4; - } else if (*ldb < 1 || *ldb < *n) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLALSD", &i__1); - return 0; - } - - eps = dlamch_("Epsilon"); - -/* Set up the tolerance. */ - - if (*rcond <= 0. || *rcond >= 1.) { - rcnd = eps; - } else { - rcnd = *rcond; - } - - *rank = 0; - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } else if (*n == 1) { - if (d__[1] == 0.) { - dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); - } else { - *rank = 1; - dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ - b_offset], ldb, info); - d__[1] = abs(d__[1]); - } - return 0; - } - -/* Rotate the matrix if it is lower bidiagonal. */ - - if (*(unsigned char *)uplo == 'L') { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - if (*nrhs == 1) { - drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & - c__1, &cs, &sn); - } else { - work[(i__ << 1) - 1] = cs; - work[i__ * 2] = sn; - } -/* L10: */ - } - if (*nrhs > 1) { - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *n - 1; - for (j = 1; j <= i__2; ++j) { - cs = work[(j << 1) - 1]; - sn = work[j * 2]; - drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * - b_dim1], &c__1, &cs, &sn); -/* L20: */ - } -/* L30: */ - } - } - } - -/* Scale. */ - - nm1 = *n - 1; - orgnrm = dlanst_("M", n, &d__[1], &e[1]); - if (orgnrm == 0.) { - dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); - return 0; - } - - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info); - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, - info); - -/* If N is smaller than the minimum divide size SMLSIZ, then solve */ -/* the problem with another solver. */ - - if (*n <= *smlsiz) { - nwork = *n * *n + 1; - dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n); - dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, & - work[1], n, &b[b_offset], ldb, &work[nwork], info); - if (*info != 0) { - return 0; - } - tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] <= tol) { - dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb); - } else { - dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ - i__ + b_dim1], ldb, info); - ++(*rank); - } -/* L40: */ - } - dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & - c_b6, &work[nwork], n); - dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb); - -/* Unscale. */ - - dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, - info); - dlasrt_("D", n, &d__[1], info); - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], - ldb, info); - - return 0; - } - -/* Book-keeping and setting up some constants. */ - - nlvl = (integer) (log((double) (*n) / (double) (*smlsiz + 1)) / - log(2.)) + 1; - - smlszp = *smlsiz + 1; - - u = 1; - vt = *smlsiz * *n + 1; - difl = vt + smlszp * *n; - difr = difl + nlvl * *n; - z__ = difr + (nlvl * *n << 1); - c__ = z__ + nlvl * *n; - s = c__ + *n; - poles = s + *n; - givnum = poles + (nlvl << 1) * *n; - bx = givnum + (nlvl << 1) * *n; - nwork = bx + *n * *nrhs; - - sizei = *n + 1; - k = sizei + *n; - givptr = k + *n; - perm = givptr + *n; - givcol = perm + nlvl * *n; - iwk = givcol + (nlvl * *n << 1); - - st = 1; - sqre = 0; - icmpq1 = 1; - icmpq2 = 0; - nsub = 0; - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) < eps) { - d__[i__] = d_sign(&eps, &d__[i__]); - } -/* L50: */ - } - - i__1 = nm1; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { - ++nsub; - iwork[nsub] = st; - -/* Subproblem found. First determine its size and then */ -/* apply divide and conquer on it. */ - - if (i__ < nm1) { - -/* A subproblem with E(I) small for I < NM1. */ - - nsize = i__ - st + 1; - iwork[sizei + nsub - 1] = nsize; - } else if ((d__1 = e[i__], abs(d__1)) >= eps) { - -/* A subproblem with E(NM1) not too small but I = NM1. */ - - nsize = *n - st + 1; - iwork[sizei + nsub - 1] = nsize; - } else { - -/* A subproblem with E(NM1) small. This implies an */ -/* 1-by-1 subproblem at D(N), which is not solved */ -/* explicitly. */ - - nsize = i__ - st + 1; - iwork[sizei + nsub - 1] = nsize; - ++nsub; - iwork[nsub] = *n; - iwork[sizei + nsub - 1] = 1; - dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n); - } - st1 = st - 1; - if (nsize == 1) { - -/* This is a 1-by-1 subproblem and is not solved */ -/* explicitly. */ - - dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); - } else if (nsize <= *smlsiz) { - -/* This is a small subproblem and is solved by DLASDQ. */ - - dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], - n); - dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[ - st], &work[vt + st1], n, &work[nwork], n, &b[st + - b_dim1], ldb, &work[nwork], info); - if (*info != 0) { - return 0; - } - dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + - st1], n); - } else { - -/* A large problem. Solve it using divide and conquer. */ - - dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & - work[u + st1], n, &work[vt + st1], &iwork[k + st1], & - work[difl + st1], &work[difr + st1], &work[z__ + st1], - &work[poles + st1], &iwork[givptr + st1], &iwork[ - givcol + st1], n, &iwork[perm + st1], &work[givnum + - st1], &work[c__ + st1], &work[s + st1], &work[nwork], - &iwork[iwk], info); - if (*info != 0) { - return 0; - } - bxst = bx + st1; - dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & - work[bxst], n, &work[u + st1], n, &work[vt + st1], & - iwork[k + st1], &work[difl + st1], &work[difr + st1], - &work[z__ + st1], &work[poles + st1], &iwork[givptr + - st1], &iwork[givcol + st1], n, &iwork[perm + st1], & - work[givnum + st1], &work[c__ + st1], &work[s + st1], - &work[nwork], &iwork[iwk], info); - if (*info != 0) { - return 0; - } - } - st = i__ + 1; - } -/* L60: */ - } - -/* Apply the singular values and treat the tiny ones as zero. */ - - tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Some of the elements in D can be negative because 1-by-1 */ -/* subproblems were not solved explicitly. */ - - if ((d__1 = d__[i__], abs(d__1)) <= tol) { - dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n); - } else { - ++(*rank); - dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ - bx + i__ - 1], n, info); - } - d__[i__] = (d__1 = d__[i__], abs(d__1)); -/* L70: */ - } - -/* Now apply back the right singular vectors. */ - - icmpq2 = 1; - i__1 = nsub; - for (i__ = 1; i__ <= i__1; ++i__) { - st = iwork[i__]; - st1 = st - 1; - nsize = iwork[sizei + i__ - 1]; - bxst = bx + st1; - if (nsize == 1) { - dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); - } else if (nsize <= *smlsiz) { - dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, - &work[bxst], n, &c_b6, &b[st + b_dim1], ldb); - } else { - dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + - b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[ - k + st1], &work[difl + st1], &work[difr + st1], &work[z__ - + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ - givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], - &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[ - iwk], info); - if (*info != 0) { - return 0; - } - } -/* L80: */ - } - -/* Unscale and sort the singular values. */ - - dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info); - dlasrt_("D", n, &d__[1], info); - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, - info); - - return 0; - -/* End of DLALSD */ - -} /* dlalsd_ */ diff --git a/external/clapack/lapack/dlamch.cpp b/external/clapack/lapack/dlamch.cpp deleted file mode 100644 index 17c3a0fa..00000000 --- a/external/clapack/lapack/dlamch.cpp +++ /dev/null @@ -1,966 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b32 = 0.; - -double dlamch_(const char *cmach) -{ - /* Initialized data */ - - static bool first = true; - - /* System generated locals */ - integer i__1; - double ret_val; - - /* Local variables */ - static double t; - integer it; - static double rnd, eps, base; - integer beta; - static double emin, prec, emax; - integer imin, imax; - bool lrnd; - static double rmin, rmax; - double rmach; - - double small; - static double sfmin; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (first) { - dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); - base = (double) beta; - t = (double) it; - if (lrnd) { - rnd = 1.; - i__1 = 1 - it; - eps = pow_di(&base, &i__1) / 2; - } else { - rnd = 0.; - i__1 = 1 - it; - eps = pow_di(&base, &i__1); - } - prec = eps * base; - emin = (double) imin; - emax = (double) imax; - sfmin = rmin; - small = 1. / rmax; - if (small >= sfmin) { - -/* Use SMALL plus a bit, to avoid the possibility of rounding */ -/* causing overflow when computing 1/sfmin. */ - - sfmin = small * (eps + 1.); - } - } - - if (lsame_(cmach, "E")) { - rmach = eps; - } else if (lsame_(cmach, "S")) { - rmach = sfmin; - } else if (lsame_(cmach, "B")) { - rmach = base; - } else if (lsame_(cmach, "P")) { - rmach = prec; - } else if (lsame_(cmach, "N")) { - rmach = t; - } else if (lsame_(cmach, "R")) { - rmach = rnd; - } else if (lsame_(cmach, "M")) { - rmach = emin; - } else if (lsame_(cmach, "U")) { - rmach = rmin; - } else if (lsame_(cmach, "L")) { - rmach = emax; - } else if (lsame_(cmach, "O")) { - rmach = rmax; - } - - ret_val = rmach; - first = false; - return ret_val; - -/* End of DLAMCH */ - -} /* dlamch_ */ - - -/* *********************************************************************** */ - -/* Subroutine */ int dlamc1_(integer *beta, integer *t, bool *rnd, bool - *ieee1) -{ - /* Initialized data */ - - static bool first = true; - - /* System generated locals */ - double d__1, d__2; - - /* Local variables */ - double a, b, c__, f, t1, t2; - static integer lt; - double one, qtr; - static bool lrnd; - static integer lbeta; - double savec; - - static bool lieee1; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (first) { - 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 */ -L10: - if (c__ == one) { - a *= 2; - c__ = dlamc3_(&a, &one); - d__1 = -a; - c__ = dlamc3_(&c__, &d__1); - goto L10; - } -/* + 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 */ -L20: - if (c__ == a) { - b *= 2; - c__ = dlamc3_(&a, &b); - goto L20; - } -/* + 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__; - d__1 = -a; - c__ = dlamc3_(&c__, &d__1); - lbeta = (integer) (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 = (double) lbeta; - d__1 = b / 2; - d__2 = -b / 100; - f = dlamc3_(&d__1, &d__2); - c__ = dlamc3_(&f, &a); - if (c__ == a) { - lrnd = true; - } else { - lrnd = false; - } - d__1 = b / 2; - d__2 = b / 100; - f = dlamc3_(&d__1, &d__2); - c__ = dlamc3_(&f, &a); - if (lrnd && c__ == 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. */ - - d__1 = b / 2; - t1 = dlamc3_(&d__1, &a); - d__1 = b / 2; - t2 = dlamc3_(&d__1, &savec); - lieee1 = t1 == a && t2 > savec && 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 */ -L30: - if (c__ == one) { - ++lt; - a *= lbeta; - c__ = dlamc3_(&a, &one); - d__1 = -a; - c__ = dlamc3_(&c__, &d__1); - goto L30; - } -/* + END WHILE */ - - } - - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *ieee1 = lieee1; - first = false; - return 0; - -/* End of DLAMC1 */ - -} /* dlamc1_ */ - - -/* *********************************************************************** */ - -/* Subroutine */ int dlamc2_(integer *beta, integer *t, bool *rnd, - double *eps, integer *emin, double *rmin, integer *emax, - double *rmax) -{ - /* Initialized data */ - - static bool first = true; - static bool iwarn = false; - - /* System generated locals */ - integer i__1; - double d__1, d__2, d__3, d__4, d__5; - - /* Local variables */ - double a, b, c__; - integer i__; - static integer lt; - double one, two; - bool ieee; - double half; - bool lrnd; - static double leps; - double zero; - static integer lbeta; - double rbase; - static integer lemin, lemax; - integer gnmin; - double small; - integer gpmin; - double third; - static double lrmin, lrmax; - double sixth; - bool lieee1; - integer ngnmin, ngpmin; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (first) { - 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. */ - - dlamc1_(&lbeta, <, &lrnd, &lieee1); - -/* Start to find EPS. */ - - b = (double) lbeta; - i__1 = -lt; - a = pow_di(&b, &i__1); - leps = a; - -/* Try some tricks to see whether or not this is the correct EPS. */ - - b = two / 3; - half = one / 2; - d__1 = -half; - sixth = dlamc3_(&b, &d__1); - third = dlamc3_(&sixth, &sixth); - d__1 = -half; - b = dlamc3_(&third, &d__1); - b = dlamc3_(&b, &sixth); - b = abs(b); - if (b < leps) { - b = leps; - } - - leps = 1.; - -/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ -L10: - if (leps > b && b > zero) { - leps = b; - d__1 = half * leps; -/* Computing 5th power */ - d__3 = two, d__4 = d__3, d__3 *= d__3; -/* Computing 2nd power */ - d__5 = leps; - d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5); - c__ = dlamc3_(&d__1, &d__2); - d__1 = -c__; - c__ = dlamc3_(&half, &d__1); - b = dlamc3_(&half, &c__); - d__1 = -b; - c__ = dlamc3_(&half, &d__1); - b = dlamc3_(&half, &c__); - goto L10; - } -/* + END WHILE */ - - if (a < 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; - for (i__ = 1; i__ <= 3; ++i__) { - d__1 = small * rbase; - small = dlamc3_(&d__1, &zero); -/* L20: */ - } - a = dlamc3_(&one, &small); - dlamc4_(&ngpmin, &one, &lbeta); - d__1 = -one; - dlamc4_(&ngnmin, &d__1, &lbeta); - dlamc4_(&gpmin, &a, &lbeta); - d__1 = -a; - dlamc4_(&gnmin, &d__1, &lbeta); - ieee = false; - - if (ngpmin == ngnmin && gpmin == gnmin) { - if (ngpmin == gpmin) { - lemin = ngpmin; -/* ( Non twos-complement machines, no gradual underflow; */ -/* e.g., VAX ) */ - } else if (gpmin - ngpmin == 3) { - lemin = ngpmin - 1 + lt; - ieee = true; -/* ( Non twos-complement machines, with gradual underflow; */ -/* e.g., IEEE standard followers ) */ - } else { - lemin = std::min(ngpmin,gpmin); -/* ( A guess; no known machine ) */ - iwarn = true; - } - - } else if (ngpmin == gpmin && ngnmin == gnmin) { - if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { - lemin = std::max(ngpmin,ngnmin); -/* ( Twos-complement machines, no gradual underflow; */ -/* e.g., CYBER 205 ) */ - } else { - lemin = std::min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = true; - } - - } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) - { - if (gpmin - std::min(ngpmin,ngnmin) == 3) { - lemin = std::max(ngpmin,ngnmin) - 1 + lt; -/* ( Twos-complement machines with gradual underflow; */ -/* no known machine ) */ - } else { - lemin = std::min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = true; - } - - } else { -/* Computing MIN */ - i__1 = std::min(ngpmin,ngnmin), i__1 = std::min(i__1,gpmin); - lemin = std::min(i__1,gnmin); -/* ( A guess; no known machine ) */ - iwarn = true; - } - first = false; -/* ** */ -/* Comment out this if block if EMIN is ok */ - if (iwarn) { - first = true; - Melder_warning (U"DLAMC2 WARNING. The value EMIN may be incorrect:- ", lemin); - } -/* ** */ - -/* 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 || 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.; - i__1 = 1 - lemin; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = lrmin * rbase; - lrmin = dlamc3_(&d__1, &zero); -/* L30: */ - } - -/* Finally, call DLAMC5 to compute EMAX and RMAX. */ - - dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); - } - - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *eps = leps; - *emin = lemin; - *rmin = lrmin; - *emax = lemax; - *rmax = lrmax; - - return 0; - - -/* End of DLAMC2 */ - -} /* dlamc2_ */ - - -/* *********************************************************************** */ - -double dlamc3_(double *a, double *b) -{ - /* - FIX by Paul Boersma 20200418: - Some optimizers can optimize away the whole call to this function if ret_val is not declared volatile. - In case this function is optimized away, - the floating-point epsilon may be estimated (by dlamch) not as 2.2e-16 - but as 2048 times lower on i386 gcc (using an 80-bit register rather than a 64-bit memory position), - so that an iterative procedure used in our discriminant analysis did not converge on 32-bit Windows - and on 32-bit i386 Linux. - */ - volatile double ret_val; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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 (input) DOUBLE PRECISION */ -/* B (input) DOUBLE PRECISION */ -/* The values A and B. */ - -/* ===================================================================== */ - -/* .. Executable Statements .. */ - - ret_val = *a + *b; - - return ret_val; - -/* End of DLAMC3 */ - -} /* dlamc3_ */ - - -/* *********************************************************************** */ - -/* Subroutine */ int dlamc4_(integer *emin, double *start, integer *base) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - double a; - integer i__; - double b1, b2, c1, c2, d1, d2, one, zero, rbase; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAMC4 is a service routine for DLAMC2. */ - -/* Arguments */ -/* ========= */ - -/* EMIN (output) INTEGER */ -/* 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 .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - a = *start; - one = 1.; - rbase = one / *base; - zero = 0.; - *emin = 1; - d__1 = a * rbase; - b1 = dlamc3_(&d__1, &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 */ -L10: - if (c1 == a && c2 == a && d1 == a && d2 == a) { - --(*emin); - a = b1; - d__1 = a / *base; - b1 = dlamc3_(&d__1, &zero); - d__1 = b1 * *base; - c1 = dlamc3_(&d__1, &zero); - d1 = zero; - i__1 = *base; - for (i__ = 1; i__ <= i__1; ++i__) { - d1 += b1; -/* L20: */ - } - d__1 = a * rbase; - b2 = dlamc3_(&d__1, &zero); - d__1 = b2 / rbase; - c2 = dlamc3_(&d__1, &zero); - d2 = zero; - i__1 = *base; - for (i__ = 1; i__ <= i__1; ++i__) { - d2 += b2; -/* L30: */ - } - goto L10; - } -/* + END WHILE */ - - return 0; - -/* End of DLAMC4 */ - -} /* dlamc4_ */ - - -/* *********************************************************************** */ - -/* Subroutine */ int dlamc5_(integer *beta, integer *p, integer *emin, - bool *ieee, integer *emax, double *rmax) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer i__; - double y, z__; - integer try__, lexp; - double oldy; - integer uexp, nbits; - - double recbas; - integer exbits, expsum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. 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; -L10: - try__ = lexp << 1; - if (try__ <= -(*emin)) { - lexp = try__; - ++exbits; - goto L10; - } - if (lexp == -(*emin)) { - uexp = lexp; - } else { - uexp = try__; - ++exbits; - } - -/* 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 > -lexp - *emin) { - expsum = lexp << 1; - } else { - expsum = uexp << 1; - } - -/* EXPSUM is the exponent range, approximately equal to */ -/* EMAX - EMIN + 1 . */ - - *emax = expsum + *emin - 1; - nbits = exbits + 1 + *p; - -/* NBITS is the total number of bits needed to store a */ -/* floating-point number. */ - - if (nbits % 2 == 1 && *beta == 2) { - -/* 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); - } - - if (*ieee) { - -/* Assume we are on an IEEE machine which reserves one exponent */ -/* for infinity and NaN. */ - - --(*emax); - } - -/* 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 = 1. / *beta; - z__ = *beta - 1.; - y = 0.; - i__1 = *p; - for (i__ = 1; i__ <= i__1; ++i__) { - z__ *= recbas; - if (y < 1.) { - oldy = y; - } - y = dlamc3_(&y, &z__); -/* L20: */ - } - if (y >= 1.) { - y = oldy; - } - -/* Now multiply by BETA**EMAX to get RMAX. */ - - i__1 = *emax; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = y * *beta; - y = dlamc3_(&d__1, &c_b32); -/* L30: */ - } - - *rmax = y; - return 0; - -/* End of DLAMC5 */ - -} /* dlamc5_ */ diff --git a/external/clapack/lapack/dlamrg.cpp b/external/clapack/lapack/dlamrg.cpp deleted file mode 100644 index 9251fe64..00000000 --- a/external/clapack/lapack/dlamrg.cpp +++ /dev/null @@ -1,119 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlamrg_(integer *n1, integer *n2, double *a, integer - *dtrd1, integer *dtrd2, integer *index) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, ind1, ind2, n1sv, n2sv; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAMRG will create a permutation list which will merge the elements */ -/* of A (which is composed of two independently sorted sets) into a */ -/* single set which is sorted in ascending order. */ - -/* Arguments */ -/* ========= */ - -/* N1 (input) INTEGER */ -/* N2 (input) INTEGER */ -/* These arguements contain the respective lengths of the two */ -/* sorted lists to be merged. */ - -/* A (input) DOUBLE PRECISION array, dimension (N1+N2) */ -/* The first N1 elements of A contain a list of numbers which */ -/* are sorted in either ascending or descending order. Likewise */ -/* for the final N2 elements. */ - -/* DTRD1 (input) INTEGER */ -/* DTRD2 (input) INTEGER */ -/* These are the strides to be taken through the array A. */ -/* Allowable strides are 1 and -1. They indicate whether a */ -/* subset of A is sorted in ascending (DTRDx = 1) or descending */ -/* (DTRDx = -1) order. */ - -/* INDEX (output) INTEGER array, dimension (N1+N2) */ -/* On exit this array will contain a permutation such that */ -/* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be */ -/* sorted in ascending order. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --index; - --a; - - /* Function Body */ - n1sv = *n1; - n2sv = *n2; - if (*dtrd1 > 0) { - ind1 = 1; - } else { - ind1 = *n1; - } - if (*dtrd2 > 0) { - ind2 = *n1 + 1; - } else { - ind2 = *n1 + *n2; - } - i__ = 1; -/* while ( (N1SV > 0) & (N2SV > 0) ) */ -L10: - if (n1sv > 0 && n2sv > 0) { - if (a[ind1] <= a[ind2]) { - index[i__] = ind1; - ++i__; - ind1 += *dtrd1; - --n1sv; - } else { - index[i__] = ind2; - ++i__; - ind2 += *dtrd2; - --n2sv; - } - goto L10; - } -/* end while */ - if (n1sv == 0) { - i__1 = n2sv; - for (n1sv = 1; n1sv <= i__1; ++n1sv) { - index[i__] = ind2; - ++i__; - ind2 += *dtrd2; -/* L20: */ - } - } else { -/* N2SV .EQ. 0 */ - i__1 = n1sv; - for (n2sv = 1; n2sv <= i__1; ++n2sv) { - index[i__] = ind1; - ++i__; - ind1 += *dtrd1; -/* L30: */ - } - } - - return 0; - -/* End of DLAMRG */ - -} /* dlamrg_ */ diff --git a/external/clapack/lapack/dlaneg.cpp b/external/clapack/lapack/dlaneg.cpp deleted file mode 100644 index a6db6018..00000000 --- a/external/clapack/lapack/dlaneg.cpp +++ /dev/null @@ -1,206 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -integer dlaneg_(integer *n, double *d__, double *lld, double * - sigma, double *pivmin, integer *r__) -{ - /* System generated locals */ - integer ret_val, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer j; - double p, t; - integer bj; - double tmp; - integer neg1, neg2; - double bsav, gamma, dplus; - - integer negcnt; - bool sawnan; - double dminus; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANEG computes the Sturm count, the number of negative pivots */ -/* encountered while factoring tridiagonal T - sigma I = L D L^T. */ -/* This implementation works directly on the factors without forming */ -/* the tridiagonal matrix T. The Sturm count is also the number of */ -/* eigenvalues of T less than sigma. */ - -/* This routine is called from DLARRB. */ - -/* The current routine does not use the PIVMIN parameter but rather */ -/* requires IEEE-754 propagation of Infinities and NaNs. This */ -/* routine also has no input range restrictions but does require */ -/* default exception handling such that x/0 produces Inf when x is */ -/* non-zero, and Inf/Inf produces NaN. For more information, see: */ - -/* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in */ -/* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on */ -/* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 */ -/* (Tech report version in LAWN 172 with the same title.) */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The N diagonal elements of the diagonal matrix D. */ - -/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (N-1) elements L(i)*L(i)*D(i). */ - -/* SIGMA (input) DOUBLE PRECISION */ -/* Shift amount in T - sigma I = L D L^T. */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum pivot in the Sturm sequence. May be used */ -/* when zero pivots are encountered on non-IEEE-754 */ -/* architectures. */ - -/* R (input) INTEGER */ -/* The twist index for the twisted factorization that is used */ -/* for the negcount. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ -/* Jason Riedy, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* Some architectures propagate Infinities and NaNs very slowly, so */ -/* the code computes counts in BLKLEN chunks. Then a NaN can */ -/* propagate at most BLKLEN columns before being detected. This is */ -/* not a general tuning parameter; it needs only to be just large */ -/* enough that the overhead is tiny in common cases. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - --lld; - --d__; - - /* Function Body */ - negcnt = 0; -/* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T */ - t = -(*sigma); - i__1 = *r__ - 1; - for (bj = 1; bj <= i__1; bj += 128) { - neg1 = 0; - bsav = t; -/* Computing MIN */ - i__3 = bj + 127, i__4 = *r__ - 1; - i__2 = std::min(i__3,i__4); - for (j = bj; j <= i__2; ++j) { - dplus = d__[j] + t; - if (dplus < 0.) { - ++neg1; - } - tmp = t / dplus; - t = tmp * lld[j] - *sigma; -/* L21: */ - } - sawnan = disnan_(&t); -/* Run a slower version of the above loop if a NaN is detected. */ -/* A NaN should occur only with a zero pivot after an infinite */ -/* pivot. In that case, substituting 1 for T/DPLUS is the */ -/* correct limit. */ - if (sawnan) { - neg1 = 0; - t = bsav; -/* Computing MIN */ - i__3 = bj + 127, i__4 = *r__ - 1; - i__2 = std::min(i__3,i__4); - for (j = bj; j <= i__2; ++j) { - dplus = d__[j] + t; - if (dplus < 0.) { - ++neg1; - } - tmp = t / dplus; - if (disnan_(&tmp)) { - tmp = 1.; - } - t = tmp * lld[j] - *sigma; -/* L22: */ - } - } - negcnt += neg1; -/* L210: */ - } - -/* II) lower part: L D L^T - SIGMA I = U- D- U-^T */ - p = d__[*n] - *sigma; - i__1 = *r__; - for (bj = *n - 1; bj >= i__1; bj += -128) { - neg2 = 0; - bsav = p; -/* Computing MAX */ - i__3 = bj - 127; - i__2 = std::max(i__3,*r__); - for (j = bj; j >= i__2; --j) { - dminus = lld[j] + p; - if (dminus < 0.) { - ++neg2; - } - tmp = p / dminus; - p = tmp * d__[j] - *sigma; -/* L23: */ - } - sawnan = disnan_(&p); -/* As above, run a slower version that substitutes 1 for Inf/Inf. */ - - if (sawnan) { - neg2 = 0; - p = bsav; -/* Computing MAX */ - i__3 = bj - 127; - i__2 = std::max(i__3,*r__); - for (j = bj; j >= i__2; --j) { - dminus = lld[j] + p; - if (dminus < 0.) { - ++neg2; - } - tmp = p / dminus; - if (disnan_(&tmp)) { - tmp = 1.; - } - p = tmp * d__[j] - *sigma; -/* L24: */ - } - } - negcnt += neg2; -/* L230: */ - } - -/* III) Twist index */ -/* T was shifted by SIGMA initially. */ - gamma = t + *sigma + p; - if (gamma < 0.) { - ++negcnt; - } - ret_val = negcnt; - return ret_val; -} /* dlaneg_ */ diff --git a/external/clapack/lapack/dlangb.cpp b/external/clapack/lapack/dlangb.cpp deleted file mode 100644 index f7d4d151..00000000 --- a/external/clapack/lapack/dlangb.cpp +++ /dev/null @@ -1,210 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlangb_(const char *norm, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, double *work) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; - double ret_val, d__1, d__2, d__3; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__, j, k, l; - double sum, scale; - double value; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANGB returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of an */ -/* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */ - -/* Description */ -/* =========== */ - -/* DLANGB returns the value */ - -/* DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANGB as described */ -/* above. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANGB is */ -/* set to zero. */ - -/* KL (input) INTEGER */ -/* The number of sub-diagonals of the matrix A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of super-diagonals of the matrix A. KU >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ -/* column of A is stored in the j-th column of the array AB as */ -/* follows: */ -/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ -/* referenced. */ - -/* ===================================================================== */ - - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --work; - - /* Function Body */ - if (*n == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = *ku + 2 - j; -/* Computing MIN */ - i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; - i__3 = std::min(i__4,i__5); - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(d__1)) - ; - value = std::max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; -/* Computing MAX */ - i__3 = *ku + 2 - j; -/* Computing MIN */ - i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; - i__2 = std::min(i__4,i__5); - for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { - sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); -/* L30: */ - } - value = std::max(value,sum); -/* L40: */ - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L50: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - k = *ku + 1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *ku; -/* Computing MIN */ - i__5 = *n, i__6 = j + *kl; - i__4 = std::min(i__5,i__6); - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - work[i__] += (d__1 = ab[k + i__ + j * ab_dim1], abs(d__1)); -/* L60: */ - } -/* L70: */ - } - value = 0.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L80: */ - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__4 = 1, i__2 = j - *ku; - l = std::max(i__4,i__2); - k = *ku + 1 - j + l; -/* Computing MIN */ - i__2 = *n, i__3 = j + *kl; - i__4 = std::min(i__2,i__3) - l + 1; - dlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum); -/* L90: */ - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANGB */ - -} /* dlangb_ */ diff --git a/external/clapack/lapack/dlange.cpp b/external/clapack/lapack/dlange.cpp deleted file mode 100644 index b0345e0f..00000000 --- a/external/clapack/lapack/dlange.cpp +++ /dev/null @@ -1,184 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlange_(const char *norm, integer *m, integer *n, double *a, integer - *lda, double *work) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double ret_val, d__1, d__2, d__3; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__, j; - double sum, scale; - double value; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANGE returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* real matrix A. */ - -/* Description */ -/* =========== */ - -/* DLANGE returns the value */ - -/* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANGE as described */ -/* above. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. When M = 0, */ -/* DLANGE is set to zero. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. N >= 0. When N = 0, */ -/* DLANGE is set to zero. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The m by n matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(M,1). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ -/* referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - - /* Function Body */ - if (std::min(*m,*n) == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - value = std::max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L30: */ - } - value = std::max(value,sum); -/* L40: */ - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L50: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L60: */ - } -/* L70: */ - } - value = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L80: */ - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); -/* L90: */ - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANGE */ - -} /* dlange_ */ diff --git a/external/clapack/lapack/dlangt.cpp b/external/clapack/lapack/dlangt.cpp deleted file mode 100644 index 25bac24e..00000000 --- a/external/clapack/lapack/dlangt.cpp +++ /dev/null @@ -1,179 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlangt_(const char *norm, integer *n, double *dl, double *d__, - double *du) -{ - /* System generated locals */ - integer i__1; - double ret_val, d__1, d__2, d__3, d__4, d__5; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__; - double sum, scale; - double anorm; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANGT returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* real tridiagonal matrix A. */ - -/* Description */ -/* =========== */ - -/* DLANGT returns the value */ - -/* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANGT as described */ -/* above. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANGT is */ -/* set to zero. */ - -/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) sub-diagonal elements of A. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of A. */ - -/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) super-diagonal elements of A. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --du; - --d__; - --dl; - - /* Function Body */ - if (*n <= 0) { - anorm = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - anorm = (d__1 = d__[*n], abs(d__1)); - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__2 = anorm, d__3 = (d__1 = dl[i__], abs(d__1)); - anorm = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1)); - anorm = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = anorm, d__3 = (d__1 = du[i__], abs(d__1)); - anorm = std::max(d__2,d__3); -/* L10: */ - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - if (*n == 1) { - anorm = abs(d__[1]); - } else { -/* Computing MAX */ - d__3 = abs(d__[1]) + abs(dl[1]), d__4 = (d__1 = d__[*n], abs(d__1) - ) + (d__2 = du[*n - 1], abs(d__2)); - anorm = std::max(d__3,d__4); - i__1 = *n - 1; - for (i__ = 2; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = - dl[i__], abs(d__2)) + (d__3 = du[i__ - 1], abs(d__3)); - anorm = std::max(d__4,d__5); -/* L20: */ - } - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - if (*n == 1) { - anorm = abs(d__[1]); - } else { -/* Computing MAX */ - d__3 = abs(d__[1]) + abs(du[1]), d__4 = (d__1 = d__[*n], abs(d__1) - ) + (d__2 = dl[*n - 1], abs(d__2)); - anorm = std::max(d__3,d__4); - i__1 = *n - 1; - for (i__ = 2; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = - du[i__], abs(d__2)) + (d__3 = dl[i__ - 1], abs(d__3)); - anorm = std::max(d__4,d__5); -/* L30: */ - } - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - dlassq_(n, &d__[1], &c__1, &scale, &sum); - if (*n > 1) { - i__1 = *n - 1; - dlassq_(&i__1, &dl[1], &c__1, &scale, &sum); - i__1 = *n - 1; - dlassq_(&i__1, &du[1], &c__1, &scale, &sum); - } - anorm = scale * sqrt(sum); - } - - ret_val = anorm; - return ret_val; - -/* End of DLANGT */ - -} /* dlangt_ */ diff --git a/external/clapack/lapack/dlanhs.cpp b/external/clapack/lapack/dlanhs.cpp deleted file mode 100644 index baf143db..00000000 --- a/external/clapack/lapack/dlanhs.cpp +++ /dev/null @@ -1,186 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlanhs_(const char *norm, integer *n, double *a, integer *lda, - double *work) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - double ret_val, d__1, d__2, d__3; - - /* Local variables */ - integer i__, j; - double sum, scale; - double value; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANHS returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* Hessenberg matrix A. */ - -/* Description */ -/* =========== */ - -/* DLANHS returns the value */ - -/* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANHS as described */ -/* above. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANHS is */ -/* set to zero. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The n by n upper Hessenberg matrix A; the part of A below the */ -/* first sub-diagonal is not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(N,1). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ -/* referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - - /* Function Body */ - if (*n == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *n, i__4 = j + 1; - i__2 = std::min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - value = std::max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; -/* Computing MIN */ - i__3 = *n, i__4 = j + 1; - i__2 = std::min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L30: */ - } - value = std::max(value,sum); -/* L40: */ - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L50: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *n, i__4 = j + 1; - i__2 = std::min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L60: */ - } -/* L70: */ - } - value = 0.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L80: */ - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *n, i__4 = j + 1; - i__2 = std::min(i__3,i__4); - dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); -/* L90: */ - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANHS */ - -} /* dlanhs_ */ diff --git a/external/clapack/lapack/dlansb.cpp b/external/clapack/lapack/dlansb.cpp deleted file mode 100644 index bff40e16..00000000 --- a/external/clapack/lapack/dlansb.cpp +++ /dev/null @@ -1,244 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlansb_(const char *norm, const char *uplo, integer *n, integer *k, double - *ab, integer *ldab, double *work) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - double ret_val, d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, l; - double sum, absa, scale; - double value; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANSB returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of an */ -/* n by n symmetric band matrix A, with k super-diagonals. */ - -/* Description */ -/* =========== */ - -/* DLANSB returns the value */ - -/* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANSB as described */ -/* above. */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* band matrix A is supplied. */ -/* = 'U': Upper triangular part is supplied */ -/* = 'L': Lower triangular part is supplied */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANSB is */ -/* set to zero. */ - -/* K (input) INTEGER */ -/* The number of super-diagonals or sub-diagonals of the */ -/* band matrix A. K >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangle of the symmetric band matrix A, */ -/* stored in the first K+1 rows of AB. The j-th column of A is */ -/* stored in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= K+1. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ -/* WORK is not referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --work; - - /* Function Body */ - if (*n == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = *k + 2 - j; - i__3 = *k + 1; - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs( - d__1)); - value = std::max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *n + 1 - j, i__4 = *k + 1; - i__3 = std::min(i__2,i__4); - for (i__ = 1; i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs( - d__1)); - value = std::max(d__2,d__3); -/* L30: */ - } -/* L40: */ - } - } - } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { - -/* Find normI(A) ( = norm1(A), since A is symmetric). */ - - value = 0.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; - l = *k + 1 - j; -/* Computing MAX */ - i__3 = 1, i__2 = j - *k; - i__4 = j - 1; - for (i__ = std::max(i__3,i__2); i__ <= i__4; ++i__) { - absa = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1)); - sum += absa; - work[i__] += absa; -/* L50: */ - } - work[j] = sum + (d__1 = ab[*k + 1 + j * ab_dim1], abs(d__1)); -/* L60: */ - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L70: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L80: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = work[j] + (d__1 = ab[j * ab_dim1 + 1], abs(d__1)); - l = 1 - j; -/* Computing MIN */ - i__3 = *n, i__2 = j + *k; - i__4 = std::min(i__3,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - absa = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1)); - sum += absa; - work[i__] += absa; -/* L90: */ - } - value = std::max(value,sum); -/* L100: */ - } - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - if (*k > 0) { - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = j - 1; - i__4 = std::min(i__3,*k); -/* Computing MAX */ - i__2 = *k + 2 - j; - dlassq_(&i__4, &ab[std::max(i__2, 1_integer)+ j * ab_dim1], &c__1, & - scale, &sum); -/* L110: */ - } - l = *k + 1; - } else { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *n - j; - i__4 = std::min(i__3,*k); - dlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum); -/* L120: */ - } - l = 1; - } - sum *= 2; - } else { - l = 1; - } - dlassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum); - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANSB */ - -} /* dlansb_ */ diff --git a/external/clapack/lapack/dlansf.cpp b/external/clapack/lapack/dlansf.cpp deleted file mode 100644 index 3ebb7699..00000000 --- a/external/clapack/lapack/dlansf.cpp +++ /dev/null @@ -1,988 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlansf_(const char *norm, char *transr, char *uplo, integer *n, double *a, double *work) -{ - /* System generated locals */ - integer i__1, i__2; - double ret_val, d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k, l; - double s; - integer n1; - double aa; - integer lda, ifm, noe, ilu; - double scale; - double value; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANSF returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* real symmetric matrix A in RFP format. */ - -/* Description */ -/* =========== */ - -/* DLANSF returns the value */ - -/* DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER */ -/* Specifies the value to be returned in DLANSF as described */ -/* above. */ - -/* TRANSR (input) CHARACTER */ -/* Specifies whether the RFP format of A is normal or */ -/* transposed format. */ -/* = 'N': RFP format is Normal; */ -/* = 'T': RFP format is Transpose. */ - -/* UPLO (input) CHARACTER */ -/* On entry, UPLO specifies whether the RFP matrix A came from */ -/* an upper or lower triangular matrix as follows: */ -/* = 'U': RFP A came from an upper triangular matrix; */ -/* = 'L': RFP A came from a lower triangular matrix. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANSF is */ -/* set to zero. */ - -/* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); */ -/* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */ -/* part of the symmetric matrix A stored in RFP format. See the */ -/* "Notes" below for more details. */ -/* Unchanged on exit. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ -/* WORK is not referenced. */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* Reference */ -/* ========= */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (*n == 0) { - ret_val = 0.; - return ret_val; - } - -/* set noe = 1 if n is odd. if n is even set noe=0 */ - - noe = 1; - if (*n % 2 == 0) { - noe = 0; - } - -/* set ifm = 0 when form='T or 't' and 1 otherwise */ - - ifm = 1; - if (lsame_(transr, "T")) { - ifm = 0; - } - -/* set ilu = 0 when uplo='U or 'u' and 1 otherwise */ - - ilu = 1; - if (lsame_(uplo, "U")) { - ilu = 0; - } - -/* set lda = (n+1)/2 when ifm = 0 */ -/* set lda = n when ifm = 1 and noe = 1 */ -/* set lda = n+1 when ifm = 1 and noe = 0 */ - - if (ifm == 1) { - if (noe == 1) { - lda = *n; - } else { -/* noe=0 */ - lda = *n + 1; - } - } else { -/* ifm=0 */ - lda = (*n + 1) / 2; - } - - if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - k = (*n + 1) / 2; - value = 0.; - if (noe == 1) { -/* n is odd */ - if (ifm == 1) { -/* A is n by k */ - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = 0; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(d__1)); - value = std::max(d__2,d__3); - } - } - } else { -/* xpose case; A is k by n */ - i__1 = *n - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(d__1)); - value = std::max(d__2,d__3); - } - } - } - } else { -/* n is even */ - if (ifm == 1) { -/* A is n+1 by k */ - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 0; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(d__1)); - value = std::max(d__2,d__3); - } - } - } else { -/* xpose case; A is k by n+1 */ - i__1 = *n; - for (j = 0; j <= i__1; ++j) { - i__2 = k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(d__1)); - value = std::max(d__2,d__3); - } - } - } - } - } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { - -/* Find normI(A) ( = norm1(A), since A is symmetric). */ - - if (ifm == 1) { - k = *n / 2; - if (noe == 1) { -/* n is odd */ - if (ilu == 0) { - i__1 = k - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - work[i__] = 0.; - } - i__1 = k; - for (j = 0; j <= i__1; ++j) { - s = 0.; - i__2 = k + j - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(i,j+k) */ - s += aa; - work[i__] += aa; - } - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j+k,j+k) */ - work[j + k] = s + aa; - if (i__ == k + k) { - goto L10; - } - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j,j) */ - work[j] += aa; - s = 0.; - i__2 = k - 1; - for (l = j + 1; l <= i__2; ++l) { - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(l,j) */ - s += aa; - work[l] += aa; - } - work[j] += s; - } -L10: - i__ = idamax_(n, work, &c__1); - value = work[i__ - 1]; - } else { -/* ilu = 1 */ - ++k; -/* k=(n+1)/2 for n odd and ilu=1 */ - i__1 = *n - 1; - for (i__ = k; i__ <= i__1; ++i__) { - work[i__] = 0.; - } - for (j = k - 1; j >= 0; --j) { - s = 0.; - i__1 = j - 2; - for (i__ = 0; i__ <= i__1; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j+k,i+k) */ - s += aa; - work[i__ + k] += aa; - } - if (j > 0) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j+k,j+k) */ - s += aa; - work[i__ + k] += s; -/* i=j */ - ++i__; - } - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j,j) */ - work[j] = aa; - s = 0.; - i__1 = *n - 1; - for (l = j + 1; l <= i__1; ++l) { - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(l,j) */ - s += aa; - work[l] += aa; - } - work[j] += s; - } - i__ = idamax_(n, work, &c__1); - value = work[i__ - 1]; - } - } else { -/* n is even */ - if (ilu == 0) { - i__1 = k - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - work[i__] = 0.; - } - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - s = 0.; - i__2 = k + j - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(i,j+k) */ - s += aa; - work[i__] += aa; - } - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j+k,j+k) */ - work[j + k] = s + aa; - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j,j) */ - work[j] += aa; - s = 0.; - i__2 = k - 1; - for (l = j + 1; l <= i__2; ++l) { - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(l,j) */ - s += aa; - work[l] += aa; - } - work[j] += s; - } - i__ = idamax_(n, work, &c__1); - value = work[i__ - 1]; - } else { -/* ilu = 1 */ - i__1 = *n - 1; - for (i__ = k; i__ <= i__1; ++i__) { - work[i__] = 0.; - } - for (j = k - 1; j >= 0; --j) { - s = 0.; - i__1 = j - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j+k,i+k) */ - s += aa; - work[i__ + k] += aa; - } - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j+k,j+k) */ - s += aa; - work[i__ + k] += s; -/* i=j */ - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(j,j) */ - work[j] = aa; - s = 0.; - i__1 = *n - 1; - for (l = j + 1; l <= i__1; ++l) { - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* -> A(l,j) */ - s += aa; - work[l] += aa; - } - work[j] += s; - } - i__ = idamax_(n, work, &c__1); - value = work[i__ - 1]; - } - } - } else { -/* ifm=0 */ - k = *n / 2; - if (noe == 1) { -/* n is odd */ - if (ilu == 0) { - n1 = k; -/* n/2 */ - ++k; -/* k is the row size and lda */ - i__1 = *n - 1; - for (i__ = n1; i__ <= i__1; ++i__) { - work[i__] = 0.; - } - i__1 = n1 - 1; - for (j = 0; j <= i__1; ++j) { - s = 0.; - i__2 = k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j,n1+i) */ - work[i__ + n1] += aa; - s += aa; - } - work[j] = s; - } -/* j=n1=k-1 is special */ - s = (d__1 = a[j * lda], abs(d__1)); -/* A(k-1,k-1) */ - i__1 = k - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(k-1,i+n1) */ - work[i__ + n1] += aa; - s += aa; - } - work[j] += s; - i__1 = *n - 1; - for (j = k; j <= i__1; ++j) { - s = 0.; - i__2 = j - k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(i,j-k) */ - work[i__] += aa; - s += aa; - } -/* i=j-k */ - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j-k,j-k) */ - s += aa; - work[j - k] += s; - ++i__; - s = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j,j) */ - i__2 = *n - 1; - for (l = j + 1; l <= i__2; ++l) { - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j,l) */ - work[l] += aa; - s += aa; - } - work[j] += s; - } - i__ = idamax_(n, work, &c__1); - value = work[i__ - 1]; - } else { -/* ilu=1 */ - ++k; -/* k=(n+1)/2 for n odd and ilu=1 */ - i__1 = *n - 1; - for (i__ = k; i__ <= i__1; ++i__) { - work[i__] = 0.; - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { -/* process */ - s = 0.; - i__2 = j - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j,i) */ - work[i__] += aa; - s += aa; - } - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* i=j so process of A(j,j) */ - s += aa; - work[j] = s; -/* is initialised here */ - ++i__; -/* i=j process A(j+k,j+k) */ - aa = (d__1 = a[i__ + j * lda], abs(d__1)); - s = aa; - i__2 = *n - 1; - for (l = k + j + 1; l <= i__2; ++l) { - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(l,k+j) */ - s += aa; - work[l] += aa; - } - work[k + j] += s; - } -/* j=k-1 is special :process col A(k-1,0:k-1) */ - s = 0.; - i__1 = k - 2; - for (i__ = 0; i__ <= i__1; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(k,i) */ - work[i__] += aa; - s += aa; - } -/* i=k-1 */ - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(k-1,k-1) */ - s += aa; - work[i__] = s; -/* done with col j=k+1 */ - i__1 = *n - 1; - for (j = k; j <= i__1; ++j) { -/* process col j of A = A(j,0:k-1) */ - s = 0.; - i__2 = k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j,i) */ - work[i__] += aa; - s += aa; - } - work[j] += s; - } - i__ = idamax_(n, work, &c__1); - value = work[i__ - 1]; - } - } else { -/* n is even */ - if (ilu == 0) { - i__1 = *n - 1; - for (i__ = k; i__ <= i__1; ++i__) { - work[i__] = 0.; - } - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - s = 0.; - i__2 = k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j,i+k) */ - work[i__ + k] += aa; - s += aa; - } - work[j] = s; - } -/* j=k */ - aa = (d__1 = a[j * lda], abs(d__1)); -/* A(k,k) */ - s = aa; - i__1 = k - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(k,k+i) */ - work[i__ + k] += aa; - s += aa; - } - work[j] += s; - i__1 = *n - 1; - for (j = k + 1; j <= i__1; ++j) { - s = 0.; - i__2 = j - 2 - k; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(i,j-k-1) */ - work[i__] += aa; - s += aa; - } -/* i=j-1-k */ - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j-k-1,j-k-1) */ - s += aa; - work[j - k - 1] += s; - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j,j) */ - s = aa; - i__2 = *n - 1; - for (l = j + 1; l <= i__2; ++l) { - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j,l) */ - work[l] += aa; - s += aa; - } - work[j] += s; - } -/* j=n */ - s = 0.; - i__1 = k - 2; - for (i__ = 0; i__ <= i__1; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(i,k-1) */ - work[i__] += aa; - s += aa; - } -/* i=k-1 */ - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(k-1,k-1) */ - s += aa; - work[i__] += s; - i__ = idamax_(n, work, &c__1); - value = work[i__ - 1]; - } else { -/* ilu=1 */ - i__1 = *n - 1; - for (i__ = k; i__ <= i__1; ++i__) { - work[i__] = 0.; - } -/* j=0 is special :process col A(k:n-1,k) */ - s = abs(a[0]); -/* A(k,k) */ - i__1 = k - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - aa = (d__1 = a[i__], abs(d__1)); -/* A(k+i,k) */ - work[i__ + k] += aa; - s += aa; - } - work[k] += s; - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { -/* process */ - s = 0.; - i__2 = j - 2; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j-1,i) */ - work[i__] += aa; - s += aa; - } - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* i=j-1 so process of A(j-1,j-1) */ - s += aa; - work[j - 1] = s; -/* is initialised here */ - ++i__; -/* i=j process A(j+k,j+k) */ - aa = (d__1 = a[i__ + j * lda], abs(d__1)); - s = aa; - i__2 = *n - 1; - for (l = k + j + 1; l <= i__2; ++l) { - ++i__; - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(l,k+j) */ - s += aa; - work[l] += aa; - } - work[k + j] += s; - } -/* j=k is special :process col A(k,0:k-1) */ - s = 0.; - i__1 = k - 2; - for (i__ = 0; i__ <= i__1; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(k,i) */ - work[i__] += aa; - s += aa; - } -/* i=k-1 */ - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(k-1,k-1) */ - s += aa; - work[i__] = s; -/* done with col j=k+1 */ - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { -/* process col j-1 of A = A(j-1,0:k-1) */ - s = 0.; - i__2 = k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - aa = (d__1 = a[i__ + j * lda], abs(d__1)); -/* A(j-1,i) */ - work[i__] += aa; - s += aa; - } - work[j - 1] += s; - } - i__ = idamax_(n, work, &c__1); - value = work[i__ - 1]; - } - } - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - k = (*n + 1) / 2; - scale = 0.; - s = 1.; - if (noe == 1) { -/* n is odd */ - if (ifm == 1) { -/* A is normal */ - if (ilu == 0) { -/* A is upper */ - i__1 = k - 3; - for (j = 0; j <= i__1; ++j) { - i__2 = k - j - 2; - dlassq_(&i__2, &a[k + j + 1 + j * lda], &c__1, &scale, - &s); -/* L at A(k,0) */ - } - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = k + j - 1; - dlassq_(&i__2, &a[j * lda], &c__1, &scale, &s); -/* trap U at A(0,0) */ - } - s += s; -/* double s for the off diagonal elements */ - i__1 = k - 1; - i__2 = lda + 1; - dlassq_(&i__1, &a[k], &i__2, &scale, &s); -/* tri L at A(k,0) */ - i__1 = lda + 1; - dlassq_(&k, &a[k - 1], &i__1, &scale, &s); -/* tri U at A(k-1,0) */ - } else { -/* ilu=1 & A is lower */ - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - j - 1; - dlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s) - ; -/* trap L at A(0,0) */ - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - dlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s); -/* U at A(0,1) */ - } - s += s; -/* double s for the off diagonal elements */ - i__1 = lda + 1; - dlassq_(&k, a, &i__1, &scale, &s); -/* tri L at A(0,0) */ - i__1 = k - 1; - i__2 = lda + 1; - dlassq_(&i__1, &a[lda], &i__2, &scale, &s); -/* tri U at A(0,1) */ - } - } else { -/* A is xpose */ - if (ilu == 0) { -/* A' is upper */ - i__1 = k - 2; - for (j = 1; j <= i__1; ++j) { - dlassq_(&j, &a[(k + j) * lda], &c__1, &scale, &s); -/* U at A(0,k) */ - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - dlassq_(&k, &a[j * lda], &c__1, &scale, &s); -/* k by k-1 rect. at A(0,0) */ - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - i__2 = k - j - 1; - dlassq_(&i__2, &a[j + 1 + (j + k - 1) * lda], &c__1, & - scale, &s); -/* L at A(0,k-1) */ - } - s += s; -/* double s for the off diagonal elements */ - i__1 = k - 1; - i__2 = lda + 1; - dlassq_(&i__1, &a[k * lda], &i__2, &scale, &s); -/* tri U at A(0,k) */ - i__1 = lda + 1; - dlassq_(&k, &a[(k - 1) * lda], &i__1, &scale, &s); -/* tri L at A(0,k-1) */ - } else { -/* A' is lower */ - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - dlassq_(&j, &a[j * lda], &c__1, &scale, &s); -/* U at A(0,0) */ - } - i__1 = *n - 1; - for (j = k; j <= i__1; ++j) { - dlassq_(&k, &a[j * lda], &c__1, &scale, &s); -/* k by k-1 rect. at A(0,k) */ - } - i__1 = k - 3; - for (j = 0; j <= i__1; ++j) { - i__2 = k - j - 2; - dlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s) - ; -/* L at A(1,0) */ - } - s += s; -/* double s for the off diagonal elements */ - i__1 = lda + 1; - dlassq_(&k, a, &i__1, &scale, &s); -/* tri U at A(0,0) */ - i__1 = k - 1; - i__2 = lda + 1; - dlassq_(&i__1, &a[1], &i__2, &scale, &s); -/* tri L at A(1,0) */ - } - } - } else { -/* n is even */ - if (ifm == 1) { -/* A is normal */ - if (ilu == 0) { -/* A is upper */ - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - i__2 = k - j - 1; - dlassq_(&i__2, &a[k + j + 2 + j * lda], &c__1, &scale, - &s); -/* L at A(k+1,0) */ - } - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = k + j; - dlassq_(&i__2, &a[j * lda], &c__1, &scale, &s); -/* trap U at A(0,0) */ - } - s += s; -/* double s for the off diagonal elements */ - i__1 = lda + 1; - dlassq_(&k, &a[k + 1], &i__1, &scale, &s); -/* tri L at A(k+1,0) */ - i__1 = lda + 1; - dlassq_(&k, &a[k], &i__1, &scale, &s); -/* tri U at A(k,0) */ - } else { -/* ilu=1 & A is lower */ - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - j - 1; - dlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s) - ; -/* trap L at A(1,0) */ - } - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - dlassq_(&j, &a[j * lda], &c__1, &scale, &s); -/* U at A(0,0) */ - } - s += s; -/* double s for the off diagonal elements */ - i__1 = lda + 1; - dlassq_(&k, &a[1], &i__1, &scale, &s); -/* tri L at A(1,0) */ - i__1 = lda + 1; - dlassq_(&k, a, &i__1, &scale, &s); -/* tri U at A(0,0) */ - } - } else { -/* A is xpose */ - if (ilu == 0) { -/* A' is upper */ - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - dlassq_(&j, &a[(k + 1 + j) * lda], &c__1, &scale, &s); -/* U at A(0,k+1) */ - } - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - dlassq_(&k, &a[j * lda], &c__1, &scale, &s); -/* k by k rect. at A(0,0) */ - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - i__2 = k - j - 1; - dlassq_(&i__2, &a[j + 1 + (j + k) * lda], &c__1, & - scale, &s); -/* L at A(0,k) */ - } - s += s; -/* double s for the off diagonal elements */ - i__1 = lda + 1; - dlassq_(&k, &a[(k + 1) * lda], &i__1, &scale, &s); -/* tri U at A(0,k+1) */ - i__1 = lda + 1; - dlassq_(&k, &a[k * lda], &i__1, &scale, &s); -/* tri L at A(0,k) */ - } else { -/* A' is lower */ - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - dlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s); -/* U at A(0,1) */ - } - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { - dlassq_(&k, &a[j * lda], &c__1, &scale, &s); -/* k by k rect. at A(0,k+1) */ - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - i__2 = k - j - 1; - dlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s) - ; -/* L at A(0,0) */ - } - s += s; -/* double s for the off diagonal elements */ - i__1 = lda + 1; - dlassq_(&k, &a[lda], &i__1, &scale, &s); -/* tri L at A(0,1) */ - i__1 = lda + 1; - dlassq_(&k, a, &i__1, &scale, &s); -/* tri U at A(0,0) */ - } - } - } - value = scale * sqrt(s); - } - - ret_val = value; - return ret_val; - -/* End of DLANSF */ - -} /* dlansf_ */ diff --git a/external/clapack/lapack/dlansp.cpp b/external/clapack/lapack/dlansp.cpp deleted file mode 100644 index a6235d4f..00000000 --- a/external/clapack/lapack/dlansp.cpp +++ /dev/null @@ -1,244 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlansp_(const char *norm, const char *uplo, integer *n, double *ap, - double *work) -{ - /* System generated locals */ - integer i__1, i__2; - double ret_val, d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double sum, absa, scale; - double value; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANSP returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* real symmetric matrix A, supplied in packed form. */ - -/* Description */ -/* =========== */ - -/* DLANSP returns the value */ - -/* DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANSP as described */ -/* above. */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is supplied. */ -/* = 'U': Upper triangular part of A is supplied */ -/* = 'L': Lower triangular part of A is supplied */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANSP is */ -/* set to zero. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangle of the symmetric matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ -/* WORK is not referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --work; - --ap; - - /* Function Body */ - if (*n == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.; - if (lsame_(uplo, "U")) { - k = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = k + j - 1; - for (i__ = k; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); - value = std::max(d__2,d__3); -/* L10: */ - } - k += j; -/* L20: */ - } - } else { - k = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = k + *n - j; - for (i__ = k; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); - value = std::max(d__2,d__3); -/* L30: */ - } - k = k + *n - j + 1; -/* L40: */ - } - } - } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { - -/* Find normI(A) ( = norm1(A), since A is symmetric). */ - - value = 0.; - k = 1; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - absa = (d__1 = ap[k], abs(d__1)); - sum += absa; - work[i__] += absa; - ++k; -/* L50: */ - } - work[j] = sum + (d__1 = ap[k], abs(d__1)); - ++k; -/* L60: */ - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L70: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L80: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = work[j] + (d__1 = ap[k], abs(d__1)); - ++k; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - absa = (d__1 = ap[k], abs(d__1)); - sum += absa; - work[i__] += absa; - ++k; -/* L90: */ - } - value = std::max(value,sum); -/* L100: */ - } - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - k = 2; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - i__2 = j - 1; - dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); - k += j; -/* L110: */ - } - } else { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); - k = k + *n - j + 1; -/* L120: */ - } - } - sum *= 2; - k = 1; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (ap[k] != 0.) { - absa = (d__1 = ap[k], abs(d__1)); - if (scale < absa) { -/* Computing 2nd power */ - d__1 = scale / absa; - sum = sum * (d__1 * d__1) + 1.; - scale = absa; - } else { -/* Computing 2nd power */ - d__1 = absa / scale; - sum += d__1 * d__1; - } - } - if (lsame_(uplo, "U")) { - k = k + i__ + 1; - } else { - k = k + *n - i__ + 1; - } -/* L130: */ - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANSP */ - -} /* dlansp_ */ diff --git a/external/clapack/lapack/dlanst.cpp b/external/clapack/lapack/dlanst.cpp deleted file mode 100644 index f6ab376c..00000000 --- a/external/clapack/lapack/dlanst.cpp +++ /dev/null @@ -1,151 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlanst_(const char *norm, integer *n, double *d__, double *e) -{ - /* System generated locals */ - integer i__1; - double ret_val, d__1, d__2, d__3, d__4, d__5; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__; - double sum, scale; - double anorm; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANST returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* real symmetric tridiagonal matrix A. */ - -/* Description */ -/* =========== */ - -/* DLANST returns the value */ - -/* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANST as described */ -/* above. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANST is */ -/* set to zero. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of A. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) sub-diagonal or super-diagonal elements of A. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --e; - --d__; - - /* Function Body */ - if (*n <= 0) { - anorm = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - anorm = (d__1 = d__[*n], abs(d__1)); - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1)); - anorm = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = anorm, d__3 = (d__1 = e[i__], abs(d__1)); - anorm = std::max(d__2,d__3); -/* L10: */ - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1' || lsame_(norm, "I")) { - -/* Find norm1(A). */ - - if (*n == 1) { - anorm = abs(d__[1]); - } else { -/* Computing MAX */ - d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = e[*n - 1], abs( - d__1)) + (d__2 = d__[*n], abs(d__2)); - anorm = std::max(d__3,d__4); - i__1 = *n - 1; - for (i__ = 2; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[ - i__], abs(d__2)) + (d__3 = e[i__ - 1], abs(d__3)); - anorm = std::max(d__4,d__5); -/* L20: */ - } - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - if (*n > 1) { - i__1 = *n - 1; - dlassq_(&i__1, &e[1], &c__1, &scale, &sum); - sum *= 2; - } - dlassq_(n, &d__[1], &c__1, &scale, &sum); - anorm = scale * sqrt(sum); - } - - ret_val = anorm; - return ret_val; - -/* End of DLANST */ - -} /* dlanst_ */ diff --git a/external/clapack/lapack/dlansy.cpp b/external/clapack/lapack/dlansy.cpp deleted file mode 100644 index f873027c..00000000 --- a/external/clapack/lapack/dlansy.cpp +++ /dev/null @@ -1,224 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlansy_(const char *norm, const char *uplo, integer *n, double *a, integer - *lda, double *work) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double ret_val, d__1, d__2, d__3; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__, j; - double sum, absa, scale; - double value; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANSY returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* real symmetric matrix A. */ - -/* Description */ -/* =========== */ - -/* DLANSY returns the value */ - -/* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANSY as described */ -/* above. */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is to be referenced. */ -/* = 'U': Upper triangular part of A is referenced */ -/* = 'L': Lower triangular part of A is referenced */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANSY is */ -/* set to zero. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The symmetric matrix A. If UPLO = 'U', the leading n by n */ -/* upper triangular part of A contains the upper triangular part */ -/* of the matrix A, and the strictly lower triangular part of A */ -/* is not referenced. If UPLO = 'L', the leading n by n lower */ -/* triangular part of A contains the lower triangular part of */ -/* the matrix A, and the strictly upper triangular part of A is */ -/* not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(N,1). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ -/* WORK is not referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - - /* Function Body */ - if (*n == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = std::max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = std::max(d__2,d__3); -/* L30: */ - } -/* L40: */ - } - } - } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { - -/* Find normI(A) ( = norm1(A), since A is symmetric). */ - - value = 0.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - sum += absa; - work[i__] += absa; -/* L50: */ - } - work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1)); -/* L60: */ - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L70: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L80: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1)); - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - sum += absa; - work[i__] += absa; -/* L90: */ - } - value = std::max(value,sum); -/* L100: */ - } - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - i__2 = j - 1; - dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); -/* L110: */ - } - } else { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); -/* L120: */ - } - } - sum *= 2; - i__1 = *lda + 1; - dlassq_(n, &a[a_offset], &i__1, &scale, &sum); - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANSY */ - -} /* dlansy_ */ diff --git a/external/clapack/lapack/dlantb.cpp b/external/clapack/lapack/dlantb.cpp deleted file mode 100644 index fd1b9eef..00000000 --- a/external/clapack/lapack/dlantb.cpp +++ /dev/null @@ -1,416 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlantb_(const char *norm, const char *uplo, const char *diag, integer *n, integer *k, - double *ab, integer *ldab, double *work) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; - double ret_val, d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, l; - double sum, scale; - bool udiag; - double value; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANTB returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of an */ -/* n by n triangular band matrix A, with ( k + 1 ) diagonals. */ - -/* Description */ -/* =========== */ - -/* DLANTB returns the value */ - -/* DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANTB as described */ -/* above. */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANTB is */ -/* set to zero. */ - -/* K (input) INTEGER */ -/* The number of super-diagonals of the matrix A if UPLO = 'U', */ -/* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */ -/* K >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangular band matrix A, stored in the */ -/* first k+1 rows of AB. The j-th column of A is stored */ -/* in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */ -/* Note that when DIAG = 'U', the elements of the array AB */ -/* corresponding to the diagonal elements of the matrix A are */ -/* not referenced, but are assumed to be one. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= K+1. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ -/* referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --work; - - /* Function Body */ - if (*n == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - if (lsame_(diag, "U")) { - value = 1.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = *k + 2 - j; - i__3 = *k; - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], - abs(d__1)); - value = std::max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *n + 1 - j, i__4 = *k + 1; - i__3 = std::min(i__2,i__4); - for (i__ = 2; i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], - abs(d__1)); - value = std::max(d__2,d__3); -/* L30: */ - } -/* L40: */ - } - } - } else { - value = 0.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__3 = *k + 2 - j; - i__2 = *k + 1; - for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], - abs(d__1)); - value = std::max(d__2,d__3); -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *n + 1 - j, i__4 = *k + 1; - i__2 = std::min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], - abs(d__1)); - value = std::max(d__2,d__3); -/* L70: */ - } -/* L80: */ - } - } - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.; - udiag = lsame_(diag, "U"); - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (udiag) { - sum = 1.; -/* Computing MAX */ - i__2 = *k + 2 - j; - i__3 = *k; - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { - sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); -/* L90: */ - } - } else { - sum = 0.; -/* Computing MAX */ - i__3 = *k + 2 - j; - i__2 = *k + 1; - for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { - sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); -/* L100: */ - } - } - value = std::max(value,sum); -/* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (udiag) { - sum = 1.; -/* Computing MIN */ - i__3 = *n + 1 - j, i__4 = *k + 1; - i__2 = std::min(i__3,i__4); - for (i__ = 2; i__ <= i__2; ++i__) { - sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); -/* L120: */ - } - } else { - sum = 0.; -/* Computing MIN */ - i__3 = *n + 1 - j, i__4 = *k + 1; - i__2 = std::min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); -/* L130: */ - } - } - value = std::max(value,sum); -/* L140: */ - } - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - value = 0.; - if (lsame_(uplo, "U")) { - if (lsame_(diag, "U")) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 1.; -/* L150: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - l = *k + 1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs( - d__1)); -/* L160: */ - } -/* L170: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L180: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - l = *k + 1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j; - for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { - work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs( - d__1)); -/* L190: */ - } -/* L200: */ - } - } - } else { - if (lsame_(diag, "U")) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 1.; -/* L210: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = std::min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs( - d__1)); -/* L220: */ - } -/* L230: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L240: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = std::min(i__4,i__2); - for (i__ = j; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs( - d__1)); -/* L250: */ - } -/* L260: */ - } - } - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L270: */ - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - if (lsame_(uplo, "U")) { - if (lsame_(diag, "U")) { - scale = 1.; - sum = (double) (*n); - if (*k > 0) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing MIN */ - i__4 = j - 1; - i__3 = std::min(i__4,*k); -/* Computing MAX */ - i__2 = *k + 2 - j; - dlassq_(&i__3, &ab[std::max(i__2,1_integer)+ j * ab_dim1], &c__1, - &scale, &sum); -/* L280: */ - } - } - } else { - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__4 = j, i__2 = *k + 1; - i__3 = std::min(i__4,i__2); -/* Computing MAX */ - i__5 = *k + 2 - j; - dlassq_(&i__3, &ab[std::max(i__5,1_integer)+ j * ab_dim1], &c__1, & - scale, &sum); -/* L290: */ - } - } - } else { - if (lsame_(diag, "U")) { - scale = 1.; - sum = (double) (*n); - if (*k > 0) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__4 = *n - j; - i__3 = std::min(i__4,*k); - dlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, & - sum); -/* L300: */ - } - } - } else { - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__4 = *n - j + 1, i__2 = *k + 1; - i__3 = std::min(i__4,i__2); - dlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum); -/* L310: */ - } - } - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANTB */ - -} /* dlantb_ */ diff --git a/external/clapack/lapack/dlantp.cpp b/external/clapack/lapack/dlantp.cpp deleted file mode 100644 index 48fb4290..00000000 --- a/external/clapack/lapack/dlantp.cpp +++ /dev/null @@ -1,372 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlantp_(const char *norm, const char *uplo, const char *diag, integer *n, double - *ap, double *work) -{ - /* System generated locals */ - integer i__1, i__2; - double ret_val, d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double sum, scale; - bool udiag; - double value; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANTP returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* triangular matrix A, supplied in packed form. */ - -/* Description */ -/* =========== */ - -/* DLANTP returns the value */ - -/* DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANTP as described */ -/* above. */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. When N = 0, DLANTP is */ -/* set to zero. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangular matrix A, packed columnwise in */ -/* a linear array. The j-th column of A is stored in the array */ -/* AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ -/* Note that when DIAG = 'U', the elements of the array AP */ -/* corresponding to the diagonal elements of the matrix A are */ -/* not referenced, but are assumed to be one. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ -/* referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --work; - --ap; - - /* Function Body */ - if (*n == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - k = 1; - if (lsame_(diag, "U")) { - value = 1.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = k + j - 2; - for (i__ = k; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); - value = std::max(d__2,d__3); -/* L10: */ - } - k += j; -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = k + *n - j; - for (i__ = k + 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); - value = std::max(d__2,d__3); -/* L30: */ - } - k = k + *n - j + 1; -/* L40: */ - } - } - } else { - value = 0.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = k + j - 1; - for (i__ = k; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); - value = std::max(d__2,d__3); -/* L50: */ - } - k += j; -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = k + *n - j; - for (i__ = k; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); - value = std::max(d__2,d__3); -/* L70: */ - } - k = k + *n - j + 1; -/* L80: */ - } - } - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.; - k = 1; - udiag = lsame_(diag, "U"); - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (udiag) { - sum = 1.; - i__2 = k + j - 2; - for (i__ = k; i__ <= i__2; ++i__) { - sum += (d__1 = ap[i__], abs(d__1)); -/* L90: */ - } - } else { - sum = 0.; - i__2 = k + j - 1; - for (i__ = k; i__ <= i__2; ++i__) { - sum += (d__1 = ap[i__], abs(d__1)); -/* L100: */ - } - } - k += j; - value = std::max(value,sum); -/* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (udiag) { - sum = 1.; - i__2 = k + *n - j; - for (i__ = k + 1; i__ <= i__2; ++i__) { - sum += (d__1 = ap[i__], abs(d__1)); -/* L120: */ - } - } else { - sum = 0.; - i__2 = k + *n - j; - for (i__ = k; i__ <= i__2; ++i__) { - sum += (d__1 = ap[i__], abs(d__1)); -/* L130: */ - } - } - k = k + *n - j + 1; - value = std::max(value,sum); -/* L140: */ - } - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - k = 1; - if (lsame_(uplo, "U")) { - if (lsame_(diag, "U")) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 1.; -/* L150: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = ap[k], abs(d__1)); - ++k; -/* L160: */ - } - ++k; -/* L170: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L180: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = ap[k], abs(d__1)); - ++k; -/* L190: */ - } -/* L200: */ - } - } - } else { - if (lsame_(diag, "U")) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 1.; -/* L210: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - ++k; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = ap[k], abs(d__1)); - ++k; -/* L220: */ - } -/* L230: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L240: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - work[i__] += (d__1 = ap[k], abs(d__1)); - ++k; -/* L250: */ - } -/* L260: */ - } - } - } - value = 0.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L270: */ - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - if (lsame_(uplo, "U")) { - if (lsame_(diag, "U")) { - scale = 1.; - sum = (double) (*n); - k = 2; - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - i__2 = j - 1; - dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); - k += j; -/* L280: */ - } - } else { - scale = 0.; - sum = 1.; - k = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dlassq_(&j, &ap[k], &c__1, &scale, &sum); - k += j; -/* L290: */ - } - } - } else { - if (lsame_(diag, "U")) { - scale = 1.; - sum = (double) (*n); - k = 2; - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); - k = k + *n - j + 1; -/* L300: */ - } - } else { - scale = 0.; - sum = 1.; - k = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j + 1; - dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); - k = k + *n - j + 1; -/* L310: */ - } - } - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANTP */ - -} /* dlantp_ */ diff --git a/external/clapack/lapack/dlantr.cpp b/external/clapack/lapack/dlantr.cpp deleted file mode 100644 index f3f42354..00000000 --- a/external/clapack/lapack/dlantr.cpp +++ /dev/null @@ -1,380 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -double dlantr_(const char *norm, const char *uplo, const char *diag, integer *m, integer *n, - double *a, integer *lda, double *work) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - double ret_val, d__1, d__2, d__3; - - /* Local variables */ - integer i__, j; - double sum, scale; - bool udiag; - double value; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANTR returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* trapezoidal or triangular matrix A. */ - -/* Description */ -/* =========== */ - -/* DLANTR returns the value */ - -/* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANTR as described */ -/* above. */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower trapezoidal. */ -/* = 'U': Upper trapezoidal */ -/* = 'L': Lower trapezoidal */ -/* Note that A is triangular instead of trapezoidal if M = N. */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A has unit diagonal. */ -/* = 'N': Non-unit diagonal */ -/* = 'U': Unit diagonal */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0, and if */ -/* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. N >= 0, and if */ -/* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The trapezoidal matrix A (A is triangular if M = N). */ -/* If UPLO = 'U', the leading m by n upper trapezoidal part of */ -/* the array A contains the upper trapezoidal matrix, and the */ -/* strictly lower triangular part of A is not referenced. */ -/* If UPLO = 'L', the leading m by n lower trapezoidal part of */ -/* the array A contains the lower trapezoidal matrix, and the */ -/* strictly upper triangular part of A is not referenced. Note */ -/* that when DIAG = 'U', the diagonal elements of A are not */ -/* referenced and are assumed to be one. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(M,1). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ -/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ -/* referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - - /* Function Body */ - if (std::min(*m,*n) == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - if (lsame_(diag, "U")) { - value = 1.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *m, i__4 = j - 1; - i__2 = std::min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = std::max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = std::max(d__2,d__3); -/* L30: */ - } -/* L40: */ - } - } - } else { - value = 0.; - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = std::min(*m,j); - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = std::max(d__2,d__3); -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = std::max(d__2,d__3); -/* L70: */ - } -/* L80: */ - } - } - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.; - udiag = lsame_(diag, "U"); - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (udiag && j <= *m) { - sum = 1.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L90: */ - } - } else { - sum = 0.; - i__2 = std::min(*m,j); - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L100: */ - } - } - value = std::max(value,sum); -/* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (udiag) { - sum = 1.; - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L120: */ - } - } else { - sum = 0.; - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L130: */ - } - } - value = std::max(value,sum); -/* L140: */ - } - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - if (lsame_(uplo, "U")) { - if (lsame_(diag, "U")) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 1.; -/* L150: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *m, i__4 = j - 1; - i__2 = std::min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L160: */ - } -/* L170: */ - } - } else { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L180: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = std::min(*m,j); - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L190: */ - } -/* L200: */ - } - } - } else { - if (lsame_(diag, "U")) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 1.; -/* L210: */ - } - i__1 = *m; - for (i__ = *n + 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L220: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L230: */ - } -/* L240: */ - } - } else { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L250: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L260: */ - } -/* L270: */ - } - } - } - value = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = std::max(d__1,d__2); -/* L280: */ - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - if (lsame_(uplo, "U")) { - if (lsame_(diag, "U")) { - scale = 1.; - sum = (double) std::min(*m,*n); - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *m, i__4 = j - 1; - i__2 = std::min(i__3,i__4); - dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); -/* L290: */ - } - } else { - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = std::min(*m,j); - dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); -/* L300: */ - } - } - } else { - if (lsame_(diag, "U")) { - scale = 1.; - sum = (double) std::min(*m,*n); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m - j; -/* Computing MIN */ - i__3 = *m, i__4 = j + 1; - dlassq_(&i__2, &a[std::min(i__3, i__4)+ j * a_dim1], &c__1, & - scale, &sum); -/* L310: */ - } - } else { - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m - j + 1; - dlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum); -/* L320: */ - } - } - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANTR */ - -} /* dlantr_ */ diff --git a/external/clapack/lapack/dlanv2.cpp b/external/clapack/lapack/dlanv2.cpp deleted file mode 100644 index fb7a20e4..00000000 --- a/external/clapack/lapack/dlanv2.cpp +++ /dev/null @@ -1,223 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b4 = 1.; - -/* Subroutine */ int dlanv2_(double *a, double *b, double *c__, - double *d__, double *rt1r, double *rt1i, double *rt2r, - double *rt2i, double *cs, double *sn) -{ - /* System generated locals */ - double d__1, d__2; - - /* Builtin functions - double d_sign(double *, double *), sqrt(double); */ - - /* Local variables */ - double p, z__, aa, bb, cc, dd, cs1, sn1, sab, sac, eps, tau, temp, - scale, bcmax, bcmis, sigma; - - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric */ -/* matrix in standard form: */ - -/* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */ -/* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */ - -/* where either */ -/* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */ -/* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */ -/* conjugate eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* A (input/output) DOUBLE PRECISION */ -/* B (input/output) DOUBLE PRECISION */ -/* C (input/output) DOUBLE PRECISION */ -/* D (input/output) DOUBLE PRECISION */ -/* On entry, the elements of the input matrix. */ -/* On exit, they are overwritten by the elements of the */ -/* standardised Schur form. */ - -/* RT1R (output) DOUBLE PRECISION */ -/* RT1I (output) DOUBLE PRECISION */ -/* RT2R (output) DOUBLE PRECISION */ -/* RT2I (output) DOUBLE PRECISION */ -/* The real and imaginary parts of the eigenvalues. If the */ -/* eigenvalues are a complex conjugate pair, RT1I > 0. */ - -/* CS (output) DOUBLE PRECISION */ -/* SN (output) DOUBLE PRECISION */ -/* Parameters of the rotation matrix. */ - -/* Further Details */ -/* =============== */ - -/* Modified by V. Sima, Research Institute for Informatics, Bucharest, */ -/* Romania, to reduce the risk of cancellation errors, */ -/* when computing real eigenvalues, and to ensure, if possible, that */ -/* abs(RT1R) >= abs(RT2R). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - eps = dlamch_("P"); - if (*c__ == 0.) { - *cs = 1.; - *sn = 0.; - goto L10; - - } else if (*b == 0.) { - -/* Swap rows and columns */ - - *cs = 0.; - *sn = 1.; - temp = *d__; - *d__ = *a; - *a = temp; - *b = -(*c__); - *c__ = 0.; - goto L10; - } else if (*a - *d__ == 0. && d_sign(&c_b4, b) != d_sign(&c_b4, c__)) { - *cs = 1.; - *sn = 0.; - goto L10; - } else { - - temp = *a - *d__; - p = temp * .5; -/* Computing MAX */ - d__1 = abs(*b), d__2 = abs(*c__); - bcmax = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = abs(*b), d__2 = abs(*c__); - bcmis = std::min(d__1,d__2) * d_sign(&c_b4, b) * d_sign(&c_b4, c__); -/* Computing MAX */ - d__1 = abs(p); - scale = std::max(d__1,bcmax); - z__ = p / scale * p + bcmax / scale * bcmis; - -/* If Z is of the order of the machine accuracy, postpone the */ -/* decision on the nature of eigenvalues */ - - if (z__ >= eps * 4.) { - -/* Real eigenvalues. Compute A and D. */ - - d__1 = sqrt(scale) * sqrt(z__); - z__ = p + d_sign(&d__1, &p); - *a = *d__ + z__; - *d__ -= bcmax / z__ * bcmis; - -/* Compute B and the rotation matrix */ - - tau = dlapy2_(c__, &z__); - *cs = z__ / tau; - *sn = *c__ / tau; - *b -= *c__; - *c__ = 0.; - } else { - -/* Complex eigenvalues, or real (almost) equal eigenvalues. */ -/* Make diagonal elements equal. */ - - sigma = *b + *c__; - tau = dlapy2_(&sigma, &temp); - *cs = sqrt((abs(sigma) / tau + 1.) * .5); - *sn = -(p / (tau * *cs)) * d_sign(&c_b4, &sigma); - -/* Compute [ AA BB ] = [ A B ] [ CS -SN ] */ -/* [ CC DD ] [ C D ] [ SN CS ] */ - - aa = *a * *cs + *b * *sn; - bb = -(*a) * *sn + *b * *cs; - cc = *c__ * *cs + *d__ * *sn; - dd = -(*c__) * *sn + *d__ * *cs; - -/* Compute [ A B ] = [ CS SN ] [ AA BB ] */ -/* [ C D ] [-SN CS ] [ CC DD ] */ - - *a = aa * *cs + cc * *sn; - *b = bb * *cs + dd * *sn; - *c__ = -aa * *sn + cc * *cs; - *d__ = -bb * *sn + dd * *cs; - - temp = (*a + *d__) * .5; - *a = temp; - *d__ = temp; - - if (*c__ != 0.) { - if (*b != 0.) { - if (d_sign(&c_b4, b) == d_sign(&c_b4, c__)) { - -/* Real eigenvalues: reduce to upper triangular form */ - - sab = sqrt((abs(*b))); - sac = sqrt((abs(*c__))); - d__1 = sab * sac; - p = d_sign(&d__1, c__); - tau = 1. / sqrt((d__1 = *b + *c__, abs(d__1))); - *a = temp + p; - *d__ = temp - p; - *b -= *c__; - *c__ = 0.; - cs1 = sab * tau; - sn1 = sac * tau; - temp = *cs * cs1 - *sn * sn1; - *sn = *cs * sn1 + *sn * cs1; - *cs = temp; - } - } else { - *b = -(*c__); - *c__ = 0.; - temp = *cs; - *cs = -(*sn); - *sn = temp; - } - } - } - - } - -L10: - -/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */ - - *rt1r = *a; - *rt2r = *d__; - if (*c__ == 0.) { - *rt1i = 0.; - *rt2i = 0.; - } else { - *rt1i = sqrt((abs(*b))) * sqrt((abs(*c__))); - *rt2i = -(*rt1i); - } - return 0; - -/* End of DLANV2 */ - -} /* dlanv2_ */ diff --git a/external/clapack/lapack/dlapll.cpp b/external/clapack/lapack/dlapll.cpp deleted file mode 100644 index 1c1a9c85..00000000 --- a/external/clapack/lapack/dlapll.cpp +++ /dev/null @@ -1,107 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlapll_(integer *n, double *x, integer *incx, - double *y, integer *incy, double *ssmin) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - double c__, a11, a12, a22, tau; - double ssmax; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Given two column vectors X and Y, let */ - -/* A = ( X Y ). */ - -/* The subroutine first computes the QR factorization of A = Q*R, */ -/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */ -/* The smaller singular value of R is returned in SSMIN, which is used */ -/* as the measurement of the linear dependency of the vectors X and Y. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The length of the vectors X and Y. */ - -/* X (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCX) */ -/* On entry, X contains the N-vector X. */ -/* On exit, X is overwritten. */ - -/* INCX (input) INTEGER */ -/* The increment between successive elements of X. INCX > 0. */ - -/* Y (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCY) */ -/* On entry, Y contains the N-vector Y. */ -/* On exit, Y is overwritten. */ - -/* INCY (input) INTEGER */ -/* The increment between successive elements of Y. INCY > 0. */ - -/* SSMIN (output) DOUBLE PRECISION */ -/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - --y; - --x; - - /* Function Body */ - if (*n <= 1) { - *ssmin = 0.; - return 0; - } - -/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */ - - dlarfg_(n, &x[1], &x[*incx + 1], incx, &tau); - a11 = x[1]; - x[1] = 1.; - - c__ = -tau * ddot_(n, &x[1], incx, &y[1], incy); - daxpy_(n, &c__, &x[1], incx, &y[1], incy); - - i__1 = *n - 1; - dlarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau); - - a12 = y[1]; - a22 = y[*incy + 1]; - -/* Compute the SVD of 2-by-2 Upper triangular matrix. */ - - dlas2_(&a11, &a12, &a22, ssmin, &ssmax); - - return 0; - -/* End of DLAPLL */ - -} /* dlapll_ */ diff --git a/external/clapack/lapack/dlapmt.cpp b/external/clapack/lapack/dlapmt.cpp deleted file mode 100644 index cfaf9723..00000000 --- a/external/clapack/lapack/dlapmt.cpp +++ /dev/null @@ -1,166 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlapmt_(bool *forwrd, integer *m, integer *n, - double *x, integer *ldx, integer *k) -{ - /* System generated locals */ - integer x_dim1, x_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, ii, in; - double temp; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAPMT rearranges the columns of the M by N matrix X as specified */ -/* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. */ -/* If FORWRD = .TRUE., forward permutation: */ - -/* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. */ - -/* If FORWRD = .FALSE., backward permutation: */ - -/* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. */ - -/* Arguments */ -/* ========= */ - -/* FORWRD (input) LOGICAL */ -/* = .TRUE., forward permutation */ -/* = .FALSE., backward permutation */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix X. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix X. N >= 0. */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */ -/* On entry, the M by N matrix X. */ -/* On exit, X contains the permuted matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X, LDX >= MAX(1,M). */ - -/* K (input/output) INTEGER array, dimension (N) */ -/* On entry, K contains the permutation vector. K is used as */ -/* internal workspace, but reset to its original value on */ -/* output. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --k; - - /* Function Body */ - if (*n <= 1) { - return 0; - } - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - k[i__] = -k[i__]; -/* L10: */ - } - - if (*forwrd) { - -/* Forward permutation */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - - if (k[i__] > 0) { - goto L40; - } - - j = i__; - k[j] = -k[j]; - in = k[j]; - -L20: - if (k[in] > 0) { - goto L40; - } - - i__2 = *m; - for (ii = 1; ii <= i__2; ++ii) { - temp = x[ii + j * x_dim1]; - x[ii + j * x_dim1] = x[ii + in * x_dim1]; - x[ii + in * x_dim1] = temp; -/* L30: */ - } - - k[in] = -k[in]; - j = in; - in = k[in]; - goto L20; - -L40: - -/* L50: */ - ; - } - - } else { - -/* Backward permutation */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - - if (k[i__] > 0) { - goto L80; - } - - k[i__] = -k[i__]; - j = k[i__]; -L60: - if (j == i__) { - goto L80; - } - - i__2 = *m; - for (ii = 1; ii <= i__2; ++ii) { - temp = x[ii + i__ * x_dim1]; - x[ii + i__ * x_dim1] = x[ii + j * x_dim1]; - x[ii + j * x_dim1] = temp; -/* L70: */ - } - - k[j] = -k[j]; - j = k[j]; - goto L60; - -L80: - -/* L90: */ - ; - } - - } - - return 0; - -/* End of DLAPMT */ - -} /* dlapmt_ */ diff --git a/external/clapack/lapack/dlapy2.cpp b/external/clapack/lapack/dlapy2.cpp deleted file mode 100644 index fcf19e6e..00000000 --- a/external/clapack/lapack/dlapy2.cpp +++ /dev/null @@ -1,61 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -double dlapy2_(double *x, double *y) -{ - /* System generated locals */ - double ret_val, d__1; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - double w, z__, xabs, yabs; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - xabs = abs(*x); - yabs = abs(*y); - w = std::max(xabs,yabs); - z__ = std::min(xabs,yabs); - if (z__ == 0.) { - ret_val = w; - } else { -/* Computing 2nd power */ - d__1 = z__ / w; - ret_val = w * sqrt(d__1 * d__1 + 1.); - } - return ret_val; - -/* End of DLAPY2 */ - -} /* dlapy2_ */ diff --git a/external/clapack/lapack/dlapy3.cpp b/external/clapack/lapack/dlapy3.cpp deleted file mode 100644 index 99ae8096..00000000 --- a/external/clapack/lapack/dlapy3.cpp +++ /dev/null @@ -1,71 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -double dlapy3_(double *x, double *y, double *z__) -{ - /* System generated locals */ - double ret_val, d__1, d__2, d__3; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - double w, xabs, yabs, zabs; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - xabs = abs(*x); - yabs = abs(*y); - zabs = abs(*z__); -/* Computing MAX */ - d__1 = std::max(xabs,yabs); - w = std::max(d__1,zabs); - if (w == 0.) { -/* W can be zero for max(0_integer,nan,0) */ -/* adding all three entries together will make sure */ -/* NaN will not disappear. */ - ret_val = xabs + yabs + zabs; - } else { -/* Computing 2nd power */ - d__1 = xabs / w; -/* Computing 2nd power */ - d__2 = yabs / w; -/* Computing 2nd power */ - d__3 = zabs / w; - ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); - } - return ret_val; - -/* End of DLAPY3 */ - -} /* dlapy3_ */ diff --git a/external/clapack/lapack/dlaqgb.cpp b/external/clapack/lapack/dlaqgb.cpp deleted file mode 100644 index 3c6ab3b4..00000000 --- a/external/clapack/lapack/dlaqgb.cpp +++ /dev/null @@ -1,204 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaqgb_(integer *m, integer *n, integer *kl, integer *ku, - double *ab, integer *ldab, double *r__, double *c__, - double *rowcnd, double *colcnd, double *amax, char *equed) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; - - /* Local variables */ - integer i__, j; - double cj, large, small; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQGB equilibrates a general M by N band matrix A with KL */ -/* subdiagonals and KU superdiagonals using the row and scaling factors */ -/* in the vectors R and C. */ - -/* 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. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ -/* The j-th column of A is stored in the j-th column of the */ -/* array AB as follows: */ -/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */ - -/* On exit, the equilibrated matrix, in the same storage format */ -/* as A. See EQUED for the form of the equilibrated matrix. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDA >= KL+KU+1. */ - -/* R (input) DOUBLE PRECISION array, dimension (M) */ -/* The row scale factors for A. */ - -/* C (input) DOUBLE PRECISION array, dimension (N) */ -/* The column scale factors for A. */ - -/* ROWCND (input) DOUBLE PRECISION */ -/* Ratio of the smallest R(i) to the largest R(i). */ - -/* COLCND (input) DOUBLE PRECISION */ -/* Ratio of the smallest C(i) to the largest C(i). */ - -/* AMAX (input) DOUBLE PRECISION */ -/* Absolute value of largest matrix entry. */ - -/* EQUED (output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration */ -/* = 'R': Row equilibration, i.e., A has been premultiplied by */ -/* diag(R). */ -/* = 'C': Column equilibration, i.e., A has been postmultiplied */ -/* by diag(C). */ -/* = 'B': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(R) * A * diag(C). */ - -/* Internal Parameters */ -/* =================== */ - -/* THRESH is a threshold value used to decide if row or column scaling */ -/* should be done based on the ratio of the row or column scaling */ -/* factors. If ROWCND < THRESH, row scaling is done, and if */ -/* COLCND < THRESH, column scaling is done. */ - -/* LARGE and SMALL are threshold values used to decide if row scaling */ -/* should be done based on the absolute size of the largest matrix */ -/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --r__; - --c__; - - /* Function Body */ - if (*m <= 0 || *n <= 0) { - *(unsigned char *)equed = 'N'; - return 0; - } - -/* Initialize LARGE and SMALL. */ - - small = dlamch_("Safe minimum") / dlamch_("Precision"); - large = 1. / small; - - if (*rowcnd >= .1 && *amax >= small && *amax <= large) { - -/* No row scaling */ - - if (*colcnd >= .1) { - -/* No column scaling */ - - *(unsigned char *)equed = 'N'; - } else { - -/* Column scaling */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = c__[j]; -/* Computing MAX */ - i__2 = 1, i__3 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__4 = std::min(i__5,i__6); - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * ab[*ku + 1 + - i__ - j + j * ab_dim1]; -/* L10: */ - } -/* L20: */ - } - *(unsigned char *)equed = 'C'; - } - } else if (*colcnd >= .1) { - -/* Row scaling, no column scaling */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__4 = 1, i__2 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__3 = std::min(i__5,i__6); - for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { - ab[*ku + 1 + i__ - j + j * ab_dim1] = r__[i__] * ab[*ku + 1 + - i__ - j + j * ab_dim1]; -/* L30: */ - } -/* L40: */ - } - *(unsigned char *)equed = 'R'; - } else { - -/* Row and column scaling */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = c__[j]; -/* Computing MAX */ - i__3 = 1, i__4 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__2 = std::min(i__5,i__6); - for (i__ = std::max(i__3,i__4); i__ <= i__2; ++i__) { - ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * r__[i__] * ab[*ku - + 1 + i__ - j + j * ab_dim1]; -/* L50: */ - } -/* L60: */ - } - *(unsigned char *)equed = 'B'; - } - - return 0; - -/* End of DLAQGB */ - -} /* dlaqgb_ */ diff --git a/external/clapack/lapack/dlaqge.cpp b/external/clapack/lapack/dlaqge.cpp deleted file mode 100644 index 2d4dd3c0..00000000 --- a/external/clapack/lapack/dlaqge.cpp +++ /dev/null @@ -1,176 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaqge_(integer *m, integer *n, double *a, integer * - lda, double *r__, double *c__, double *rowcnd, double - *colcnd, double *amax, char *equed) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - double cj, large, small; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQGE equilibrates a general M by N matrix A using the row and */ -/* column scaling factors in the vectors R and C. */ - -/* 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 equilibrated matrix. See EQUED for the form of */ -/* the equilibrated matrix. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(M,1). */ - -/* R (input) DOUBLE PRECISION array, dimension (M) */ -/* The row scale factors for A. */ - -/* C (input) DOUBLE PRECISION array, dimension (N) */ -/* The column scale factors for A. */ - -/* ROWCND (input) DOUBLE PRECISION */ -/* Ratio of the smallest R(i) to the largest R(i). */ - -/* COLCND (input) DOUBLE PRECISION */ -/* Ratio of the smallest C(i) to the largest C(i). */ - -/* AMAX (input) DOUBLE PRECISION */ -/* Absolute value of largest matrix entry. */ - -/* EQUED (output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration */ -/* = 'R': Row equilibration, i.e., A has been premultiplied by */ -/* diag(R). */ -/* = 'C': Column equilibration, i.e., A has been postmultiplied */ -/* by diag(C). */ -/* = 'B': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(R) * A * diag(C). */ - -/* Internal Parameters */ -/* =================== */ - -/* THRESH is a threshold value used to decide if row or column scaling */ -/* should be done based on the ratio of the row or column scaling */ -/* factors. If ROWCND < THRESH, row scaling is done, and if */ -/* COLCND < THRESH, column scaling is done. */ - -/* LARGE and SMALL are threshold values used to decide if row scaling */ -/* should be done based on the absolute size of the largest matrix */ -/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --r__; - --c__; - - /* Function Body */ - if (*m <= 0 || *n <= 0) { - *(unsigned char *)equed = 'N'; - return 0; - } - -/* Initialize LARGE and SMALL. */ - - small = dlamch_("Safe minimum") / dlamch_("Precision"); - large = 1. / small; - - if (*rowcnd >= .1 && *amax >= small && *amax <= large) { - -/* No row scaling */ - - if (*colcnd >= .1) { - -/* No column scaling */ - - *(unsigned char *)equed = 'N'; - } else { - -/* Column scaling */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = c__[j]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = cj * a[i__ + j * a_dim1]; -/* L10: */ - } -/* L20: */ - } - *(unsigned char *)equed = 'C'; - } - } else if (*colcnd >= .1) { - -/* Row scaling, no column scaling */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = r__[i__] * a[i__ + j * a_dim1]; -/* L30: */ - } -/* L40: */ - } - *(unsigned char *)equed = 'R'; - } else { - -/* Row and column scaling */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = c__[j]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = cj * r__[i__] * a[i__ + j * a_dim1]; -/* L50: */ - } -/* L60: */ - } - *(unsigned char *)equed = 'B'; - } - - return 0; - -/* End of DLAQGE */ - -} /* dlaqge_ */ diff --git a/external/clapack/lapack/dlaqp2.cpp b/external/clapack/lapack/dlaqp2.cpp deleted file mode 100644 index 591dc492..00000000 --- a/external/clapack/lapack/dlaqp2.cpp +++ /dev/null @@ -1,212 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -int dlaqp2_(integer *m, integer *n, integer *offset, - double *a, integer *lda, integer *jpvt, double *tau, - double *vn1, double *vn2, double *work) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1, d__2; - - /* Local variables */ - integer i__, j, mn; - double aii; - integer pvt; - double temp; - double temp2, tol3z; - integer offpi, itemp; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQP2 computes a QR factorization with column pivoting of */ -/* the block A(OFFSET+1:M,1:N). */ -/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ - -/* 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. */ - -/* OFFSET (input) INTEGER */ -/* The number of rows of the matrix A that must be pivoted */ -/* but no factorized. OFFSET >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */ -/* the triangular factor obtained; the elements in block */ -/* A(OFFSET+1:M,1:N) below the diagonal, together with the */ -/* array TAU, represent the orthogonal matrix Q as a product of */ -/* elementary reflectors. Block A(1:OFFSET,1:N) has been */ -/* accordingly pivoted, but no factorized. */ - -/* 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. */ - -/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */ -/* The vector with the partial column norms. */ - -/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */ -/* The vector with the exact column norms. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ -/* X. Sun, Computer Science Dept., Duke University, USA */ - -/* Partial column norm updating strategy modified by */ -/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ -/* University of Zagreb, Croatia. */ -/* June 2006. */ -/* For more details see LAPACK Working Note 176. */ -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --jpvt; - --tau; - --vn1; - --vn2; - --work; - - /* Function Body */ -/* Computing MIN */ - i__1 = *m - *offset; - mn = std::min(i__1,*n); - tol3z = sqrt(dlamch_("Epsilon")); - -/* Compute factorization. */ - - i__1 = mn; - for (i__ = 1; i__ <= i__1; ++i__) { - - offpi = *offset + i__; - -/* Determine ith pivot column and swap if necessary. */ - - i__2 = *n - i__ + 1; - pvt = i__ - 1 + idamax_(&i__2, &vn1[i__], &c__1); - - if (pvt != i__) { - dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & - c__1); - itemp = jpvt[pvt]; - jpvt[pvt] = jpvt[i__]; - jpvt[i__] = itemp; - vn1[pvt] = vn1[i__]; - vn2[pvt] = vn2[i__]; - } - -/* Generate elementary reflector H(i). */ - - if (offpi < *m) { - i__2 = *m - offpi + 1; - dlarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ * - a_dim1], &c__1, &tau[i__]); - } else { - dlarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], & - c__1, &tau[i__]); - } - - if (i__ <= *n) { - -/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */ - - aii = a[offpi + i__ * a_dim1]; - a[offpi + i__ * a_dim1] = 1.; - i__2 = *m - offpi + 1; - i__3 = *n - i__; - dlarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, & - tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]); - a[offpi + i__ * a_dim1] = aii; - } - -/* Update partial column norms. */ - - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - if (vn1[j] != 0.) { - -/* NOTE: The following 4 lines follow from the analysis in */ -/* Lapack Working Note 176. */ - -/* Computing 2nd power */ - d__2 = (d__1 = a[offpi + j * a_dim1], abs(d__1)) / vn1[j]; - temp = 1. - d__2 * d__2; - temp = std::max(temp,0.); -/* Computing 2nd power */ - d__1 = vn1[j] / vn2[j]; - temp2 = temp * (d__1 * d__1); - if (temp2 <= tol3z) { - if (offpi < *m) { - i__3 = *m - offpi; - vn1[j] = dnrm2_(&i__3, &a[offpi + 1 + j * a_dim1], & - c__1); - vn2[j] = vn1[j]; - } else { - vn1[j] = 0.; - vn2[j] = 0.; - } - } else { - vn1[j] *= sqrt(temp); - } - } -/* L10: */ - } - -/* L20: */ - } - - return 0; - -/* End of DLAQP2 */ - -} /* dlaqp2_ */ diff --git a/external/clapack/lapack/dlaqps.cpp b/external/clapack/lapack/dlaqps.cpp deleted file mode 100644 index 9fe0ab55..00000000 --- a/external/clapack/lapack/dlaqps.cpp +++ /dev/null @@ -1,316 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b8 = -1.; -static double c_b9 = 1.; -static double c_b16 = 0.; - -int dlaqps_(integer *m, integer *n, integer *offset, integer - *nb, integer *kb, double *a, integer *lda, integer *jpvt, - double *tau, double *vn1, double *vn2, double *auxv, - double *f, integer *ldf) -{ - /* System generated locals */ - integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer j, k, rk; - double akk; - integer pvt; - double temp; - double temp2, tol3z; - integer itemp; - integer lsticc, lastrk; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQPS computes a step of QR factorization with column pivoting */ -/* of a real M-by-N matrix A by using Blas-3. It tries to factorize */ -/* NB columns from A starting from the row OFFSET+1, and updates all */ -/* of the matrix with Blas-3 xGEMM. */ - -/* In some cases, due to catastrophic cancellations, it cannot */ -/* factorize NB columns. Hence, the actual number of factorized */ -/* columns is returned in KB. */ - -/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ - -/* 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 */ - -/* OFFSET (input) INTEGER */ -/* The number of rows of A that have been factorized in */ -/* previous steps. */ - -/* NB (input) INTEGER */ -/* The number of columns to factorize. */ - -/* KB (output) INTEGER */ -/* The number of columns actually factorized. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */ -/* factor obtained and block A(1:OFFSET,1:N) has been */ -/* accordingly pivoted, but no factorized. */ -/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */ -/* been updated. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* JPVT (input/output) INTEGER array, dimension (N) */ -/* JPVT(I) = K <==> Column K of the full matrix A has been */ -/* permuted into position I in AP. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (KB) */ -/* The scalar factors of the elementary reflectors. */ - -/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */ -/* The vector with the partial column norms. */ - -/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */ -/* The vector with the exact column norms. */ - -/* AUXV (input/output) DOUBLE PRECISION array, dimension (NB) */ -/* Auxiliar vector. */ - -/* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB) */ -/* Matrix F' = L*Y'*A. */ - -/* LDF (input) INTEGER */ -/* The leading dimension of the array F. LDF >= max(1,N). */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ -/* X. Sun, Computer Science Dept., Duke University, USA */ - -/* Partial column norm updating strategy modified by */ -/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ -/* University of Zagreb, Croatia. */ -/* June 2006. */ -/* For more details see LAPACK Working Note 176. */ -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --jpvt; - --tau; - --vn1; - --vn2; - --auxv; - f_dim1 = *ldf; - f_offset = 1 + f_dim1; - f -= f_offset; - - /* Function Body */ -/* Computing MIN */ - i__1 = *m, i__2 = *n + *offset; - lastrk = std::min(i__1,i__2); - lsticc = 0; - k = 0; - tol3z = sqrt(dlamch_("Epsilon")); - -/* Beginning of while loop. */ - -L10: - if (k < *nb && lsticc == 0) { - ++k; - rk = *offset + k; - -/* Determine ith pivot column and swap if necessary */ - - i__1 = *n - k + 1; - pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1); - if (pvt != k) { - dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); - i__1 = k - 1; - dswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf); - itemp = jpvt[pvt]; - jpvt[pvt] = jpvt[k]; - jpvt[k] = itemp; - vn1[pvt] = vn1[k]; - vn2[pvt] = vn2[k]; - } - -/* Apply previous Householder reflectors to column K: */ -/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */ - - if (k > 1) { - i__1 = *m - rk + 1; - i__2 = k - 1; - dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[rk + a_dim1], lda, - &f[k + f_dim1], ldf, &c_b9, &a[rk + k * a_dim1], &c__1); - } - -/* Generate elementary reflector H(k). */ - - if (rk < *m) { - i__1 = *m - rk + 1; - dlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], & - c__1, &tau[k]); - } else { - dlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, & - tau[k]); - } - - akk = a[rk + k * a_dim1]; - a[rk + k * a_dim1] = 1.; - -/* Compute Kth column of F: */ - -/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */ - - if (k < *n) { - i__1 = *m - rk + 1; - i__2 = *n - k; - dgemv_("Transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 1) * - a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b16, &f[k + - 1 + k * f_dim1], &c__1); - } - -/* Padding F(1:K,K) with zeros. */ - - i__1 = k; - for (j = 1; j <= i__1; ++j) { - f[j + k * f_dim1] = 0.; -/* L20: */ - } - -/* Incremental updating of F: */ -/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */ -/* *A(RK:M,K). */ - - if (k > 1) { - i__1 = *m - rk + 1; - i__2 = k - 1; - d__1 = -tau[k]; - dgemv_("Transpose", &i__1, &i__2, &d__1, &a[rk + a_dim1], lda, &a[ - rk + k * a_dim1], &c__1, &c_b16, &auxv[1], &c__1); - - i__1 = k - 1; - dgemv_("No transpose", n, &i__1, &c_b9, &f[f_dim1 + 1], ldf, & - auxv[1], &c__1, &c_b9, &f[k * f_dim1 + 1], &c__1); - } - -/* Update the current row of A: */ -/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */ - - if (k < *n) { - i__1 = *n - k; - dgemv_("No transpose", &i__1, &k, &c_b8, &f[k + 1 + f_dim1], ldf, - &a[rk + a_dim1], lda, &c_b9, &a[rk + (k + 1) * a_dim1], - lda); - } - -/* Update partial column norms. */ - - if (rk < lastrk) { - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { - if (vn1[j] != 0.) { - -/* NOTE: The following 4 lines follow from the analysis in */ -/* Lapack Working Note 176. */ - - temp = (d__1 = a[rk + j * a_dim1], abs(d__1)) / vn1[j]; -/* Computing MAX */ - d__1 = 0., d__2 = (temp + 1.) * (1. - temp); - temp = std::max(d__1,d__2); -/* Computing 2nd power */ - d__1 = vn1[j] / vn2[j]; - temp2 = temp * (d__1 * d__1); - if (temp2 <= tol3z) { - vn2[j] = (double) lsticc; - lsticc = j; - } else { - vn1[j] *= sqrt(temp); - } - } -/* L30: */ - } - } - - a[rk + k * a_dim1] = akk; - -/* End of while loop. */ - - goto L10; - } - *kb = k; - rk = *offset + *kb; - -/* Apply the block reflector to the rest of the matrix: */ -/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */ -/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */ - -/* Computing MIN */ - i__1 = *n, i__2 = *m - *offset; - if (*kb < std::min(i__1,i__2)) { - i__1 = *m - rk; - i__2 = *n - *kb; - dgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b8, &a[rk + - 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b9, &a[rk + 1 - + (*kb + 1) * a_dim1], lda); - } - -/* Recomputation of difficult columns. */ - -L40: - if (lsticc > 0) { - itemp = i_dnnt(&vn2[lsticc]); - i__1 = *m - rk; - vn1[lsticc] = dnrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1); - -/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ -/* SNRM2 does not fail on vectors with norm below the value of */ -/* SQRT(DLAMCH('S')) */ - - vn2[lsticc] = vn1[lsticc]; - lsticc = itemp; - goto L40; - } - - return 0; - -/* End of DLAQPS */ - -} /* dlaqps_ */ diff --git a/external/clapack/lapack/dlaqr0.cpp b/external/clapack/lapack/dlaqr0.cpp deleted file mode 100644 index cc24df5e..00000000 --- a/external/clapack/lapack/dlaqr0.cpp +++ /dev/null @@ -1,719 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__13 = 13; -static integer c__15 = 15; -static integer c_n1 = -1; -static integer c__12 = 12; -static integer c__14 = 14; -static integer c__16 = 16; -static bool c_false = false; -static integer c__1 = 1; -static integer c__3 = 3; - -int dlaqr0_(bool *wantt, bool *wantz, integer *n, - integer *ilo, integer *ihi, double *h__, integer *ldh, double - *wr, double *wi, integer *iloz, integer *ihiz, double *z__, - integer *ldz, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer i__, k; - double aa, bb, cc, dd; - integer ld; - double cs; - integer nh, it, ks, kt; - double sn; - integer ku, kv, ls, ns; - double ss; - integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; - double swap; - integer ktop; - double zdum[1] /* was [1][1] */; - integer kacc22, itmax, nsmax, nwmax, kwtop; - integer nibble, nwupbd; - char jbcmpz[3]; - bool sorted; - integer lwkopt; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQR0 computes the eigenvalues of a Hessenberg matrix H */ -/* and, optionally, the matrices T and Z from the Schur decomposition */ -/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ -/* Schur form), and Z is the orthogonal matrix of Schur vectors. */ - -/* Optionally Z may be postmultiplied into an input orthogonal */ -/* matrix Q so that this routine can give the Schur factorization */ -/* of a matrix A which has been reduced to the Hessenberg form H */ -/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ - -/* Arguments */ -/* ========= */ - -/* WANTT (input) LOGICAL */ -/* = .TRUE. : the full Schur form T is required; */ -/* = .FALSE.: only eigenvalues are required. */ - -/* WANTZ (input) LOGICAL */ -/* = .TRUE. : the matrix of Schur vectors Z is required; */ -/* = .FALSE.: Schur vectors are not required. */ - -/* N (input) INTEGER */ -/* The order of the matrix H. N .GE. 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* It is assumed that H is already upper triangular in rows */ -/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */ -/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ -/* previous call to DGEBAL, and then passed to DGEHRD when the */ -/* matrix output by DGEBAL is reduced to Hessenberg form. */ -/* Otherwise, ILO and IHI should be set to 1 and N, */ -/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ -/* If N = 0, then ILO = 1 and IHI = 0. */ - -/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ -/* On entry, the upper Hessenberg matrix H. */ -/* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */ -/* the upper quasi-triangular matrix T from the Schur */ -/* decomposition (the Schur form); 2-by-2 diagonal blocks */ -/* (corresponding to complex conjugate pairs of eigenvalues) */ -/* are returned in standard form, with H(i,i) = H(i+1,i+1) */ -/* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */ -/* .FALSE., then the contents of H are unspecified on exit. */ -/* (The output value of H when INFO.GT.0 is given under the */ -/* description of INFO below.) */ - -/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */ -/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ - -/* LDH (input) INTEGER */ -/* The leading dimension of the array H. LDH .GE. max(1,N). */ - -/* WR (output) DOUBLE PRECISION array, dimension (IHI) */ -/* WI (output) DOUBLE PRECISION array, dimension (IHI) */ -/* The real and imaginary parts, respectively, of the computed */ -/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */ -/* and WI(ILO:IHI). If two eigenvalues are computed as a */ -/* complex conjugate pair, they are stored in consecutive */ -/* elements of WR and WI, say the i-th and (i+1)th, with */ -/* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */ -/* the eigenvalues are stored in the same order as on the */ -/* diagonal of the Schur form returned in H, with */ -/* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */ -/* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ -/* WI(i+1) = -WI(i). */ - -/* ILOZ (input) INTEGER */ -/* IHIZ (input) INTEGER */ -/* Specify the rows of Z to which transformations must be */ -/* applied if WANTZ is .TRUE.. */ -/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */ -/* If WANTZ is .FALSE., then Z is not referenced. */ -/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ -/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ -/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ -/* (The output value of Z when INFO.GT.0 is given under */ -/* the description of INFO below.) */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. if WANTZ is .TRUE. */ -/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK */ -/* On exit, if LWORK = -1, WORK(1) returns an estimate of */ -/* the optimal value for LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK .GE. max(1,N) */ -/* is sufficient, but LWORK typically as large as 6*N may */ -/* be required for optimal performance. A workspace query */ -/* to determine the optimal workspace size is recommended. */ - -/* If LWORK = -1, then DLAQR0 does a workspace query. */ -/* In this case, DLAQR0 checks the input parameters and */ -/* estimates the optimal workspace size for the given */ -/* values of N, ILO and IHI. The estimate is returned */ -/* in WORK(1). No error message related to LWORK is */ -/* issued by XERBLA. Neither H nor Z are accessed. */ - - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* .GT. 0: if INFO = i, DLAQR0 failed to compute all of */ -/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ -/* and WI contain those eigenvalues which have been */ -/* successfully computed. (Failures are rare.) */ - -/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */ -/* the remaining unconverged eigenvalues are the eigen- */ -/* values of the upper Hessenberg matrix rows and */ -/* columns ILO through INFO of the final, output */ -/* value of H. */ - -/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */ - -/* (*) (initial value of H)*U = U*(final value of H) */ - -/* where U is an orthogonal matrix. The final */ -/* value of H is upper Hessenberg and quasi-triangular */ -/* in rows and columns INFO+1 through IHI. */ - -/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */ - -/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */ -/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ - -/* where U is the orthogonal matrix in (*) (regard- */ -/* less of the value of WANTT.) */ - -/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */ -/* accessed. */ - -/* ================================================================ */ -/* Based on contributions by */ -/* Karen Braman and Ralph Byers, Department of Mathematics, */ -/* University of Kansas, USA */ - -/* ================================================================ */ -/* References: */ -/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ -/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ -/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ -/* 929--947, 2002. */ - -/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ -/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ -/* of Matrix Analysis, volume 23, pages 948--973, 2002. */ - -/* ================================================================ */ -/* .. Parameters .. */ - -/* ==== Matrices of order NTINY or smaller must be processed by */ -/* . DLAHQR because of insufficient subdiagonal scratch space. */ -/* . (This is a hard limit.) ==== */ - -/* ==== Exceptional deflation windows: try to cure rare */ -/* . slow convergence by varying the size of the */ -/* . deflation window after KEXNW iterations. ==== */ - -/* ==== Exceptional shifts: try to cure rare slow convergence */ -/* . with ad-hoc exceptional shifts every KEXSH iterations. */ -/* . ==== */ - -/* ==== The constants WILK1 and WILK2 are used to form the */ -/* . exceptional shifts. ==== */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - --wr; - --wi; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - *info = 0; - -/* ==== Quick return for N = 0: nothing to do. ==== */ - - if (*n == 0) { - work[1] = 1.; - return 0; - } - - if (*n <= 11) { - -/* ==== Tiny matrices must use DLAHQR. ==== */ - - lwkopt = 1; - if (*lwork != -1) { - dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & - wi[1], iloz, ihiz, &z__[z_offset], ldz, info); - } - } else { - -/* ==== Use small bulge multi-shift QR with aggressive early */ -/* . deflation on larger-than-tiny matrices. ==== */ - -/* ==== Hope for the best. ==== */ - - *info = 0; - -/* ==== Set up job flags for ILAENV. ==== */ - - if (*wantt) { - * (unsigned char *) & jbcmpz [0] = 'S'; - } else { - * (unsigned char *) & jbcmpz [0] = 'E'; - } - if (*wantz) { - * (unsigned char *) & jbcmpz [1] = 'V'; - } else { - * (unsigned char *) & jbcmpz [1] = 'N'; - } - jbcmpz [2] = '\0'; -/* ==== NWR = recommended deflation window size. At this */ -/* . point, N .GT. NTINY = 11, so there is enough */ -/* . subdiagonal workspace for NWR.GE.2 as required. */ -/* . (In fact, there is enough subdiagonal space for */ -/* . NWR.GE.3.) ==== */ - - nwr = ilaenv_(&c__13, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); - nwr = std::max(2_integer,nwr); -/* Computing MIN */ - i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = std::min(i__1,i__2); - nwr = std::min(i__1,nwr); - -/* ==== NSR = recommended number of simultaneous shifts. */ -/* . At this point N .GT. NTINY = 11, so there is at */ -/* . enough subdiagonal workspace for NSR to be even */ -/* . and greater than or equal to two as required. ==== */ - - nsr = ilaenv_(&c__15, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); -/* Computing MIN */ - i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = std::min(i__1,i__2), i__2 = *ihi - *ilo; - nsr = std::min(i__1,i__2); -/* Computing MAX */ - i__1 = 2, i__2 = nsr - nsr % 2; - nsr = std::max(i__1,i__2); - -/* ==== Estimate optimal workspace ==== */ - -/* ==== Workspace query call to DLAQR3 ==== */ - - i__1 = nwr + 1; - dlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, - ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ - h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], - ldh, &work[1], &c_n1); - -/* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== */ - -/* Computing MAX */ - i__1 = nsr * 3 / 2, i__2 = (integer) work[1]; - lwkopt = std::max(i__1,i__2); - -/* ==== Quick return in case of workspace query. ==== */ - - if (*lwork == -1) { - work[1] = (double) lwkopt; - return 0; - } - -/* ==== DLAHQR/DLAQR0 crossover point ==== */ - - nmin = ilaenv_(&c__12, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); - nmin = std::max(11_integer,nmin); - -/* ==== Nibble crossover point ==== */ - - nibble = ilaenv_(&c__14, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); - nibble = std::max(0_integer,nibble); - -/* ==== Accumulate reflections during ttswp? Use block */ -/* . 2-by-2 structure during matrix-matrix multiply? ==== */ - - kacc22 = ilaenv_(&c__16, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); - kacc22 = std::max(0_integer,kacc22); - kacc22 = std::min(2_integer,kacc22); - -/* ==== NWMAX = the largest possible deflation window for */ -/* . which there is sufficient workspace. ==== */ - -/* Computing MIN */ - i__1 = (*n - 1) / 3, i__2 = *lwork / 2; - nwmax = std::min(i__1,i__2); - nw = nwmax; - -/* ==== NSMAX = the Largest number of simultaneous shifts */ -/* . for which there is sufficient workspace. ==== */ - -/* Computing MIN */ - i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3; - nsmax = std::min(i__1,i__2); - nsmax -= nsmax % 2; - -/* ==== NDFL: an iteration count restarted at deflation. ==== */ - - ndfl = 1; - -/* ==== ITMAX = iteration limit ==== */ - -/* Computing MAX */ - i__1 = 10, i__2 = *ihi - *ilo + 1; - itmax = std::max(i__1,i__2) * 30; - -/* ==== Last row and column in the active block ==== */ - - kbot = *ihi; - -/* ==== Main Loop ==== */ - - i__1 = itmax; - for (it = 1; it <= i__1; ++it) { - -/* ==== Done when KBOT falls below ILO ==== */ - - if (kbot < *ilo) { - goto L90; - } - -/* ==== Locate active block ==== */ - - i__2 = *ilo + 1; - for (k = kbot; k >= i__2; --k) { - if (h__[k + (k - 1) * h_dim1] == 0.) { - goto L20; - } -/* L10: */ - } - k = *ilo; -L20: - ktop = k; - -/* ==== Select deflation window size: */ -/* . Typical Case: */ -/* . If possible and advisable, nibble the entire */ -/* . active block. If not, use size MIN(NWR,NWMAX) */ -/* . or MIN(NWR+1,NWMAX) depending upon which has */ -/* . the smaller corresponding subdiagonal entry */ -/* . (a heuristic). */ -/* . */ -/* . Exceptional Case: */ -/* . If there have been no deflations in KEXNW or */ -/* . more iterations, then vary the deflation window */ -/* . size. At first, because, larger windows are, */ -/* . in general, more powerful than smaller ones, */ -/* . rapidly increase the window to the maximum possible. */ -/* . Then, gradually reduce the window size. ==== */ - - nh = kbot - ktop + 1; - nwupbd = std::min(nh,nwmax); - if (ndfl < 5) { - nw = std::min(nwupbd,nwr); - } else { -/* Computing MIN */ - i__2 =nwupbd, i__3 = nw << 1; - nw = std::min(i__2,i__3); - } - if (nw < nwmax) { - if (nw >= nh - 1) { - nw = nh; - } else { - kwtop = kbot - nw + 1; - if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) - > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], - abs(d__2))) { - ++nw; - } - } - } - if (ndfl < 5) { - ndec = -1; - } else if (ndec >= 0 || nw >= nwupbd) { - ++ndec; - if (nw - ndec < 2) { - ndec = 0; - } - nw -= ndec; - } - -/* ==== Aggressive early deflation: */ -/* . split workspace under the subdiagonal into */ -/* . - an nw-by-nw work array V in the lower */ -/* . left-hand-corner, */ -/* . - an NW-by-at-least-NW-but-more-is-better */ -/* . (NW-by-NHO) horizontal work array along */ -/* . the bottom edge, */ -/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ -/* . vertical work array along the left-hand-edge. */ -/* . ==== */ - - kv = *n - nw + 1; - kt = nw + 1; - nho = *n - nw - 1 - kt + 1; - kwv = nw + 2; - nve = *n - nw - kwv + 1; - -/* ==== Aggressive early deflation ==== */ - - dlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, - iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], - &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], - ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); - -/* ==== Adjust KBOT accounting for new deflations. ==== */ - - kbot -= ld; - -/* ==== KS points to the shifts. ==== */ - - ks = kbot - ls + 1; - -/* ==== Skip an expensive QR sweep if there is a (partly */ -/* . heuristic) reason to expect that many eigenvalues */ -/* . will deflate without it. Here, the QR sweep is */ -/* . skipped if many eigenvalues have just been deflated */ -/* . or if the remaining active block is small. */ - - if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > std::min( - nmin,nwmax)) { - -/* ==== NS = nominal number of simultaneous shifts. */ -/* . This may be lowered (slightly) if DLAQR3 */ -/* . did not provide that many shifts. ==== */ - -/* Computing MIN */ -/* Computing MAX */ - i__4 = 2, i__5 = kbot - ktop; - i__2 = std::min(nsmax,nsr), i__3 = std::max(i__4,i__5); - ns = std::min(i__2,i__3); - ns -= ns % 2; - -/* ==== If there have been no deflations */ -/* . in a multiple of KEXSH iterations, */ -/* . then try exceptional shifts. */ -/* . Otherwise use shifts provided by */ -/* . DLAQR3 above or from the eigenvalues */ -/* . of a trailing principal submatrix. ==== */ - - if (ndfl % 6 == 0) { - ks = kbot - ns + 1; -/* Computing MAX */ - i__3 = ks + 1, i__4 = ktop + 2; - i__2 = std::max(i__3,i__4); - for (i__ = kbot; i__ >= i__2; i__ += -2) { - ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) - + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], - abs(d__2)); - aa = ss * .75 + h__[i__ + i__ * h_dim1]; - bb = ss; - cc = ss * -.4375; - dd = aa; - dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] -, &wr[i__], &wi[i__], &cs, &sn); -/* L30: */ - } - if (ks == ktop) { - wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; - wi[ks + 1] = 0.; - wr[ks] = wr[ks + 1]; - wi[ks] = wi[ks + 1]; - } - } else { - -/* ==== Got NS/2 or fewer shifts? Use DLAQR4 or */ -/* . DLAHQR on a trailing principal submatrix to */ -/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */ -/* . there is enough space below the subdiagonal */ -/* . to fit an NS-by-NS scratch array.) ==== */ - - if (kbot - ks + 1 <= ns / 2) { - ks = kbot - ns + 1; - kt = *n - ns + 1; - dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & - h__[kt + h_dim1], ldh); - if (ns > nmin) { - dlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ - kt + h_dim1], ldh, &wr[ks], &wi[ks], & - c__1, &c__1, zdum, &c__1, &work[1], lwork, - &inf); - } else { - dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ - kt + h_dim1], ldh, &wr[ks], &wi[ks], & - c__1, &c__1, zdum, &c__1, &inf); - } - ks += inf; - -/* ==== In case of a rare QR failure use */ -/* . eigenvalues of the trailing 2-by-2 */ -/* . principal submatrix. ==== */ - - if (ks >= kbot) { - aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; - cc = h__[kbot + (kbot - 1) * h_dim1]; - bb = h__[kbot - 1 + kbot * h_dim1]; - dd = h__[kbot + kbot * h_dim1]; - dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ - kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) - ; - ks = kbot - 1; - } - } - - if (kbot - ks + 1 > ns) { - -/* ==== Sort the shifts (Helps a little) */ -/* . Bubble sort keeps complex conjugate */ -/* . pairs together. ==== */ - - sorted = false; - i__2 = ks + 1; - for (k = kbot; k >= i__2; --k) { - if (sorted) { - goto L60; - } - sorted = true; - i__3 = k - 1; - for (i__ = ks; i__ <= i__3; ++i__) { - if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[ - i__], abs(d__2)) < (d__3 = wr[i__ + 1] - , abs(d__3)) + (d__4 = wi[i__ + 1], - abs(d__4))) { - sorted = false; - - swap = wr[i__]; - wr[i__] = wr[i__ + 1]; - wr[i__ + 1] = swap; - - swap = wi[i__]; - wi[i__] = wi[i__ + 1]; - wi[i__ + 1] = swap; - } -/* L40: */ - } -/* L50: */ - } -L60: - ; - } - -/* ==== Shuffle shifts into pairs of real shifts */ -/* . and pairs of complex conjugate shifts */ -/* . assuming complex conjugate shifts are */ -/* . already adjacent to one another. (Yes, */ -/* . they are.) ==== */ - - i__2 = ks + 2; - for (i__ = kbot; i__ >= i__2; i__ += -2) { - if (wi[i__] != -wi[i__ - 1]) { - - swap = wr[i__]; - wr[i__] = wr[i__ - 1]; - wr[i__ - 1] = wr[i__ - 2]; - wr[i__ - 2] = swap; - - swap = wi[i__]; - wi[i__] = wi[i__ - 1]; - wi[i__ - 1] = wi[i__ - 2]; - wi[i__ - 2] = swap; - } -/* L70: */ - } - } - -/* ==== If there are only two shifts and both are */ -/* . real, then use only one. ==== */ - - if (kbot - ks + 1 == 2) { - if (wi[kbot] == 0.) { - if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs( - d__1)) < (d__2 = wr[kbot - 1] - h__[kbot + - kbot * h_dim1], abs(d__2))) { - wr[kbot - 1] = wr[kbot]; - } else { - wr[kbot] = wr[kbot - 1]; - } - } - } - -/* ==== Use up to NS of the the smallest magnatiude */ -/* . shifts. If there aren't NS shifts available, */ -/* . then use them all, possibly dropping one to */ -/* . make the number of shifts even. ==== */ - -/* Computing MIN */ - i__2 = ns, i__3 = kbot - ks + 1; - ns = std::min(i__2,i__3); - ns -= ns % 2; - ks = kbot - ns + 1; - -/* ==== Small-bulge multi-shift QR sweep: */ -/* . split workspace under the subdiagonal into */ -/* . - a KDU-by-KDU work array U in the lower */ -/* . left-hand-corner, */ -/* . - a KDU-by-at-least-KDU-but-more-is-better */ -/* . (KDU-by-NHo) horizontal work array WH along */ -/* . the bottom edge, */ -/* . - and an at-least-KDU-but-more-is-better-by-KDU */ -/* . (NVE-by-KDU) vertical work WV arrow along */ -/* . the left-hand-edge. ==== */ - - kdu = ns * 3 - 3; - ku = *n - kdu + 1; - kwh = kdu + 1; - nho = *n - kdu - 3 - (kdu + 1) + 1; - kwv = kdu + 4; - nve = *n - kdu - kwv + 1; - -/* ==== Small-bulge multi-shift QR sweep ==== */ - - dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], - &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ - z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], - ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + - kwh * h_dim1], ldh); - } - -/* ==== Note progress (or the lack of it). ==== */ - - if (ld > 0) { - ndfl = 1; - } else { - ++ndfl; - } - -/* ==== End of main loop ==== */ -/* L80: */ - } - -/* ==== Iteration limit exceeded. Set INFO to show where */ -/* . the problem occurred and exit. ==== */ - - *info = kbot; -L90: - ; - } - -/* ==== Return the optimal value of LWORK. ==== */ - - work[1] = (double) lwkopt; - -/* ==== End of DLAQR0 ==== */ - - return 0; -} /* dlaqr0_ */ diff --git a/external/clapack/lapack/dlaqr1.cpp b/external/clapack/lapack/dlaqr1.cpp deleted file mode 100644 index 577027c5..00000000 --- a/external/clapack/lapack/dlaqr1.cpp +++ /dev/null @@ -1,115 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaqr1_(integer *n, double *h__, integer *ldh, - double *sr1, double *si1, double *sr2, double *si2, - double *v) -{ - /* System generated locals */ - integer h_dim1, h_offset; - double d__1, d__2, d__3; - - /* Local variables */ - double s, h21s, h31s; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a */ -/* scalar multiple of the first column of the product */ - -/* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) */ - -/* scaling to avoid overflows and most underflows. It */ -/* is assumed that either */ - -/* 1) sr1 = sr2 and si1 = -si2 */ -/* or */ -/* 2) si1 = si2 = 0. */ - -/* This is useful for starting double implicit shift bulges */ -/* in the QR algorithm. */ - - -/* N (input) integer */ -/* Order of the matrix H. N must be either 2 or 3. */ - -/* H (input) DOUBLE PRECISION array of dimension (LDH,N) */ -/* The 2-by-2 or 3-by-3 matrix H in (*). */ - -/* LDH (input) integer */ -/* The leading dimension of H as declared in */ -/* the calling procedure. LDH.GE.N */ - -/* SR1 (input) DOUBLE PRECISION */ -/* SI1 The shifts in (*). */ -/* SR2 */ -/* SI2 */ - -/* V (output) DOUBLE PRECISION array of dimension N */ -/* A scalar multiple of the first column of the */ -/* matrix K in (*). */ - -/* ================================================================ */ -/* Based on contributions by */ -/* Karen Braman and Ralph Byers, Department of Mathematics, */ -/* University of Kansas, USA */ - -/* ================================================================ */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - --v; - - /* Function Body */ - if (*n == 2) { - s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) + (d__2 = - h__[h_dim1 + 2], abs(d__2)); - if (s == 0.) { - v[1] = 0.; - v[2] = 0.; - } else { - h21s = h__[h_dim1 + 2] / s; - v[1] = h21s * h__[(h_dim1 << 1) + 1] + (h__[h_dim1 + 1] - *sr1) * - ((h__[h_dim1 + 1] - *sr2) / s) - *si1 * (*si2 / s); - v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - * - sr2); - } - } else { - s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) + (d__2 = - h__[h_dim1 + 2], abs(d__2)) + (d__3 = h__[h_dim1 + 3], abs( - d__3)); - if (s == 0.) { - v[1] = 0.; - v[2] = 0.; - v[3] = 0.; - } else { - h21s = h__[h_dim1 + 2] / s; - h31s = h__[h_dim1 + 3] / s; - v[1] = (h__[h_dim1 + 1] - *sr1) * ((h__[h_dim1 + 1] - *sr2) / s) - - *si1 * (*si2 / s) + h__[(h_dim1 << 1) + 1] * h21s + h__[ - h_dim1 * 3 + 1] * h31s; - v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - * - sr2) + h__[h_dim1 * 3 + 2] * h31s; - v[3] = h31s * (h__[h_dim1 + 1] + h__[h_dim1 * 3 + 3] - *sr1 - * - sr2) + h21s * h__[(h_dim1 << 1) + 3]; - } - } - return 0; -} /* dlaqr1_ */ diff --git a/external/clapack/lapack/dlaqr2.cpp b/external/clapack/lapack/dlaqr2.cpp deleted file mode 100644 index a4b3ae62..00000000 --- a/external/clapack/lapack/dlaqr2.cpp +++ /dev/null @@ -1,652 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b12 = 0.; -static double c_b13 = 1.; -static bool c_true = true; - -int dlaqr2_(bool *wantt, bool *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, - double *h__, integer *ldh, integer *iloz, integer *ihiz, double *z__, integer *ldz, - integer *ns, integer *nd, double *sr, double *si, double *v, integer *ldv, integer *nh, - double *t, integer *ldt, integer *nv, double *wv, integer *ldwv, double *work, integer *lwork) -{ - /* System generated locals */ - integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, - wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; - double d__1, d__2, d__3, d__4, d__5, d__6; - - /* Local variables */ - integer i__, j, k; - double s, aa, bb, cc, dd, cs, sn; - integer jw; - double evi, evk, foo; - integer kln; - double tau, ulp; - integer lwk1, lwk2; - double beta; - integer kend, kcol, info, ifst, ilst, ltop, krow; - bool bulge; - integer infqr, kwtop; - double safmin; - double safmax; - bool sorted; - double smlnum; - integer lwkopt; - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ -/* -- April 2009 -- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* This subroutine is identical to DLAQR3 except that it avoids */ -/* recursion by calling DLAHQR instead of DLAQR4. */ - - -/* ****************************************************************** */ -/* Aggressive early deflation: */ - -/* This subroutine accepts as input an upper Hessenberg matrix */ -/* H and performs an orthogonal similarity transformation */ -/* designed to detect and deflate fully converged eigenvalues from */ -/* a trailing principal submatrix. On output H has been over- */ -/* written by a new Hessenberg matrix that is a perturbation of */ -/* an orthogonal similarity transformation of H. It is to be */ -/* hoped that the final version of H has many zero subdiagonal */ -/* entries. */ - -/* ****************************************************************** */ -/* WANTT (input) LOGICAL */ -/* If .TRUE., then the Hessenberg matrix H is fully updated */ -/* so that the quasi-triangular Schur factor may be */ -/* computed (in cooperation with the calling subroutine). */ -/* If .FALSE., then only enough of H is updated to preserve */ -/* the eigenvalues. */ - -/* WANTZ (input) LOGICAL */ -/* If .TRUE., then the orthogonal matrix Z is updated so */ -/* so that the orthogonal Schur factor may be computed */ -/* (in cooperation with the calling subroutine). */ -/* If .FALSE., then Z is not referenced. */ - -/* N (input) INTEGER */ -/* The order of the matrix H and (if WANTZ is .TRUE.) the */ -/* order of the orthogonal matrix Z. */ - -/* KTOP (input) INTEGER */ -/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ -/* KBOT and KTOP together determine an isolated block */ -/* along the diagonal of the Hessenberg matrix. */ - -/* KBOT (input) INTEGER */ -/* It is assumed without a check that either */ -/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ -/* determine an isolated block along the diagonal of the */ -/* Hessenberg matrix. */ - -/* NW (input) INTEGER */ -/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */ - -/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ -/* On input the initial N-by-N section of H stores the */ -/* Hessenberg matrix undergoing aggressive early deflation. */ -/* On output H has been transformed by an orthogonal */ -/* similarity transformation, perturbed, and the returned */ -/* to Hessenberg form that (it is to be hoped) has some */ -/* zero subdiagonal entries. */ - -/* LDH (input) integer */ -/* Leading dimension of H just as declared in the calling */ -/* subroutine. N .LE. LDH */ - -/* ILOZ (input) INTEGER */ -/* IHIZ (input) INTEGER */ -/* Specify the rows of Z to which transformations must be */ -/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* IF WANTZ is .TRUE., then on output, the orthogonal */ -/* similarity transformation mentioned above has been */ -/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */ -/* If WANTZ is .FALSE., then Z is unreferenced. */ - -/* LDZ (input) integer */ -/* The leading dimension of Z just as declared in the */ -/* calling subroutine. 1 .LE. LDZ. */ - -/* NS (output) integer */ -/* The number of unconverged (ie approximate) eigenvalues */ -/* returned in SR and SI that may be used as shifts by the */ -/* calling subroutine. */ - -/* ND (output) integer */ -/* The number of converged eigenvalues uncovered by this */ -/* subroutine. */ - -/* SR (output) DOUBLE PRECISION array, dimension KBOT */ -/* SI (output) DOUBLE PRECISION array, dimension KBOT */ -/* On output, the real and imaginary parts of approximate */ -/* eigenvalues that may be used for shifts are stored in */ -/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ -/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ -/* The real and imaginary parts of converged eigenvalues */ -/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */ -/* SI(KBOT-ND+1) through SI(KBOT), respectively. */ - -/* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) */ -/* An NW-by-NW work array. */ - -/* LDV (input) integer scalar */ -/* The leading dimension of V just as declared in the */ -/* calling subroutine. NW .LE. LDV */ - -/* NH (input) integer scalar */ -/* The number of columns of T. NH.GE.NW. */ - -/* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) */ - -/* LDT (input) integer */ -/* The leading dimension of T just as declared in the */ -/* calling subroutine. NW .LE. LDT */ - -/* NV (input) integer */ -/* The number of rows of work array WV available for */ -/* workspace. NV.GE.NW. */ - -/* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) */ - -/* LDWV (input) integer */ -/* The leading dimension of W just as declared in the */ -/* calling subroutine. NW .LE. LDV */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. */ -/* On exit, WORK(1) is set to an estimate of the optimal value */ -/* of LWORK for the given values of N, NW, KTOP and KBOT. */ - -/* LWORK (input) integer */ -/* The dimension of the work array WORK. LWORK = 2*NW */ -/* suffices, but greater efficiency may result from larger */ -/* values of LWORK. */ - -/* If LWORK = -1, then a workspace query is assumed; DLAQR2 */ -/* only estimates the optimal workspace size for the given */ -/* values of N, NW, KTOP and KBOT. The estimate is returned */ -/* in WORK(1). No error message related to LWORK is issued */ -/* by XERBLA. Neither H nor Z are accessed. */ - -/* ================================================================ */ -/* Based on contributions by */ -/* Karen Braman and Ralph Byers, Department of Mathematics, */ -/* University of Kansas, USA */ - -/* ================================================================ */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* ==== Estimate optimal workspace. ==== */ - - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --sr; - --si; - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - wv_dim1 = *ldwv; - wv_offset = 1 + wv_dim1; - wv -= wv_offset; - --work; - - /* Function Body */ -/* Computing MIN */ - i__1 = *nw, i__2 = *kbot - *ktop + 1; - jw = std::min(i__1,i__2); - if (jw <= 2) { - lwkopt = 1; - } else { - -/* ==== Workspace query call to DGEHRD ==== */ - - i__1 = jw - 1; - dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & - c_n1, &info); - lwk1 = (integer) work[1]; - -/* ==== Workspace query call to DORMHR ==== */ - - i__1 = jw - 1; - dormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], - &v[v_offset], ldv, &work[1], &c_n1, &info); - lwk2 = (integer) work[1]; - -/* ==== Optimal workspace ==== */ - - lwkopt = jw + std::max(lwk1,lwk2); - } - -/* ==== Quick return in case of workspace query. ==== */ - - if (*lwork == -1) { - work[1] = (double) lwkopt; - return 0; - } - -/* ==== Nothing to do ... */ -/* ... for an empty active block ... ==== */ - *ns = 0; - *nd = 0; - work[1] = 1.; - if (*ktop > *kbot) { - return 0; - } -/* ... nor for an empty deflation window. ==== */ - if (*nw < 1) { - return 0; - } - -/* ==== Machine constants ==== */ - - safmin = dlamch_("SAFE MINIMUM"); - safmax = 1. / safmin; - dlabad_(&safmin, &safmax); - ulp = dlamch_("PRECISION"); - smlnum = safmin * ((double) (*n) / ulp); - -/* ==== Setup deflation window ==== */ - -/* Computing MIN */ - i__1 = *nw, i__2 = *kbot - *ktop + 1; - jw = std::min(i__1,i__2); - kwtop = *kbot - jw + 1; - if (kwtop == *ktop) { - s = 0.; - } else { - s = h__[kwtop + (kwtop - 1) * h_dim1]; - } - - if (*kbot == kwtop) { - -/* ==== 1-by-1 deflation window: not much to do ==== */ - - sr[kwtop] = h__[kwtop + kwtop * h_dim1]; - si[kwtop] = 0.; - *ns = 1; - *nd = 0; -/* Computing MAX */ - d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs( - d__1)); - if (abs(s) <= std::max(d__2,d__3)) { - *ns = 0; - *nd = 1; - if (kwtop > *ktop) { - h__[kwtop + (kwtop - 1) * h_dim1] = 0.; - } - } - work[1] = 1.; - return 0; - } - -/* ==== Convert to spike-triangular form. (In case of a */ -/* . rare QR failure, this routine continues to do */ -/* . aggressive early deflation using that part of */ -/* . the deflation window that converged using INFQR */ -/* . here and there to keep track.) ==== */ - - dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], - ldt); - i__1 = jw - 1; - i__2 = *ldh + 1; - i__3 = *ldt + 1; - dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & - i__3); - - dlaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv); - dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], - &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); - -/* ==== DTREXC needs a clean margin near the diagonal ==== */ - - i__1 = jw - 3; - for (j = 1; j <= i__1; ++j) { - t[j + 2 + j * t_dim1] = 0.; - t[j + 3 + j * t_dim1] = 0.; -/* L10: */ - } - if (jw > 2) { - t[jw + (jw - 2) * t_dim1] = 0.; - } - -/* ==== Deflation detection loop ==== */ - - *ns = jw; - ilst = infqr + 1; -L20: - if (ilst <= *ns) { - if (*ns == 1) { - bulge = false; - } else { - bulge = t[*ns + (*ns - 1) * t_dim1] != 0.; - } - -/* ==== Small spike tip test for deflation ==== */ - - if (! bulge) { - -/* ==== Real eigenvalue ==== */ - - foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1)); - if (foo == 0.) { - foo = abs(s); - } -/* Computing MAX */ - d__2 = smlnum, d__3 = ulp * foo; - if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= std::max(d__2,d__3)) - { - -/* ==== Deflatable ==== */ - - --(*ns); - } else { - -/* ==== Undeflatable. Move it up out of the way. */ -/* . (DTREXC can not fail in this case.) ==== */ - - ifst = *ns; - dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, - &ilst, &work[1], &info); - ++ilst; - } - } else { - -/* ==== Complex conjugate pair ==== */ - - foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[* - ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[* - ns - 1 + *ns * t_dim1], abs(d__2))); - if (foo == 0.) { - foo = abs(s); - } -/* Computing MAX */ - d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 = - s * v[(*ns - 1) * v_dim1 + 1], abs(d__2)); -/* Computing MAX */ - d__5 = smlnum, d__6 = ulp * foo; - if (std::max(d__3,d__4) <= std::max(d__5,d__6)) { - -/* ==== Deflatable ==== */ - - *ns += -2; - } else { - -/* ==== Undflatable. Move them up out of the way. */ -/* . Fortunately, DTREXC does the right thing with */ -/* . ILST in case of a rare exchange failure. ==== */ - - ifst = *ns; - dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, - &ilst, &work[1], &info); - ilst += 2; - } - } - -/* ==== End deflation detection loop ==== */ - - goto L20; - } - -/* ==== Return to Hessenberg form ==== */ - - if (*ns == 0) { - s = 0.; - } - - if (*ns < jw) { - -/* ==== sorting diagonal blocks of T improves accuracy for */ -/* . graded matrices. Bubble sort deals well with */ -/* . exchange failures. ==== */ - - sorted = false; - i__ = *ns + 1; -L30: - if (sorted) { - goto L50; - } - sorted = true; - - kend = i__ - 1; - i__ = infqr + 1; - if (i__ == *ns) { - k = i__ + 1; - } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { - k = i__ + 1; - } else { - k = i__ + 2; - } -L40: - if (k <= kend) { - if (k == i__ + 1) { - evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1)); - } else { - evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 = - t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 = - t[i__ + (i__ + 1) * t_dim1], abs(d__2))); - } - - if (k == kend) { - evk = (d__1 = t[k + k * t_dim1], abs(d__1)); - } else if (t[k + 1 + k * t_dim1] == 0.) { - evk = (d__1 = t[k + k * t_dim1], abs(d__1)); - } else { - evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[ - k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k + - (k + 1) * t_dim1], abs(d__2))); - } - - if (evi >= evk) { - i__ = k; - } else { - sorted = false; - ifst = i__; - ilst = k; - dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, - &ilst, &work[1], &info); - if (info == 0) { - i__ = ilst; - } else { - i__ = k; - } - } - if (i__ == kend) { - k = i__ + 1; - } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { - k = i__ + 1; - } else { - k = i__ + 2; - } - goto L40; - } - goto L30; -L50: - ; - } - -/* ==== Restore shift/eigenvalue array from T ==== */ - - i__ = jw; -L60: - if (i__ >= infqr + 1) { - if (i__ == infqr + 1) { - sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; - si[kwtop + i__ - 1] = 0.; - --i__; - } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) { - sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; - si[kwtop + i__ - 1] = 0.; - --i__; - } else { - aa = t[i__ - 1 + (i__ - 1) * t_dim1]; - cc = t[i__ + (i__ - 1) * t_dim1]; - bb = t[i__ - 1 + i__ * t_dim1]; - dd = t[i__ + i__ * t_dim1]; - dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & - sn); - i__ += -2; - } - goto L60; - } - - if (*ns < jw || s == 0.) { - if (*ns > 1 && s != 0.) { - -/* ==== Reflect spike back into lower triangle ==== */ - - dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); - beta = work[1]; - dlarfg_(ns, &beta, &work[2], &c__1, &tau); - work[1] = 1.; - - i__1 = jw - 2; - i__2 = jw - 2; - dlaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt); - - dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & - work[jw + 1]); - dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & - work[jw + 1]); - dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & - work[jw + 1]); - - i__1 = *lwork - jw; - dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] -, &i__1, &info); - } - -/* ==== Copy updated reduced window into place ==== */ - - if (kwtop > 1) { - h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; - } - dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] -, ldh); - i__1 = jw - 1; - i__2 = *ldt + 1; - i__3 = *ldh + 1; - dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], - &i__3); - -/* ==== Accumulate orthogonal matrix in order update */ -/* . H and Z, if requested. ==== */ - - if (*ns > 1 && s != 0.) { - i__1 = *lwork - jw; - dormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], - &v[v_offset], ldv, &work[jw + 1], &i__1, &info); - } - -/* ==== Update vertical slab in H ==== */ - - if (*wantt) { - ltop = 1; - } else { - ltop = *ktop; - } - i__1 = kwtop - 1; - i__2 = *nv; - for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += - i__2) { -/* Computing MIN */ - i__3 = *nv, i__4 = kwtop - krow; - kln = std::min(i__3,i__4); - dgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * - h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], - ldwv); - dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * - h_dim1], ldh); -/* L70: */ - } - -/* ==== Update horizontal slab in H ==== */ - - if (*wantt) { - i__2 = *n; - i__1 = *nh; - for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; - kcol += i__1) { -/* Computing MIN */ - i__3 = *nh, i__4 = *n - kcol + 1; - kln = std::min(i__3,i__4); - dgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & - h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], - ldt); - dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * - h_dim1], ldh); -/* L80: */ - } - } - -/* ==== Update vertical slab in Z ==== */ - - if (*wantz) { - i__1 = *ihiz; - i__2 = *nv; - for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += - i__2) { -/* Computing MIN */ - i__3 = *nv, i__4 = *ihiz - krow + 1; - kln = std::min(i__3,i__4); - dgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * - z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ - wv_offset], ldwv); - dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + - kwtop * z_dim1], ldz); -/* L90: */ - } - } - } - -/* ==== Return the number of deflations ... ==== */ - - *nd = jw - *ns; - -/* ==== ... and the number of shifts. (Subtracting */ -/* . INFQR from the spike length takes care */ -/* . of the case of a rare QR failure while */ -/* . calculating eigenvalues of the deflation */ -/* . window.) ==== */ - - *ns -= infqr; - -/* ==== Return optimal workspace. ==== */ - - work[1] = (double) lwkopt; - -/* ==== End of DLAQR2 ==== */ - - return 0; -} /* dlaqr2_ */ diff --git a/external/clapack/lapack/dlaqr3.cpp b/external/clapack/lapack/dlaqr3.cpp deleted file mode 100644 index 5752728e..00000000 --- a/external/clapack/lapack/dlaqr3.cpp +++ /dev/null @@ -1,666 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static bool c_true = true; -static double c_b17 = 0.; -static double c_b18 = 1.; -static integer c__12 = 12; - -int dlaqr3_(bool *wantt, bool *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, - double *h__, integer *ldh, integer *iloz, integer *ihiz, double *z__, integer *ldz, - integer *ns, integer *nd, double *sr, double *si, double *v, integer *ldv, integer *nh, - double *t, integer *ldt, integer *nv, double *wv, integer *ldwv, double *work, integer *lwork) -{ - /* System generated locals */ - integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, - wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; - double d__1, d__2, d__3, d__4, d__5, d__6; - - /* Local variables */ - integer i__, j, k; - double s, aa, bb, cc, dd, cs, sn; - integer jw; - double evi, evk, foo; - integer kln; - double tau, ulp; - integer lwk1, lwk2, lwk3; - double beta; - integer kend, kcol, info, nmin, ifst, ilst, ltop, krow; - bool bulge; - integer infqr, kwtop; - double safmin; - double safmax; - bool sorted; - double smlnum; - integer lwkopt; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ -/* -- April 2009 -- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* ****************************************************************** */ -/* Aggressive early deflation: */ - -/* This subroutine accepts as input an upper Hessenberg matrix */ -/* H and performs an orthogonal similarity transformation */ -/* designed to detect and deflate fully converged eigenvalues from */ -/* a trailing principal submatrix. On output H has been over- */ -/* written by a new Hessenberg matrix that is a perturbation of */ -/* an orthogonal similarity transformation of H. It is to be */ -/* hoped that the final version of H has many zero subdiagonal */ -/* entries. */ - -/* ****************************************************************** */ -/* WANTT (input) LOGICAL */ -/* If .TRUE., then the Hessenberg matrix H is fully updated */ -/* so that the quasi-triangular Schur factor may be */ -/* computed (in cooperation with the calling subroutine). */ -/* If .FALSE., then only enough of H is updated to preserve */ -/* the eigenvalues. */ - -/* WANTZ (input) LOGICAL */ -/* If .TRUE., then the orthogonal matrix Z is updated so */ -/* so that the orthogonal Schur factor may be computed */ -/* (in cooperation with the calling subroutine). */ -/* If .FALSE., then Z is not referenced. */ - -/* N (input) INTEGER */ -/* The order of the matrix H and (if WANTZ is .TRUE.) the */ -/* order of the orthogonal matrix Z. */ - -/* KTOP (input) INTEGER */ -/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ -/* KBOT and KTOP together determine an isolated block */ -/* along the diagonal of the Hessenberg matrix. */ - -/* KBOT (input) INTEGER */ -/* It is assumed without a check that either */ -/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ -/* determine an isolated block along the diagonal of the */ -/* Hessenberg matrix. */ - -/* NW (input) INTEGER */ -/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */ - -/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ -/* On input the initial N-by-N section of H stores the */ -/* Hessenberg matrix undergoing aggressive early deflation. */ -/* On output H has been transformed by an orthogonal */ -/* similarity transformation, perturbed, and the returned */ -/* to Hessenberg form that (it is to be hoped) has some */ -/* zero subdiagonal entries. */ - -/* LDH (input) integer */ -/* Leading dimension of H just as declared in the calling */ -/* subroutine. N .LE. LDH */ - -/* ILOZ (input) INTEGER */ -/* IHIZ (input) INTEGER */ -/* Specify the rows of Z to which transformations must be */ -/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* IF WANTZ is .TRUE., then on output, the orthogonal */ -/* similarity transformation mentioned above has been */ -/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */ -/* If WANTZ is .FALSE., then Z is unreferenced. */ - -/* LDZ (input) integer */ -/* The leading dimension of Z just as declared in the */ -/* calling subroutine. 1 .LE. LDZ. */ - -/* NS (output) integer */ -/* The number of unconverged (ie approximate) eigenvalues */ -/* returned in SR and SI that may be used as shifts by the */ -/* calling subroutine. */ - -/* ND (output) integer */ -/* The number of converged eigenvalues uncovered by this */ -/* subroutine. */ - -/* SR (output) DOUBLE PRECISION array, dimension KBOT */ -/* SI (output) DOUBLE PRECISION array, dimension KBOT */ -/* On output, the real and imaginary parts of approximate */ -/* eigenvalues that may be used for shifts are stored in */ -/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ -/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ -/* The real and imaginary parts of converged eigenvalues */ -/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */ -/* SI(KBOT-ND+1) through SI(KBOT), respectively. */ - -/* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) */ -/* An NW-by-NW work array. */ - -/* LDV (input) integer scalar */ -/* The leading dimension of V just as declared in the */ -/* calling subroutine. NW .LE. LDV */ - -/* NH (input) integer scalar */ -/* The number of columns of T. NH.GE.NW. */ - -/* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) */ - -/* LDT (input) integer */ -/* The leading dimension of T just as declared in the */ -/* calling subroutine. NW .LE. LDT */ - -/* NV (input) integer */ -/* The number of rows of work array WV available for */ -/* workspace. NV.GE.NW. */ - -/* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) */ - -/* LDWV (input) integer */ -/* The leading dimension of W just as declared in the */ -/* calling subroutine. NW .LE. LDV */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. */ -/* On exit, WORK(1) is set to an estimate of the optimal value */ -/* of LWORK for the given values of N, NW, KTOP and KBOT. */ - -/* LWORK (input) integer */ -/* The dimension of the work array WORK. LWORK = 2*NW */ -/* suffices, but greater efficiency may result from larger */ -/* values of LWORK. */ - -/* If LWORK = -1, then a workspace query is assumed; DLAQR3 */ -/* only estimates the optimal workspace size for the given */ -/* values of N, NW, KTOP and KBOT. The estimate is returned */ -/* in WORK(1). No error message related to LWORK is issued */ -/* by XERBLA. Neither H nor Z are accessed. */ - -/* ================================================================ */ -/* Based on contributions by */ -/* Karen Braman and Ralph Byers, Department of Mathematics, */ -/* University of Kansas, USA */ - -/* ================================================================== */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* ==== Estimate optimal workspace. ==== */ - - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --sr; - --si; - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - wv_dim1 = *ldwv; - wv_offset = 1 + wv_dim1; - wv -= wv_offset; - --work; - - /* Function Body */ -/* Computing MIN */ - i__1 = *nw, i__2 = *kbot - *ktop + 1; - jw = std::min(i__1,i__2); - if (jw <= 2) { - lwkopt = 1; - } else { - -/* ==== Workspace query call to DGEHRD ==== */ - - i__1 = jw - 1; - dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & - c_n1, &info); - lwk1 = (integer) work[1]; - -/* ==== Workspace query call to DORMHR ==== */ - - i__1 = jw - 1; - dormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], - &v[v_offset], ldv, &work[1], &c_n1, &info); - lwk2 = (integer) work[1]; - -/* ==== Workspace query call to DLAQR4 ==== */ - - dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[1], - &si[1], &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, & - infqr); - lwk3 = (integer) work[1]; - -/* ==== Optimal workspace ==== */ - -/* Computing MAX */ - i__1 = jw + std::max(lwk1,lwk2); - lwkopt = std::max(i__1,lwk3); - } - -/* ==== Quick return in case of workspace query. ==== */ - - if (*lwork == -1) { - work[1] = (double) lwkopt; - return 0; - } - -/* ==== Nothing to do ... */ -/* ... for an empty active block ... ==== */ - *ns = 0; - *nd = 0; - work[1] = 1.; - if (*ktop > *kbot) { - return 0; - } -/* ... nor for an empty deflation window. ==== */ - if (*nw < 1) { - return 0; - } - -/* ==== Machine constants ==== */ - - safmin = dlamch_("SAFE MINIMUM"); - safmax = 1. / safmin; - dlabad_(&safmin, &safmax); - ulp = dlamch_("PRECISION"); - smlnum = safmin * ((double) (*n) / ulp); - -/* ==== Setup deflation window ==== */ - -/* Computing MIN */ - i__1 = *nw, i__2 = *kbot - *ktop + 1; - jw = std::min(i__1,i__2); - kwtop = *kbot - jw + 1; - if (kwtop == *ktop) { - s = 0.; - } else { - s = h__[kwtop + (kwtop - 1) * h_dim1]; - } - - if (*kbot == kwtop) { - -/* ==== 1-by-1 deflation window: not much to do ==== */ - - sr[kwtop] = h__[kwtop + kwtop * h_dim1]; - si[kwtop] = 0.; - *ns = 1; - *nd = 0; -/* Computing MAX */ - d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs( - d__1)); - if (abs(s) <= std::max(d__2,d__3)) { - *ns = 0; - *nd = 1; - if (kwtop > *ktop) { - h__[kwtop + (kwtop - 1) * h_dim1] = 0.; - } - } - work[1] = 1.; - return 0; - } - -/* ==== Convert to spike-triangular form. (In case of a */ -/* . rare QR failure, this routine continues to do */ -/* . aggressive early deflation using that part of */ -/* . the deflation window that converged using INFQR */ -/* . here and there to keep track.) ==== */ - - dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], - ldt); - i__1 = jw - 1; - i__2 = *ldh + 1; - i__3 = *ldt + 1; - dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & - i__3); - - dlaset_("A", &jw, &jw, &c_b17, &c_b18, &v[v_offset], ldv); - nmin = ilaenv_(&c__12, "DLAQR3", "SV", &jw, &c__1, &jw, lwork); - if (jw > nmin) { - dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[ - kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], - lwork, &infqr); - } else { - dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[ - kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); - } - -/* ==== DTREXC needs a clean margin near the diagonal ==== */ - - i__1 = jw - 3; - for (j = 1; j <= i__1; ++j) { - t[j + 2 + j * t_dim1] = 0.; - t[j + 3 + j * t_dim1] = 0.; -/* L10: */ - } - if (jw > 2) { - t[jw + (jw - 2) * t_dim1] = 0.; - } - -/* ==== Deflation detection loop ==== */ - - *ns = jw; - ilst = infqr + 1; -L20: - if (ilst <= *ns) { - if (*ns == 1) { - bulge = false; - } else { - bulge = t[*ns + (*ns - 1) * t_dim1] != 0.; - } - -/* ==== Small spike tip test for deflation ==== */ - - if (! bulge) { - -/* ==== Real eigenvalue ==== */ - - foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1)); - if (foo == 0.) { - foo = abs(s); - } -/* Computing MAX */ - d__2 = smlnum, d__3 = ulp * foo; - if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= std::max(d__2,d__3)) - { - -/* ==== Deflatable ==== */ - - --(*ns); - } else { - -/* ==== Undeflatable. Move it up out of the way. */ -/* . (DTREXC can not fail in this case.) ==== */ - - ifst = *ns; - dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, - &ilst, &work[1], &info); - ++ilst; - } - } else { - -/* ==== Complex conjugate pair ==== */ - - foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[* - ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[* - ns - 1 + *ns * t_dim1], abs(d__2))); - if (foo == 0.) { - foo = abs(s); - } -/* Computing MAX */ - d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 = - s * v[(*ns - 1) * v_dim1 + 1], abs(d__2)); -/* Computing MAX */ - d__5 = smlnum, d__6 = ulp * foo; - if (std::max(d__3,d__4) <= std::max(d__5,d__6)) { - -/* ==== Deflatable ==== */ - - *ns += -2; - } else { - -/* ==== Undeflatable. Move them up out of the way. */ -/* . Fortunately, DTREXC does the right thing with */ -/* . ILST in case of a rare exchange failure. ==== */ - - ifst = *ns; - dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, - &ilst, &work[1], &info); - ilst += 2; - } - } - -/* ==== End deflation detection loop ==== */ - - goto L20; - } - -/* ==== Return to Hessenberg form ==== */ - - if (*ns == 0) { - s = 0.; - } - - if (*ns < jw) { - -/* ==== sorting diagonal blocks of T improves accuracy for */ -/* . graded matrices. Bubble sort deals well with */ -/* . exchange failures. ==== */ - - sorted = false; - i__ = *ns + 1; -L30: - if (sorted) { - goto L50; - } - sorted = true; - - kend = i__ - 1; - i__ = infqr + 1; - if (i__ == *ns) { - k = i__ + 1; - } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { - k = i__ + 1; - } else { - k = i__ + 2; - } -L40: - if (k <= kend) { - if (k == i__ + 1) { - evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1)); - } else { - evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 = - t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 = - t[i__ + (i__ + 1) * t_dim1], abs(d__2))); - } - - if (k == kend) { - evk = (d__1 = t[k + k * t_dim1], abs(d__1)); - } else if (t[k + 1 + k * t_dim1] == 0.) { - evk = (d__1 = t[k + k * t_dim1], abs(d__1)); - } else { - evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[ - k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k + - (k + 1) * t_dim1], abs(d__2))); - } - - if (evi >= evk) { - i__ = k; - } else { - sorted = false; - ifst = i__; - ilst = k; - dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, - &ilst, &work[1], &info); - if (info == 0) { - i__ = ilst; - } else { - i__ = k; - } - } - if (i__ == kend) { - k = i__ + 1; - } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { - k = i__ + 1; - } else { - k = i__ + 2; - } - goto L40; - } - goto L30; -L50: - ; - } - -/* ==== Restore shift/eigenvalue array from T ==== */ - - i__ = jw; -L60: - if (i__ >= infqr + 1) { - if (i__ == infqr + 1) { - sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; - si[kwtop + i__ - 1] = 0.; - --i__; - } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) { - sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; - si[kwtop + i__ - 1] = 0.; - --i__; - } else { - aa = t[i__ - 1 + (i__ - 1) * t_dim1]; - cc = t[i__ + (i__ - 1) * t_dim1]; - bb = t[i__ - 1 + i__ * t_dim1]; - dd = t[i__ + i__ * t_dim1]; - dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & - sn); - i__ += -2; - } - goto L60; - } - - if (*ns < jw || s == 0.) { - if (*ns > 1 && s != 0.) { - -/* ==== Reflect spike back into lower triangle ==== */ - - dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); - beta = work[1]; - dlarfg_(ns, &beta, &work[2], &c__1, &tau); - work[1] = 1.; - - i__1 = jw - 2; - i__2 = jw - 2; - dlaset_("L", &i__1, &i__2, &c_b17, &c_b17, &t[t_dim1 + 3], ldt); - - dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & - work[jw + 1]); - dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & - work[jw + 1]); - dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & - work[jw + 1]); - - i__1 = *lwork - jw; - dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] -, &i__1, &info); - } - -/* ==== Copy updated reduced window into place ==== */ - - if (kwtop > 1) { - h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; - } - dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] -, ldh); - i__1 = jw - 1; - i__2 = *ldt + 1; - i__3 = *ldh + 1; - dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], - &i__3); - -/* ==== Accumulate orthogonal matrix in order update */ -/* . H and Z, if requested. ==== */ - - if (*ns > 1 && s != 0.) { - i__1 = *lwork - jw; - dormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], - &v[v_offset], ldv, &work[jw + 1], &i__1, &info); - } - -/* ==== Update vertical slab in H ==== */ - - if (*wantt) { - ltop = 1; - } else { - ltop = *ktop; - } - i__1 = kwtop - 1; - i__2 = *nv; - for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += - i__2) { -/* Computing MIN */ - i__3 = *nv, i__4 = kwtop - krow; - kln = std::min(i__3,i__4); - dgemm_("N", "N", &kln, &jw, &jw, &c_b18, &h__[krow + kwtop * - h_dim1], ldh, &v[v_offset], ldv, &c_b17, &wv[wv_offset], - ldwv); - dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * - h_dim1], ldh); -/* L70: */ - } - -/* ==== Update horizontal slab in H ==== */ - - if (*wantt) { - i__2 = *n; - i__1 = *nh; - for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; - kcol += i__1) { -/* Computing MIN */ - i__3 = *nh, i__4 = *n - kcol + 1; - kln = std::min(i__3,i__4); - dgemm_("C", "N", &jw, &kln, &jw, &c_b18, &v[v_offset], ldv, & - h__[kwtop + kcol * h_dim1], ldh, &c_b17, &t[t_offset], - ldt); - dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * - h_dim1], ldh); -/* L80: */ - } - } - -/* ==== Update vertical slab in Z ==== */ - - if (*wantz) { - i__1 = *ihiz; - i__2 = *nv; - for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += - i__2) { -/* Computing MIN */ - i__3 = *nv, i__4 = *ihiz - krow + 1; - kln = std::min(i__3,i__4); - dgemm_("N", "N", &kln, &jw, &jw, &c_b18, &z__[krow + kwtop * - z_dim1], ldz, &v[v_offset], ldv, &c_b17, &wv[ - wv_offset], ldwv); - dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + - kwtop * z_dim1], ldz); -/* L90: */ - } - } - } - -/* ==== Return the number of deflations ... ==== */ - - *nd = jw - *ns; - -/* ==== ... and the number of shifts. (Subtracting */ -/* . INFQR from the spike length takes care */ -/* . of the case of a rare QR failure while */ -/* . calculating eigenvalues of the deflation */ -/* . window.) ==== */ - - *ns -= infqr; - -/* ==== Return optimal workspace. ==== */ - - work[1] = (double) lwkopt; - -/* ==== End of DLAQR3 ==== */ - - return 0; -} /* dlaqr3_ */ diff --git a/external/clapack/lapack/dlaqr4.cpp b/external/clapack/lapack/dlaqr4.cpp deleted file mode 100644 index cfed2e48..00000000 --- a/external/clapack/lapack/dlaqr4.cpp +++ /dev/null @@ -1,710 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__13 = 13; -static integer c__15 = 15; -static integer c_n1 = -1; -static integer c__12 = 12; -static integer c__14 = 14; -static integer c__16 = 16; -static bool c_false = false; -static integer c__1 = 1; -static integer c__3 = 3; - -int dlaqr4_(bool *wantt, bool *wantz, integer *n, integer *ilo, integer *ihi, double *h__, - integer *ldh, double *wr, double *wi, integer *iloz, integer *ihiz, double *z__, - integer *ldz, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer i__, k, ld, nh, it, ks, kt, ku, kv, ls, ns; - double aa, bb, cc, dd; - double cs, sn, ss, swap; - integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; - integer ktop, kacc22; - double zdum[1] /* was [1][1] */; - bool sorted; - integer itmax, nsmax, nwmax, kwtop, lwkopt, nibble, nwupbd; - char jbcmpz[3]; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* This subroutine implements one level of recursion for DLAQR0. */ -/* It is a complete implementation of the small bulge multi-shift */ -/* QR algorithm. It may be called by DLAQR0 and, for large enough */ -/* deflation window size, it may be called by DLAQR3. This */ -/* subroutine is identical to DLAQR0 except that it calls DLAQR2 */ -/* instead of DLAQR3. */ - -/* Purpose */ -/* ======= */ - -/* DLAQR4 computes the eigenvalues of a Hessenberg matrix H */ -/* and, optionally, the matrices T and Z from the Schur decomposition */ -/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ -/* Schur form), and Z is the orthogonal matrix of Schur vectors. */ - -/* Optionally Z may be postmultiplied into an input orthogonal */ -/* matrix Q so that this routine can give the Schur factorization */ -/* of a matrix A which has been reduced to the Hessenberg form H */ -/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ - -/* Arguments */ -/* ========= */ - -/* WANTT (input) LOGICAL */ -/* = .TRUE. : the full Schur form T is required; */ -/* = .FALSE.: only eigenvalues are required. */ - -/* WANTZ (input) LOGICAL */ -/* = .TRUE. : the matrix of Schur vectors Z is required; */ -/* = .FALSE.: Schur vectors are not required. */ - -/* N (input) INTEGER */ -/* The order of the matrix H. N .GE. 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* It is assumed that H is already upper triangular in rows */ -/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */ -/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ -/* previous call to DGEBAL, and then passed to DGEHRD when the */ -/* matrix output by DGEBAL is reduced to Hessenberg form. */ -/* Otherwise, ILO and IHI should be set to 1 and N, */ -/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ -/* If N = 0, then ILO = 1 and IHI = 0. */ - -/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ -/* On entry, the upper Hessenberg matrix H. */ -/* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */ -/* the upper quasi-triangular matrix T from the Schur */ -/* decomposition (the Schur form); 2-by-2 diagonal blocks */ -/* (corresponding to complex conjugate pairs of eigenvalues) */ -/* are returned in standard form, with H(i,i) = H(i+1,i+1) */ -/* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */ -/* .FALSE., then the contents of H are unspecified on exit. */ -/* (The output value of H when INFO.GT.0 is given under the */ -/* description of INFO below.) */ - -/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */ -/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ - -/* LDH (input) INTEGER */ -/* The leading dimension of the array H. LDH .GE. max(1,N). */ - -/* WR (output) DOUBLE PRECISION array, dimension (IHI) */ -/* WI (output) DOUBLE PRECISION array, dimension (IHI) */ -/* The real and imaginary parts, respectively, of the computed */ -/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */ -/* and WI(ILO:IHI). If two eigenvalues are computed as a */ -/* complex conjugate pair, they are stored in consecutive */ -/* elements of WR and WI, say the i-th and (i+1)th, with */ -/* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */ -/* the eigenvalues are stored in the same order as on the */ -/* diagonal of the Schur form returned in H, with */ -/* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */ -/* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ -/* WI(i+1) = -WI(i). */ - -/* ILOZ (input) INTEGER */ -/* IHIZ (input) INTEGER */ -/* Specify the rows of Z to which transformations must be */ -/* applied if WANTZ is .TRUE.. */ -/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */ -/* If WANTZ is .FALSE., then Z is not referenced. */ -/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ -/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ -/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ -/* (The output value of Z when INFO.GT.0 is given under */ -/* the description of INFO below.) */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. if WANTZ is .TRUE. */ -/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK */ -/* On exit, if LWORK = -1, WORK(1) returns an estimate of */ -/* the optimal value for LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK .GE. max(1,N) */ -/* is sufficient, but LWORK typically as large as 6*N may */ -/* be required for optimal performance. A workspace query */ -/* to determine the optimal workspace size is recommended. */ - -/* If LWORK = -1, then DLAQR4 does a workspace query. */ -/* In this case, DLAQR4 checks the input parameters and */ -/* estimates the optimal workspace size for the given */ -/* values of N, ILO and IHI. The estimate is returned */ -/* in WORK(1). No error message related to LWORK is */ -/* issued by XERBLA. Neither H nor Z are accessed. */ - - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* .GT. 0: if INFO = i, DLAQR4 failed to compute all of */ -/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ -/* and WI contain those eigenvalues which have been */ -/* successfully computed. (Failures are rare.) */ - -/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */ -/* the remaining unconverged eigenvalues are the eigen- */ -/* values of the upper Hessenberg matrix rows and */ -/* columns ILO through INFO of the final, output */ -/* value of H. */ - -/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */ - -/* (*) (initial value of H)*U = U*(final value of H) */ - -/* where U is an orthogonal matrix. The final */ -/* value of H is upper Hessenberg and quasi-triangular */ -/* in rows and columns INFO+1 through IHI. */ - -/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */ - -/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */ -/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ - -/* where U is the orthogonal matrix in (*) (regard- */ -/* less of the value of WANTT.) */ - -/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */ -/* accessed. */ - -/* ================================================================ */ -/* Based on contributions by */ -/* Karen Braman and Ralph Byers, Department of Mathematics, */ -/* University of Kansas, USA */ - -/* ================================================================ */ -/* References: */ -/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ -/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ -/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ -/* 929--947, 2002. */ - -/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ -/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ -/* of Matrix Analysis, volume 23, pages 948--973, 2002. */ - -/* ================================================================ */ -/* .. Parameters .. */ - -/* ==== Matrices of order NTINY or smaller must be processed by */ -/* . DLAHQR because of insufficient subdiagonal scratch space. */ -/* . (This is a hard limit.) ==== */ - -/* ==== Exceptional deflation windows: try to cure rare */ -/* . slow convergence by varying the size of the */ -/* . deflation window after KEXNW iterations. ==== */ - -/* ==== Exceptional shifts: try to cure rare slow convergence */ -/* . with ad-hoc exceptional shifts every KEXSH iterations. */ -/* . ==== */ - -/* ==== The constants WILK1 and WILK2 are used to form the */ -/* . exceptional shifts. ==== */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - --wr; - --wi; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - *info = 0; - -/* ==== Quick return for N = 0: nothing to do. ==== */ - - if (*n == 0) { - work[1] = 1.; - return 0; - } - - if (*n <= 11) { -/* ==== Tiny matrices must use DLAHQR. ==== */ - - lwkopt = 1; - if (*lwork != -1) { - dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & - wi[1], iloz, ihiz, &z__[z_offset], ldz, info); - } - } else { - -/* ==== Use small bulge multi-shift QR with aggressive early */ -/* . deflation on larger-than-tiny matrices. ==== */ - -/* ==== Hope for the best. ==== */ - - *info = 0; - -/* ==== Set up job flags for ILAENV. ==== */ - - if (*wantt) { - * (unsigned char *) & jbcmpz [0] = 'S'; - } else { - * (unsigned char *) & jbcmpz [0] = 'E'; - } - if (*wantz) { - * (unsigned char *) & jbcmpz [1] = 'V'; - } else { - * (unsigned char *) & jbcmpz [1] = 'N'; - } - jbcmpz [2] = '\0'; -/* ==== NWR = recommended deflation window size. At this */ -/* . point, N .GT. NTINY = 11, so there is enough */ -/* . subdiagonal workspace for NWR.GE.2 as required. */ -/* . (In fact, there is enough subdiagonal space for */ -/* . NWR.GE.3.) ==== */ - - nwr = ilaenv_(&c__13, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); - nwr = std::max(2_integer,nwr); -/* Computing MIN */ - i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = std::min(i__1,i__2); - nwr = std::min(i__1,nwr); - -/* ==== NSR = recommended number of simultaneous shifts. */ -/* . At this point N .GT. NTINY = 11, so there is at */ -/* . enough subdiagonal workspace for NSR to be even */ -/* . and greater than or equal to two as required. ==== */ - - nsr = ilaenv_(&c__15, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); -/* Computing MIN */ - i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = std::min(i__1,i__2), i__2 = *ihi - - *ilo; - nsr = std::min(i__1,i__2); -/* Computing MAX */ - i__1 = 2, i__2 = nsr - nsr % 2; - nsr = std::max(i__1,i__2); - -/* ==== Estimate optimal workspace ==== */ - -/* ==== Workspace query call to DLAQR2 ==== */ - - i__1 = nwr + 1; - dlaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, - ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ - h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], - ldh, &work[1], &c_n1); - -/* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== */ - -/* Computing MAX */ - i__1 = nsr * 3 / 2, i__2 = (integer) work[1]; - lwkopt = std::max(i__1,i__2); - -/* ==== Quick return in case of workspace query. ==== */ - - if (*lwork == -1) { - work[1] = (double) lwkopt; - return 0; - } - -/* ==== DLAHQR/DLAQR0 crossover point ==== */ - - nmin = ilaenv_(&c__12, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); - nmin = std::max(11_integer,nmin); - -/* ==== Nibble crossover point ==== */ - - nibble = ilaenv_(&c__14, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); - nibble = std::max(0_integer,nibble); - -/* ==== Accumulate reflections during ttswp? Use block */ -/* . 2-by-2 structure during matrix-matrix multiply? ==== */ - - kacc22 = ilaenv_(&c__16, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); - kacc22 = std::max(0_integer,kacc22); - kacc22 = std::min(2_integer,kacc22); - -/* ==== NWMAX = the largest possible deflation window for */ -/* . which there is sufficient workspace. ==== */ - -/* Computing MIN */ - i__1 = (*n - 1) / 3, i__2 = *lwork / 2; - nwmax = std::min(i__1,i__2); - nw = nwmax; - -/* ==== NSMAX = the Largest number of simultaneous shifts */ -/* . for which there is sufficient workspace. ==== */ - -/* Computing MIN */ - i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3; - nsmax = std::min(i__1,i__2); - nsmax -= nsmax % 2; - -/* ==== NDFL: an iteration count restarted at deflation. ==== */ - - ndfl = 1; - -/* ==== ITMAX = iteration limit ==== */ - -/* Computing MAX */ - i__1 = 10, i__2 = *ihi - *ilo + 1; - itmax = std::max(i__1,i__2) * 30; - -/* ==== Last row and column in the active block ==== */ - - kbot = *ihi; - -/* ==== Main Loop ==== */ - - i__1 = itmax; - for (it = 1; it <= i__1; ++it) { - -/* ==== Done when KBOT falls below ILO ==== */ - - if (kbot < *ilo) { - goto L90; - } - -/* ==== Locate active block ==== */ - - i__2 = *ilo + 1; - for (k = kbot; k >= i__2; --k) { - if (h__[k + (k - 1) * h_dim1] == 0.) { - goto L20; - } -/* L10: */ - } - k = *ilo; -L20: - ktop = k; - -/* ==== Select deflation window size: */ -/* . Typical Case: */ -/* . If possible and advisable, nibble the entire */ -/* . active block. If not, use size MIN(NWR,NWMAX) */ -/* . or MIN(NWR+1,NWMAX) depending upon which has */ -/* . the smaller corresponding subdiagonal entry */ -/* . (a heuristic). */ -/* . */ -/* . Exceptional Case: */ -/* . If there have been no deflations in KEXNW or */ -/* . more iterations, then vary the deflation window */ -/* . size. At first, because, larger windows are, */ -/* . in general, more powerful than smaller ones, */ -/* . rapidly increase the window to the maximum possible. */ -/* . Then, gradually reduce the window size. ==== */ - - nh = kbot - ktop + 1; - nwupbd = std::min(nh,nwmax); - if (ndfl < 5) { - nw = std::min(nwupbd,nwr); - } else { -/* Computing MIN */ - i__2 = nwupbd, i__3 = nw << 1; - nw = std::min(i__2,i__3); - } - if (nw < nwmax) { - if (nw >= nh - 1) { - nw = nh; - } else { - kwtop = kbot - nw + 1; - if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) - > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], - abs(d__2))) { - ++nw; - } - } - } - if (ndfl < 5) { - ndec = -1; - } else if (ndec >= 0 || nw >= nwupbd) { - ++ndec; - if (nw - ndec < 2) { - ndec = 0; - } - nw -= ndec; - } - -/* ==== Aggressive early deflation: */ -/* . split workspace under the subdiagonal into */ -/* . - an nw-by-nw work array V in the lower */ -/* . left-hand-corner, */ -/* . - an NW-by-at-least-NW-but-more-is-better */ -/* . (NW-by-NHO) horizontal work array along */ -/* . the bottom edge, */ -/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ -/* . vertical work array along the left-hand-edge. */ -/* . ==== */ - - kv = *n - nw + 1; - kt = nw + 1; - nho = *n - nw - 1 - kt + 1; - kwv = nw + 2; - nve = *n - nw - kwv + 1; - -/* ==== Aggressive early deflation ==== */ - - dlaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, - iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], - &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], - ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); - -/* ==== Adjust KBOT accounting for new deflations. ==== */ - - kbot -= ld; - -/* ==== KS points to the shifts. ==== */ - - ks = kbot - ls + 1; - -/* ==== Skip an expensive QR sweep if there is a (partly */ -/* . heuristic) reason to expect that many eigenvalues */ -/* . will deflate without it. Here, the QR sweep is */ -/* . skipped if many eigenvalues have just been deflated */ -/* . or if the remaining active block is small. */ - - if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > std::min( - nmin,nwmax)) { - -/* ==== NS = nominal number of simultaneous shifts. */ -/* . This may be lowered (slightly) if DLAQR2 */ -/* . did not provide that many shifts. ==== */ - -/* Computing MIN */ -/* Computing MAX */ - i__4 = 2, i__5 = kbot - ktop; - i__2 = std::min(nsmax,nsr), i__3 = std::max(i__4,i__5); - ns = std::min(i__2,i__3); - ns -= ns % 2; - -/* ==== If there have been no deflations */ -/* . in a multiple of KEXSH iterations, */ -/* . then try exceptional shifts. */ -/* . Otherwise use shifts provided by */ -/* . DLAQR2 above or from the eigenvalues */ -/* . of a trailing principal submatrix. ==== */ - - if (ndfl % 6 == 0) { - ks = kbot - ns + 1; -/* Computing MAX */ - i__3 = ks + 1, i__4 = ktop + 2; - i__2 = std::max(i__3,i__4); - for (i__ = kbot; i__ >= i__2; i__ += -2) { - ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) - + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], - abs(d__2)); - aa = ss * .75 + h__[i__ + i__ * h_dim1]; - bb = ss; - cc = ss * -.4375; - dd = aa; - dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] -, &wr[i__], &wi[i__], &cs, &sn); -/* L30: */ - } - if (ks == ktop) { - wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; - wi[ks + 1] = 0.; - wr[ks] = wr[ks + 1]; - wi[ks] = wi[ks + 1]; - } - } else { - -/* ==== Got NS/2 or fewer shifts? Use DLAHQR */ -/* . on a trailing principal submatrix to */ -/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */ -/* . there is enough space below the subdiagonal */ -/* . to fit an NS-by-NS scratch array.) ==== */ - - if (kbot - ks + 1 <= ns / 2) { - ks = kbot - ns + 1; - kt = *n - ns + 1; - dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & - h__[kt + h_dim1], ldh); - dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt - + h_dim1], ldh, &wr[ks], &wi[ks], &c__1, & - c__1, zdum, &c__1, &inf); - ks += inf; - -/* ==== In case of a rare QR failure use */ -/* . eigenvalues of the trailing 2-by-2 */ -/* . principal submatrix. ==== */ - - if (ks >= kbot) { - aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; - cc = h__[kbot + (kbot - 1) * h_dim1]; - bb = h__[kbot - 1 + kbot * h_dim1]; - dd = h__[kbot + kbot * h_dim1]; - dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ - kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) - ; - ks = kbot - 1; - } - } - - if (kbot - ks + 1 > ns) { - -/* ==== Sort the shifts (Helps a little) */ -/* . Bubble sort keeps complex conjugate */ -/* . pairs together. ==== */ - - sorted = false; - i__2 = ks + 1; - for (k = kbot; k >= i__2; --k) { - if (sorted) { - goto L60; - } - sorted = true; - i__3 = k - 1; - for (i__ = ks; i__ <= i__3; ++i__) { - if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[ - i__], abs(d__2)) < (d__3 = wr[i__ + 1] - , abs(d__3)) + (d__4 = wi[i__ + 1], - abs(d__4))) { - sorted = false; - - swap = wr[i__]; - wr[i__] = wr[i__ + 1]; - wr[i__ + 1] = swap; - - swap = wi[i__]; - wi[i__] = wi[i__ + 1]; - wi[i__ + 1] = swap; - } -/* L40: */ - } -/* L50: */ - } -L60: - ; - } - -/* ==== Shuffle shifts into pairs of real shifts */ -/* . and pairs of complex conjugate shifts */ -/* . assuming complex conjugate shifts are */ -/* . already adjacent to one another. (Yes, */ -/* . they are.) ==== */ - - i__2 = ks + 2; - for (i__ = kbot; i__ >= i__2; i__ += -2) { - if (wi[i__] != -wi[i__ - 1]) { - - swap = wr[i__]; - wr[i__] = wr[i__ - 1]; - wr[i__ - 1] = wr[i__ - 2]; - wr[i__ - 2] = swap; - - swap = wi[i__]; - wi[i__] = wi[i__ - 1]; - wi[i__ - 1] = wi[i__ - 2]; - wi[i__ - 2] = swap; - } -/* L70: */ - } - } - -/* ==== If there are only two shifts and both are */ -/* . real, then use only one. ==== */ - - if (kbot - ks + 1 == 2) { - if (wi[kbot] == 0.) { - if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs( - d__1)) < (d__2 = wr[kbot - 1] - h__[kbot + - kbot * h_dim1], abs(d__2))) { - wr[kbot - 1] = wr[kbot]; - } else { - wr[kbot] = wr[kbot - 1]; - } - } - } - -/* ==== Use up to NS of the the smallest magnatiude */ -/* . shifts. If there aren't NS shifts available, */ -/* . then use them all, possibly dropping one to */ -/* . make the number of shifts even. ==== */ - -/* Computing MIN */ - i__2 = ns, i__3 = kbot - ks + 1; - ns = std::min(i__2,i__3); - ns -= ns % 2; - ks = kbot - ns + 1; - -/* ==== Small-bulge multi-shift QR sweep: */ -/* . split workspace under the subdiagonal into */ -/* . - a KDU-by-KDU work array U in the lower */ -/* . left-hand-corner, */ -/* . - a KDU-by-at-least-KDU-but-more-is-better */ -/* . (KDU-by-NHo) horizontal work array WH along */ -/* . the bottom edge, */ -/* . - and an at-least-KDU-but-more-is-better-by-KDU */ -/* . (NVE-by-KDU) vertical work WV arrow along */ -/* . the left-hand-edge. ==== */ - - kdu = ns * 3 - 3; - ku = *n - kdu + 1; - kwh = kdu + 1; - nho = *n - kdu - 3 - (kdu + 1) + 1; - kwv = kdu + 4; - nve = *n - kdu - kwv + 1; - -/* ==== Small-bulge multi-shift QR sweep ==== */ - - dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], - &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ - z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], - ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + - kwh * h_dim1], ldh); - } - -/* ==== Note progress (or the lack of it). ==== */ - - if (ld > 0) { - ndfl = 1; - } else { - ++ndfl; - } - -/* ==== End of main loop ==== */ -/* L80: */ - } - -/* ==== Iteration limit exceeded. Set INFO to show where */ -/* . the problem occurred and exit. ==== */ - - *info = kbot; -L90: - ; - } - -/* ==== Return the optimal value of LWORK. ==== */ - - work[1] = (double) lwkopt; - -/* ==== End of DLAQR4 ==== */ - - return 0; -} /* dlaqr4_ */ diff --git a/external/clapack/lapack/dlaqr5.cpp b/external/clapack/lapack/dlaqr5.cpp deleted file mode 100644 index 2764b4f0..00000000 --- a/external/clapack/lapack/dlaqr5.cpp +++ /dev/null @@ -1,992 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b7 = 0.; -static double c_b8 = 1.; -static integer c__3 = 3; -static integer c__1 = 1; -static integer c__2 = 2; - -int dlaqr5_(bool *wantt, bool *wantz, integer *kacc22, - integer *n, integer *ktop, integer *kbot, integer *nshfts, double - *sr, double *si, double *h__, integer *ldh, integer *iloz, - integer *ihiz, double *z__, integer *ldz, double *v, integer * - ldv, double *u, integer *ldu, integer *nv, double *wv, - integer *ldwv, integer *nh, double *wh, integer *ldwh) -{ - /* System generated locals */ - integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1, - wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, - i__4, i__5, i__6, i__7; - double d__1, d__2, d__3, d__4, d__5; - - /* Local variables */ - integer i__, j, k, m, i2, j2, i4, j4, k1; - double h11, h12, h21, h22; - integer m22, ns, nu; - double vt[3], scl; - integer kdu, kms; - double ulp; - integer knz, kzs; - double tst1, tst2, beta; - bool blk22, bmp22, accum; - integer mend, jcol, jlen, jbot, mbot, jtop, jrow, mtop; - integer ndcol, incol, krcol, nbmps; - double swap, alpha, safmin, safmax, refsum, smlnum; - integer mstart; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* This auxiliary subroutine called by DLAQR0 performs a */ -/* single small-bulge multi-shift QR sweep. */ - -/* WANTT (input) logical scalar */ -/* WANTT = .true. if the quasi-triangular Schur factor */ -/* is being computed. WANTT is set to .false. otherwise. */ - -/* WANTZ (input) logical scalar */ -/* WANTZ = .true. if the orthogonal Schur factor is being */ -/* computed. WANTZ is set to .false. otherwise. */ - -/* KACC22 (input) integer with value 0, 1, or 2. */ -/* Specifies the computation mode of far-from-diagonal */ -/* orthogonal updates. */ -/* = 0: DLAQR5 does not accumulate reflections and does not */ -/* use matrix-matrix multiply to update far-from-diagonal */ -/* matrix entries. */ -/* = 1: DLAQR5 accumulates reflections and uses matrix-matrix */ -/* multiply to update the far-from-diagonal matrix entries. */ -/* = 2: DLAQR5 accumulates reflections, uses matrix-matrix */ -/* multiply to update the far-from-diagonal matrix entries, */ -/* and takes advantage of 2-by-2 block structure during */ -/* matrix multiplies. */ - -/* N (input) integer scalar */ -/* N is the order of the Hessenberg matrix H upon which this */ -/* subroutine operates. */ - -/* KTOP (input) integer scalar */ -/* KBOT (input) integer scalar */ -/* These are the first and last rows and columns of an */ -/* isolated diagonal block upon which the QR sweep is to be */ -/* applied. It is assumed without a check that */ -/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */ -/* and */ -/* either KBOT = N or H(KBOT+1,KBOT) = 0. */ - -/* NSHFTS (input) integer scalar */ -/* NSHFTS gives the number of simultaneous shifts. NSHFTS */ -/* must be positive and even. */ - -/* SR (input/output) DOUBLE PRECISION array of size (NSHFTS) */ -/* SI (input/output) DOUBLE PRECISION array of size (NSHFTS) */ -/* SR contains the real parts and SI contains the imaginary */ -/* parts of the NSHFTS shifts of origin that define the */ -/* multi-shift QR sweep. On output SR and SI may be */ -/* reordered. */ - -/* H (input/output) DOUBLE PRECISION array of size (LDH,N) */ -/* On input H contains a Hessenberg matrix. On output a */ -/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */ -/* to the isolated diagonal block in rows and columns KTOP */ -/* through KBOT. */ - -/* LDH (input) integer scalar */ -/* LDH is the leading dimension of H just as declared in the */ -/* calling procedure. LDH.GE.MAX(1,N). */ - -/* ILOZ (input) INTEGER */ -/* IHIZ (input) INTEGER */ -/* Specify the rows of Z to which transformations must be */ -/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N */ - -/* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI) */ -/* If WANTZ = .TRUE., then the QR Sweep orthogonal */ -/* similarity transformation is accumulated into */ -/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */ -/* If WANTZ = .FALSE., then Z is unreferenced. */ - -/* LDZ (input) integer scalar */ -/* LDA is the leading dimension of Z just as declared in */ -/* the calling procedure. LDZ.GE.N. */ - -/* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2) */ - -/* LDV (input) integer scalar */ -/* LDV is the leading dimension of V as declared in the */ -/* calling procedure. LDV.GE.3. */ - -/* U (workspace) DOUBLE PRECISION array of size */ -/* (LDU,3*NSHFTS-3) */ - -/* LDU (input) integer scalar */ -/* LDU is the leading dimension of U just as declared in the */ -/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */ - -/* NH (input) integer scalar */ -/* NH is the number of columns in array WH available for */ -/* workspace. NH.GE.1. */ - -/* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH) */ - -/* LDWH (input) integer scalar */ -/* Leading dimension of WH just as declared in the */ -/* calling procedure. LDWH.GE.3*NSHFTS-3. */ - -/* NV (input) integer scalar */ -/* NV is the number of rows in WV agailable for workspace. */ -/* NV.GE.1. */ - -/* WV (workspace) DOUBLE PRECISION array of size */ -/* (LDWV,3*NSHFTS-3) */ - -/* LDWV (input) integer scalar */ -/* LDWV is the leading dimension of WV as declared in the */ -/* in the calling subroutine. LDWV.GE.NV. */ - -/* ================================================================ */ -/* Based on contributions by */ -/* Karen Braman and Ralph Byers, Department of Mathematics, */ -/* University of Kansas, USA */ - -/* ================================================================ */ -/* Reference: */ - -/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ -/* Algorithm Part I: Maintaining Well Focused Shifts, and */ -/* Level 3 Performance, SIAM Journal of Matrix Analysis, */ -/* volume 23, pages 929--947, 2002. */ - -/* ================================================================ */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ - -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* ==== If there are no shifts, then there is nothing to do. ==== */ - - /* Parameter adjustments */ - --sr; - --si; - h_dim1 = *ldh; - h_offset = 1 + h_dim1; - h__ -= h_offset; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - wv_dim1 = *ldwv; - wv_offset = 1 + wv_dim1; - wv -= wv_offset; - wh_dim1 = *ldwh; - wh_offset = 1 + wh_dim1; - wh -= wh_offset; - - /* Function Body */ - if (*nshfts < 2) { - return 0; - } - -/* ==== If the active block is empty or 1-by-1, then there */ -/* . is nothing to do. ==== */ - - if (*ktop >= *kbot) { - return 0; - } - -/* ==== Shuffle shifts into pairs of real shifts and pairs */ -/* . of complex conjugate shifts assuming complex */ -/* . conjugate shifts are already adjacent to one */ -/* . another. ==== */ - - i__1 = *nshfts - 2; - for (i__ = 1; i__ <= i__1; i__ += 2) { - if (si[i__] != -si[i__ + 1]) { - - swap = sr[i__]; - sr[i__] = sr[i__ + 1]; - sr[i__ + 1] = sr[i__ + 2]; - sr[i__ + 2] = swap; - - swap = si[i__]; - si[i__] = si[i__ + 1]; - si[i__ + 1] = si[i__ + 2]; - si[i__ + 2] = swap; - } -/* L10: */ - } - -/* ==== NSHFTS is supposed to be even, but if it is odd, */ -/* . then simply reduce it by one. The shuffle above */ -/* . ensures that the dropped shift is real and that */ -/* . the remaining shifts are paired. ==== */ - - ns = *nshfts - *nshfts % 2; - -/* ==== Machine constants for deflation ==== */ - - safmin = dlamch_("SAFE MINIMUM"); - safmax = 1. / safmin; - dlabad_(&safmin, &safmax); - ulp = dlamch_("PRECISION"); - smlnum = safmin * ((double) (*n) / ulp); - -/* ==== Use accumulated reflections to update far-from-diagonal */ -/* . entries ? ==== */ - - accum = *kacc22 == 1 || *kacc22 == 2; - -/* ==== If so, exploit the 2-by-2 block structure? ==== */ - - blk22 = ns > 2 && *kacc22 == 2; - -/* ==== clear trash ==== */ - - if (*ktop + 2 <= *kbot) { - h__[*ktop + 2 + *ktop * h_dim1] = 0.; - } - -/* ==== NBMPS = number of 2-shift bulges in the chain ==== */ - - nbmps = ns / 2; - -/* ==== KDU = width of slab ==== */ - - kdu = nbmps * 6 - 3; - -/* ==== Create and chase chains of NBMPS bulges ==== */ - - i__1 = *kbot - 2; - i__2 = nbmps * 3 - 2; - for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 : - incol <= i__1; incol += i__2) { - ndcol = incol + kdu; - if (accum) { - dlaset_("ALL", &kdu, &kdu, &c_b7, &c_b8, &u[u_offset], ldu); - } - -/* ==== Near-the-diagonal bulge chase. The following loop */ -/* . performs the near-the-diagonal part of a small bulge */ -/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */ -/* . chunk extends from column INCOL to column NDCOL */ -/* . (including both column INCOL and column NDCOL). The */ -/* . following loop chases a 3*NBMPS column long chain of */ -/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */ -/* . may be less than KTOP and and NDCOL may be greater than */ -/* . KBOT indicating phantom columns from which to chase */ -/* . bulges before they are actually introduced or to which */ -/* . to chase bulges beyond column KBOT.) ==== */ - -/* Computing MIN */ - i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2; - i__3 = std::min(i__4,i__5); - for (krcol = incol; krcol <= i__3; ++krcol) { - -/* ==== Bulges number MTOP to MBOT are active double implicit */ -/* . shift bulges. There may or may not also be small */ -/* . 2-by-2 bulge, if there is room. The inactive bulges */ -/* . (if any) must wait until the active bulges have moved */ -/* . down the diagonal to make room. The phantom matrix */ -/* . paradigm described above helps keep track. ==== */ - -/* Computing MAX */ - i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1; - mtop = std::max(i__4,i__5); -/* Computing MIN */ - i__4 = nbmps, i__5 = (*kbot - krcol) / 3; - mbot = std::min(i__4,i__5); - m22 = mbot + 1; - bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2; - -/* ==== Generate reflections to chase the chain right */ -/* . one column. (The minimum value of K is KTOP-1.) ==== */ - - i__4 = mbot; - for (m = mtop; m <= i__4; ++m) { - k = krcol + (m - 1) * 3; - if (k == *ktop - 1) { - dlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &sr[(m - << 1) - 1], &si[(m << 1) - 1], &sr[m * 2], &si[m * - 2], &v[m * v_dim1 + 1]); - alpha = v[m * v_dim1 + 1]; - dlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m * - v_dim1 + 1]); - } else { - beta = h__[k + 1 + k * h_dim1]; - v[m * v_dim1 + 2] = h__[k + 2 + k * h_dim1]; - v[m * v_dim1 + 3] = h__[k + 3 + k * h_dim1]; - dlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m * - v_dim1 + 1]); - -/* ==== A Bulge may collapse because of vigilant */ -/* . deflation or destructive underflow. In the */ -/* . underflow case, try the two-small-subdiagonals */ -/* . trick to try to reinflate the bulge. ==== */ - - if (h__[k + 3 + k * h_dim1] != 0. || h__[k + 3 + (k + 1) * - h_dim1] != 0. || h__[k + 3 + (k + 2) * h_dim1] == - 0.) { - -/* ==== Typical case: not collapsed (yet). ==== */ - - h__[k + 1 + k * h_dim1] = beta; - h__[k + 2 + k * h_dim1] = 0.; - h__[k + 3 + k * h_dim1] = 0.; - } else { - -/* ==== Atypical case: collapsed. Attempt to */ -/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */ -/* . If the fill resulting from the new */ -/* . reflector is too large, then abandon it. */ -/* . Otherwise, use the new one. ==== */ - - dlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, & - sr[(m << 1) - 1], &si[(m << 1) - 1], &sr[m * - 2], &si[m * 2], vt); - alpha = vt[0]; - dlarfg_(&c__3, &alpha, &vt[1], &c__1, vt); - refsum = vt[0] * (h__[k + 1 + k * h_dim1] + vt[1] * - h__[k + 2 + k * h_dim1]); - - if ((d__1 = h__[k + 2 + k * h_dim1] - refsum * vt[1], - abs(d__1)) + (d__2 = refsum * vt[2], abs(d__2) - ) > ulp * ((d__3 = h__[k + k * h_dim1], abs( - d__3)) + (d__4 = h__[k + 1 + (k + 1) * h_dim1] - , abs(d__4)) + (d__5 = h__[k + 2 + (k + 2) * - h_dim1], abs(d__5)))) { - -/* ==== Starting a new bulge here would */ -/* . create non-negligible fill. Use */ -/* . the old one with trepidation. ==== */ - - h__[k + 1 + k * h_dim1] = beta; - h__[k + 2 + k * h_dim1] = 0.; - h__[k + 3 + k * h_dim1] = 0.; - } else { - -/* ==== Stating a new bulge here would */ -/* . create only negligible fill. */ -/* . Replace the old reflector with */ -/* . the new one. ==== */ - - h__[k + 1 + k * h_dim1] -= refsum; - h__[k + 2 + k * h_dim1] = 0.; - h__[k + 3 + k * h_dim1] = 0.; - v[m * v_dim1 + 1] = vt[0]; - v[m * v_dim1 + 2] = vt[1]; - v[m * v_dim1 + 3] = vt[2]; - } - } - } -/* L20: */ - } - -/* ==== Generate a 2-by-2 reflection, if needed. ==== */ - - k = krcol + (m22 - 1) * 3; - if (bmp22) { - if (k == *ktop - 1) { - dlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[( - m22 << 1) - 1], &si[(m22 << 1) - 1], &sr[m22 * 2], - &si[m22 * 2], &v[m22 * v_dim1 + 1]); - beta = v[m22 * v_dim1 + 1]; - dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 - * v_dim1 + 1]); - } else { - beta = h__[k + 1 + k * h_dim1]; - v[m22 * v_dim1 + 2] = h__[k + 2 + k * h_dim1]; - dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 - * v_dim1 + 1]); - h__[k + 1 + k * h_dim1] = beta; - h__[k + 2 + k * h_dim1] = 0.; - } - } - -/* ==== Multiply H by reflections from the left ==== */ - - if (accum) { - jbot = std::min(ndcol,*kbot); - } else if (*wantt) { - jbot = *n; - } else { - jbot = *kbot; - } - i__4 = jbot; - for (j = std::max(*ktop,krcol); j <= i__4; ++j) { -/* Computing MIN */ - i__5 = mbot, i__6 = (j - krcol + 2) / 3; - mend = std::min(i__5,i__6); - i__5 = mend; - for (m = mtop; m <= i__5; ++m) { - k = krcol + (m - 1) * 3; - refsum = v[m * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + v[ - m * v_dim1 + 2] * h__[k + 2 + j * h_dim1] + v[m * - v_dim1 + 3] * h__[k + 3 + j * h_dim1]); - h__[k + 1 + j * h_dim1] -= refsum; - h__[k + 2 + j * h_dim1] -= refsum * v[m * v_dim1 + 2]; - h__[k + 3 + j * h_dim1] -= refsum * v[m * v_dim1 + 3]; -/* L30: */ - } -/* L40: */ - } - if (bmp22) { - k = krcol + (m22 - 1) * 3; -/* Computing MAX */ - i__4 = k + 1; - i__5 = jbot; - for (j = std::max(i__4,*ktop); j <= i__5; ++j) { - refsum = v[m22 * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + - v[m22 * v_dim1 + 2] * h__[k + 2 + j * h_dim1]); - h__[k + 1 + j * h_dim1] -= refsum; - h__[k + 2 + j * h_dim1] -= refsum * v[m22 * v_dim1 + 2]; -/* L50: */ - } - } - -/* ==== Multiply H by reflections from the right. */ -/* . Delay filling in the last row until the */ -/* . vigilant deflation check is complete. ==== */ - - if (accum) { - jtop = std::max(*ktop,incol); - } else if (*wantt) { - jtop = 1; - } else { - jtop = *ktop; - } - i__5 = mbot; - for (m = mtop; m <= i__5; ++m) { - if (v[m * v_dim1 + 1] != 0.) { - k = krcol + (m - 1) * 3; -/* Computing MIN */ - i__6 = *kbot, i__7 = k + 3; - i__4 = std::min(i__6,i__7); - for (j = jtop; j <= i__4; ++j) { - refsum = v[m * v_dim1 + 1] * (h__[j + (k + 1) * - h_dim1] + v[m * v_dim1 + 2] * h__[j + (k + 2) - * h_dim1] + v[m * v_dim1 + 3] * h__[j + (k + - 3) * h_dim1]); - h__[j + (k + 1) * h_dim1] -= refsum; - h__[j + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 + - 2]; - h__[j + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + - 3]; -/* L60: */ - } - - if (accum) { - -/* ==== Accumulate U. (If necessary, update Z later */ -/* . with with an efficient matrix-matrix */ -/* . multiply.) ==== */ - - kms = k - incol; -/* Computing MAX */ - i__4 = 1, i__6 = *ktop - incol; - i__7 = kdu; - for (j = std::max(i__4,i__6); j <= i__7; ++j) { - refsum = v[m * v_dim1 + 1] * (u[j + (kms + 1) * - u_dim1] + v[m * v_dim1 + 2] * u[j + (kms - + 2) * u_dim1] + v[m * v_dim1 + 3] * u[j - + (kms + 3) * u_dim1]); - u[j + (kms + 1) * u_dim1] -= refsum; - u[j + (kms + 2) * u_dim1] -= refsum * v[m * - v_dim1 + 2]; - u[j + (kms + 3) * u_dim1] -= refsum * v[m * - v_dim1 + 3]; -/* L70: */ - } - } else if (*wantz) { - -/* ==== U is not accumulated, so update Z */ -/* . now by multiplying by reflections */ -/* . from the right. ==== */ - - i__7 = *ihiz; - for (j = *iloz; j <= i__7; ++j) { - refsum = v[m * v_dim1 + 1] * (z__[j + (k + 1) * - z_dim1] + v[m * v_dim1 + 2] * z__[j + (k - + 2) * z_dim1] + v[m * v_dim1 + 3] * z__[ - j + (k + 3) * z_dim1]); - z__[j + (k + 1) * z_dim1] -= refsum; - z__[j + (k + 2) * z_dim1] -= refsum * v[m * - v_dim1 + 2]; - z__[j + (k + 3) * z_dim1] -= refsum * v[m * - v_dim1 + 3]; -/* L80: */ - } - } - } -/* L90: */ - } - -/* ==== Special case: 2-by-2 reflection (if needed) ==== */ - - k = krcol + (m22 - 1) * 3; - if (bmp22 && v[m22 * v_dim1 + 1] != 0.) { -/* Computing MIN */ - i__7 = *kbot, i__4 = k + 3; - i__5 = std::min(i__7,i__4); - for (j = jtop; j <= i__5; ++j) { - refsum = v[m22 * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1] - + v[m22 * v_dim1 + 2] * h__[j + (k + 2) * h_dim1]) - ; - h__[j + (k + 1) * h_dim1] -= refsum; - h__[j + (k + 2) * h_dim1] -= refsum * v[m22 * v_dim1 + 2]; -/* L100: */ - } - - if (accum) { - kms = k - incol; -/* Computing MAX */ - i__5 = 1, i__7 = *ktop - incol; - i__4 = kdu; - for (j = std::max(i__5,i__7); j <= i__4; ++j) { - refsum = v[m22 * v_dim1 + 1] * (u[j + (kms + 1) * - u_dim1] + v[m22 * v_dim1 + 2] * u[j + (kms + - 2) * u_dim1]); - u[j + (kms + 1) * u_dim1] -= refsum; - u[j + (kms + 2) * u_dim1] -= refsum * v[m22 * v_dim1 - + 2]; -/* L110: */ - } - } else if (*wantz) { - i__4 = *ihiz; - for (j = *iloz; j <= i__4; ++j) { - refsum = v[m22 * v_dim1 + 1] * (z__[j + (k + 1) * - z_dim1] + v[m22 * v_dim1 + 2] * z__[j + (k + - 2) * z_dim1]); - z__[j + (k + 1) * z_dim1] -= refsum; - z__[j + (k + 2) * z_dim1] -= refsum * v[m22 * v_dim1 - + 2]; -/* L120: */ - } - } - } - -/* ==== Vigilant deflation check ==== */ - - mstart = mtop; - if (krcol + (mstart - 1) * 3 < *ktop) { - ++mstart; - } - mend = mbot; - if (bmp22) { - ++mend; - } - if (krcol == *kbot - 2) { - ++mend; - } - i__4 = mend; - for (m = mstart; m <= i__4; ++m) { -/* Computing MIN */ - i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3; - k = std::min(i__5,i__7); - -/* ==== The following convergence test requires that */ -/* . the tradition small-compared-to-nearby-diagonals */ -/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */ -/* . criteria both be satisfied. The latter improves */ -/* . accuracy in some examples. Falling back on an */ -/* . alternate convergence criterion when TST1 or TST2 */ -/* . is zero (as done here) is traditional but probably */ -/* . unnecessary. ==== */ - - if (h__[k + 1 + k * h_dim1] != 0.) { - tst1 = (d__1 = h__[k + k * h_dim1], abs(d__1)) + (d__2 = - h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); - if (tst1 == 0.) { - if (k >= *ktop + 1) { - tst1 += (d__1 = h__[k + (k - 1) * h_dim1], abs( - d__1)); - } - if (k >= *ktop + 2) { - tst1 += (d__1 = h__[k + (k - 2) * h_dim1], abs( - d__1)); - } - if (k >= *ktop + 3) { - tst1 += (d__1 = h__[k + (k - 3) * h_dim1], abs( - d__1)); - } - if (k <= *kbot - 2) { - tst1 += (d__1 = h__[k + 2 + (k + 1) * h_dim1], - abs(d__1)); - } - if (k <= *kbot - 3) { - tst1 += (d__1 = h__[k + 3 + (k + 1) * h_dim1], - abs(d__1)); - } - if (k <= *kbot - 4) { - tst1 += (d__1 = h__[k + 4 + (k + 1) * h_dim1], - abs(d__1)); - } - } -/* Computing MAX */ - d__2 = smlnum, d__3 = ulp * tst1; - if ((d__1 = h__[k + 1 + k * h_dim1], abs(d__1)) <= std::max( - d__2,d__3)) { -/* Computing MAX */ - d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)), - d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs( - d__2)); - h12 = std::max(d__3,d__4); -/* Computing MIN */ - d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)), - d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs( - d__2)); - h21 = std::min(d__3,d__4); -/* Computing MAX */ - d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs( - d__1)), d__4 = (d__2 = h__[k + k * h_dim1] - - h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); - h11 = std::max(d__3,d__4); -/* Computing MIN */ - d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs( - d__1)), d__4 = (d__2 = h__[k + k * h_dim1] - - h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); - h22 = std::min(d__3,d__4); - scl = h11 + h12; - tst2 = h22 * (h11 / scl); - -/* Computing MAX */ - d__1 = smlnum, d__2 = ulp * tst2; - if (tst2 == 0. || h21 * (h12 / scl) <= std::max(d__1,d__2)) - { - h__[k + 1 + k * h_dim1] = 0.; - } - } - } -/* L130: */ - } - -/* ==== Fill in the last row of each bulge. ==== */ - -/* Computing MIN */ - i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3; - mend = std::min(i__4,i__5); - i__4 = mend; - for (m = mtop; m <= i__4; ++m) { - k = krcol + (m - 1) * 3; - refsum = v[m * v_dim1 + 1] * v[m * v_dim1 + 3] * h__[k + 4 + ( - k + 3) * h_dim1]; - h__[k + 4 + (k + 1) * h_dim1] = -refsum; - h__[k + 4 + (k + 2) * h_dim1] = -refsum * v[m * v_dim1 + 2]; - h__[k + 4 + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3]; -/* L140: */ - } - -/* ==== End of near-the-diagonal bulge chase. ==== */ - -/* L150: */ - } - -/* ==== Use U (if accumulated) to update far-from-diagonal */ -/* . entries in H. If required, use U to update Z as */ -/* . well. ==== */ - - if (accum) { - if (*wantt) { - jtop = 1; - jbot = *n; - } else { - jtop = *ktop; - jbot = *kbot; - } - if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) { - -/* ==== Updates not exploiting the 2-by-2 block */ -/* . structure of U. K1 and NU keep track of */ -/* . the location and size of U in the special */ -/* . cases of introducing bulges and chasing */ -/* . bulges off the bottom. In these special */ -/* . cases and in case the number of shifts */ -/* . is NS = 2, there is no 2-by-2 block */ -/* . structure to exploit. ==== */ - -/* Computing MAX */ - i__3 = 1, i__4 = *ktop - incol; - k1 = std::max(i__3,i__4); -/* Computing MAX */ - i__3 = 0, i__4 = ndcol - *kbot; - nu = kdu - std::max(i__3,i__4) - k1 + 1; - -/* ==== Horizontal Multiply ==== */ - - i__3 = jbot; - i__4 = *nh; - for (jcol = std::min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 : - jcol <= i__3; jcol += i__4) { -/* Computing MIN */ - i__5 = *nh, i__7 = jbot - jcol + 1; - jlen = std::min(i__5,i__7); - dgemm_("C", "N", &nu, &jlen, &nu, &c_b8, &u[k1 + k1 * - u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1], - ldh, &c_b7, &wh[wh_offset], ldwh); - dlacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[ - incol + k1 + jcol * h_dim1], ldh); -/* L160: */ - } - -/* ==== Vertical multiply ==== */ - - i__4 = std::max(*ktop,incol) - 1; - i__3 = *nv; - for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4; - jrow += i__3) { -/* Computing MIN */ - i__5 = *nv, i__7 = std::max(*ktop,incol) - jrow; - jlen = std::min(i__5,i__7); - dgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &h__[jrow + ( - incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1], - ldu, &c_b7, &wv[wv_offset], ldwv); - dlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[ - jrow + (incol + k1) * h_dim1], ldh); -/* L170: */ - } - -/* ==== Z multiply (also vertical) ==== */ - - if (*wantz) { - i__3 = *ihiz; - i__4 = *nv; - for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3; - jrow += i__4) { -/* Computing MIN */ - i__5 = *nv, i__7 = *ihiz - jrow + 1; - jlen = std::min(i__5,i__7); - dgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &z__[jrow + ( - incol + k1) * z_dim1], ldz, &u[k1 + k1 * - u_dim1], ldu, &c_b7, &wv[wv_offset], ldwv); - dlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[ - jrow + (incol + k1) * z_dim1], ldz) - ; -/* L180: */ - } - } - } else { - -/* ==== Updates exploiting U's 2-by-2 block structure. */ -/* . (I2, I4, J2, J4 are the last rows and columns */ -/* . of the blocks.) ==== */ - - i2 = (kdu + 1) / 2; - i4 = kdu; - j2 = i4 - i2; - j4 = kdu; - -/* ==== KZS and KNZ deal with the band of zeros */ -/* . along the diagonal of one of the triangular */ -/* . blocks. ==== */ - - kzs = j4 - j2 - (ns + 1); - knz = ns + 1; - -/* ==== Horizontal multiply ==== */ - - i__4 = jbot; - i__3 = *nh; - for (jcol = std::min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 : - jcol <= i__4; jcol += i__3) { -/* Computing MIN */ - i__5 = *nh, i__7 = jbot - jcol + 1; - jlen = std::min(i__5,i__7); - -/* ==== Copy bottom of H to top+KZS of scratch ==== */ -/* (The first KZS rows get multiplied by zero.) ==== */ - - dlacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol * - h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh); - -/* ==== Multiply by U21' ==== */ - - dlaset_("ALL", &kzs, &jlen, &c_b7, &c_b7, &wh[wh_offset], - ldwh); - dtrmm_("L", "U", "C", "N", &knz, &jlen, &c_b8, &u[j2 + 1 - + (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1] -, ldwh); - -/* ==== Multiply top of H by U11' ==== */ - - dgemm_("C", "N", &i2, &jlen, &j2, &c_b8, &u[u_offset], - ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b8, - &wh[wh_offset], ldwh); - -/* ==== Copy top of H to bottom of WH ==== */ - - dlacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1] -, ldh, &wh[i2 + 1 + wh_dim1], ldwh); - -/* ==== Multiply by U21' ==== */ - - dtrmm_("L", "L", "C", "N", &j2, &jlen, &c_b8, &u[(i2 + 1) - * u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh); - -/* ==== Multiply by U22 ==== */ - - i__5 = i4 - i2; - i__7 = j4 - j2; - dgemm_("C", "N", &i__5, &jlen, &i__7, &c_b8, &u[j2 + 1 + ( - i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 + - jcol * h_dim1], ldh, &c_b8, &wh[i2 + 1 + wh_dim1], - ldwh); - -/* ==== Copy it back ==== */ - - dlacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[ - incol + 1 + jcol * h_dim1], ldh); -/* L190: */ - } - -/* ==== Vertical multiply ==== */ - - i__3 = std::max(incol,*ktop) - 1; - i__4 = *nv; - for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3; - jrow += i__4) { -/* Computing MIN */ - i__5 = *nv, i__7 = std::max(incol,*ktop) - jrow; - jlen = std::min(i__5,i__7); - -/* ==== Copy right of H to scratch (the first KZS */ -/* . columns get multiplied by zero) ==== */ - - dlacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) * - h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv); - -/* ==== Multiply by U21 ==== */ - - dlaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[wv_offset], - ldwv); - dtrmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 + 1 - + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) * - wv_dim1 + 1], ldwv); - -/* ==== Multiply by U11 ==== */ - - dgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &h__[jrow + ( - incol + 1) * h_dim1], ldh, &u[u_offset], ldu, & - c_b8, &wv[wv_offset], ldwv); - -/* ==== Copy left of H to right of scratch ==== */ - - dlacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) * - h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv); - -/* ==== Multiply by U21 ==== */ - - i__5 = i4 - i2; - dtrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(i2 + - 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1] -, ldwv); - -/* ==== Multiply by U22 ==== */ - - i__5 = i4 - i2; - i__7 = j4 - j2; - dgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &h__[jrow + ( - incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 + - 1) * u_dim1], ldu, &c_b8, &wv[(i2 + 1) * wv_dim1 - + 1], ldwv); - -/* ==== Copy it back ==== */ - - dlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[ - jrow + (incol + 1) * h_dim1], ldh); -/* L200: */ - } - -/* ==== Multiply Z (also vertical) ==== */ - - if (*wantz) { - i__4 = *ihiz; - i__3 = *nv; - for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4; - jrow += i__3) { -/* Computing MIN */ - i__5 = *nv, i__7 = *ihiz - jrow + 1; - jlen = std::min(i__5,i__7); - -/* ==== Copy right of Z to left of scratch (first */ -/* . KZS columns get multiplied by zero) ==== */ - - dlacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 + - j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 + - 1], ldwv); - -/* ==== Multiply by U12 ==== */ - - dlaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[ - wv_offset], ldwv); - dtrmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 - + 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) - * wv_dim1 + 1], ldwv); - -/* ==== Multiply by U11 ==== */ - - dgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &z__[jrow + ( - incol + 1) * z_dim1], ldz, &u[u_offset], ldu, - &c_b8, &wv[wv_offset], ldwv); - -/* ==== Copy left of Z to right of scratch ==== */ - - dlacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) * - z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1], - ldwv); - -/* ==== Multiply by U21 ==== */ - - i__5 = i4 - i2; - dtrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[( - i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * - wv_dim1 + 1], ldwv); - -/* ==== Multiply by U22 ==== */ - - i__5 = i4 - i2; - i__7 = j4 - j2; - dgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &z__[ - jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2 - + 1 + (i2 + 1) * u_dim1], ldu, &c_b8, &wv[(i2 - + 1) * wv_dim1 + 1], ldwv); - -/* ==== Copy the result back to Z ==== */ - - dlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, & - z__[jrow + (incol + 1) * z_dim1], ldz); -/* L210: */ - } - } - } - } -/* L220: */ - } - -/* ==== End of DLAQR5 ==== */ - - return 0; -} /* dlaqr5_ */ diff --git a/external/clapack/lapack/dlaqsb.cpp b/external/clapack/lapack/dlaqsb.cpp deleted file mode 100644 index ee516dc8..00000000 --- a/external/clapack/lapack/dlaqsb.cpp +++ /dev/null @@ -1,173 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaqsb_(const char *uplo, integer *n, integer *kd, double * - ab, integer *ldab, double *s, double *scond, double *amax, - const char *equed) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j; - double cj, large; - - double small; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQSB equilibrates a symmetric band matrix A using the scaling */ -/* factors in the vector S. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of super-diagonals of the matrix A if UPLO = 'U', */ -/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* On exit, if INFO = 0, the triangular factor U or L from the */ -/* Cholesky factorization A = U'*U or A = L*L' of the band */ -/* matrix A, in the same storage format as A. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* S (input) DOUBLE PRECISION array, dimension (N) */ -/* The scale factors for A. */ - -/* SCOND (input) DOUBLE PRECISION */ -/* Ratio of the smallest S(i) to the largest S(i). */ - -/* AMAX (input) DOUBLE PRECISION */ -/* Absolute value of largest matrix entry. */ - -/* EQUED (output) CHARACTER*1 */ -/* Specifies whether or not equilibration was done. */ -/* = 'N': No equilibration. */ -/* = 'Y': Equilibration was done, i.e., A has been replaced by */ -/* diag(S) * A * diag(S). */ - -/* Internal Parameters */ -/* =================== */ - -/* THRESH is a threshold value used to decide if scaling should be done */ -/* based on the ratio of the scaling factors. If SCOND < THRESH, */ -/* scaling is done. */ - -/* LARGE and SMALL are threshold values used to decide if scaling should */ -/* be done based on the absolute size of the largest matrix element. */ -/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --s; - - /* Function Body */ - if (*n <= 0) { - *(unsigned char *)equed = 'N'; - return 0; - } - -/* Initialize LARGE and SMALL. */ - - small = dlamch_("Safe minimum") / dlamch_("Precision"); - large = 1. / small; - - if (*scond >= .1 && *amax >= small && *amax <= large) { - -/* No equilibration */ - - *(unsigned char *)equed = 'N'; - } else { - -/* Replace A by diag(S) * A * diag(S). */ - - if (lsame_(uplo, "U")) { - -/* Upper triangle of A is stored in band format. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = s[j]; -/* Computing MAX */ - i__2 = 1, i__3 = j - *kd; - i__4 = j; - for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { - ab[*kd + 1 + i__ - j + j * ab_dim1] = cj * s[i__] * ab[* - kd + 1 + i__ - j + j * ab_dim1]; -/* L10: */ - } -/* L20: */ - } - } else { - -/* Lower triangle of A is stored. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = s[j]; -/* Computing MIN */ - i__2 = *n, i__3 = j + *kd; - i__4 = std::min(i__2,i__3); - for (i__ = j; i__ <= i__4; ++i__) { - ab[i__ + 1 - j + j * ab_dim1] = cj * s[i__] * ab[i__ + 1 - - j + j * ab_dim1]; -/* L30: */ - } -/* L40: */ - } - } - *(unsigned char *)equed = 'Y'; - } - - return 0; - -/* End of DLAQSB */ - -} /* dlaqsb_ */ diff --git a/external/clapack/lapack/dlaqsp.cpp b/external/clapack/lapack/dlaqsp.cpp deleted file mode 100644 index cdcd003f..00000000 --- a/external/clapack/lapack/dlaqsp.cpp +++ /dev/null @@ -1,157 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaqsp_(const char *uplo, integer *n, double *ap, - double *s, double *scond, double *amax, char *equed) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j, jc; - double cj, large; - - double small; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQSP equilibrates a symmetric matrix A using the scaling factors */ -/* in the vector S. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */ -/* the same storage format as A. */ - -/* S (input) DOUBLE PRECISION array, dimension (N) */ -/* The scale factors for A. */ - -/* SCOND (input) DOUBLE PRECISION */ -/* Ratio of the smallest S(i) to the largest S(i). */ - -/* AMAX (input) DOUBLE PRECISION */ -/* Absolute value of largest matrix entry. */ - -/* EQUED (output) CHARACTER*1 */ -/* Specifies whether or not equilibration was done. */ -/* = 'N': No equilibration. */ -/* = 'Y': Equilibration was done, i.e., A has been replaced by */ -/* diag(S) * A * diag(S). */ - -/* Internal Parameters */ -/* =================== */ - -/* THRESH is a threshold value used to decide if scaling should be done */ -/* based on the ratio of the scaling factors. If SCOND < THRESH, */ -/* scaling is done. */ - -/* LARGE and SMALL are threshold values used to decide if scaling should */ -/* be done based on the absolute size of the largest matrix element. */ -/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - --s; - --ap; - - /* Function Body */ - if (*n <= 0) { - *(unsigned char *)equed = 'N'; - return 0; - } - -/* Initialize LARGE and SMALL. */ - - small = dlamch_("Safe minimum") / dlamch_("Precision"); - large = 1. / small; - - if (*scond >= .1 && *amax >= small && *amax <= large) { - -/* No equilibration */ - - *(unsigned char *)equed = 'N'; - } else { - -/* Replace A by diag(S) * A * diag(S). */ - - if (lsame_(uplo, "U")) { - -/* Upper triangle of A is stored. */ - - jc = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = s[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - ap[jc + i__ - 1] = cj * s[i__] * ap[jc + i__ - 1]; -/* L10: */ - } - jc += j; -/* L20: */ - } - } else { - -/* Lower triangle of A is stored. */ - - jc = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = s[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - ap[jc + i__ - j] = cj * s[i__] * ap[jc + i__ - j]; -/* L30: */ - } - jc = jc + *n - j + 1; -/* L40: */ - } - } - *(unsigned char *)equed = 'Y'; - } - - return 0; - -/* End of DLAQSP */ - -} /* dlaqsp_ */ diff --git a/external/clapack/lapack/dlaqsy.cpp b/external/clapack/lapack/dlaqsy.cpp deleted file mode 100644 index adc75b98..00000000 --- a/external/clapack/lapack/dlaqsy.cpp +++ /dev/null @@ -1,160 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaqsy_(const char *uplo, integer *n, double *a, integer * - lda, double *s, double *scond, double *amax, char *equed) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - double cj, large; - - double small; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQSY equilibrates a symmetric matrix A using the scaling factors */ -/* in the vector S. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n by n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if EQUED = 'Y', the equilibrated matrix: */ -/* diag(S) * A * diag(S). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(N,1). */ - -/* S (input) DOUBLE PRECISION array, dimension (N) */ -/* The scale factors for A. */ - -/* SCOND (input) DOUBLE PRECISION */ -/* Ratio of the smallest S(i) to the largest S(i). */ - -/* AMAX (input) DOUBLE PRECISION */ -/* Absolute value of largest matrix entry. */ - -/* EQUED (output) CHARACTER*1 */ -/* Specifies whether or not equilibration was done. */ -/* = 'N': No equilibration. */ -/* = 'Y': Equilibration was done, i.e., A has been replaced by */ -/* diag(S) * A * diag(S). */ - -/* Internal Parameters */ -/* =================== */ - -/* THRESH is a threshold value used to decide if scaling should be done */ -/* based on the ratio of the scaling factors. If SCOND < THRESH, */ -/* scaling is done. */ - -/* LARGE and SMALL are threshold values used to decide if scaling should */ -/* be done based on the absolute size of the largest matrix element. */ -/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --s; - - /* Function Body */ - if (*n <= 0) { - *(unsigned char *)equed = 'N'; - return 0; - } - -/* Initialize LARGE and SMALL. */ - - small = dlamch_("Safe minimum") / dlamch_("Precision"); - large = 1. / small; - - if (*scond >= .1 && *amax >= small && *amax <= large) { - -/* No equilibration */ - - *(unsigned char *)equed = 'N'; - } else { - -/* Replace A by diag(S) * A * diag(S). */ - - if (lsame_(uplo, "U")) { - -/* Upper triangle of A is stored. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = s[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1]; -/* L10: */ - } -/* L20: */ - } - } else { - -/* Lower triangle of A is stored. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - cj = s[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1]; -/* L30: */ - } -/* L40: */ - } - } - *(unsigned char *)equed = 'Y'; - } - - return 0; - -/* End of DLAQSY */ - -} /* dlaqsy_ */ diff --git a/external/clapack/lapack/dlaqtr.cpp b/external/clapack/lapack/dlaqtr.cpp deleted file mode 100644 index 021b52f3..00000000 --- a/external/clapack/lapack/dlaqtr.cpp +++ /dev/null @@ -1,804 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static bool c_false = false; -static integer c__2 = 2; -static double c_b21 = 1.; -static double c_b25 = 0.; -static bool c_true = true; - -/* Subroutine */ int dlaqtr_(bool *ltran, bool *lreal, integer *n, - double *t, integer *ldt, double *b, double *w, double - *scale, double *x, double *work, integer *info) -{ - /* System generated locals */ - integer t_dim1, t_offset, i__1, i__2; - double d__1, d__2, d__3, d__4, d__5, d__6; - - /* Local variables */ - double d__[4] /* was [2][2] */; - integer i__, j, k; - double v[4] /* was [2][2] */, z__; - integer j1, j2, n1, n2; - double si, xj, sr, rec, eps, tjj, tmp; - integer ierr; - double smin, xmax; - integer jnext; - double sminw, xnorm; - double scaloc; - double bignum; - bool notran; - double smlnum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAQTR solves the real quasi-triangular system */ - -/* op(T)*p = scale*c, if LREAL = .TRUE. */ - -/* or the complex quasi-triangular systems */ - -/* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */ - -/* in real arithmetic, where T is upper quasi-triangular. */ -/* If LREAL = .FALSE., then the first diagonal block of T must be */ -/* 1 by 1, B is the specially structured matrix */ - -/* B = [ b(1) b(2) ... b(n) ] */ -/* [ w ] */ -/* [ w ] */ -/* [ . ] */ -/* [ w ] */ - -/* op(A) = A or A', A' denotes the conjugate transpose of */ -/* matrix A. */ - -/* On input, X = [ c ]. On output, X = [ p ]. */ -/* [ d ] [ q ] */ - -/* This subroutine is designed for the condition number estimation */ -/* in routine DTRSNA. */ - -/* Arguments */ -/* ========= */ - -/* LTRAN (input) LOGICAL */ -/* On entry, LTRAN specifies the option of conjugate transpose: */ -/* = .FALSE., op(T+i*B) = T+i*B, */ -/* = .TRUE., op(T+i*B) = (T+i*B)'. */ - -/* LREAL (input) LOGICAL */ -/* On entry, LREAL specifies the input matrix structure: */ -/* = .FALSE., the input is complex */ -/* = .TRUE., the input is real */ - -/* N (input) INTEGER */ -/* On entry, N specifies the order of T+i*B. N >= 0. */ - -/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */ -/* On entry, T contains a matrix in Schur canonical form. */ -/* If LREAL = .FALSE., then the first diagonal block of T mu */ -/* be 1 by 1. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the matrix T. LDT >= max(1,N). */ - -/* B (input) DOUBLE PRECISION array, dimension (N) */ -/* On entry, B contains the elements to form the matrix */ -/* B as described above. */ -/* If LREAL = .TRUE., B is not referenced. */ - -/* W (input) DOUBLE PRECISION */ -/* On entry, W is the diagonal element of the matrix B. */ -/* If LREAL = .TRUE., W is not referenced. */ - -/* SCALE (output) DOUBLE PRECISION */ -/* On exit, SCALE is the scale factor. */ - -/* X (input/output) DOUBLE PRECISION array, dimension (2*N) */ -/* On entry, X contains the right hand side of the system. */ -/* On exit, X is overwritten by the solution. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* On exit, INFO is set to */ -/* 0: successful exit. */ -/* 1: the some diagonal 1 by 1 block has been perturbed by */ -/* a small number SMIN to keep nonsingularity. */ -/* 2: the some diagonal 2 by 2 block has been perturbed by */ -/* a small number in DLALN2 to keep nonsingularity. */ -/* NOTE: In the interests of speed, this routine does not */ -/* check the inputs for errors. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Do not test the input parameters for errors */ - - /* Parameter adjustments */ - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - --b; - --x; - --work; - - /* Function Body */ - notran = ! (*ltran); - *info = 0; - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Set constants to control overflow */ - - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; - bignum = 1. / smlnum; - - xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__); - if (! (*lreal)) { -/* Computing MAX */ - d__1 = xnorm, d__2 = abs(*w), d__1 = std::max(d__1,d__2), d__2 = dlange_( - "M", n, &c__1, &b[1], n, d__); - xnorm = std::max(d__1,d__2); - } -/* Computing MAX */ - d__1 = smlnum, d__2 = eps * xnorm; - smin = std::max(d__1,d__2); - -/* Compute 1-norm of each column of strictly upper triangular */ -/* part of T to control overflow in triangular solver. */ - - work[1] = 0.; - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - i__2 = j - 1; - work[j] = dasum_(&i__2, &t[j * t_dim1 + 1], &c__1); -/* L10: */ - } - - if (! (*lreal)) { - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - work[i__] += (d__1 = b[i__], abs(d__1)); -/* L20: */ - } - } - - n2 = *n << 1; - n1 = *n; - if (! (*lreal)) { - n1 = n2; - } - k = idamax_(&n1, &x[1], &c__1); - xmax = (d__1 = x[k], abs(d__1)); - *scale = 1.; - - if (xmax > bignum) { - *scale = bignum / xmax; - dscal_(&n1, scale, &x[1], &c__1); - xmax = bignum; - } - - if (*lreal) { - - if (notran) { - -/* Solve T*p = scale*c */ - - jnext = *n; - for (j = *n; j >= 1; --j) { - if (j > jnext) { - goto L30; - } - j1 = j; - j2 = j; - jnext = j - 1; - if (j > 1) { - if (t[j + (j - 1) * t_dim1] != 0.) { - j1 = j - 1; - jnext = j - 2; - } - } - - if (j1 == j2) { - -/* Meet 1 by 1 diagonal block */ - -/* Scale to avoid overflow when computing */ -/* x(j) = b(j)/T(j,j) */ - - xj = (d__1 = x[j1], abs(d__1)); - tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)); - tmp = t[j1 + j1 * t_dim1]; - if (tjj < smin) { - tmp = smin; - tjj = smin; - *info = 1; - } - - if (xj == 0.) { - goto L30; - } - - if (tjj < 1.) { - if (xj > bignum * tjj) { - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j1] /= tmp; - xj = (d__1 = x[j1], abs(d__1)); - -/* Scale x if necessary to avoid overflow when adding a */ -/* multiple of column j1 of T. */ - - if (xj > 1.) { - rec = 1. / xj; - if (work[j1] > (bignum - xmax) * rec) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - } - } - if (j1 > 1) { - i__1 = j1 - 1; - d__1 = -x[j1]; - daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] -, &c__1); - i__1 = j1 - 1; - k = idamax_(&i__1, &x[1], &c__1); - xmax = (d__1 = x[k], abs(d__1)); - } - - } else { - -/* Meet 2 by 2 diagonal block */ - -/* Call 2 by 2 linear system solve, to take */ -/* care of possible overflow by scaling factor. */ - - d__[0] = x[j1]; - d__[1] = x[j2]; - dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 - * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & - c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 2; - } - - if (scaloc != 1.) { - dscal_(n, &scaloc, &x[1], &c__1); - *scale *= scaloc; - } - x[j1] = v[0]; - x[j2] = v[1]; - -/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */ -/* to avoid overflow in updating right-hand side. */ - -/* Computing MAX */ - d__1 = abs(v[0]), d__2 = abs(v[1]); - xj = std::max(d__1,d__2); - if (xj > 1.) { - rec = 1. / xj; -/* Computing MAX */ - d__1 = work[j1], d__2 = work[j2]; - if (std::max(d__1,d__2) > (bignum - xmax) * rec) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - } - } - -/* Update right-hand side */ - - if (j1 > 1) { - i__1 = j1 - 1; - d__1 = -x[j1]; - daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] -, &c__1); - i__1 = j1 - 1; - d__1 = -x[j2]; - daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] -, &c__1); - i__1 = j1 - 1; - k = idamax_(&i__1, &x[1], &c__1); - xmax = (d__1 = x[k], abs(d__1)); - } - - } - -L30: - ; - } - - } else { - -/* Solve T'*p = scale*c */ - - jnext = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (j < jnext) { - goto L40; - } - j1 = j; - j2 = j; - jnext = j + 1; - if (j < *n) { - if (t[j + 1 + j * t_dim1] != 0.) { - j2 = j + 1; - jnext = j + 2; - } - } - - if (j1 == j2) { - -/* 1 by 1 diagonal block */ - -/* Scale if necessary to avoid overflow in forming the */ -/* right-hand side element by inner product. */ - - xj = (d__1 = x[j1], abs(d__1)); - if (xmax > 1.) { - rec = 1. / xmax; - if (work[j1] > (bignum - xj) * rec) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - i__2 = j1 - 1; - x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & - c__1); - - xj = (d__1 = x[j1], abs(d__1)); - tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)); - tmp = t[j1 + j1 * t_dim1]; - if (tjj < smin) { - tmp = smin; - tjj = smin; - *info = 1; - } - - if (tjj < 1.) { - if (xj > bignum * tjj) { - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j1] /= tmp; -/* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1)); - xmax = std::max(d__2,d__3); - - } else { - -/* 2 by 2 diagonal block */ - -/* Scale if necessary to avoid overflow in forming the */ -/* right-hand side elements by inner product. */ - -/* Computing MAX */ - d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2], - abs(d__2)); - xj = std::max(d__3,d__4); - if (xmax > 1.) { - rec = 1. / xmax; -/* Computing MAX */ - d__1 = work[j2], d__2 = work[j1]; - if (std::max(d__1,d__2) > (bignum - xj) * rec) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - i__2 = j1 - 1; - d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, - &x[1], &c__1); - i__2 = j1 - 1; - d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, - &x[1], &c__1); - - dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 * - t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, - &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 2; - } - - if (scaloc != 1.) { - dscal_(n, &scaloc, &x[1], &c__1); - *scale *= scaloc; - } - x[j1] = v[0]; - x[j2] = v[1]; -/* Computing MAX */ - d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2], - abs(d__2)), d__3 = std::max(d__3,d__4); - xmax = std::max(d__3,xmax); - - } -L40: - ; - } - } - - } else { - -/* Computing MAX */ - d__1 = eps * abs(*w); - sminw = std::max(d__1,smin); - if (notran) { - -/* Solve (T + iB)*(p+iq) = c+id */ - - jnext = *n; - for (j = *n; j >= 1; --j) { - if (j > jnext) { - goto L70; - } - j1 = j; - j2 = j; - jnext = j - 1; - if (j > 1) { - if (t[j + (j - 1) * t_dim1] != 0.) { - j1 = j - 1; - jnext = j - 2; - } - } - - if (j1 == j2) { - -/* 1 by 1 diagonal block */ - -/* Scale if necessary to avoid overflow in division */ - - z__ = *w; - if (j1 == 1) { - z__ = b[1]; - } - xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs( - d__2)); - tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__); - tmp = t[j1 + j1 * t_dim1]; - if (tjj < sminw) { - tmp = sminw; - tjj = sminw; - *info = 1; - } - - if (xj == 0.) { - goto L70; - } - - if (tjj < 1.) { - if (xj > bignum * tjj) { - rec = 1. / xj; - dscal_(&n2, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si); - x[j1] = sr; - x[*n + j1] = si; - xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs( - d__2)); - -/* Scale x if necessary to avoid overflow when adding a */ -/* multiple of column j1 of T. */ - - if (xj > 1.) { - rec = 1. / xj; - if (work[j1] > (bignum - xmax) * rec) { - dscal_(&n2, &rec, &x[1], &c__1); - *scale *= rec; - } - } - - if (j1 > 1) { - i__1 = j1 - 1; - d__1 = -x[j1]; - daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] -, &c__1); - i__1 = j1 - 1; - d__1 = -x[*n + j1]; - daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[* - n + 1], &c__1); - - x[1] += b[j1] * x[*n + j1]; - x[*n + 1] -= b[j1] * x[j1]; - - xmax = 0.; - i__1 = j1 - 1; - for (k = 1; k <= i__1; ++k) { -/* Computing MAX */ - d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + ( - d__2 = x[k + *n], abs(d__2)); - xmax = std::max(d__3,d__4); -/* L50: */ - } - } - - } else { - -/* Meet 2 by 2 diagonal block */ - - d__[0] = x[j1]; - d__[1] = x[j2]; - d__[2] = x[*n + j1]; - d__[3] = x[*n + j2]; - d__1 = -(*w); - dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 + - j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & - c_b25, &d__1, v, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 2; - } - - if (scaloc != 1.) { - i__1 = *n << 1; - dscal_(&i__1, &scaloc, &x[1], &c__1); - *scale = scaloc * *scale; - } - x[j1] = v[0]; - x[j2] = v[1]; - x[*n + j1] = v[2]; - x[*n + j2] = v[3]; - -/* Scale X(J1), .... to avoid overflow in */ -/* updating right hand side. */ - -/* Computing MAX */ - d__1 = abs(v[0]) + abs(v[2]), d__2 = abs(v[1]) + abs(v[3]) - ; - xj = std::max(d__1,d__2); - if (xj > 1.) { - rec = 1. / xj; -/* Computing MAX */ - d__1 = work[j1], d__2 = work[j2]; - if (std::max(d__1,d__2) > (bignum - xmax) * rec) { - dscal_(&n2, &rec, &x[1], &c__1); - *scale *= rec; - } - } - -/* Update the right-hand side. */ - - if (j1 > 1) { - i__1 = j1 - 1; - d__1 = -x[j1]; - daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] -, &c__1); - i__1 = j1 - 1; - d__1 = -x[j2]; - daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] -, &c__1); - - i__1 = j1 - 1; - d__1 = -x[*n + j1]; - daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[* - n + 1], &c__1); - i__1 = j1 - 1; - d__1 = -x[*n + j2]; - daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[* - n + 1], &c__1); - - x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2]; - x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2]; - - xmax = 0.; - i__1 = j1 - 1; - for (k = 1; k <= i__1; ++k) { -/* Computing MAX */ - d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + * - n], abs(d__2)); - xmax = std::max(d__3,xmax); -/* L60: */ - } - } - - } -L70: - ; - } - - } else { - -/* Solve (T + iB)'*(p+iq) = c+id */ - - jnext = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (j < jnext) { - goto L80; - } - j1 = j; - j2 = j; - jnext = j + 1; - if (j < *n) { - if (t[j + 1 + j * t_dim1] != 0.) { - j2 = j + 1; - jnext = j + 2; - } - } - - if (j1 == j2) { - -/* 1 by 1 diagonal block */ - -/* Scale if necessary to avoid overflow in forming the */ -/* right-hand side element by inner product. */ - - xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs( - d__2)); - if (xmax > 1.) { - rec = 1. / xmax; - if (work[j1] > (bignum - xj) * rec) { - dscal_(&n2, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - i__2 = j1 - 1; - x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & - c__1); - i__2 = j1 - 1; - x[*n + j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[ - *n + 1], &c__1); - if (j1 > 1) { - x[j1] -= b[j1] * x[*n + 1]; - x[*n + j1] += b[j1] * x[1]; - } - xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs( - d__2)); - - z__ = *w; - if (j1 == 1) { - z__ = b[1]; - } - -/* Scale if necessary to avoid overflow in */ -/* complex division */ - - tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__); - tmp = t[j1 + j1 * t_dim1]; - if (tjj < sminw) { - tmp = sminw; - tjj = sminw; - *info = 1; - } - - if (tjj < 1.) { - if (xj > bignum * tjj) { - rec = 1. / xj; - dscal_(&n2, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - d__1 = -z__; - dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si); - x[j1] = sr; - x[j1 + *n] = si; -/* Computing MAX */ - d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], - abs(d__2)); - xmax = std::max(d__3,xmax); - - } else { - -/* 2 by 2 diagonal block */ - -/* Scale if necessary to avoid overflow in forming the */ -/* right-hand side element by inner product. */ - -/* Computing MAX */ - d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], - abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + ( - d__4 = x[*n + j2], abs(d__4)); - xj = std::max(d__5,d__6); - if (xmax > 1.) { - rec = 1. / xmax; -/* Computing MAX */ - d__1 = work[j1], d__2 = work[j2]; - if (std::max(d__1,d__2) > (bignum - xj) / xmax) { - dscal_(&n2, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - i__2 = j1 - 1; - d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, - &x[1], &c__1); - i__2 = j1 - 1; - d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, - &x[1], &c__1); - i__2 = j1 - 1; - d__[2] = x[*n + j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], & - c__1, &x[*n + 1], &c__1); - i__2 = j1 - 1; - d__[3] = x[*n + j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], & - c__1, &x[*n + 1], &c__1); - d__[0] -= b[j1] * x[*n + 1]; - d__[1] -= b[j2] * x[*n + 1]; - d__[2] += b[j1] * x[1]; - d__[3] += b[j2] * x[1]; - - dlaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1 - * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & - c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 2; - } - - if (scaloc != 1.) { - dscal_(&n2, &scaloc, &x[1], &c__1); - *scale = scaloc * *scale; - } - x[j1] = v[0]; - x[j2] = v[1]; - x[*n + j1] = v[2]; - x[*n + j2] = v[3]; -/* Computing MAX */ - d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], - abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + ( - d__4 = x[*n + j2], abs(d__4)), d__5 = std::max(d__5, - d__6); - xmax = std::max(d__5,xmax); - - } - -L80: - ; - } - - } - - } - - return 0; - -/* End of DLAQTR */ - -} /* dlaqtr_ */ diff --git a/external/clapack/lapack/dlar1v.cpp b/external/clapack/lapack/dlar1v.cpp deleted file mode 100644 index 34743d03..00000000 --- a/external/clapack/lapack/dlar1v.cpp +++ /dev/null @@ -1,429 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlar1v_(integer *n, integer *b1, integer *bn, double - *lambda, double *d__, double *l, double *ld, double * - lld, double *pivmin, double *gaptol, double *z__, bool - *wantnc, integer *negcnt, double *ztz, double *mingma, - integer *r__, integer *isuppz, double *nrminv, double *resid, - double *rqcorr, double *work) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2, d__3; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__; - double s; - integer r1, r2; - double eps, tmp; - integer neg1, neg2, indp, inds; - double dplus; - - - integer indlpl, indumn; - double dminus; - bool sawnan1, sawnan2; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAR1V computes the (scaled) r-th column of the inverse of */ -/* the sumbmatrix in rows B1 through BN of the tridiagonal matrix */ -/* L D L^T - sigma I. When sigma is close to an eigenvalue, the */ -/* computed vector is an accurate eigenvector. Usually, r corresponds */ -/* to the index where the eigenvector is largest in magnitude. */ -/* The following steps accomplish this computation : */ -/* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T, */ -/* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, */ -/* (c) Computation of the diagonal elements of the inverse of */ -/* L D L^T - sigma I by combining the above transforms, and choosing */ -/* r as the index where the diagonal of the inverse is (one of the) */ -/* largest in magnitude. */ -/* (d) Computation of the (scaled) r-th column of the inverse using the */ -/* twisted factorization obtained by combining the top part of the */ -/* the stationary and the bottom part of the progressive transform. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix L D L^T. */ - -/* B1 (input) INTEGER */ -/* First index of the submatrix of L D L^T. */ - -/* BN (input) INTEGER */ -/* Last index of the submatrix of L D L^T. */ - -/* LAMBDA (input) DOUBLE PRECISION */ -/* The shift. In order to compute an accurate eigenvector, */ -/* LAMBDA should be a good approximation to an eigenvalue */ -/* of L D L^T. */ - -/* L (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */ -/* L, in elements 1 to N-1. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the diagonal matrix D. */ - -/* LD (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The n-1 elements L(i)*D(i). */ - -/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The n-1 elements L(i)*L(i)*D(i). */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum pivot in the Sturm sequence. */ - -/* GAPTOL (input) DOUBLE PRECISION */ -/* Tolerance that indicates when eigenvector entries are negligible */ -/* w.r.t. their contribution to the residual. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On input, all entries of Z must be set to 0. */ -/* On output, Z contains the (scaled) r-th column of the */ -/* inverse. The scaling is such that Z(R) equals 1. */ - -/* WANTNC (input) LOGICAL */ -/* Specifies whether NEGCNT has to be computed. */ - -/* NEGCNT (output) INTEGER */ -/* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */ -/* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise. */ - -/* ZTZ (output) DOUBLE PRECISION */ -/* The square of the 2-norm of Z. */ - -/* MINGMA (output) DOUBLE PRECISION */ -/* The reciprocal of the largest (in magnitude) diagonal */ -/* element of the inverse of L D L^T - sigma I. */ - -/* R (input/output) INTEGER */ -/* The twist index for the twisted factorization used to */ -/* compute Z. */ -/* On input, 0 <= R <= N. If R is input as 0, R is set to */ -/* the index where (L D L^T - sigma I)^{-1} is largest */ -/* in magnitude. If 1 <= R <= N, R is unchanged. */ -/* On output, R contains the twist index used to compute Z. */ -/* Ideally, R designates the position of the maximum entry in the */ -/* eigenvector. */ - -/* ISUPPZ (output) INTEGER array, dimension (2) */ -/* The support of the vector in Z, i.e., the vector Z is */ -/* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */ - -/* NRMINV (output) DOUBLE PRECISION */ -/* NRMINV = 1/SQRT( ZTZ ) */ - -/* RESID (output) DOUBLE PRECISION */ -/* The residual of the FP vector. */ -/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */ - -/* RQCORR (output) DOUBLE PRECISION */ -/* The Rayleigh Quotient correction to LAMBDA. */ -/* RQCORR = MINGMA*TMP */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --work; - --isuppz; - --z__; - --lld; - --ld; - --l; - --d__; - - /* Function Body */ - eps = dlamch_("Precision"); - if (*r__ == 0) { - r1 = *b1; - r2 = *bn; - } else { - r1 = *r__; - r2 = *r__; - } -/* Storage for LPLUS */ - indlpl = 0; -/* Storage for UMINUS */ - indumn = *n; - inds = (*n << 1) + 1; - indp = *n * 3 + 1; - if (*b1 == 1) { - work[inds] = 0.; - } else { - work[inds + *b1 - 1] = lld[*b1 - 1]; - } - -/* Compute the stationary transform (using the differential form) */ -/* until the index R2. */ - - sawnan1 = false; - neg1 = 0; - s = work[inds + *b1 - 1] - *lambda; - i__1 = r1 - 1; - for (i__ = *b1; i__ <= i__1; ++i__) { - dplus = d__[i__] + s; - work[indlpl + i__] = ld[i__] / dplus; - if (dplus < 0.) { - ++neg1; - } - work[inds + i__] = s * work[indlpl + i__] * l[i__]; - s = work[inds + i__] - *lambda; -/* L50: */ - } - sawnan1 = disnan_(&s); - if (sawnan1) { - goto L60; - } - i__1 = r2 - 1; - for (i__ = r1; i__ <= i__1; ++i__) { - dplus = d__[i__] + s; - work[indlpl + i__] = ld[i__] / dplus; - work[inds + i__] = s * work[indlpl + i__] * l[i__]; - s = work[inds + i__] - *lambda; -/* L51: */ - } - sawnan1 = disnan_(&s); - -L60: - if (sawnan1) { -/* Runs a slower version of the above loop if a NaN is detected */ - neg1 = 0; - s = work[inds + *b1 - 1] - *lambda; - i__1 = r1 - 1; - for (i__ = *b1; i__ <= i__1; ++i__) { - dplus = d__[i__] + s; - if (abs(dplus) < *pivmin) { - dplus = -(*pivmin); - } - work[indlpl + i__] = ld[i__] / dplus; - if (dplus < 0.) { - ++neg1; - } - work[inds + i__] = s * work[indlpl + i__] * l[i__]; - if (work[indlpl + i__] == 0.) { - work[inds + i__] = lld[i__]; - } - s = work[inds + i__] - *lambda; -/* L70: */ - } - i__1 = r2 - 1; - for (i__ = r1; i__ <= i__1; ++i__) { - dplus = d__[i__] + s; - if (abs(dplus) < *pivmin) { - dplus = -(*pivmin); - } - work[indlpl + i__] = ld[i__] / dplus; - work[inds + i__] = s * work[indlpl + i__] * l[i__]; - if (work[indlpl + i__] == 0.) { - work[inds + i__] = lld[i__]; - } - s = work[inds + i__] - *lambda; -/* L71: */ - } - } - -/* Compute the progressive transform (using the differential form) */ -/* until the index R1 */ - - sawnan2 = false; - neg2 = 0; - work[indp + *bn - 1] = d__[*bn] - *lambda; - i__1 = r1; - for (i__ = *bn - 1; i__ >= i__1; --i__) { - dminus = lld[i__] + work[indp + i__]; - tmp = d__[i__] / dminus; - if (dminus < 0.) { - ++neg2; - } - work[indumn + i__] = l[i__] * tmp; - work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; -/* L80: */ - } - tmp = work[indp + r1 - 1]; - sawnan2 = disnan_(&tmp); - if (sawnan2) { -/* Runs a slower version of the above loop if a NaN is detected */ - neg2 = 0; - i__1 = r1; - for (i__ = *bn - 1; i__ >= i__1; --i__) { - dminus = lld[i__] + work[indp + i__]; - if (abs(dminus) < *pivmin) { - dminus = -(*pivmin); - } - tmp = d__[i__] / dminus; - if (dminus < 0.) { - ++neg2; - } - work[indumn + i__] = l[i__] * tmp; - work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; - if (tmp == 0.) { - work[indp + i__ - 1] = d__[i__] - *lambda; - } -/* L100: */ - } - } - -/* Find the index (from R1 to R2) of the largest (in magnitude) */ -/* diagonal element of the inverse */ - - *mingma = work[inds + r1 - 1] + work[indp + r1 - 1]; - if (*mingma < 0.) { - ++neg1; - } - if (*wantnc) { - *negcnt = neg1 + neg2; - } else { - *negcnt = -1; - } - if (abs(*mingma) == 0.) { - *mingma = eps * work[inds + r1 - 1]; - } - *r__ = r1; - i__1 = r2 - 1; - for (i__ = r1; i__ <= i__1; ++i__) { - tmp = work[inds + i__] + work[indp + i__]; - if (tmp == 0.) { - tmp = eps * work[inds + i__]; - } - if (abs(tmp) <= abs(*mingma)) { - *mingma = tmp; - *r__ = i__ + 1; - } -/* L110: */ - } - -/* Compute the FP vector: solve N^T v = e_r */ - - isuppz[1] = *b1; - isuppz[2] = *bn; - z__[*r__] = 1.; - *ztz = 1.; - -/* Compute the FP vector upwards from R */ - - if (! sawnan1 && ! sawnan2) { - i__1 = *b1; - for (i__ = *r__ - 1; i__ >= i__1; --i__) { - z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]); - if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs( - d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) { - z__[i__] = 0.; - isuppz[1] = i__ + 1; - goto L220; - } - *ztz += z__[i__] * z__[i__]; -/* L210: */ - } -L220: - ; - } else { -/* Run slower loop if NaN occurred. */ - i__1 = *b1; - for (i__ = *r__ - 1; i__ >= i__1; --i__) { - if (z__[i__ + 1] == 0.) { - z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2]; - } else { - z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]); - } - if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs( - d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) { - z__[i__] = 0.; - isuppz[1] = i__ + 1; - goto L240; - } - *ztz += z__[i__] * z__[i__]; -/* L230: */ - } -L240: - ; - } -/* Compute the FP vector downwards from R in blocks of size BLKSIZ */ - if (! sawnan1 && ! sawnan2) { - i__1 = *bn - 1; - for (i__ = *r__; i__ <= i__1; ++i__) { - z__[i__ + 1] = -(work[indumn + i__] * z__[i__]); - if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs( - d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) { - z__[i__ + 1] = 0.; - isuppz[2] = i__; - goto L260; - } - *ztz += z__[i__ + 1] * z__[i__ + 1]; -/* L250: */ - } -L260: - ; - } else { -/* Run slower loop if NaN occurred. */ - i__1 = *bn - 1; - for (i__ = *r__; i__ <= i__1; ++i__) { - if (z__[i__] == 0.) { - z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1]; - } else { - z__[i__ + 1] = -(work[indumn + i__] * z__[i__]); - } - if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs( - d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) { - z__[i__ + 1] = 0.; - isuppz[2] = i__; - goto L280; - } - *ztz += z__[i__ + 1] * z__[i__ + 1]; -/* L270: */ - } -L280: - ; - } - -/* Compute quantities for convergence test */ - - tmp = 1. / *ztz; - *nrminv = sqrt(tmp); - *resid = abs(*mingma) * *nrminv; - *rqcorr = *mingma * tmp; - - - return 0; - -/* End of DLAR1V */ - -} /* dlar1v_ */ diff --git a/external/clapack/lapack/dlar2v.cpp b/external/clapack/lapack/dlar2v.cpp deleted file mode 100644 index 0cae6af5..00000000 --- a/external/clapack/lapack/dlar2v.cpp +++ /dev/null @@ -1,109 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlar2v_(integer *n, double *x, double *y, - double *z__, integer *incx, double *c__, double *s, - integer *incc) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__; - double t1, t2, t3, t4, t5, t6; - integer ic; - double ci, si; - integer ix; - double xi, yi, zi; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAR2V applies a vector of real plane rotations from both sides to */ -/* a sequence of 2-by-2 real symmetric matrices, defined by the elements */ -/* of the vectors x, y and z. For i = 1,2,...,n */ - -/* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) */ -/* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of plane rotations to be applied. */ - -/* X (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCX) */ -/* The vector x. */ - -/* Y (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCX) */ -/* The vector y. */ - -/* Z (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCX) */ -/* The vector z. */ - -/* INCX (input) INTEGER */ -/* The increment between elements of X, Y and Z. INCX > 0. */ - -/* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ -/* The cosines of the plane rotations. */ - -/* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ -/* The sines of the plane rotations. */ - -/* INCC (input) INTEGER */ -/* The increment between elements of C and S. INCC > 0. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --s; - --c__; - --z__; - --y; - --x; - - /* Function Body */ - ix = 1; - ic = 1; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - xi = x[ix]; - yi = y[ix]; - zi = z__[ix]; - ci = c__[ic]; - si = s[ic]; - t1 = si * zi; - t2 = ci * zi; - t3 = t2 - si * xi; - t4 = t2 + si * yi; - t5 = ci * xi + t1; - t6 = ci * yi - t1; - x[ix] = ci * t5 + si * t4; - y[ix] = ci * t6 - si * t3; - z__[ix] = ci * t4 - si * t5; - ix += *incx; - ic += *incc; -/* L10: */ - } - -/* End of DLAR2V */ - - return 0; -} /* dlar2v_ */ diff --git a/external/clapack/lapack/dlarf.cpp b/external/clapack/lapack/dlarf.cpp deleted file mode 100644 index 0bf87d07..00000000 --- a/external/clapack/lapack/dlarf.cpp +++ /dev/null @@ -1,171 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b4 = 1.; -static double c_b5 = 0.; -static integer c__1 = 1; - -int dlarf_(const char *side, integer *m, integer *n, double *v, integer *incv, double *tau, double *c__, - integer *ldc, double *work) -{ - /* System generated locals */ - integer c_dim1, c_offset; - double d__1; - - /* Local variables */ - integer i__; - bool applyleft; - integer lastc, lastv; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --v; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - applyleft = lsame_(side, "L"); - lastv = 0; - lastc = 0; - if (*tau != 0.) { -/* Set up variables for scanning V. LASTV begins pointing to the end */ -/* of V. */ - if (applyleft) { - lastv = *m; - } else { - lastv = *n; - } - if (*incv > 0) { - i__ = (lastv - 1) * *incv + 1; - } else { - i__ = 1; - } -/* Look for the last non-zero row in V. */ - while(lastv > 0 && v[i__] == 0.) { - --lastv; - i__ -= *incv; - } - if (applyleft) { -/* Scan for the last non-zero column in C(1:lastv,:). */ - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - } else { -/* Scan for the last non-zero row in C(:,1:lastv). */ - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - } - } -/* Note that lastc.eq.0 renders the BLAS operations null; no special */ -/* case is needed at this level. */ - if (applyleft) { - -/* Form H * C */ - - if (lastv > 0) { - -/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */ - - dgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, & - v[1], incv, &c_b5, &work[1], &c__1); - -/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */ - - d__1 = -(*tau); - dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[ - c_offset], ldc); - } - } else { - -/* Form C * H */ - - if (lastv > 0) { - -/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */ - - dgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, - &v[1], incv, &c_b5, &work[1], &c__1); - -/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */ - - d__1 = -(*tau); - dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[ - c_offset], ldc); - } - } - return 0; - -/* End of DLARF */ - -} /* dlarf_ */ diff --git a/external/clapack/lapack/dlarfb.cpp b/external/clapack/lapack/dlarfb.cpp deleted file mode 100644 index 31958200..00000000 --- a/external/clapack/lapack/dlarfb.cpp +++ /dev/null @@ -1,751 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b14 = 1.; -static double c_b25 = -1.; - -int dlarfb_(const char *side, const char *trans, const char *direct, const char *storev, integer *m, - integer *n, integer *k, double *v, integer *ldv, double *t, integer *ldt, double *c__, - integer *ldc, double *work, integer *ldwork) -{ - /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - integer lastc; - integer lastv; - char transt[1]; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - work_dim1 = *ldwork; - work_offset = 1 + work_dim1; - work -= work_offset; - - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } - - if (lsame_(trans, "N")) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - if (lsame_(storev, "C")) { - - if (lsame_(direct, "F")) { - -/* Let V = ( V1 ) (first K rows) */ -/* ( V2 ) */ -/* where V1 is unit lower triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv); - lastv = std::max(i__1,i__2); - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ - -/* W := C1' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); -/* L10: */ - } - -/* W := W * V1 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C2'*V2 */ - - i__1 = lastv - *k; - dgemm_("Transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + - v_dim1], ldv, &c_b14, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V * W' */ - - if (lastv > *k) { - -/* C2 := C2 - V2 * W' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &i__1, &lastc, k, & - c_b25, &v[*k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork, &c_b14, &c__[*k + 1 + - c_dim1], ldc); - } - -/* W := W * V1' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; -/* L20: */ - } -/* L30: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv); - lastv = std::max(i__1,i__2); - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ - -/* W := C1 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L40: */ - } - -/* W := W * V1 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C2 * V2 */ - - i__1 = lastv - *k; - dgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + - 1 + v_dim1], ldv, &c_b14, &work[work_offset], - ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V' */ - - if (lastv > *k) { - -/* C2 := C2 - W * V2' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[*k + 1 + - v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], - ldc); - } - -/* W := W * V1' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; -/* L50: */ - } -/* L60: */ - } - } - - } else { - -/* Let V = ( V1 ) */ -/* ( V2 ) (last K rows) */ -/* where V2 is unit upper triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv); - lastv = std::max(i__1,i__2); - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ - -/* W := C2' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); -/* L70: */ - } - -/* W := W * V2 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1'*V1 */ - - i__1 = lastv - *k; - dgemm_("Transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V * W' */ - - if (lastv > *k) { - -/* C1 := C1 - V1 * W' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &i__1, &lastc, k, & - c_b25, &v[v_offset], ldv, &work[work_offset], - ldwork, &c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * - work_dim1]; -/* L80: */ - } -/* L90: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv); - lastv = std::max(i__1,i__2); - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ - -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, & - work[j * work_dim1 + 1], &c__1); -/* L100: */ - } - -/* W := W * V2 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1 */ - - i__1 = lastv - *k; - dgemm_("No transpose", "No transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V' */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * - work_dim1]; -/* L110: */ - } -/* L120: */ - } - } - } - - } else if (lsame_(storev, "R")) { - - if (lsame_(direct, "F")) { - -/* Let V = ( V1 V2 ) (V1: first K columns) */ -/* where V1 is unit upper triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv); - lastv = std::max(i__1,i__2); - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C1' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 - + 1], &c__1); -/* L130: */ - } - -/* W := W * V1' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C2'*V2' */ - - i__1 = lastv - *k; - dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, - &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 - + 1], ldv, &c_b14, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C2 := C2 - V2' * W' */ - - i__1 = lastv - *k; - dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, - &v[(*k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork, &c_b14, &c__[*k + 1 + - c_dim1], ldc); - } - -/* W := W * V1 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; -/* L140: */ - } -/* L150: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv); - lastv = std::max(i__1,i__2); - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C1 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * - work_dim1 + 1], &c__1); -/* L160: */ - } - -/* W := W * V1' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C2 * V2' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &lastc, k, &i__1, & - c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + - 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], - ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C2 := C2 - W * V2 */ - - i__1 = lastv - *k; - dgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[(*k + 1) * - v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 - + 1], ldc); - } - -/* W := W * V1 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & - c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; -/* L170: */ - } -/* L180: */ - } - - } - - } else { - -/* Let V = ( V1 V2 ) (V2: last K columns) */ -/* where V2 is unit lower triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) */ -/* ( C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv); - lastv = std::max(i__1,i__2); - lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); - -/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ - -/* W := C2' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ - j * work_dim1 + 1], &c__1); -/* L190: */ - } - -/* W := W * V2' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1'*V1' */ - - i__1 = lastv - *k; - dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, - &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, & - c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (lastv > *k) { - -/* C1 := C1 - V1' * W' */ - - i__1 = lastv - *k; - dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, - &v[v_offset], ldv, &work[work_offset], ldwork, & - c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C2 := C2 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * - work_dim1]; -/* L200: */ - } -/* L210: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) */ - -/* Computing MAX */ - i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv); - lastv = std::max(i__1,i__2); - lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); - -/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ - -/* W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, - &work[j * work_dim1 + 1], &c__1); -/* L220: */ - } - -/* W := W * V2' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - if (lastv > *k) { - -/* W := W + C1 * V1' */ - - i__1 = lastv - *k; - dgemm_("No transpose", "Transpose", &lastc, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, - &t[t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (lastv > *k) { - -/* C1 := C1 - W * V1 */ - - i__1 = lastv - *k; - dgemm_("No transpose", "No transpose", &lastc, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & - c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ - work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = lastc; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * - work_dim1]; -/* L230: */ - } -/* L240: */ - } - - } - - } - } - - return 0; - -/* End of DLARFB */ - -} /* dlarfb_ */ diff --git a/external/clapack/lapack/dlarfg.cpp b/external/clapack/lapack/dlarfg.cpp deleted file mode 100644 index 6ee2db73..00000000 --- a/external/clapack/lapack/dlarfg.cpp +++ /dev/null @@ -1,149 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - - -int dlarfg_(integer *n, double *alpha, double *x, integer *incx, double *tau) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer j, knt; - double beta, xnorm, safmin, rsafmn; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n <= 1) { - *tau = 0.; - return 0; - } - - i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); - - if (xnorm == 0.) { - -/* H = I */ - - *tau = 0.; - } else { - -/* general case */ - - d__1 = dlapy2_(alpha, &xnorm); - beta = -d_sign(&d__1, alpha); - safmin = dlamch_("S") / dlamch_("E"); - knt = 0; - if (abs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - - rsafmn = 1. / safmin; -L10: - ++knt; - i__1 = *n - 1; - dscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - *alpha *= rsafmn; - if (abs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); - d__1 = dlapy2_(alpha, &xnorm); - beta = -d_sign(&d__1, alpha); - } - *tau = (beta - *alpha) / beta; - i__1 = *n - 1; - d__1 = 1. / (*alpha - beta); - dscal_(&i__1, &d__1, &x[1], incx); - -/* If ALPHA is subnormal, it may lose relative accuracy */ - - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - beta *= safmin; -/* L20: */ - } - *alpha = beta; - } - - return 0; - -/* End of DLARFG */ - -} /* dlarfg_ */ diff --git a/external/clapack/lapack/dlarfp.cpp b/external/clapack/lapack/dlarfp.cpp deleted file mode 100644 index d04b5733..00000000 --- a/external/clapack/lapack/dlarfp.cpp +++ /dev/null @@ -1,172 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dlarfp_(integer *n, double *alpha, double *x, integer *incx, double *tau) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer j, knt; - double beta; - double xnorm; - double safmin, rsafmn; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARFP 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, beta is non-negative, 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n <= 0) { - *tau = 0.; - return 0; - } - - i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); - - if (xnorm == 0.) { - -/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0 */ - - if (*alpha >= 0.) { -/* When TAU.eq.ZERO, the vector is special-cased to be */ -/* all zeros in the application routines. We do not need */ -/* to clear it. */ - *tau = 0.; - } else { -/* However, the application routines rely on explicit */ -/* zero checks when TAU.ne.ZERO, and we must clear X. */ - *tau = 2.; - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - x[(j - 1) * *incx + 1] = 0.; - } - *alpha = -(*alpha); - } - } else { - -/* general case */ - - d__1 = dlapy2_(alpha, &xnorm); - beta = d_sign(&d__1, alpha); - safmin = dlamch_("S") / dlamch_("E"); - knt = 0; - if (abs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - - rsafmn = 1. / safmin; -L10: - ++knt; - i__1 = *n - 1; - dscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - *alpha *= rsafmn; - if (abs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); - d__1 = dlapy2_(alpha, &xnorm); - beta = d_sign(&d__1, alpha); - } - *alpha += beta; - if (beta < 0.) { - beta = -beta; - *tau = -(*alpha) / beta; - } else { - *alpha = xnorm * (xnorm / *alpha); - *tau = *alpha / beta; - *alpha = -(*alpha); - } - i__1 = *n - 1; - d__1 = 1. / *alpha; - dscal_(&i__1, &d__1, &x[1], incx); - -/* If BETA is subnormal, it may lose relative accuracy */ - - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - beta *= safmin; -/* L20: */ - } - *alpha = beta; - } - - return 0; - -/* End of DLARFP */ - -} /* dlarfp_ */ diff --git a/external/clapack/lapack/dlarft.cpp b/external/clapack/lapack/dlarft.cpp deleted file mode 100644 index 8f932973..00000000 --- a/external/clapack/lapack/dlarft.cpp +++ /dev/null @@ -1,306 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b8 = 0.; - -int dlarft_(const char *direct, const char *storev, integer *n, integer *k, double *v, integer *ldv, - double *tau, double *t, integer *ldt) -{ - /* System generated locals */ - integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer i__, j, prevlastv; - double vii; - integer lastv; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - --tau; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - - /* Function Body */ - if (*n == 0) { - return 0; - } - - if (lsame_(direct, "F")) { - prevlastv = *n; - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - prevlastv = std::max(i__,prevlastv); - if (tau[i__] == 0.) { - -/* H(i) = I */ - - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t[j + i__ * t_dim1] = 0.; -/* L10: */ - } - } else { - -/* general case */ - - vii = v[i__ + i__ * v_dim1]; - v[i__ + i__ * v_dim1] = 1.; - if (lsame_(storev, "C")) { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[lastv + i__ * v_dim1] != 0.) { - break; - } - } - j = std::min(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ - - i__2 = j - i__ + 1; - i__3 = i__ - 1; - d__1 = -tau[i__]; - dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1], - ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[ - i__ * t_dim1 + 1], &c__1); - } else { -/* Skip any trailing zeros. */ - i__2 = i__ + 1; - for (lastv = *n; lastv >= i__2; --lastv) { - if (v[i__ + lastv * v_dim1] != 0.) { - break; - } - } - j = std::min(lastv,prevlastv); - -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ - - i__2 = i__ - 1; - i__3 = j - i__ + 1; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ * - v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, & - c_b8, &t[i__ * t_dim1 + 1], &c__1); - } - v[i__ + i__ * v_dim1] = vii; - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); - t[i__ + i__ * t_dim1] = tau[i__]; - if (i__ > 1) { - prevlastv = std::max(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } -/* L20: */ - } - } else { - prevlastv = 1; - for (i__ = *k; i__ >= 1; --i__) { - if (tau[i__] == 0.) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t[j + i__ * t_dim1] = 0.; -/* L30: */ - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { - vii = v[*n - *k + i__ + i__ * v_dim1]; - v[*n - *k + i__ + i__ * v_dim1] = 1.; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[lastv + i__ * v_dim1] != 0.) { - break; - } - } - j = std::max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ - - i__1 = *n - *k + i__ - j + 1; - i__2 = *k - i__; - d__1 = -tau[i__]; - dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__ - + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & - c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], & - c__1); - v[*n - *k + i__ + i__ * v_dim1] = vii; - } else { - vii = v[i__ + (*n - *k + i__) * v_dim1]; - v[i__ + (*n - *k + i__) * v_dim1] = 1.; -/* Skip any leading zeros. */ - i__1 = i__ - 1; - for (lastv = 1; lastv <= i__1; ++lastv) { - if (v[i__ + lastv * v_dim1] != 0.) { - break; - } - } - j = std::max(lastv,prevlastv); - -/* T(i+1:k,i) := */ -/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ - - i__1 = *k - i__; - i__2 = *n - *k + i__ - j + 1; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + - 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], - ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1); - v[i__ + (*n - *k + i__) * v_dim1] = vii; - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ - + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * - t_dim1], &c__1) - ; - if (i__ > 1) { - prevlastv = std::min(prevlastv,lastv); - } else { - prevlastv = lastv; - } - } - t[i__ + i__ * t_dim1] = tau[i__]; - } -/* L40: */ - } - } - return 0; - -/* End of DLARFT */ - -} /* dlarft_ */ diff --git a/external/clapack/lapack/dlarfx.cpp b/external/clapack/lapack/dlarfx.cpp deleted file mode 100644 index 8ac22584..00000000 --- a/external/clapack/lapack/dlarfx.cpp +++ /dev/null @@ -1,712 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -int dlarfx_(const char *side, integer *m, integer *n, double *v, double *tau, double *c__, integer *ldc, double *work) -{ - /* System generated locals */ - integer c_dim1, c_offset, i__1; - - /* Local variables */ - integer j; - double t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7, - v8, v9, t10, v10, sum; - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --v; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - if (*tau == 0.) { - return 0; - } - if (lsame_(side, "L")) { - -/* Form H * C, where H has order m. */ - - switch (*m) { - case 1: goto L10; - case 2: goto L30; - case 3: goto L50; - case 4: goto L70; - case 5: goto L90; - case 6: goto L110; - case 7: goto L130; - case 8: goto L150; - case 9: goto L170; - case 10: goto L190; - } - -/* Code for general M */ - - dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); - goto L410; -L10: - -/* Special code for 1 x 1 Householder */ - - t1 = 1. - *tau * v[1] * v[1]; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1]; -/* L20: */ - } - goto L410; -L30: - -/* Special code for 2 x 2 Householder */ - - v1 = v[1]; - t1 = *tau * v1; - v2 = v[2]; - t2 = *tau * v2; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; -/* L40: */ - } - goto L410; -L50: - -/* 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; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * - c__[j * c_dim1 + 3]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; - c__[j * c_dim1 + 3] -= sum * t3; -/* L60: */ - } - goto L410; -L70: - -/* 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; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * - c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; - c__[j * c_dim1 + 3] -= sum * t3; - c__[j * c_dim1 + 4] -= sum * t4; -/* L80: */ - } - goto L410; -L90: - -/* 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; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * - c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ - j * c_dim1 + 5]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; - c__[j * c_dim1 + 3] -= sum * t3; - c__[j * c_dim1 + 4] -= sum * t4; - c__[j * c_dim1 + 5] -= sum * t5; -/* L100: */ - } - goto L410; -L110: - -/* 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; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * - c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ - j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; - c__[j * c_dim1 + 3] -= sum * t3; - c__[j * c_dim1 + 4] -= sum * t4; - c__[j * c_dim1 + 5] -= sum * t5; - c__[j * c_dim1 + 6] -= sum * t6; -/* L120: */ - } - goto L410; -L130: - -/* 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; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * - c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ - j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * - c_dim1 + 7]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; - c__[j * c_dim1 + 3] -= sum * t3; - c__[j * c_dim1 + 4] -= sum * t4; - c__[j * c_dim1 + 5] -= sum * t5; - c__[j * c_dim1 + 6] -= sum * t6; - c__[j * c_dim1 + 7] -= sum * t7; -/* L140: */ - } - goto L410; -L150: - -/* 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; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * - c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ - j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * - c_dim1 + 7] + v8 * c__[j * c_dim1 + 8]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; - c__[j * c_dim1 + 3] -= sum * t3; - c__[j * c_dim1 + 4] -= sum * t4; - c__[j * c_dim1 + 5] -= sum * t5; - c__[j * c_dim1 + 6] -= sum * t6; - c__[j * c_dim1 + 7] -= sum * t7; - c__[j * c_dim1 + 8] -= sum * t8; -/* L160: */ - } - goto L410; -L170: - -/* 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; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * - c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ - j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * - c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * - c_dim1 + 9]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; - c__[j * c_dim1 + 3] -= sum * t3; - c__[j * c_dim1 + 4] -= sum * t4; - c__[j * c_dim1 + 5] -= sum * t5; - c__[j * c_dim1 + 6] -= sum * t6; - c__[j * c_dim1 + 7] -= sum * t7; - c__[j * c_dim1 + 8] -= sum * t8; - c__[j * c_dim1 + 9] -= sum * t9; -/* L180: */ - } - goto L410; -L190: - -/* 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; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * - c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ - j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * - c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * - c_dim1 + 9] + v10 * c__[j * c_dim1 + 10]; - c__[j * c_dim1 + 1] -= sum * t1; - c__[j * c_dim1 + 2] -= sum * t2; - c__[j * c_dim1 + 3] -= sum * t3; - c__[j * c_dim1 + 4] -= sum * t4; - c__[j * c_dim1 + 5] -= sum * t5; - c__[j * c_dim1 + 6] -= sum * t6; - c__[j * c_dim1 + 7] -= sum * t7; - c__[j * c_dim1 + 8] -= sum * t8; - c__[j * c_dim1 + 9] -= sum * t9; - c__[j * c_dim1 + 10] -= sum * t10; -/* L200: */ - } - goto L410; - } else { - -/* Form C * H, where H has order n. */ - - switch (*n) { - case 1: goto L210; - case 2: goto L230; - case 3: goto L250; - case 4: goto L270; - case 5: goto L290; - case 6: goto L310; - case 7: goto L330; - case 8: goto L350; - case 9: goto L370; - case 10: goto L390; - } - -/* Code for general N */ - - dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); - goto L410; -L210: - -/* Special code for 1 x 1 Householder */ - - t1 = 1. - *tau * v[1] * v[1]; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - c__[j + c_dim1] = t1 * c__[j + c_dim1]; -/* L220: */ - } - goto L410; -L230: - -/* Special code for 2 x 2 Householder */ - - v1 = v[1]; - t1 = *tau * v1; - v2 = v[2]; - t2 = *tau * v2; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; -/* L240: */ - } - goto L410; -L250: - -/* 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; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * - c__[j + c_dim1 * 3]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; - c__[j + c_dim1 * 3] -= sum * t3; -/* L260: */ - } - goto L410; -L270: - -/* 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; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * - c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; - c__[j + c_dim1 * 3] -= sum * t3; - c__[j + (c_dim1 << 2)] -= sum * t4; -/* L280: */ - } - goto L410; -L290: - -/* 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; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * - c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * - c__[j + c_dim1 * 5]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; - c__[j + c_dim1 * 3] -= sum * t3; - c__[j + (c_dim1 << 2)] -= sum * t4; - c__[j + c_dim1 * 5] -= sum * t5; -/* L300: */ - } - goto L410; -L310: - -/* 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; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * - c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * - c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; - c__[j + c_dim1 * 3] -= sum * t3; - c__[j + (c_dim1 << 2)] -= sum * t4; - c__[j + c_dim1 * 5] -= sum * t5; - c__[j + c_dim1 * 6] -= sum * t6; -/* L320: */ - } - goto L410; -L330: - -/* 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; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * - c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * - c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ - j + c_dim1 * 7]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; - c__[j + c_dim1 * 3] -= sum * t3; - c__[j + (c_dim1 << 2)] -= sum * t4; - c__[j + c_dim1 * 5] -= sum * t5; - c__[j + c_dim1 * 6] -= sum * t6; - c__[j + c_dim1 * 7] -= sum * t7; -/* L340: */ - } - goto L410; -L350: - -/* 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; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * - c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * - c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ - j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; - c__[j + c_dim1 * 3] -= sum * t3; - c__[j + (c_dim1 << 2)] -= sum * t4; - c__[j + c_dim1 * 5] -= sum * t5; - c__[j + c_dim1 * 6] -= sum * t6; - c__[j + c_dim1 * 7] -= sum * t7; - c__[j + (c_dim1 << 3)] -= sum * t8; -/* L360: */ - } - goto L410; -L370: - -/* 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; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * - c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * - c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ - j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[ - j + c_dim1 * 9]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; - c__[j + c_dim1 * 3] -= sum * t3; - c__[j + (c_dim1 << 2)] -= sum * t4; - c__[j + c_dim1 * 5] -= sum * t5; - c__[j + c_dim1 * 6] -= sum * t6; - c__[j + c_dim1 * 7] -= sum * t7; - c__[j + (c_dim1 << 3)] -= sum * t8; - c__[j + c_dim1 * 9] -= sum * t9; -/* L380: */ - } - goto L410; -L390: - -/* 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; - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * - c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * - c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ - j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[ - j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10]; - c__[j + c_dim1] -= sum * t1; - c__[j + (c_dim1 << 1)] -= sum * t2; - c__[j + c_dim1 * 3] -= sum * t3; - c__[j + (c_dim1 << 2)] -= sum * t4; - c__[j + c_dim1 * 5] -= sum * t5; - c__[j + c_dim1 * 6] -= sum * t6; - c__[j + c_dim1 * 7] -= sum * t7; - c__[j + (c_dim1 << 3)] -= sum * t8; - c__[j + c_dim1 * 9] -= sum * t9; - c__[j + c_dim1 * 10] -= sum * t10; -/* L400: */ - } - goto L410; - } -L410: - return 0; - -/* End of DLARFX */ - -} /* dlarfx_ */ diff --git a/external/clapack/lapack/dlargv.cpp b/external/clapack/lapack/dlargv.cpp deleted file mode 100644 index 2b615999..00000000 --- a/external/clapack/lapack/dlargv.cpp +++ /dev/null @@ -1,118 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlargv_(integer *n, double *x, integer *incx, - double *y, integer *incy, double *c__, integer *incc) -{ - /* System generated locals */ - integer i__1; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - double f, g; - integer i__; - double t; - integer ic, ix, iy; - double tt; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARGV generates a vector of real plane rotations, determined by */ -/* elements of the real vectors x and y. For i = 1,2,...,n */ - -/* ( c(i) s(i) ) ( x(i) ) = ( a(i) ) */ -/* ( -s(i) c(i) ) ( y(i) ) = ( 0 ) */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of plane rotations to be generated. */ - -/* X (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCX) */ -/* On entry, the vector x. */ -/* On exit, x(i) is overwritten by a(i), for i = 1,...,n. */ - -/* INCX (input) INTEGER */ -/* The increment between elements of X. INCX > 0. */ - -/* Y (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCY) */ -/* On entry, the vector y. */ -/* On exit, the sines of the plane rotations. */ - -/* INCY (input) INTEGER */ -/* The increment between elements of Y. INCY > 0. */ - -/* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ -/* The cosines of the plane rotations. */ - -/* INCC (input) INTEGER */ -/* The increment between elements of C. INCC > 0. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --c__; - --y; - --x; - - /* Function Body */ - ix = 1; - iy = 1; - ic = 1; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - f = x[ix]; - g = y[iy]; - if (g == 0.) { - c__[ic] = 1.; - } else if (f == 0.) { - c__[ic] = 0.; - y[iy] = 1.; - x[ix] = g; - } else if (abs(f) > abs(g)) { - t = g / f; - tt = sqrt(t * t + 1.); - c__[ic] = 1. / tt; - y[iy] = t * c__[ic]; - x[ix] = f * tt; - } else { - t = f / g; - tt = sqrt(t * t + 1.); - y[iy] = 1. / tt; - c__[ic] = t * y[iy]; - x[ix] = g * tt; - } - ic += *incc; - iy += *incy; - ix += *incx; -/* L10: */ - } - return 0; - -/* End of DLARGV */ - -} /* dlargv_ */ diff --git a/external/clapack/lapack/dlarnv.cpp b/external/clapack/lapack/dlarnv.cpp deleted file mode 100644 index 621b242b..00000000 --- a/external/clapack/lapack/dlarnv.cpp +++ /dev/null @@ -1,134 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlarnv_(integer *idist, integer *iseed, integer *n, - double *x) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - - /* Builtin functions - double log(double), sqrt(double), cos(double); */ - - /* Local variables */ - integer i__; - double u[128]; - integer il, iv, il2; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARNV returns a vector of n random real numbers from a uniform or */ -/* normal distribution. */ - -/* Arguments */ -/* ========= */ - -/* IDIST (input) INTEGER */ -/* Specifies the distribution of the random numbers: */ -/* = 1: uniform (0,1) */ -/* = 2: uniform (-1,1) */ -/* = 3: normal (0,1) */ - -/* ISEED (input/output) INTEGER array, dimension (4) */ -/* On entry, the seed of the random number generator; the array */ -/* elements must be between 0 and 4095, and ISEED(4) must be */ -/* odd. */ -/* On exit, the seed is updated. */ - -/* N (input) INTEGER */ -/* The number of random numbers to be generated. */ - -/* X (output) DOUBLE PRECISION array, dimension (N) */ -/* The generated random numbers. */ - -/* Further Details */ -/* =============== */ - -/* This routine calls the auxiliary routine DLARUV to generate random */ -/* real numbers from a uniform (0,1) distribution, in batches of up to */ -/* 128 using vectorisable code. The Box-Muller method is used to */ -/* transform numbers from a uniform to a normal distribution. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --x; - --iseed; - - /* Function Body */ - i__1 = *n; - for (iv = 1; iv <= i__1; iv += 64) { -/* Computing MIN */ - i__2 = 64, i__3 = *n - iv + 1; - il = std::min(i__2,i__3); - if (*idist == 3) { - il2 = il << 1; - } else { - il2 = il; - } - -/* Call DLARUV to generate IL2 numbers from a uniform (0,1) */ -/* distribution (IL2 <= LV) */ - - dlaruv_(&iseed[1], &il2, u); - - if (*idist == 1) { - -/* Copy generated numbers */ - - i__2 = il; - for (i__ = 1; i__ <= i__2; ++i__) { - x[iv + i__ - 1] = u[i__ - 1]; -/* L10: */ - } - } else if (*idist == 2) { - -/* Convert generated numbers to uniform (-1,1) distribution */ - - i__2 = il; - for (i__ = 1; i__ <= i__2; ++i__) { - x[iv + i__ - 1] = u[i__ - 1] * 2. - 1.; -/* L20: */ - } - } else if (*idist == 3) { - -/* Convert generated numbers to normal (0,1) distribution */ - - i__2 = il; - for (i__ = 1; i__ <= i__2; ++i__) { - x[iv + i__ - 1] = sqrt(log(u[(i__ << 1) - 2]) * -2.) * cos(u[( - i__ << 1) - 1] * 6.2831853071795864769252867663); -/* L30: */ - } - } -/* L40: */ - } - return 0; - -/* End of DLARNV */ - -} /* dlarnv_ */ diff --git a/external/clapack/lapack/dlarra.cpp b/external/clapack/lapack/dlarra.cpp deleted file mode 100644 index a0dbff2f..00000000 --- a/external/clapack/lapack/dlarra.cpp +++ /dev/null @@ -1,144 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlarra_(integer *n, double *d__, double *e, - double *e2, double *spltol, double *tnrm, integer *nsplit, - integer *isplit, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - integer i__; - double tmp1, eabs; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Compute the splitting points with threshold SPLTOL. */ -/* DLARRA sets any "small" off-diagonal elements to zero. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N > 0. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the N diagonal elements of the tridiagonal */ -/* matrix T. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the first (N-1) entries contain the subdiagonal */ -/* elements of the tridiagonal matrix T; E(N) need not be set. */ -/* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, */ -/* are set to zero, the other entries of E are untouched. */ - -/* E2 (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the first (N-1) entries contain the SQUARES of the */ -/* subdiagonal elements of the tridiagonal matrix T; */ -/* E2(N) need not be set. */ -/* On exit, the entries E2( ISPLIT( I ) ), */ -/* 1 <= I <= NSPLIT, have been set to zero */ - -/* SPLTOL (input) DOUBLE PRECISION */ -/* The threshold for splitting. Two criteria can be used: */ -/* SPLTOL<0 : criterion based on absolute off-diagonal value */ -/* SPLTOL>0 : criterion that preserves relative accuracy */ - -/* TNRM (input) DOUBLE PRECISION */ -/* The norm of the matrix. */ - -/* NSPLIT (output) INTEGER */ -/* The number of blocks T splits into. 1 <= NSPLIT <= N. */ - -/* ISPLIT (output) INTEGER array, dimension (N) */ -/* The splitting points, at which T breaks up into blocks. */ -/* The first block consists of rows/columns 1 to ISPLIT(1), */ -/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ -/* etc., and the NSPLIT-th consists of rows/columns */ -/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ - - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --isplit; - --e2; - --e; - --d__; - - /* Function Body */ - *info = 0; -/* Compute splitting points */ - *nsplit = 1; - if (*spltol < 0.) { -/* Criterion based on absolute off-diagonal value */ - tmp1 = abs(*spltol) * *tnrm; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - eabs = (d__1 = e[i__], abs(d__1)); - if (eabs <= tmp1) { - e[i__] = 0.; - e2[i__] = 0.; - isplit[*nsplit] = i__; - ++(*nsplit); - } -/* L9: */ - } - } else { -/* Criterion that guarantees relative accuracy */ - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - eabs = (d__1 = e[i__], abs(d__1)); - if (eabs <= *spltol * sqrt((d__1 = d__[i__], abs(d__1))) * sqrt(( - d__2 = d__[i__ + 1], abs(d__2)))) { - e[i__] = 0.; - e2[i__] = 0.; - isplit[*nsplit] = i__; - ++(*nsplit); - } -/* L10: */ - } - } - isplit[*nsplit] = *n; - return 0; - -/* End of DLARRA */ - -} /* dlarra_ */ diff --git a/external/clapack/lapack/dlarrb.cpp b/external/clapack/lapack/dlarrb.cpp deleted file mode 100644 index 4659f841..00000000 --- a/external/clapack/lapack/dlarrb.cpp +++ /dev/null @@ -1,333 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlarrb_(integer *n, double *d__, double *lld, - integer *ifirst, integer *ilast, double *rtol1, double *rtol2, - integer *offset, double *w, double *wgap, double *werr, - double *work, integer *iwork, double *pivmin, double * - spdiam, integer *twist, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - integer i__, k, r__, i1, ii, ip; - double gap, mid, tmp, back, lgap, rgap, left; - integer iter, nint, prev, next; - double cvrgd, right, width; - integer negcnt; - double mnwdth; - integer olnint, maxitr; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Given the relatively robust representation(RRR) L D L^T, DLARRB */ -/* does "limited" bisection to refine the eigenvalues of L D L^T, */ -/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */ -/* guesses for these eigenvalues are input in W, the corresponding estimate */ -/* of the error in these guesses and their gaps are input in WERR */ -/* and WGAP, respectively. During bisection, intervals */ -/* [left, right] are maintained by storing their mid-points and */ -/* semi-widths in the arrays W and WERR respectively. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The N diagonal elements of the diagonal matrix D. */ - -/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (N-1) elements L(i)*L(i)*D(i). */ - -/* IFIRST (input) INTEGER */ -/* The index of the first eigenvalue to be computed. */ - -/* ILAST (input) INTEGER */ -/* The index of the last eigenvalue to be computed. */ - -/* RTOL1 (input) DOUBLE PRECISION */ -/* RTOL2 (input) DOUBLE PRECISION */ -/* Tolerance for the convergence of the bisection intervals. */ -/* An interval [LEFT,RIGHT] has converged if */ -/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ -/* where GAP is the (estimated) distance to the nearest */ -/* eigenvalue. */ - -/* OFFSET (input) INTEGER */ -/* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET */ -/* through ILAST-OFFSET elements of these arrays are to be used. */ - -/* W (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */ -/* estimates of the eigenvalues of L D L^T indexed IFIRST throug */ -/* ILAST. */ -/* On output, these estimates are refined. */ - -/* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On input, the (estimated) gaps between consecutive */ -/* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between */ -/* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST */ -/* then WGAP(IFIRST-OFFSET) must be set to ZERO. */ -/* On output, these gaps are refined. */ - -/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */ -/* the errors in the estimates of the corresponding elements in W. */ -/* On output, these errors are refined. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ -/* Workspace. */ - -/* IWORK (workspace) INTEGER array, dimension (2*N) */ -/* Workspace. */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum pivot in the Sturm sequence. */ - -/* SPDIAM (input) DOUBLE PRECISION */ -/* The spectral diameter of the matrix. */ - -/* TWIST (input) INTEGER */ -/* The twist index for the twisted factorization that is used */ -/* for the negcount. */ -/* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T */ -/* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T */ -/* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) */ - -/* INFO (output) INTEGER */ -/* Error flag. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ - -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --iwork; - --work; - --werr; - --wgap; - --w; - --lld; - --d__; - - /* Function Body */ - *info = 0; - - maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.)) + - 2; - mnwdth = *pivmin * 2.; - - r__ = *twist; - if (r__ < 1 || r__ > *n) { - r__ = *n; - } - -/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */ -/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */ -/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */ -/* for an unconverged interval is set to the index of the next unconverged */ -/* interval, and is -1 or 0 for a converged interval. Thus a linked */ -/* list of unconverged intervals is set up. */ - - i1 = *ifirst; -/* The number of unconverged intervals */ - nint = 0; -/* The last unconverged interval found */ - prev = 0; - rgap = wgap[i1 - *offset]; - i__1 = *ilast; - for (i__ = i1; i__ <= i__1; ++i__) { - k = i__ << 1; - ii = i__ - *offset; - left = w[ii] - werr[ii]; - right = w[ii] + werr[ii]; - lgap = rgap; - rgap = wgap[ii]; - gap = std::min(lgap,rgap); -/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */ -/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT */ - -/* Do while( NEGCNT(LEFT).GT.I-1 ) */ - - back = werr[ii]; -L20: - negcnt = dlaneg_(n, &d__[1], &lld[1], &left, pivmin, &r__); - if (negcnt > i__ - 1) { - left -= back; - back *= 2.; - goto L20; - } - -/* Do while( NEGCNT(RIGHT).LT.I ) */ -/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT */ - - back = werr[ii]; -L50: - negcnt = dlaneg_(n, &d__[1], &lld[1], &right, pivmin, &r__); - if (negcnt < i__) { - right += back; - back *= 2.; - goto L50; - } - width = (d__1 = left - right, abs(d__1)) * .5; -/* Computing MAX */ - d__1 = abs(left), d__2 = abs(right); - tmp = std::max(d__1,d__2); -/* Computing MAX */ - d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp; - cvrgd = std::max(d__1,d__2); - if (width <= cvrgd || width <= mnwdth) { -/* This interval has already converged and does not need refinement. */ -/* (Note that the gaps might change through refining the */ -/* eigenvalues, however, they can only get bigger.) */ -/* Remove it from the list. */ - iwork[k - 1] = -1; -/* Make sure that I1 always points to the first unconverged interval */ - if (i__ == i1 && i__ < *ilast) { - i1 = i__ + 1; - } - if (prev >= i1 && i__ <= *ilast) { - iwork[(prev << 1) - 1] = i__ + 1; - } - } else { -/* unconverged interval found */ - prev = i__; - ++nint; - iwork[k - 1] = i__ + 1; - iwork[k] = negcnt; - } - work[k - 1] = left; - work[k] = right; -/* L75: */ - } - -/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */ -/* and while (ITER.LT.MAXITR) */ - - iter = 0; -L80: - prev = i1 - 1; - i__ = i1; - olnint = nint; - i__1 = olnint; - for (ip = 1; ip <= i__1; ++ip) { - k = i__ << 1; - ii = i__ - *offset; - rgap = wgap[ii]; - lgap = rgap; - if (ii > 1) { - lgap = wgap[ii - 1]; - } - gap = std::min(lgap,rgap); - next = iwork[k - 1]; - left = work[k - 1]; - right = work[k]; - mid = (left + right) * .5; -/* semiwidth of interval */ - width = right - mid; -/* Computing MAX */ - d__1 = abs(left), d__2 = abs(right); - tmp = std::max(d__1,d__2); -/* Computing MAX */ - d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp; - cvrgd = std::max(d__1,d__2); - if (width <= cvrgd || width <= mnwdth || iter == maxitr) { -/* reduce number of unconverged intervals */ - --nint; -/* Mark interval as converged. */ - iwork[k - 1] = 0; - if (i1 == i__) { - i1 = next; - } else { -/* Prev holds the last unconverged interval previously examined */ - if (prev >= i1) { - iwork[(prev << 1) - 1] = next; - } - } - i__ = next; - goto L100; - } - prev = i__; - -/* Perform one bisection step */ - - negcnt = dlaneg_(n, &d__[1], &lld[1], &mid, pivmin, &r__); - if (negcnt <= i__ - 1) { - work[k - 1] = mid; - } else { - work[k] = mid; - } - i__ = next; -L100: - ; - } - ++iter; -/* do another loop if there are still unconverged intervals */ -/* However, in the last iteration, all intervals are accepted */ -/* since this is the best we can do. */ - if (nint > 0 && iter <= maxitr) { - goto L80; - } - - -/* At this point, all the intervals have converged */ - i__1 = *ilast; - for (i__ = *ifirst; i__ <= i__1; ++i__) { - k = i__ << 1; - ii = i__ - *offset; -/* All intervals marked by '0' have been refined. */ - if (iwork[k - 1] == 0) { - w[ii] = (work[k - 1] + work[k]) * .5; - werr[ii] = work[k] - w[ii]; - } -/* L110: */ - } - - i__1 = *ilast; - for (i__ = *ifirst + 1; i__ <= i__1; ++i__) { - k = i__ << 1; - ii = i__ - *offset; -/* Computing MAX */ - d__1 = 0., d__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1]; - wgap[ii - 1] = std::max(d__1,d__2); -/* L111: */ - } - return 0; - -/* End of DLARRB */ - -} /* dlarrb_ */ diff --git a/external/clapack/lapack/dlarrc.cpp b/external/clapack/lapack/dlarrc.cpp deleted file mode 100644 index 4f2cbca3..00000000 --- a/external/clapack/lapack/dlarrc.cpp +++ /dev/null @@ -1,171 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlarrc_(const char *jobt, integer *n, double *vl, - double *vu, double *d__, double *e, double *pivmin, - integer *eigcnt, integer *lcnt, integer *rcnt, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer i__; - double sl, su, tmp, tmp2; - bool matt; - - double lpivot, rpivot; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Find the number of eigenvalues of the symmetric tridiagonal matrix T */ -/* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T */ -/* if JOBT = 'L'. */ - -/* Arguments */ -/* ========= */ - -/* JOBT (input) CHARACTER*1 */ -/* = 'T': Compute Sturm count for matrix T. */ -/* = 'L': Compute Sturm count for matrix L D L^T. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N > 0. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* The lower and upper bounds for the eigenvalues. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. */ -/* JOBT = 'L': The N diagonal elements of the diagonal matrix D. */ - -/* E (input) DOUBLE PRECISION array, dimension (N) */ -/* JOBT = 'T': The N-1 offdiagonal elements of the matrix T. */ -/* JOBT = 'L': The N-1 offdiagonal elements of the matrix L. */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum pivot in the Sturm sequence for T. */ - -/* EIGCNT (output) INTEGER */ -/* The number of eigenvalues of the symmetric tridiagonal matrix T */ -/* that are in the interval (VL,VU] */ - -/* LCNT (output) INTEGER */ -/* RCNT (output) INTEGER */ -/* The left and right negcounts of the interval. */ - -/* INFO (output) INTEGER */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --e; - --d__; - - /* Function Body */ - *info = 0; - *lcnt = 0; - *rcnt = 0; - *eigcnt = 0; - matt = lsame_(jobt, "T"); - if (matt) { -/* Sturm sequence count on T */ - lpivot = d__[1] - *vl; - rpivot = d__[1] - *vu; - if (lpivot <= 0.) { - ++(*lcnt); - } - if (rpivot <= 0.) { - ++(*rcnt); - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing 2nd power */ - d__1 = e[i__]; - tmp = d__1 * d__1; - lpivot = d__[i__ + 1] - *vl - tmp / lpivot; - rpivot = d__[i__ + 1] - *vu - tmp / rpivot; - if (lpivot <= 0.) { - ++(*lcnt); - } - if (rpivot <= 0.) { - ++(*rcnt); - } -/* L10: */ - } - } else { -/* Sturm sequence count on L D L^T */ - sl = -(*vl); - su = -(*vu); - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - lpivot = d__[i__] + sl; - rpivot = d__[i__] + su; - if (lpivot <= 0.) { - ++(*lcnt); - } - if (rpivot <= 0.) { - ++(*rcnt); - } - tmp = e[i__] * d__[i__] * e[i__]; - - tmp2 = tmp / lpivot; - if (tmp2 == 0.) { - sl = tmp - *vl; - } else { - sl = sl * tmp2 - *vl; - } - - tmp2 = tmp / rpivot; - if (tmp2 == 0.) { - su = tmp - *vu; - } else { - su = su * tmp2 - *vu; - } -/* L20: */ - } - lpivot = d__[*n] + sl; - rpivot = d__[*n] + su; - if (lpivot <= 0.) { - ++(*lcnt); - } - if (rpivot <= 0.) { - ++(*rcnt); - } - } - *eigcnt = *rcnt - *lcnt; - return 0; - -/* end of DLARRC */ - -} /* dlarrc_ */ diff --git a/external/clapack/lapack/dlarrd.cpp b/external/clapack/lapack/dlarrd.cpp deleted file mode 100644 index fc5415c8..00000000 --- a/external/clapack/lapack/dlarrd.cpp +++ /dev/null @@ -1,763 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; -static integer c__0 = 0; - -int dlarrd_(const char *range, const char *order, integer *n, double *vl, double *vu, integer *il, - integer *iu, double *gers, double *reltol, double *d__, double *e, double *e2, double *pivmin, - integer *nsplit, integer *isplit, integer *m, double *w, double *werr, double *wl, double *wu, - integer *iblock, integer *indexw, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - double d__1, d__2; - - /* Local variables */ - integer i__, j, ib, ie, je, nb; - double gl; - integer im, in; - double gu; - integer iw, jee; - double eps; - integer nwl; - double wlu, wul; - integer nwu; - double tmp1, tmp2; - integer iend, jblk, ioff, iout, itmp1, itmp2, jdisc, iinfo; - double atoli; - integer iwoff, itmax; - double wkill, rtoli, uflow, tnorm; - integer ibegin,irange, idiscl, idumma[1], idiscu; - bool ncnvrg, toofew; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* -- April 2009 -- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARRD computes the eigenvalues of a symmetric tridiagonal */ -/* matrix T to suitable accuracy. This is an auxiliary code to be */ -/* called from DSTEMR. */ -/* The user may ask for all eigenvalues, all eigenvalues */ -/* in the half-open interval (VL, VU], or the IL-th through IU-th */ -/* eigenvalues. */ - -/* To avoid overflow, the matrix must be scaled so that its */ -/* largest element is no greater than overflow**(1/2) * */ -/* underflow**(1/4) in absolute value, and for greatest */ -/* accuracy, it should not be much smaller than that. */ - -/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ -/* Matrix", Report CS41, Computer Science Dept., Stanford */ -/* University, July 21, 1966. */ - -/* Arguments */ -/* ========= */ - -/* RANGE (input) CHARACTER */ -/* = 'A': ("All") all eigenvalues will be found. */ -/* = 'V': ("Value") all eigenvalues in the half-open interval */ -/* (VL, VU] will be found. */ -/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ -/* entire matrix) will be found. */ - -/* ORDER (input) CHARACTER */ -/* = 'B': ("By Block") the eigenvalues will be grouped by */ -/* split-off block (see IBLOCK, ISPLIT) and */ -/* ordered from smallest to largest within */ -/* the block. */ -/* = 'E': ("Entire matrix") */ -/* the eigenvalues for the entire matrix */ -/* will be ordered from smallest to */ -/* largest. */ - -/* N (input) INTEGER */ -/* The order of the tridiagonal matrix T. N >= 0. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. Eigenvalues less than or equal */ -/* to VL, or greater than VU, will not be returned. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */ -/* The N Gerschgorin intervals (the i-th Gerschgorin interval */ -/* is (GERS(2*i-1), GERS(2*i)). */ - -/* RELTOL (input) DOUBLE PRECISION */ -/* The minimum relative width of an interval. When an interval */ -/* is narrower than RELTOL times the larger (in */ -/* magnitude) endpoint, then it is considered to be */ -/* sufficiently small, i.e., converged. Note: this should */ -/* always be at least radix*machine epsilon. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix T. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */ - -/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum pivot allowed in the Sturm sequence for T. */ - -/* NSPLIT (input) INTEGER */ -/* The number of diagonal blocks in the matrix T. */ -/* 1 <= NSPLIT <= N. */ - -/* ISPLIT (input) INTEGER array, dimension (N) */ -/* The splitting points, at which T breaks up into submatrices. */ -/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */ -/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ -/* etc., and the NSPLIT-th consists of rows/columns */ -/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ -/* (Only the first NSPLIT elements will actually be used, but */ -/* since the user cannot know a priori what value NSPLIT will */ -/* have, N words must be reserved for ISPLIT.) */ - -/* M (output) INTEGER */ -/* The actual number of eigenvalues found. 0 <= M <= N. */ -/* (See also the description of INFO=2,3.) */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, the first M elements of W will contain the */ -/* eigenvalue approximations. DLARRD computes an interval */ -/* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue */ -/* approximation is given as the interval midpoint */ -/* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by */ -/* WERR(j) = abs( a_j - b_j)/2 */ - -/* WERR (output) DOUBLE PRECISION array, dimension (N) */ -/* The error bound on the corresponding eigenvalue approximation */ -/* in W. */ - -/* WL (output) DOUBLE PRECISION */ -/* WU (output) DOUBLE PRECISION */ -/* The interval (WL, WU] contains all the wanted eigenvalues. */ -/* If RANGE='V', then WL=VL and WU=VU. */ -/* If RANGE='A', then WL and WU are the global Gerschgorin bounds */ -/* on the spectrum. */ -/* If RANGE='I', then WL and WU are computed by DLAEBZ from the */ -/* index range specified. */ - -/* IBLOCK (output) INTEGER array, dimension (N) */ -/* At each row/column j where E(j) is zero or small, the */ -/* matrix T is considered to split into a block diagonal */ -/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */ -/* block (from 1 to the number of blocks) the eigenvalue W(i) */ -/* belongs. (DLARRD may use the remaining N-M elements as */ -/* workspace.) */ - -/* INDEXW (output) INTEGER array, dimension (N) */ -/* The indices of the eigenvalues within each block (submatrix); */ -/* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the */ -/* i-th eigenvalue W(i) is the j-th eigenvalue in block k. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* IWORK (workspace) INTEGER array, dimension (3*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: some or all of the eigenvalues failed to converge or */ -/* were not computed: */ -/* =1 or 3: Bisection failed to converge for some */ -/* eigenvalues; these eigenvalues are flagged by a */ -/* negative block number. The effect is that the */ -/* eigenvalues may not be as accurate as the */ -/* absolute and relative tolerances. This is */ -/* generally caused by unexpectedly inaccurate */ -/* arithmetic. */ -/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */ -/* IL:IU were found. */ -/* Effect: M < IU+1-IL */ -/* Cause: non-monotonic arithmetic, causing the */ -/* Sturm sequence to be non-monotonic. */ -/* Cure: recalculate, using RANGE='A', and pick */ -/* out eigenvalues IL:IU. In some cases, */ -/* increasing the PARAMETER "FUDGE" may */ -/* make things work. */ -/* = 4: RANGE='I', and the Gershgorin interval */ -/* initially used was too small. No eigenvalues */ -/* were computed. */ -/* Probable cause: your machine has sloppy */ -/* floating-point arithmetic. */ -/* Cure: Increase the PARAMETER "FUDGE", */ -/* recompile, and try again. */ - -/* Internal Parameters */ -/* =================== */ - -/* FUDGE DOUBLE PRECISION, default = 2 */ -/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */ -/* a value of 1 should work, but on machines with sloppy */ -/* arithmetic, this needs to be larger. The default for */ -/* publicly released versions should be large enough to handle */ -/* the worst machine around. Note that this has no effect */ -/* on accuracy of the solution. */ - -/* Based on contributions by */ -/* W. Kahan, University of California, Berkeley, USA */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --iwork; - --work; - --indexw; - --iblock; - --werr; - --w; - --isplit; - --e2; - --e; - --d__; - --gers; - - /* Function Body */ - *info = 0; - -/* Decode RANGE */ - - if (lsame_(range, "A")) { - irange = 1; - } else if (lsame_(range, "V")) { - irange = 2; - } else if (lsame_(range, "I")) { - irange = 3; - } else { - irange = 0; - } - -/* Check for Errors */ - - if (irange <= 0) { - *info = -1; - } else if (! (lsame_(order, "B") || lsame_(order, - "E"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (irange == 2) { - if (*vl >= *vu) { - *info = -5; - } - } else if (irange == 3 && (*il < 1 || *il > std::max(1_integer,*n))) { - *info = -6; - } else if (irange == 3 && (*iu < std::min(*n,*il) || *iu > *n)) { - *info = -7; - } - - if (*info != 0) { - return 0; - } -/* Initialize error flags */ - *info = 0; - ncnvrg = false; - toofew = false; -/* Quick return if possible */ - *m = 0; - if (*n == 0) { - return 0; - } -/* Simplification: */ - if (irange == 3 && *il == 1 && *iu == *n) { - irange = 1; - } -/* Get machine constants */ - eps = dlamch_("P"); - uflow = dlamch_("U"); -/* Special Case when N=1 */ -/* Treat case of 1x1 matrix for quick return */ - if (*n == 1) { - if (irange == 1 || irange == 2 && d__[1] > *vl && d__[1] <= *vu || - irange == 3 && *il == 1 && *iu == 1) { - *m = 1; - w[1] = d__[1]; -/* The computation error of the eigenvalue is zero */ - werr[1] = 0.; - iblock[1] = 1; - indexw[1] = 1; - } - return 0; - } -/* NB is the minimum vector length for vector bisection, or 0 */ -/* if only scalar is to be done. */ - nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1); - if (nb <= 1) { - nb = 0; - } -/* Find global spectral radius */ - gl = d__[1]; - gu = d__[1]; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MIN */ - d__1 = gl, d__2 = gers[(i__ << 1) - 1]; - gl = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = gu, d__2 = gers[i__ * 2]; - gu = std::max(d__1,d__2); -/* L5: */ - } -/* Compute global Gerschgorin bounds and spectral diameter */ -/* Computing MAX */ - d__1 = abs(gl), d__2 = abs(gu); - tnorm = std::max(d__1,d__2); - gl = gl - tnorm * 2. * eps * *n - *pivmin * 4.; - gu = gu + tnorm * 2. * eps * *n + *pivmin * 4.; -/* [JAN/28/2009] remove the line below since SPDIAM variable not use */ -/* SPDIAM = GU - GL */ -/* Input arguments for DLAEBZ: */ -/* The relative tolerance. An interval (a,b] lies within */ -/* "relative tolerance" if b-a < RELTOL*max(|a|,|b|), */ - rtoli = *reltol; -/* Set the absolute tolerance for interval convergence to zero to force */ -/* interval convergence based on relative size of the interval. */ -/* This is dangerous because intervals might not converge when RELTOL is */ -/* small. But at least a very small number should be selected so that for */ -/* strongly graded matrices, the code can get relatively accurate */ -/* eigenvalues. */ - atoli = uflow * 4. + *pivmin * 4.; - if (irange == 3) { -/* RANGE='I': Compute an interval containing eigenvalues */ -/* IL through IU. The initial interval [GL,GU] from the global */ -/* Gerschgorin bounds GL and GU is refined by DLAEBZ. */ - itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.)) + - 2; - work[*n + 1] = gl; - work[*n + 2] = gl; - work[*n + 3] = gu; - work[*n + 4] = gu; - work[*n + 5] = gl; - work[*n + 6] = gu; - iwork[1] = -1; - iwork[2] = -1; - iwork[3] = *n + 1; - iwork[4] = *n + 1; - iwork[5] = *il - 1; - iwork[6] = *iu; - - dlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, pivmin, & - d__[1], &e[1], &e2[1], &iwork[5], &work[*n + 1], &work[*n + 5] -, &iout, &iwork[1], &w[1], &iblock[1], &iinfo); - if (iinfo != 0) { - *info = iinfo; - return 0; - } -/* On exit, output intervals may not be ordered by ascending negcount */ - if (iwork[6] == *iu) { - *wl = work[*n + 1]; - wlu = work[*n + 3]; - nwl = iwork[1]; - *wu = work[*n + 4]; - wul = work[*n + 2]; - nwu = iwork[4]; - } else { - *wl = work[*n + 2]; - wlu = work[*n + 4]; - nwl = iwork[2]; - *wu = work[*n + 3]; - wul = work[*n + 1]; - nwu = iwork[3]; - } -/* On exit, the interval [WL, WLU] contains a value with negcount NWL, */ -/* and [WUL, WU] contains a value with negcount NWU. */ - if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) { - *info = 4; - return 0; - } - } else if (irange == 2) { - *wl = *vl; - *wu = *vu; - } else if (irange == 1) { - *wl = gl; - *wu = gu; - } -/* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. */ -/* NWL accumulates the number of eigenvalues .le. WL, */ -/* NWU accumulates the number of eigenvalues .le. WU */ - *m = 0; - iend = 0; - *info = 0; - nwl = 0; - nwu = 0; - - i__1 = *nsplit; - for (jblk = 1; jblk <= i__1; ++jblk) { - ioff = iend; - ibegin = ioff + 1; - iend = isplit[jblk]; - in = iend - ioff; - - if (in == 1) { -/* 1x1 block */ - if (*wl >= d__[ibegin] - *pivmin) { - ++nwl; - } - if (*wu >= d__[ibegin] - *pivmin) { - ++nwu; - } - if (irange == 1 || *wl < d__[ibegin] - *pivmin && *wu >= d__[ - ibegin] - *pivmin) { - ++(*m); - w[*m] = d__[ibegin]; - werr[*m] = 0.; -/* The gap for a single block doesn't matter for the later */ -/* algorithm and is assigned an arbitrary large value */ - iblock[*m] = jblk; - indexw[*m] = 1; - } -/* Disabled 2x2 case because of a failure on the following matrix */ -/* RANGE = 'I', IL = IU = 4 */ -/* Original Tridiagonal, d = [ */ -/* -0.150102010615740E+00 */ -/* -0.849897989384260E+00 */ -/* -0.128208148052635E-15 */ -/* 0.128257718286320E-15 */ -/* ]; */ -/* e = [ */ -/* -0.357171383266986E+00 */ -/* -0.180411241501588E-15 */ -/* -0.175152352710251E-15 */ -/* ]; */ - -/* ELSE IF( IN.EQ.2 ) THEN */ -/* * 2x2 block */ -/* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) */ -/* TMP1 = HALF*(D(IBEGIN)+D(IEND)) */ -/* L1 = TMP1 - DISC */ -/* IF( WL.GE. L1-PIVMIN ) */ -/* $ NWL = NWL + 1 */ -/* IF( WU.GE. L1-PIVMIN ) */ -/* $ NWU = NWU + 1 */ -/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. */ -/* $ L1-PIVMIN ) ) THEN */ -/* M = M + 1 */ -/* W( M ) = L1 */ -/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */ -/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */ -/* IBLOCK( M ) = JBLK */ -/* INDEXW( M ) = 1 */ -/* ENDIF */ -/* L2 = TMP1 + DISC */ -/* IF( WL.GE. L2-PIVMIN ) */ -/* $ NWL = NWL + 1 */ -/* IF( WU.GE. L2-PIVMIN ) */ -/* $ NWU = NWU + 1 */ -/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. */ -/* $ L2-PIVMIN ) ) THEN */ -/* M = M + 1 */ -/* W( M ) = L2 */ -/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */ -/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */ -/* IBLOCK( M ) = JBLK */ -/* INDEXW( M ) = 2 */ -/* ENDIF */ - } else { -/* General Case - block of size IN >= 2 */ -/* Compute local Gerschgorin interval and use it as the initial */ -/* interval for DLAEBZ */ - gu = d__[ibegin]; - gl = d__[ibegin]; - tmp1 = 0.; - i__2 = iend; - for (j = ibegin; j <= i__2; ++j) { -/* Computing MIN */ - d__1 = gl, d__2 = gers[(j << 1) - 1]; - gl = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = gu, d__2 = gers[j * 2]; - gu = std::max(d__1,d__2); -/* L40: */ - } -/* [JAN/28/2009] */ -/* change SPDIAM by TNORM in lines 2 and 3 thereafter */ -/* line 1: remove computation of SPDIAM (not useful anymore) */ -/* SPDIAM = GU - GL */ -/* GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN */ -/* GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN */ - gl = gl - tnorm * 2. * eps * in - *pivmin * 2.; - gu = gu + tnorm * 2. * eps * in + *pivmin * 2.; - - if (irange > 1) { - if (gu < *wl) { -/* the local block contains none of the wanted eigenvalues */ - nwl += in; - nwu += in; - goto L70; - } -/* refine search interval if possible, only range (WL,WU] matters */ - gl = std::max(gl,*wl); - gu = std::min(gu,*wu); - if (gl >= gu) { - goto L70; - } - } -/* Find negcount of initial interval boundaries GL and GU */ - work[*n + 1] = gl; - work[*n + in + 1] = gu; - dlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, - pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, & - work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], & - w[*m + 1], &iblock[*m + 1], &iinfo); - if (iinfo != 0) { - *info = iinfo; - return 0; - } - - nwl += iwork[1]; - nwu += iwork[in + 1]; - iwoff = *m - iwork[1]; -/* Compute Eigenvalues */ - itmax = (integer) ((log(gu - gl + *pivmin) - log(*pivmin)) / log( - 2.)) + 2; - dlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, - pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, & - work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], - &w[*m + 1], &iblock[*m + 1], &iinfo); - if (iinfo != 0) { - *info = iinfo; - return 0; - } - -/* Copy eigenvalues into W and IBLOCK */ -/* Use -JBLK for block number for unconverged eigenvalues. */ -/* Loop over the number of output intervals from DLAEBZ */ - i__2 = iout; - for (j = 1; j <= i__2; ++j) { -/* eigenvalue approximation is middle point of interval */ - tmp1 = (work[j + *n] + work[j + in + *n]) * .5; -/* semi length of error interval */ - tmp2 = (d__1 = work[j + *n] - work[j + in + *n], abs(d__1)) * - .5; - if (j > iout - iinfo) { -/* Flag non-convergence. */ - ncnvrg = true; - ib = -jblk; - } else { - ib = jblk; - } - i__3 = iwork[j + in] + iwoff; - for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) { - w[je] = tmp1; - werr[je] = tmp2; - indexw[je] = je - iwoff; - iblock[je] = ib; -/* L50: */ - } -/* L60: */ - } - - *m += im; - } -L70: - ; - } -/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */ -/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */ - if (irange == 3) { - idiscl = *il - 1 - nwl; - idiscu = nwu - *iu; - - if (idiscl > 0) { - im = 0; - i__1 = *m; - for (je = 1; je <= i__1; ++je) { -/* Remove some of the smallest eigenvalues from the left so that */ -/* at the end IDISCL =0. Move all eigenvalues up to the left. */ - if (w[je] <= wlu && idiscl > 0) { - --idiscl; - } else { - ++im; - w[im] = w[je]; - werr[im] = werr[je]; - indexw[im] = indexw[je]; - iblock[im] = iblock[je]; - } -/* L80: */ - } - *m = im; - } - if (idiscu > 0) { -/* Remove some of the largest eigenvalues from the right so that */ -/* at the end IDISCU =0. Move all eigenvalues up to the left. */ - im = *m + 1; - for (je = *m; je >= 1; --je) { - if (w[je] >= wul && idiscu > 0) { - --idiscu; - } else { - --im; - w[im] = w[je]; - werr[im] = werr[je]; - indexw[im] = indexw[je]; - iblock[im] = iblock[je]; - } -/* L81: */ - } - jee = 0; - i__1 = *m; - for (je = im; je <= i__1; ++je) { - ++jee; - w[jee] = w[je]; - werr[jee] = werr[je]; - indexw[jee] = indexw[je]; - iblock[jee] = iblock[je]; -/* L82: */ - } - *m = *m - im + 1; - } - if (idiscl > 0 || idiscu > 0) { -/* Code to deal with effects of bad arithmetic. (If N(w) is */ -/* monotone non-decreasing, this should never happen.) */ -/* Some low eigenvalues to be discarded are not in (WL,WLU], */ -/* or high eigenvalues to be discarded are not in (WUL,WU] */ -/* so just kill off the smallest IDISCL/largest IDISCU */ -/* eigenvalues, by marking the corresponding IBLOCK = 0 */ - if (idiscl > 0) { - wkill = *wu; - i__1 = idiscl; - for (jdisc = 1; jdisc <= i__1; ++jdisc) { - iw = 0; - i__2 = *m; - for (je = 1; je <= i__2; ++je) { - if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) { - iw = je; - wkill = w[je]; - } -/* L90: */ - } - iblock[iw] = 0; -/* L100: */ - } - } - if (idiscu > 0) { - wkill = *wl; - i__1 = idiscu; - for (jdisc = 1; jdisc <= i__1; ++jdisc) { - iw = 0; - i__2 = *m; - for (je = 1; je <= i__2; ++je) { - if (iblock[je] != 0 && (w[je] >= wkill || iw == 0)) { - iw = je; - wkill = w[je]; - } -/* L110: */ - } - iblock[iw] = 0; -/* L120: */ - } - } -/* Now erase all eigenvalues with IBLOCK set to zero */ - im = 0; - i__1 = *m; - for (je = 1; je <= i__1; ++je) { - if (iblock[je] != 0) { - ++im; - w[im] = w[je]; - werr[im] = werr[je]; - indexw[im] = indexw[je]; - iblock[im] = iblock[je]; - } -/* L130: */ - } - *m = im; - } - if (idiscl < 0 || idiscu < 0) { - toofew = true; - } - } - - if (irange == 1 && *m != *n || irange == 3 && *m != *iu - *il + 1) { - toofew = true; - } -/* If ORDER='B', do nothing the eigenvalues are already sorted by */ -/* block. */ -/* If ORDER='E', sort the eigenvalues from smallest to largest */ - if (lsame_(order, "E") && *nsplit > 1) { - i__1 = *m - 1; - for (je = 1; je <= i__1; ++je) { - ie = 0; - tmp1 = w[je]; - i__2 = *m; - for (j = je + 1; j <= i__2; ++j) { - if (w[j] < tmp1) { - ie = j; - tmp1 = w[j]; - } -/* L140: */ - } - if (ie != 0) { - tmp2 = werr[ie]; - itmp1 = iblock[ie]; - itmp2 = indexw[ie]; - w[ie] = w[je]; - werr[ie] = werr[je]; - iblock[ie] = iblock[je]; - indexw[ie] = indexw[je]; - w[je] = tmp1; - werr[je] = tmp2; - iblock[je] = itmp1; - indexw[je] = itmp2; - } -/* L150: */ - } - } - - *info = 0; - if (ncnvrg) { - ++(*info); - } - if (toofew) { - *info += 2; - } - return 0; - -/* End of DLARRD */ - -} /* dlarrd_ */ diff --git a/external/clapack/lapack/dlarre.cpp b/external/clapack/lapack/dlarre.cpp deleted file mode 100644 index 68216341..00000000 --- a/external/clapack/lapack/dlarre.cpp +++ /dev/null @@ -1,822 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int dlarre_(const char *range, integer *n, double *vl, - double *vu, integer *il, integer *iu, double *d__, double - *e, double *e2, double *rtol1, double *rtol2, double * - spltol, integer *nsplit, integer *isplit, integer *m, double *w, - double *werr, double *wgap, integer *iblock, integer *indexw, - double *gers, double *pivmin, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - double d__1, d__2, d__3; - - /* Builtin functions - double sqrt(double), log(double); */ - - /* Local variables */ - integer i__, j; - double s1, s2; - integer mb; - double gl; - integer in, mm; - double gu; - integer cnt; - double eps, tau, tmp, rtl; - integer cnt1, cnt2; - double tmp1, eabs; - integer iend, jblk; - double eold; - integer indl; - double dmax__, emax; - integer wend, idum, indu; - double rtol; - integer iseed[4]; - double avgap, sigma; - integer iinfo; - bool norep; - integer ibegin; - bool forceb; - integer irange; - double sgndef; - integer wbegin; - double safmin, spdiam; - bool usedqd; - double clwdth, isleft; - double isrght, bsrtol, dpivot; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* To find the desired eigenvalues of a given real symmetric */ -/* tridiagonal matrix T, DLARRE sets any "small" off-diagonal */ -/* elements to zero, and for each unreduced block T_i, it finds */ -/* (a) a suitable shift at one end of the block's spectrum, */ -/* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */ -/* (c) eigenvalues of each L_i D_i L_i^T. */ -/* The representations and eigenvalues found are then used by */ -/* DSTEMR to compute the eigenvectors of T. */ -/* The accuracy varies depending on whether bisection is used to */ -/* find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to */ -/* conpute all and then discard any unwanted one. */ -/* As an added benefit, DLARRE also outputs the n */ -/* Gerschgorin intervals for the matrices L_i D_i L_i^T. */ - -/* Arguments */ -/* ========= */ - -/* RANGE (input) CHARACTER */ -/* = 'A': ("All") all eigenvalues will be found. */ -/* = 'V': ("Value") all eigenvalues in the half-open interval */ -/* (VL, VU] will be found. */ -/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ -/* entire matrix) will be found. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N > 0. */ - -/* VL (input/output) DOUBLE PRECISION */ -/* VU (input/output) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds for the eigenvalues. */ -/* Eigenvalues less than or equal to VL, or greater than VU, */ -/* will not be returned. VL < VU. */ -/* If RANGE='I' or ='A', DLARRE computes bounds on the desired */ -/* part of the spectrum. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the N diagonal elements of the tridiagonal */ -/* matrix T. */ -/* On exit, the N diagonal elements of the diagonal */ -/* matrices D_i. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the first (N-1) entries contain the subdiagonal */ -/* elements of the tridiagonal matrix T; E(N) need not be set. */ -/* On exit, E contains the subdiagonal elements of the unit */ -/* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */ -/* 1 <= I <= NSPLIT, contain the base points sigma_i on output. */ - -/* E2 (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the first (N-1) entries contain the SQUARES of the */ -/* subdiagonal elements of the tridiagonal matrix T; */ -/* E2(N) need not be set. */ -/* On exit, the entries E2( ISPLIT( I ) ), */ -/* 1 <= I <= NSPLIT, have been set to zero */ - -/* RTOL1 (input) DOUBLE PRECISION */ -/* RTOL2 (input) DOUBLE PRECISION */ -/* Parameters for bisection. */ -/* An interval [LEFT,RIGHT] has converged if */ -/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ - -/* SPLTOL (input) DOUBLE PRECISION */ -/* The threshold for splitting. */ - -/* NSPLIT (output) INTEGER */ -/* The number of blocks T splits into. 1 <= NSPLIT <= N. */ - -/* ISPLIT (output) INTEGER array, dimension (N) */ -/* The splitting points, at which T breaks up into blocks. */ -/* The first block consists of rows/columns 1 to ISPLIT(1), */ -/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ -/* etc., and the NSPLIT-th consists of rows/columns */ -/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues (of all L_i D_i L_i^T) */ -/* found. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the eigenvalues. The */ -/* eigenvalues of each of the blocks, L_i D_i L_i^T, are */ -/* sorted in ascending order ( DLARRE may use the */ -/* remaining N-M elements as workspace). */ - -/* WERR (output) DOUBLE PRECISION array, dimension (N) */ -/* The error bound on the corresponding eigenvalue in W. */ - -/* WGAP (output) DOUBLE PRECISION array, dimension (N) */ -/* The separation from the right neighbor eigenvalue in W. */ -/* The gap is only with respect to the eigenvalues of the same block */ -/* as each block has its own representation tree. */ -/* Exception: at the right end of a block we store the left gap */ - -/* IBLOCK (output) INTEGER array, dimension (N) */ -/* The indices of the blocks (submatrices) associated with the */ -/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */ -/* W(i) belongs to the first block from the top, =2 if W(i) */ -/* belongs to the second block, etc. */ - -/* INDEXW (output) INTEGER array, dimension (N) */ -/* The indices of the eigenvalues within each block (submatrix); */ -/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */ -/* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */ - -/* GERS (output) DOUBLE PRECISION array, dimension (2*N) */ -/* The N Gerschgorin intervals (the i-th Gerschgorin interval */ -/* is (GERS(2*i-1), GERS(2*i)). */ - -/* PIVMIN (output) DOUBLE PRECISION */ -/* The minimum pivot in the Sturm sequence for T. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) */ -/* Workspace. */ - -/* IWORK (workspace) INTEGER array, dimension (5*N) */ -/* Workspace. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* > 0: A problem occured in DLARRE. */ -/* < 0: One of the called subroutines signaled an internal problem. */ -/* Needs inspection of the corresponding parameter IINFO */ -/* for further information. */ - -/* =-1: Problem in DLARRD. */ -/* = 2: No base representation could be found in MAXTRY iterations. */ -/* Increasing MAXTRY and recompilation might be a remedy. */ -/* =-3: Problem in DLARRB when computing the refined root */ -/* representation for DLASQ2. */ -/* =-4: Problem in DLARRB when preforming bisection on the */ -/* desired part of the spectrum. */ -/* =-5: Problem in DLASQ2. */ -/* =-6: Problem in DLASQ2. */ - -/* Further Details */ -/* The base representations are required to suffer very little */ -/* element growth and consequently define all their eigenvalues to */ -/* high relative accuracy. */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --iwork; - --work; - --gers; - --indexw; - --iblock; - --wgap; - --werr; - --w; - --isplit; - --e2; - --e; - --d__; - - /* Function Body */ - *info = 0; - -/* Decode RANGE */ - - if (lsame_(range, "A")) { - irange = 1; - } else if (lsame_(range, "V")) { - irange = 3; - } else if (lsame_(range, "I")) { - irange = 2; - } - *m = 0; -/* Get machine constants */ - safmin = dlamch_("S"); - eps = dlamch_("P"); -/* Set parameters */ - rtl = sqrt(eps); - bsrtol = sqrt(eps); -/* Treat case of 1x1 matrix for quick return */ - if (*n == 1) { - if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu || - irange == 2 && *il == 1 && *iu == 1) { - *m = 1; - w[1] = d__[1]; -/* The computation error of the eigenvalue is zero */ - werr[1] = 0.; - wgap[1] = 0.; - iblock[1] = 1; - indexw[1] = 1; - gers[1] = d__[1]; - gers[2] = d__[1]; - } -/* store the shift for the initial RRR, which is zero in this case */ - e[1] = 0.; - return 0; - } -/* General case: tridiagonal matrix of order > 1 */ - -/* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */ -/* Compute maximum off-diagonal entry and pivmin. */ - gl = d__[1]; - gu = d__[1]; - eold = 0.; - emax = 0.; - e[*n] = 0.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - werr[i__] = 0.; - wgap[i__] = 0.; - eabs = (d__1 = e[i__], abs(d__1)); - if (eabs >= emax) { - emax = eabs; - } - tmp1 = eabs + eold; - gers[(i__ << 1) - 1] = d__[i__] - tmp1; -/* Computing MIN */ - d__1 = gl, d__2 = gers[(i__ << 1) - 1]; - gl = std::min(d__1,d__2); - gers[i__ * 2] = d__[i__] + tmp1; -/* Computing MAX */ - d__1 = gu, d__2 = gers[i__ * 2]; - gu = std::max(d__1,d__2); - eold = eabs; -/* L5: */ - } -/* The minimum pivot allowed in the Sturm sequence for T */ -/* Computing MAX */ -/* Computing 2nd power */ - d__3 = emax; - d__1 = 1., d__2 = d__3 * d__3; - *pivmin = safmin * std::max(d__1,d__2); -/* Compute spectral diameter. The Gerschgorin bounds give an */ -/* estimate that is wrong by at most a factor of SQRT(2) */ - spdiam = gu - gl; -/* Compute splitting points */ - dlarra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], & - iinfo); -/* Can force use of bisection instead of faster DQDS. */ -/* Option left in the code for future multisection work. */ - forceb = false; - if (irange == 1 && ! forceb) { -/* Set interval [VL,VU] that contains all eigenvalues */ - *vl = gl; - *vu = gu; - } else { -/* We call DLARRD to find crude approximations to the eigenvalues */ -/* in the desired range. In case IRANGE = INDRNG, we also obtain the */ -/* interval (VL,VU] that contains all the wanted eigenvalues. */ -/* An interval [LEFT,RIGHT] has converged if */ -/* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */ -/* DLARRD needs a WORK of size 4*N, IWORK of size 3*N */ - dlarrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[ - 1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1], - vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo); - if (iinfo != 0) { - *info = -1; - return 0; - } -/* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */ - i__1 = *n; - for (i__ = mm + 1; i__ <= i__1; ++i__) { - w[i__] = 0.; - werr[i__] = 0.; - iblock[i__] = 0; - indexw[i__] = 0; -/* L14: */ - } - } -/* ** */ -/* Loop over unreduced blocks */ - ibegin = 1; - wbegin = 1; - i__1 = *nsplit; - for (jblk = 1; jblk <= i__1; ++jblk) { - iend = isplit[jblk]; - in = iend - ibegin + 1; -/* 1 X 1 block */ - if (in == 1) { - if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin] - <= *vu || irange == 2 && iblock[wbegin] == jblk) { - ++(*m); - w[*m] = d__[ibegin]; - werr[*m] = 0.; -/* The gap for a single block doesn't matter for the later */ -/* algorithm and is assigned an arbitrary large value */ - wgap[*m] = 0.; - iblock[*m] = jblk; - indexw[*m] = 1; - ++wbegin; - } -/* E( IEND ) holds the shift for the initial RRR */ - e[iend] = 0.; - ibegin = iend + 1; - goto L170; - } - -/* Blocks of size larger than 1x1 */ - -/* E( IEND ) will hold the shift for the initial RRR, for now set it =0 */ - e[iend] = 0.; - -/* Find local outer bounds GL,GU for the block */ - gl = d__[ibegin]; - gu = d__[ibegin]; - i__2 = iend; - for (i__ = ibegin; i__ <= i__2; ++i__) { -/* Computing MIN */ - d__1 = gers[(i__ << 1) - 1]; - gl = std::min(d__1,gl); -/* Computing MAX */ - d__1 = gers[i__ * 2]; - gu = std::max(d__1,gu); -/* L15: */ - } - spdiam = gu - gl; - if (! (irange == 1 && ! forceb)) { -/* Count the number of eigenvalues in the current block. */ - mb = 0; - i__2 = mm; - for (i__ = wbegin; i__ <= i__2; ++i__) { - if (iblock[i__] == jblk) { - ++mb; - } else { - goto L21; - } -/* L20: */ - } -L21: - if (mb == 0) { -/* No eigenvalue in the current block lies in the desired range */ -/* E( IEND ) holds the shift for the initial RRR */ - e[iend] = 0.; - ibegin = iend + 1; - goto L170; - } else { -/* Decide whether dqds or bisection is more efficient */ - usedqd = (double) mb > in * .5 && ! forceb; - wend = wbegin + mb - 1; -/* Calculate gaps for the current block */ -/* In later stages, when representations for individual */ -/* eigenvalues are different, we use SIGMA = E( IEND ). */ - sigma = 0.; - i__2 = wend - 1; - for (i__ = wbegin; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + - werr[i__]); - wgap[i__] = std::max(d__1,d__2); -/* L30: */ - } -/* Computing MAX */ - d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]); - wgap[wend] = std::max(d__1,d__2); -/* Find local index of the first and last desired evalue. */ - indl = indexw[wbegin]; - indu = indexw[wend]; - } - } - if (irange == 1 && ! forceb || usedqd) { -/* Case of DQDS */ -/* Find approximations to the extremal eigenvalues of the block */ - dlarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & - rtl, &tmp, &tmp1, &iinfo); - if (iinfo != 0) { - *info = -1; - return 0; - } -/* Computing MAX */ - d__2 = gl, d__3 = tmp - tmp1 - eps * 100. * (d__1 = tmp - tmp1, - abs(d__1)); - isleft = std::max(d__2,d__3); - dlarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & - rtl, &tmp, &tmp1, &iinfo); - if (iinfo != 0) { - *info = -1; - return 0; - } -/* Computing MIN */ - d__2 = gu, d__3 = tmp + tmp1 + eps * 100. * (d__1 = tmp + tmp1, - abs(d__1)); - isrght = std::min(d__2,d__3); -/* Improve the estimate of the spectral diameter */ - spdiam = isrght - isleft; - } else { -/* Case of bisection */ -/* Find approximations to the wanted extremal eigenvalues */ -/* Computing MAX */ - d__2 = gl, d__3 = w[wbegin] - werr[wbegin] - eps * 100. * (d__1 = - w[wbegin] - werr[wbegin], abs(d__1)); - isleft = std::max(d__2,d__3); -/* Computing MIN */ - d__2 = gu, d__3 = w[wend] + werr[wend] + eps * 100. * (d__1 = w[ - wend] + werr[wend], abs(d__1)); - isrght = std::min(d__2,d__3); - } -/* Decide whether the base representation for the current block */ -/* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */ -/* should be on the left or the right end of the current block. */ -/* The strategy is to shift to the end which is "more populated" */ -/* Furthermore, decide whether to use DQDS for the computation of */ -/* the eigenvalue approximations at the end of DLARRE or bisection. */ -/* dqds is chosen if all eigenvalues are desired or the number of */ -/* eigenvalues to be computed is large compared to the blocksize. */ - if (irange == 1 && ! forceb) { -/* If all the eigenvalues have to be computed, we use dqd */ - usedqd = true; -/* INDL is the local index of the first eigenvalue to compute */ - indl = 1; - indu = in; -/* MB = number of eigenvalues to compute */ - mb = in; - wend = wbegin + mb - 1; -/* Define 1/4 and 3/4 points of the spectrum */ - s1 = isleft + spdiam * .25; - s2 = isrght - spdiam * .25; - } else { -/* DLARRD has computed IBLOCK and INDEXW for each eigenvalue */ -/* approximation. */ -/* choose sigma */ - if (usedqd) { - s1 = isleft + spdiam * .25; - s2 = isrght - spdiam * .25; - } else { - tmp = std::min(isrght,*vu) - std::max(isleft,*vl); - s1 = std::max(isleft,*vl) + tmp * .25; - s2 = std::min(isrght,*vu) - tmp * .25; - } - } -/* Compute the negcount at the 1/4 and 3/4 points */ - if (mb > 1) { - dlarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, & - cnt, &cnt1, &cnt2, &iinfo); - } - if (mb == 1) { - sigma = gl; - sgndef = 1.; - } else if (cnt1 - indl >= indu - cnt2) { - if (irange == 1 && ! forceb) { - sigma = std::max(isleft,gl); - } else if (usedqd) { -/* use Gerschgorin bound as shift to get pos def matrix */ -/* for dqds */ - sigma = isleft; - } else { -/* use approximation of the first desired eigenvalue of the */ -/* block as shift */ - sigma = std::max(isleft,*vl); - } - sgndef = 1.; - } else { - if (irange == 1 && ! forceb) { - sigma = std::min(isrght,gu); - } else if (usedqd) { -/* use Gerschgorin bound as shift to get neg def matrix */ -/* for dqds */ - sigma = isrght; - } else { -/* use approximation of the first desired eigenvalue of the */ -/* block as shift */ - sigma = std::min(isrght,*vu); - } - sgndef = -1.; - } -/* An initial SIGMA has been chosen that will be used for computing */ -/* T - SIGMA I = L D L^T */ -/* Define the increment TAU of the shift in case the initial shift */ -/* needs to be refined to obtain a factorization with not too much */ -/* element growth. */ - if (usedqd) { -/* The initial SIGMA was to the outer end of the spectrum */ -/* the matrix is definite and we need not retreat. */ - tau = spdiam * eps * *n + *pivmin * 2.; - } else { - if (mb > 1) { - clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin]; - avgap = (d__1 = clwdth / (double) (wend - wbegin), abs( - d__1)); - if (sgndef == 1.) { -/* Computing MAX */ - d__1 = wgap[wbegin]; - tau = std::max(d__1,avgap) * .5; -/* Computing MAX */ - d__1 = tau, d__2 = werr[wbegin]; - tau = std::max(d__1,d__2); - } else { -/* Computing MAX */ - d__1 = wgap[wend - 1]; - tau = std::max(d__1,avgap) * .5; -/* Computing MAX */ - d__1 = tau, d__2 = werr[wend]; - tau = std::max(d__1,d__2); - } - } else { - tau = werr[wbegin]; - } - } - - for (idum = 1; idum <= 6; ++idum) { -/* Compute L D L^T factorization of tridiagonal matrix T - sigma I. */ -/* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */ -/* pivots in WORK(2*IN+1:3*IN) */ - dpivot = d__[ibegin] - sigma; - work[1] = dpivot; - dmax__ = abs(work[1]); - j = ibegin; - i__2 = in - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[(in << 1) + i__] = 1. / work[i__]; - tmp = e[j] * work[(in << 1) + i__]; - work[in + i__] = tmp; - dpivot = d__[j + 1] - sigma - tmp * e[j]; - work[i__ + 1] = dpivot; -/* Computing MAX */ - d__1 = dmax__, d__2 = abs(dpivot); - dmax__ = std::max(d__1,d__2); - ++j; -/* L70: */ - } -/* check for element growth */ - if (dmax__ > spdiam * 64.) { - norep = true; - } else { - norep = false; - } - if (usedqd && ! norep) { -/* Ensure the definiteness of the representation */ -/* All entries of D (of L D L^T) must have the same sign */ - i__2 = in; - for (i__ = 1; i__ <= i__2; ++i__) { - tmp = sgndef * work[i__]; - if (tmp < 0.) { - norep = true; - } -/* L71: */ - } - } - if (norep) { -/* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */ -/* shift which makes the matrix definite. So we should end up */ -/* here really only in the case of IRANGE = VALRNG or INDRNG. */ - if (idum == 5) { - if (sgndef == 1.) { -/* The fudged Gerschgorin shift should succeed */ - sigma = gl - spdiam * 2. * eps * *n - *pivmin * 4.; - } else { - sigma = gu + spdiam * 2. * eps * *n + *pivmin * 4.; - } - } else { - sigma -= sgndef * tau; - tau *= 2.; - } - } else { -/* an initial RRR is found */ - goto L83; - } -/* L80: */ - } -/* if the program reaches this point, no base representation could be */ -/* found in MAXTRY iterations. */ - *info = 2; - return 0; -L83: -/* At this point, we have found an initial base representation */ -/* T - SIGMA I = L D L^T with not too much element growth. */ -/* Store the shift. */ - e[iend] = sigma; -/* Store D and L. */ - dcopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1); - i__2 = in - 1; - dcopy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1); - if (mb > 1) { - -/* Perturb each entry of the base representation by a small */ -/* (but random) relative amount to overcome difficulties with */ -/* glued matrices. */ - - for (i__ = 1; i__ <= 4; ++i__) { - iseed[i__ - 1] = 1; -/* L122: */ - } - i__2 = (in << 1) - 1; - dlarnv_(&c__2, iseed, &i__2, &work[1]); - i__2 = in - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - d__[ibegin + i__ - 1] *= eps * 8. * work[i__] + 1.; - e[ibegin + i__ - 1] *= eps * 8. * work[in + i__] + 1.; -/* L125: */ - } - d__[iend] *= eps * 4. * work[in] + 1.; - - } - -/* Don't update the Gerschgorin intervals because keeping track */ -/* of the updates would be too much work in DLARRV. */ -/* We update W instead and use it to locate the proper Gerschgorin */ -/* intervals. */ -/* Compute the required eigenvalues of L D L' by bisection or dqds */ - if (! usedqd) { -/* If DLARRD has been used, shift the eigenvalue approximations */ -/* according to their representation. This is necessary for */ -/* a uniform DLARRV since dqds computes eigenvalues of the */ -/* shifted representation. In DLARRV, W will always hold the */ -/* UNshifted eigenvalue approximation. */ - i__2 = wend; - for (j = wbegin; j <= i__2; ++j) { - w[j] -= sigma; - werr[j] += (d__1 = w[j], abs(d__1)) * eps; -/* L134: */ - } -/* call DLARRB to reduce eigenvalue error of the approximations */ -/* from DLARRD */ - i__2 = iend - 1; - for (i__ = ibegin; i__ <= i__2; ++i__) { -/* Computing 2nd power */ - d__1 = e[i__]; - work[i__] = d__[i__] * (d__1 * d__1); -/* L135: */ - } -/* use bisection to find EV from INDL to INDU */ - i__2 = indl - 1; - dlarrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1, - rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], & - work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, & - iinfo); - if (iinfo != 0) { - *info = -4; - return 0; - } -/* DLARRB computes all gaps correctly except for the last one */ -/* Record distance to VU/GU */ -/* Computing MAX */ - d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]); - wgap[wend] = std::max(d__1,d__2); - i__2 = indu; - for (i__ = indl; i__ <= i__2; ++i__) { - ++(*m); - iblock[*m] = jblk; - indexw[*m] = i__; -/* L138: */ - } - } else { -/* Call dqds to get all eigs (and then possibly delete unwanted */ -/* eigenvalues). */ -/* Note that dqds finds the eigenvalues of the L D L^T representation */ -/* of T to high relative accuracy. High relative accuracy */ -/* might be lost when the shift of the RRR is subtracted to obtain */ -/* the eigenvalues of T. However, T is not guaranteed to define its */ -/* eigenvalues to high relative accuracy anyway. */ -/* Set RTOL to the order of the tolerance used in DLASQ2 */ -/* This is an ESTIMATED error, the worst case bound is 4*N*EPS */ -/* which is usually too large and requires unnecessary work to be */ -/* done by bisection when computing the eigenvectors */ - rtol = log((double) in) * 4. * eps; - j = ibegin; - i__2 = in - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[(i__ << 1) - 1] = (d__1 = d__[j], abs(d__1)); - work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1]; - ++j; -/* L140: */ - } - work[(in << 1) - 1] = (d__1 = d__[iend], abs(d__1)); - work[in * 2] = 0.; - dlasq2_(&in, &work[1], &iinfo); - if (iinfo != 0) { -/* If IINFO = -5 then an index is part of a tight cluster */ -/* and should be changed. The index is in IWORK(1) and the */ -/* gap is in WORK(N+1) */ - *info = -5; - return 0; - } else { -/* Test that all eigenvalues are positive as expected */ - i__2 = in; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] < 0.) { - *info = -6; - return 0; - } -/* L149: */ - } - } - if (sgndef > 0.) { - i__2 = indu; - for (i__ = indl; i__ <= i__2; ++i__) { - ++(*m); - w[*m] = work[in - i__ + 1]; - iblock[*m] = jblk; - indexw[*m] = i__; -/* L150: */ - } - } else { - i__2 = indu; - for (i__ = indl; i__ <= i__2; ++i__) { - ++(*m); - w[*m] = -work[i__]; - iblock[*m] = jblk; - indexw[*m] = i__; -/* L160: */ - } - } - i__2 = *m; - for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { -/* the value of RTOL below should be the tolerance in DLASQ2 */ - werr[i__] = rtol * (d__1 = w[i__], abs(d__1)); -/* L165: */ - } - i__2 = *m - 1; - for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { -/* compute the right gap between the intervals */ -/* Computing MAX */ - d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + werr[ - i__]); - wgap[i__] = std::max(d__1,d__2); -/* L166: */ - } -/* Computing MAX */ - d__1 = 0., d__2 = *vu - sigma - (w[*m] + werr[*m]); - wgap[*m] = std::max(d__1,d__2); - } -/* proceed with next block */ - ibegin = iend + 1; - wbegin = wend + 1; -L170: - ; - } - - return 0; - -/* end of DLARRE */ - -} /* dlarre_ */ diff --git a/external/clapack/lapack/dlarrf.cpp b/external/clapack/lapack/dlarrf.cpp deleted file mode 100644 index 1b30be82..00000000 --- a/external/clapack/lapack/dlarrf.cpp +++ /dev/null @@ -1,404 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dlarrf_(integer *n, double *d__, double *l, - double *ld, integer *clstrt, integer *clend, double *w, - double *wgap, double *werr, double *spdiam, double * - clgapl, double *clgapr, double *pivmin, double *sigma, - double *dplus, double *lplus, double *work, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__; - double s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2, - znm2, growthbound, fail, fact, oldp; - integer indx; - double prod; - integer ktry; - double fail2, avgap, ldmax, rdmax; - integer shift; - bool dorrr1; - double ldelta; - bool nofail; - double mingap, lsigma, rdelta; - bool forcer; - double rsigma, clwdth; - bool sawnan1, sawnan2, tryrrr1; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ -/* * */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Given the initial representation L D L^T and its cluster of close */ -/* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... */ -/* W( CLEND ), DLARRF finds a new relatively robust representation */ -/* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the */ -/* eigenvalues of L(+) D(+) L(+)^T is relatively isolated. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix (subblock, if the matrix splitted). */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The N diagonal elements of the diagonal matrix D. */ - -/* L (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (N-1) subdiagonal elements of the unit bidiagonal */ -/* matrix L. */ - -/* LD (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (N-1) elements L(i)*D(i). */ - -/* CLSTRT (input) INTEGER */ -/* The index of the first eigenvalue in the cluster. */ - -/* CLEND (input) INTEGER */ -/* The index of the last eigenvalue in the cluster. */ - -/* W (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */ -/* The eigenvalue APPROXIMATIONS of L D L^T in ascending order. */ -/* W( CLSTRT ) through W( CLEND ) form the cluster of relatively */ -/* close eigenalues. */ - -/* WGAP (input/output) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */ -/* The separation from the right neighbor eigenvalue in W. */ - -/* WERR (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */ -/* WERR contain the semiwidth of the uncertainty */ -/* interval of the corresponding eigenvalue APPROXIMATION in W */ - -/* SPDIAM (input) estimate of the spectral diameter obtained from the */ -/* Gerschgorin intervals */ - -/* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster. */ -/* Set by the calling routine to protect against shifts too close */ -/* to eigenvalues outside the cluster. */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum pivot allowed in the Sturm sequence. */ - -/* SIGMA (output) DOUBLE PRECISION */ -/* The shift used to form L(+) D(+) L(+)^T. */ - -/* DPLUS (output) DOUBLE PRECISION array, dimension (N) */ -/* The N diagonal elements of the diagonal matrix D(+). */ - -/* LPLUS (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The first (N-1) elements of LPLUS contain the subdiagonal */ -/* elements of the unit bidiagonal matrix L(+). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ -/* Workspace. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --work; - --lplus; - --dplus; - --werr; - --wgap; - --w; - --ld; - --l; - --d__; - - /* Function Body */ - *info = 0; - fact = 2.; - eps = dlamch_("Precision"); - shift = 0; - forcer = false; -/* Note that we cannot guarantee that for any of the shifts tried, */ -/* the factorization has a small or even moderate element growth. */ -/* There could be Ritz values at both ends of the cluster and despite */ -/* backing off, there are examples where all factorizations tried */ -/* (in IEEE mode, allowing zero pivots & infinities) have INFINITE */ -/* element growth. */ -/* For this reason, we should use PIVMIN in this subroutine so that at */ -/* least the L D L^T factorization exists. It can be checked afterwards */ -/* whether the element growth caused bad residuals/orthogonality. */ -/* Decide whether the code should accept the best among all */ -/* representations despite large element growth or signal INFO=1 */ - nofail = true; - -/* Compute the average gap length of the cluster */ - clwdth = (d__1 = w[*clend] - w[*clstrt], abs(d__1)) + werr[*clend] + werr[ - *clstrt]; - avgap = clwdth / (double) (*clend - *clstrt); - mingap = std::min(*clgapl,*clgapr); -/* Initial values for shifts to both ends of cluster */ -/* Computing MIN */ - d__1 = w[*clstrt], d__2 = w[*clend]; - lsigma = std::min(d__1,d__2) - werr[*clstrt]; -/* Computing MAX */ - d__1 = w[*clstrt], d__2 = w[*clend]; - rsigma = std::max(d__1,d__2) + werr[*clend]; -/* Use a small fudge to make sure that we really shift to the outside */ - lsigma -= abs(lsigma) * 4. * eps; - rsigma += abs(rsigma) * 4. * eps; -/* Compute upper bounds for how much to back off the initial shifts */ - ldmax = mingap * .25 + *pivmin * 2.; - rdmax = mingap * .25 + *pivmin * 2.; -/* Computing MAX */ - d__1 = avgap, d__2 = wgap[*clstrt]; - ldelta = std::max(d__1,d__2) / fact; -/* Computing MAX */ - d__1 = avgap, d__2 = wgap[*clend - 1]; - rdelta = std::max(d__1,d__2) / fact; - -/* Initialize the record of the best representation found */ - - s = dlamch_("S"); - smlgrowth = 1. / s; - fail = (double) (*n - 1) * mingap / (*spdiam * eps); - fail2 = (double) (*n - 1) * mingap / (*spdiam * sqrt(eps)); - bestshift = lsigma; - -/* while (KTRY <= KTRYMAX) */ - ktry = 0; - growthbound = *spdiam * 8.; -L5: - sawnan1 = false; - sawnan2 = false; -/* Ensure that we do not back off too much of the initial shifts */ - ldelta = std::min(ldmax,ldelta); - rdelta = std::min(rdmax,rdelta); -/* Compute the element growth when shifting to both ends of the cluster */ -/* accept the shift if there is no element growth at one of the two ends */ -/* Left end */ - s = -lsigma; - dplus[1] = d__[1] + s; - if (abs(dplus[1]) < *pivmin) { - dplus[1] = -(*pivmin); -/* Need to set SAWNAN1 because refined RRR test should not be used */ -/* in this case */ - sawnan1 = true; - } - max1 = abs(dplus[1]); - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - lplus[i__] = ld[i__] / dplus[i__]; - s = s * lplus[i__] * l[i__] - lsigma; - dplus[i__ + 1] = d__[i__ + 1] + s; - if ((d__1 = dplus[i__ + 1], abs(d__1)) < *pivmin) { - dplus[i__ + 1] = -(*pivmin); -/* Need to set SAWNAN1 because refined RRR test should not be used */ -/* in this case */ - sawnan1 = true; - } -/* Computing MAX */ - d__2 = max1, d__3 = (d__1 = dplus[i__ + 1], abs(d__1)); - max1 = std::max(d__2,d__3); -/* L6: */ - } - sawnan1 = sawnan1 || disnan_(&max1); - if (forcer || max1 <= growthbound && ! sawnan1) { - *sigma = lsigma; - shift = 1; - goto L100; - } -/* Right end */ - s = -rsigma; - work[1] = d__[1] + s; - if (abs(work[1]) < *pivmin) { - work[1] = -(*pivmin); -/* Need to set SAWNAN2 because refined RRR test should not be used */ -/* in this case */ - sawnan2 = true; - } - max2 = abs(work[1]); - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - work[*n + i__] = ld[i__] / work[i__]; - s = s * work[*n + i__] * l[i__] - rsigma; - work[i__ + 1] = d__[i__ + 1] + s; - if ((d__1 = work[i__ + 1], abs(d__1)) < *pivmin) { - work[i__ + 1] = -(*pivmin); -/* Need to set SAWNAN2 because refined RRR test should not be used */ -/* in this case */ - sawnan2 = true; - } -/* Computing MAX */ - d__2 = max2, d__3 = (d__1 = work[i__ + 1], abs(d__1)); - max2 = std::max(d__2,d__3); -/* L7: */ - } - sawnan2 = sawnan2 || disnan_(&max2); - if (forcer || max2 <= growthbound && ! sawnan2) { - *sigma = rsigma; - shift = 2; - goto L100; - } -/* If we are at this point, both shifts led to too much element growth */ -/* Record the better of the two shifts (provided it didn't lead to NaN) */ - if (sawnan1 && sawnan2) { -/* both MAX1 and MAX2 are NaN */ - goto L50; - } else { - if (! sawnan1) { - indx = 1; - if (max1 <= smlgrowth) { - smlgrowth = max1; - bestshift = lsigma; - } - } - if (! sawnan2) { - if (sawnan1 || max2 <= max1) { - indx = 2; - } - if (max2 <= smlgrowth) { - smlgrowth = max2; - bestshift = rsigma; - } - } - } -/* If we are here, both the left and the right shift led to */ -/* element growth. If the element growth is moderate, then */ -/* we may still accept the representation, if it passes a */ -/* refined test for RRR. This test supposes that no NaN occurred. */ -/* Moreover, we use the refined RRR test only for isolated clusters. */ - if (clwdth < mingap / 128. && std::min(max1,max2) < fail2 && ! sawnan1 && ! - sawnan2) { - dorrr1 = true; - } else { - dorrr1 = false; - } - tryrrr1 = true; - if (tryrrr1 && dorrr1) { - if (indx == 1) { - tmp = (d__1 = dplus[*n], abs(d__1)); - znm2 = 1.; - prod = 1.; - oldp = 1.; - for (i__ = *n - 1; i__ >= 1; --i__) { - if (prod <= eps) { - prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] * - work[*n + i__]) * oldp; - } else { - prod *= (d__1 = work[*n + i__], abs(d__1)); - } - oldp = prod; -/* Computing 2nd power */ - d__1 = prod; - znm2 += d__1 * d__1; -/* Computing MAX */ - d__2 = tmp, d__3 = (d__1 = dplus[i__] * prod, abs(d__1)); - tmp = std::max(d__2,d__3); -/* L15: */ - } - rrr1 = tmp / (*spdiam * sqrt(znm2)); - if (rrr1 <= 8.) { - *sigma = lsigma; - shift = 1; - goto L100; - } - } else if (indx == 2) { - tmp = (d__1 = work[*n], abs(d__1)); - znm2 = 1.; - prod = 1.; - oldp = 1.; - for (i__ = *n - 1; i__ >= 1; --i__) { - if (prod <= eps) { - prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] * - lplus[i__]) * oldp; - } else { - prod *= (d__1 = lplus[i__], abs(d__1)); - } - oldp = prod; -/* Computing 2nd power */ - d__1 = prod; - znm2 += d__1 * d__1; -/* Computing MAX */ - d__2 = tmp, d__3 = (d__1 = work[i__] * prod, abs(d__1)); - tmp = std::max(d__2,d__3); -/* L16: */ - } - rrr2 = tmp / (*spdiam * sqrt(znm2)); - if (rrr2 <= 8.) { - *sigma = rsigma; - shift = 2; - goto L100; - } - } - } -L50: - if (ktry < 1) { -/* If we are here, both shifts failed also the RRR test. */ -/* Back off to the outside */ -/* Computing MAX */ - d__1 = lsigma - ldelta, d__2 = lsigma - ldmax; - lsigma = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = rsigma + rdelta, d__2 = rsigma + rdmax; - rsigma = std::min(d__1,d__2); - ldelta *= 2.; - rdelta *= 2.; - ++ktry; - goto L5; - } else { -/* None of the representations investigated satisfied our */ -/* criteria. Take the best one we found. */ - if (smlgrowth < fail || nofail) { - lsigma = bestshift; - rsigma = bestshift; - forcer = true; - goto L5; - } else { - *info = 1; - return 0; - } - } -L100: - if (shift == 1) { - } else if (shift == 2) { -/* store new L and D back into DPLUS, LPLUS */ - dcopy_(n, &work[1], &c__1, &dplus[1], &c__1); - i__1 = *n - 1; - dcopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1); - } - return 0; - -/* End of DLARRF */ - -} /* dlarrf_ */ diff --git a/external/clapack/lapack/dlarrj.cpp b/external/clapack/lapack/dlarrj.cpp deleted file mode 100644 index bce42479..00000000 --- a/external/clapack/lapack/dlarrj.cpp +++ /dev/null @@ -1,326 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlarrj_(integer *n, double *d__, double *e2, - integer *ifirst, integer *ilast, double *rtol, integer *offset, - double *w, double *werr, double *work, integer *iwork, - double *pivmin, double *spdiam, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - double d__1, d__2; - - /* Builtin functions - double log(double); */ - - /* Local variables */ - integer i__, j, k, p; - double s; - integer i1, i2, ii; - double fac, mid; - integer cnt; - double tmp, left; - integer iter, nint, prev, next, savi1; - double right, width, dplus; - integer olnint, maxitr; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Given the initial eigenvalue approximations of T, DLARRJ */ -/* does bisection to refine the eigenvalues of T, */ -/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */ -/* guesses for these eigenvalues are input in W, the corresponding estimate */ -/* of the error in these guesses in WERR. During bisection, intervals */ -/* [left, right] are maintained by storing their mid-points and */ -/* semi-widths in the arrays W and WERR respectively. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The N diagonal elements of T. */ - -/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The Squares of the (N-1) subdiagonal elements of T. */ - -/* IFIRST (input) INTEGER */ -/* The index of the first eigenvalue to be computed. */ - -/* ILAST (input) INTEGER */ -/* The index of the last eigenvalue to be computed. */ - -/* RTOL (input) DOUBLE PRECISION */ -/* Tolerance for the convergence of the bisection intervals. */ -/* An interval [LEFT,RIGHT] has converged if */ -/* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|). */ - -/* OFFSET (input) INTEGER */ -/* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET */ -/* through ILAST-OFFSET elements of these arrays are to be used. */ - -/* W (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */ -/* estimates of the eigenvalues of L D L^T indexed IFIRST through */ -/* ILAST. */ -/* On output, these estimates are refined. */ - -/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */ -/* the errors in the estimates of the corresponding elements in W. */ -/* On output, these errors are refined. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ -/* Workspace. */ - -/* IWORK (workspace) INTEGER array, dimension (2*N) */ -/* Workspace. */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum pivot in the Sturm sequence for T. */ - -/* SPDIAM (input) DOUBLE PRECISION */ -/* The spectral diameter of T. */ - -/* INFO (output) INTEGER */ -/* Error flag. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ - -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --iwork; - --work; - --werr; - --w; - --e2; - --d__; - - /* Function Body */ - *info = 0; - - maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.)) + - 2; - -/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */ -/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */ -/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */ -/* for an unconverged interval is set to the index of the next unconverged */ -/* interval, and is -1 or 0 for a converged interval. Thus a linked */ -/* list of unconverged intervals is set up. */ - - i1 = *ifirst; - i2 = *ilast; -/* The number of unconverged intervals */ - nint = 0; -/* The last unconverged interval found */ - prev = 0; - i__1 = i2; - for (i__ = i1; i__ <= i__1; ++i__) { - k = i__ << 1; - ii = i__ - *offset; - left = w[ii] - werr[ii]; - mid = w[ii]; - right = w[ii] + werr[ii]; - width = right - mid; -/* Computing MAX */ - d__1 = abs(left), d__2 = abs(right); - tmp = std::max(d__1,d__2); -/* The following test prevents the test of converged intervals */ - if (width < *rtol * tmp) { -/* This interval has already converged and does not need refinement. */ -/* (Note that the gaps might change through refining the */ -/* eigenvalues, however, they can only get bigger.) */ -/* Remove it from the list. */ - iwork[k - 1] = -1; -/* Make sure that I1 always points to the first unconverged interval */ - if (i__ == i1 && i__ < i2) { - i1 = i__ + 1; - } - if (prev >= i1 && i__ <= i2) { - iwork[(prev << 1) - 1] = i__ + 1; - } - } else { -/* unconverged interval found */ - prev = i__; -/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */ - -/* Do while( CNT(LEFT).GT.I-1 ) */ - - fac = 1.; -L20: - cnt = 0; - s = left; - dplus = d__[1] - s; - if (dplus < 0.) { - ++cnt; - } - i__2 = *n; - for (j = 2; j <= i__2; ++j) { - dplus = d__[j] - s - e2[j - 1] / dplus; - if (dplus < 0.) { - ++cnt; - } -/* L30: */ - } - if (cnt > i__ - 1) { - left -= werr[ii] * fac; - fac *= 2.; - goto L20; - } - -/* Do while( CNT(RIGHT).LT.I ) */ - - fac = 1.; -L50: - cnt = 0; - s = right; - dplus = d__[1] - s; - if (dplus < 0.) { - ++cnt; - } - i__2 = *n; - for (j = 2; j <= i__2; ++j) { - dplus = d__[j] - s - e2[j - 1] / dplus; - if (dplus < 0.) { - ++cnt; - } -/* L60: */ - } - if (cnt < i__) { - right += werr[ii] * fac; - fac *= 2.; - goto L50; - } - ++nint; - iwork[k - 1] = i__ + 1; - iwork[k] = cnt; - } - work[k - 1] = left; - work[k] = right; -/* L75: */ - } - savi1 = i1; - -/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */ -/* and while (ITER.LT.MAXITR) */ - - iter = 0; -L80: - prev = i1 - 1; - i__ = i1; - olnint = nint; - i__1 = olnint; - for (p = 1; p <= i__1; ++p) { - k = i__ << 1; - ii = i__ - *offset; - next = iwork[k - 1]; - left = work[k - 1]; - right = work[k]; - mid = (left + right) * .5; -/* semiwidth of interval */ - width = right - mid; -/* Computing MAX */ - d__1 = abs(left), d__2 = abs(right); - tmp = std::max(d__1,d__2); - if (width < *rtol * tmp || iter == maxitr) { -/* reduce number of unconverged intervals */ - --nint; -/* Mark interval as converged. */ - iwork[k - 1] = 0; - if (i1 == i__) { - i1 = next; - } else { -/* Prev holds the last unconverged interval previously examined */ - if (prev >= i1) { - iwork[(prev << 1) - 1] = next; - } - } - i__ = next; - goto L100; - } - prev = i__; - -/* Perform one bisection step */ - - cnt = 0; - s = mid; - dplus = d__[1] - s; - if (dplus < 0.) { - ++cnt; - } - i__2 = *n; - for (j = 2; j <= i__2; ++j) { - dplus = d__[j] - s - e2[j - 1] / dplus; - if (dplus < 0.) { - ++cnt; - } -/* L90: */ - } - if (cnt <= i__ - 1) { - work[k - 1] = mid; - } else { - work[k] = mid; - } - i__ = next; -L100: - ; - } - ++iter; -/* do another loop if there are still unconverged intervals */ -/* However, in the last iteration, all intervals are accepted */ -/* since this is the best we can do. */ - if (nint > 0 && iter <= maxitr) { - goto L80; - } - - -/* At this point, all the intervals have converged */ - i__1 = *ilast; - for (i__ = savi1; i__ <= i__1; ++i__) { - k = i__ << 1; - ii = i__ - *offset; -/* All intervals marked by '0' have been refined. */ - if (iwork[k - 1] == 0) { - w[ii] = (work[k - 1] + work[k]) * .5; - werr[ii] = work[k] - w[ii]; - } -/* L110: */ - } - - return 0; - -/* End of DLARRJ */ - -} /* dlarrj_ */ diff --git a/external/clapack/lapack/dlarrk.cpp b/external/clapack/lapack/dlarrk.cpp deleted file mode 100644 index 58a06439..00000000 --- a/external/clapack/lapack/dlarrk.cpp +++ /dev/null @@ -1,181 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlarrk_(integer *n, integer *iw, double *gl, - double *gu, double *d__, double *e2, double *pivmin, - double *reltol, double *w, double *werr, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Builtin functions - double log(double); */ - - /* Local variables */ - integer i__, it; - double mid, eps, tmp1, tmp2, left, atoli, right; - integer itmax; - double rtoli, tnorm; - - integer negcnt; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARRK computes one eigenvalue of a symmetric tridiagonal */ -/* matrix T to suitable accuracy. This is an auxiliary code to be */ -/* called from DSTEMR. */ - -/* To avoid overflow, the matrix must be scaled so that its */ -/* largest element is no greater than overflow**(1/2) * */ -/* underflow**(1/4) in absolute value, and for greatest */ -/* accuracy, it should not be much smaller than that. */ - -/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ -/* Matrix", Report CS41, Computer Science Dept., Stanford */ -/* University, July 21, 1966. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the tridiagonal matrix T. N >= 0. */ - -/* IW (input) INTEGER */ -/* The index of the eigenvalues to be returned. */ - -/* GL (input) DOUBLE PRECISION */ -/* GU (input) DOUBLE PRECISION */ -/* An upper and a lower bound on the eigenvalue. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix T. */ - -/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ - -/* PIVMIN (input) DOUBLE PRECISION */ -/* The minimum pivot allowed in the Sturm sequence for T. */ - -/* RELTOL (input) DOUBLE PRECISION */ -/* The minimum relative width of an interval. When an interval */ -/* is narrower than RELTOL times the larger (in */ -/* magnitude) endpoint, then it is considered to be */ -/* sufficiently small, i.e., converged. Note: this should */ -/* always be at least radix*machine epsilon. */ - -/* W (output) DOUBLE PRECISION */ - -/* WERR (output) DOUBLE PRECISION */ -/* The error bound on the corresponding eigenvalue approximation */ -/* in W. */ - -/* INFO (output) INTEGER */ -/* = 0: Eigenvalue converged */ -/* = -1: Eigenvalue did NOT converge */ - -/* Internal Parameters */ -/* =================== */ - -/* FUDGE DOUBLE PRECISION, default = 2 */ -/* A "fudge factor" to widen the Gershgorin intervals. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Get machine constants */ - /* Parameter adjustments */ - --e2; - --d__; - - /* Function Body */ - eps = dlamch_("P"); -/* Computing MAX */ - d__1 = abs(*gl), d__2 = abs(*gu); - tnorm = std::max(d__1,d__2); - rtoli = *reltol; - atoli = *pivmin * 4.; - itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.)) + 2; - *info = -1; - left = *gl - tnorm * 2. * eps * *n - *pivmin * 4.; - right = *gu + tnorm * 2. * eps * *n + *pivmin * 4.; - it = 0; -L10: - -/* Check if interval converged or maximum number of iterations reached */ - - tmp1 = (d__1 = right - left, abs(d__1)); -/* Computing MAX */ - d__1 = abs(right), d__2 = abs(left); - tmp2 = std::max(d__1,d__2); -/* Computing MAX */ - d__1 = std::max(atoli,*pivmin), d__2 = rtoli * tmp2; - if (tmp1 < std::max(d__1,d__2)) { - *info = 0; - goto L30; - } - if (it > itmax) { - goto L30; - } - -/* Count number of negative pivots for mid-point */ - - ++it; - mid = (left + right) * .5; - negcnt = 0; - tmp1 = d__[1] - mid; - if (abs(tmp1) < *pivmin) { - tmp1 = -(*pivmin); - } - if (tmp1 <= 0.) { - ++negcnt; - } - - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - tmp1 = d__[i__] - e2[i__ - 1] / tmp1 - mid; - if (abs(tmp1) < *pivmin) { - tmp1 = -(*pivmin); - } - if (tmp1 <= 0.) { - ++negcnt; - } -/* L20: */ - } - if (negcnt >= *iw) { - right = mid; - } else { - left = mid; - } - goto L10; -L30: - -/* Converged or maximum number of iterations reached */ - - *w = (left + right) * .5; - *werr = (d__1 = right - left, abs(d__1)) * .5; - return 0; - -/* End of DLARRK */ - -} /* dlarrk_ */ diff --git a/external/clapack/lapack/dlarrr.cpp b/external/clapack/lapack/dlarrr.cpp deleted file mode 100644 index 7081b5eb..00000000 --- a/external/clapack/lapack/dlarrr.cpp +++ /dev/null @@ -1,161 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlarrr_(integer *n, double *d__, double *e, - integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer i__; - double eps, tmp, tmp2, rmin; - - double offdig, safmin; - bool yesrel; - double smlnum, offdig2; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - - -/* Purpose */ -/* ======= */ - -/* Perform tests to decide whether the symmetric tridiagonal matrix T */ -/* warrants expensive computations which guarantee high relative accuracy */ -/* in the eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N > 0. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The N diagonal elements of the tridiagonal matrix T. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the first (N-1) entries contain the subdiagonal */ -/* elements of the tridiagonal matrix T; E(N) is set to ZERO. */ - -/* INFO (output) INTEGER */ -/* INFO = 0(default) : the matrix warrants computations preserving */ -/* relative accuracy. */ -/* INFO = 1 : the matrix warrants computations guaranteeing */ -/* only absolute accuracy. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* As a default, do NOT go for relative-accuracy preserving computations. */ - /* Parameter adjustments */ - --e; - --d__; - - /* Function Body */ - *info = 1; - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - rmin = sqrt(smlnum); -/* Tests for relative accuracy */ - -/* Test for scaled diagonal dominance */ -/* Scale the diagonal entries to one and check whether the sum of the */ -/* off-diagonals is less than one */ - -/* The sdd relative error bounds have a 1/(1- 2*x) factor in them, */ -/* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative */ -/* accuracy is promised. In the notation of the code fragment below, */ -/* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number. */ -/* We don't think it is worth going into "sdd mode" unless the relative */ -/* condition number is reasonable, not 1/macheps. */ -/* The threshold should be compatible with other thresholds used in the */ -/* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds */ -/* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000 */ -/* instead of the current OFFDIG + OFFDIG2 < 1 */ - - yesrel = true; - offdig = 0.; - tmp = sqrt((abs(d__[1]))); - if (tmp < rmin) { - yesrel = false; - } - if (! yesrel) { - goto L11; - } - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - tmp2 = sqrt((d__1 = d__[i__], abs(d__1))); - if (tmp2 < rmin) { - yesrel = false; - } - if (! yesrel) { - goto L11; - } - offdig2 = (d__1 = e[i__ - 1], abs(d__1)) / (tmp * tmp2); - if (offdig + offdig2 >= .999) { - yesrel = false; - } - if (! yesrel) { - goto L11; - } - tmp = tmp2; - offdig = offdig2; -/* L10: */ - } -L11: - if (yesrel) { - *info = 0; - return 0; - } else { - } - - -/* *** MORE TO BE IMPLEMENTED *** */ - - -/* Test if the lower bidiagonal matrix L from T = L D L^T */ -/* (zero shift facto) is well conditioned */ - - -/* Test if the upper bidiagonal matrix U from T = U D U^T */ -/* (zero shift facto) is well conditioned. */ -/* In this case, the matrix needs to be flipped and, at the end */ -/* of the eigenvector computation, the flip needs to be applied */ -/* to the computed eigenvectors (and the support) */ - - - return 0; - -/* END OF DLARRR */ - -} /* dlarrr_ */ diff --git a/external/clapack/lapack/dlarrv.cpp b/external/clapack/lapack/dlarrv.cpp deleted file mode 100644 index 7626270d..00000000 --- a/external/clapack/lapack/dlarrv.cpp +++ /dev/null @@ -1,955 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b5 = 0.; -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int dlarrv_(integer *n, double *vl, double *vu, - double *d__, double *l, double *pivmin, integer *isplit, - integer *m, integer *dol, integer *dou, double *minrgp, - double *rtol1, double *rtol2, double *w, double *werr, - double *wgap, integer *iblock, integer *indexw, double *gers, - double *z__, integer *ldz, integer *isuppz, double *work, - integer *iwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; - double d__1, d__2; - bool L__1; - - /* Builtin functions - double log(double); */ - - /* Local variables */ - integer minwsize, i__, j, k, p, q, miniwsize, ii; - double gl; - integer im, in; - double gu, gap, eps, tau, tol, tmp; - integer zto; - double ztz; - integer iend, jblk; - double lgap; - integer done; - double rgap, left; - integer wend, iter; - double bstw; - integer itmp1; - integer indld; - double fudge; - integer idone; - double sigma; - integer iinfo, iindr; - double resid; - bool eskip; - double right; - integer nclus, zfrom; - double rqtol; - integer iindc1, iindc2; - bool stp2ii; - double lambda; - integer ibegin, indeig; - bool needbs; - integer indlld; - double sgndef, mingma; - integer oldien, oldncl, wbegin; - double spdiam; - integer negcnt; - integer oldcls; - double savgap; - integer ndepth; - double ssigma; - bool usedbs; - integer iindwk, offset; - double gaptol; - integer newcls, oldfst, indwrk, windex, oldlst; - bool usedrq; - integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl; - double bstres; - integer newsiz, zusedu, zusedw; - double nrminv, rqcorr; - bool tryrqc; - integer isupmx; - - -/* -- LAPACK auxiliary routine (version 3.1.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARRV computes the eigenvectors of the tridiagonal matrix */ -/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */ -/* The input eigenvalues should have been computed by DLARRE. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* Lower and upper bounds of the interval that contains the desired */ -/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */ -/* end of the extremal eigenvalues in the desired RANGE. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the N diagonal elements of the diagonal matrix D. */ -/* On exit, D may be overwritten. */ - -/* L (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the (N-1) subdiagonal elements of the unit */ -/* bidiagonal matrix L are in elements 1 to N-1 of L */ -/* (if the matrix is not splitted.) At the end of each block */ -/* is stored the corresponding shift as given by DLARRE. */ -/* On exit, L is overwritten. */ - -/* PIVMIN (in) DOUBLE PRECISION */ -/* The minimum pivot allowed in the Sturm sequence. */ - -/* ISPLIT (input) INTEGER array, dimension (N) */ -/* The splitting points, at which T breaks up into blocks. */ -/* The first block consists of rows/columns 1 to */ -/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */ -/* through ISPLIT( 2 ), etc. */ - -/* M (input) INTEGER */ -/* The total number of input eigenvalues. 0 <= M <= N. */ - -/* DOL (input) INTEGER */ -/* DOU (input) INTEGER */ -/* If the user wants to compute only selected eigenvectors from all */ -/* the eigenvalues supplied, he can specify an index range DOL:DOU. */ -/* Or else the setting DOL=1, DOU=M should be applied. */ -/* Note that DOL and DOU refer to the order in which the eigenvalues */ -/* are stored in W. */ -/* If the user wants to compute only selected eigenpairs, then */ -/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */ -/* computed eigenvectors. All other columns of Z are set to zero. */ - -/* MINRGP (input) DOUBLE PRECISION */ - -/* RTOL1 (input) DOUBLE PRECISION */ -/* RTOL2 (input) DOUBLE PRECISION */ -/* Parameters for bisection. */ -/* An interval [LEFT,RIGHT] has converged if */ -/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ - -/* W (input/output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements of W contain the APPROXIMATE eigenvalues for */ -/* which eigenvectors are to be computed. The eigenvalues */ -/* should be grouped by split-off block and ordered from */ -/* smallest to largest within the block ( The output array */ -/* W from DLARRE is expected here ). Furthermore, they are with */ -/* respect to the shift of the corresponding root representation */ -/* for their block. On exit, W holds the eigenvalues of the */ -/* UNshifted matrix. */ - -/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the semiwidth of the uncertainty */ -/* interval of the corresponding eigenvalue in W */ - -/* WGAP (input/output) DOUBLE PRECISION array, dimension (N) */ -/* The separation from the right neighbor eigenvalue in W. */ - -/* IBLOCK (input) INTEGER array, dimension (N) */ -/* The indices of the blocks (submatrices) associated with the */ -/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */ -/* W(i) belongs to the first block from the top, =2 if W(i) */ -/* belongs to the second block, etc. */ - -/* INDEXW (input) INTEGER array, dimension (N) */ -/* The indices of the eigenvalues within each block (submatrix); */ -/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */ -/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */ - -/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */ -/* The N Gerschgorin intervals (the i-th Gerschgorin interval */ -/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */ -/* be computed from the original UNshifted matrix. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ -/* If INFO = 0, the first M columns of Z contain the */ -/* orthonormal eigenvectors of the matrix T */ -/* corresponding to the input eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */ -/* The support of the eigenvectors in Z, i.e., the indices */ -/* indicating the nonzero elements in Z. The I-th eigenvector */ -/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */ -/* ISUPPZ( 2*I ). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (12*N) */ - -/* IWORK (workspace) INTEGER array, dimension (7*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ - -/* > 0: A problem occured in DLARRV. */ -/* < 0: One of the called subroutines signaled an internal problem. */ -/* Needs inspection of the corresponding parameter IINFO */ -/* for further information. */ - -/* =-1: Problem in DLARRB when refining a child's eigenvalues. */ -/* =-2: Problem in DLARRF when computing the RRR of a child. */ -/* When a child is inside a tight cluster, it can be difficult */ -/* to find an RRR. A partial remedy from the user's point of */ -/* view is to make the parameter MINRGP smaller and recompile. */ -/* However, as the orthogonality of the computed vectors is */ -/* proportional to 1/MINRGP, the user should be aware that */ -/* he might be trading in precision when he decreases MINRGP. */ -/* =-3: Problem in DLARRB when refining a single eigenvalue */ -/* after the Rayleigh correction was rejected. */ -/* = 5: The Rayleigh Quotient Iteration failed to converge to */ -/* full accuracy in MAXITR steps. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ -/* .. */ -/* The first N entries of WORK are reserved for the eigenvalues */ - /* Parameter adjustments */ - --d__; - --l; - --isplit; - --w; - --werr; - --wgap; - --iblock; - --indexw; - --gers; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - indld = *n + 1; - indlld = (*n << 1) + 1; - indwrk = *n * 3 + 1; - minwsize = *n * 12; - i__1 = minwsize; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L5: */ - } -/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */ -/* factorization used to compute the FP vector */ - iindr = 0; -/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */ -/* layer and the one above. */ - iindc1 = *n; - iindc2 = *n << 1; - iindwk = *n * 3 + 1; - miniwsize = *n * 7; - i__1 = miniwsize; - for (i__ = 1; i__ <= i__1; ++i__) { - iwork[i__] = 0; -/* L10: */ - } - zusedl = 1; - if (*dol > 1) { -/* Set lower bound for use of Z */ - zusedl = *dol - 1; - } - zusedu = *m; - if (*dou < *m) { -/* Set lower bound for use of Z */ - zusedu = *dou + 1; - } -/* The width of the part of Z that is used */ - zusedw = zusedu - zusedl + 1; - dlaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz); - eps = dlamch_("Precision"); - rqtol = eps * 2.; - -/* Set expert flags for standard code. */ - tryrqc = true; - if (*dol == 1 && *dou == *m) { - } else { -/* Only selected eigenpairs are computed. Since the other evalues */ -/* are not refined by RQ iteration, bisection has to compute to full */ -/* accuracy. */ - *rtol1 = eps * 4.; - *rtol2 = eps * 4.; - } -/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */ -/* desired eigenvalues. The support of the nonzero eigenvector */ -/* entries is contained in the interval IBEGIN:IEND. */ -/* Remark that if k eigenpairs are desired, then the eigenvectors */ -/* are stored in k contiguous columns of Z. */ -/* DONE is the number of eigenvectors already computed */ - done = 0; - ibegin = 1; - wbegin = 1; - i__1 = iblock[*m]; - for (jblk = 1; jblk <= i__1; ++jblk) { - iend = isplit[jblk]; - sigma = l[iend]; -/* Find the eigenvectors of the submatrix indexed IBEGIN */ -/* through IEND. */ - wend = wbegin - 1; -L15: - if (wend < *m) { - if (iblock[wend + 1] == jblk) { - ++wend; - goto L15; - } - } - if (wend < wbegin) { - ibegin = iend + 1; - goto L170; - } else if (wend < *dol || wbegin > *dou) { - ibegin = iend + 1; - wbegin = wend + 1; - goto L170; - } -/* Find local spectral diameter of the block */ - gl = gers[(ibegin << 1) - 1]; - gu = gers[ibegin * 2]; - i__2 = iend; - for (i__ = ibegin + 1; i__ <= i__2; ++i__) { -/* Computing MIN */ - d__1 = gers[(i__ << 1) - 1]; - gl = std::min(d__1,gl); -/* Computing MAX */ - d__1 = gers[i__ * 2]; - gu = std::max(d__1,gu); -/* L20: */ - } - spdiam = gu - gl; -/* OLDIEN is the last index of the previous block */ - oldien = ibegin - 1; -/* Calculate the size of the current block */ - in = iend - ibegin + 1; -/* The number of eigenvalues in the current block */ - im = wend - wbegin + 1; -/* This is for a 1x1 block */ - if (ibegin == iend) { - ++done; - z__[ibegin + wbegin * z_dim1] = 1.; - isuppz[(wbegin << 1) - 1] = ibegin; - isuppz[wbegin * 2] = ibegin; - w[wbegin] += sigma; - work[wbegin] = w[wbegin]; - ibegin = iend + 1; - ++wbegin; - goto L170; - } -/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */ -/* Note that these can be approximations, in this case, the corresp. */ -/* entries of WERR give the size of the uncertainty interval. */ -/* The eigenvalue approximations will be refined when necessary as */ -/* high relative accuracy is required for the computation of the */ -/* corresponding eigenvectors. */ - dcopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1); -/* We store in W the eigenvalue approximations w.r.t. the original */ -/* matrix T. */ - i__2 = im; - for (i__ = 1; i__ <= i__2; ++i__) { - w[wbegin + i__ - 1] += sigma; -/* L30: */ - } -/* NDEPTH is the current depth of the representation tree */ - ndepth = 0; -/* PARITY is either 1 or 0 */ - parity = 1; -/* NCLUS is the number of clusters for the next level of the */ -/* representation tree, we start with NCLUS = 1 for the root */ - nclus = 1; - iwork[iindc1 + 1] = 1; - iwork[iindc1 + 2] = im; -/* IDONE is the number of eigenvectors already computed in the current */ -/* block */ - idone = 0; -/* loop while( IDONE.LT.IM ) */ -/* generate the representation tree for the current block and */ -/* compute the eigenvectors */ -L40: - if (idone < im) { -/* This is a crude protection against infinitely deep trees */ - if (ndepth > *m) { - *info = -2; - return 0; - } -/* breadth first processing of the current level of the representation */ -/* tree: OLDNCL = number of clusters on current level */ - oldncl = nclus; -/* reset NCLUS to count the number of child clusters */ - nclus = 0; - - parity = 1 - parity; - if (parity == 0) { - oldcls = iindc1; - newcls = iindc2; - } else { - oldcls = iindc2; - newcls = iindc1; - } -/* Process the clusters on the current level */ - i__2 = oldncl; - for (i__ = 1; i__ <= i__2; ++i__) { - j = oldcls + (i__ << 1); -/* OLDFST, OLDLST = first, last index of current cluster. */ -/* cluster indices start with 1 and are relative */ -/* to WBEGIN when accessing W, WGAP, WERR, Z */ - oldfst = iwork[j - 1]; - oldlst = iwork[j]; - if (ndepth > 0) { -/* Retrieve relatively robust representation (RRR) of cluster */ -/* that has been computed at the previous level */ -/* The RRR is stored in Z and overwritten once the eigenvectors */ -/* have been computed or when the cluster is refined */ - if (*dol == 1 && *dou == *m) { -/* Get representation from location of the leftmost evalue */ -/* of the cluster */ - j = wbegin + oldfst - 1; - } else { - if (wbegin + oldfst - 1 < *dol) { -/* Get representation from the left end of Z array */ - j = *dol - 1; - } else if (wbegin + oldfst - 1 > *dou) { -/* Get representation from the right end of Z array */ - j = *dou; - } else { - j = wbegin + oldfst - 1; - } - } - dcopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin] -, &c__1); - i__3 = in - 1; - dcopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[ - ibegin], &c__1); - sigma = z__[iend + (j + 1) * z_dim1]; -/* Set the corresponding entries in Z to zero */ - dlaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j - * z_dim1], ldz); - } -/* Compute DL and DLL of current RRR */ - i__3 = iend - 1; - for (j = ibegin; j <= i__3; ++j) { - tmp = d__[j] * l[j]; - work[indld - 1 + j] = tmp; - work[indlld - 1 + j] = tmp * l[j]; -/* L50: */ - } - if (ndepth > 0) { -/* P and Q are index of the first and last eigenvalue to compute */ -/* within the current block */ - p = indexw[wbegin - 1 + oldfst]; - q = indexw[wbegin - 1 + oldlst]; -/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */ -/* thru' Q-OFFSET elements of these arrays are to be used. */ -/* OFFSET = P-OLDFST */ - offset = indexw[wbegin] - 1; -/* perform limited bisection (if necessary) to get approximate */ -/* eigenvalues to the precision needed. */ - dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p, - &q, rtol1, rtol2, &offset, &work[wbegin], &wgap[ - wbegin], &werr[wbegin], &work[indwrk], &iwork[ - iindwk], pivmin, &spdiam, &in, &iinfo); - if (iinfo != 0) { - *info = -1; - return 0; - } -/* We also recompute the extremal gaps. W holds all eigenvalues */ -/* of the unshifted matrix and must be used for computation */ -/* of WGAP, the entries of WORK might stem from RRRs with */ -/* different shifts. The gaps from WBEGIN-1+OLDFST to */ -/* WBEGIN-1+OLDLST are correctly computed in DLARRB. */ -/* However, we only allow the gaps to become greater since */ -/* this is what should happen when we decrease WERR */ - if (oldfst > 1) { -/* Computing MAX */ - d__1 = wgap[wbegin + oldfst - 2], d__2 = w[wbegin + - oldfst - 1] - werr[wbegin + oldfst - 1] - w[ - wbegin + oldfst - 2] - werr[wbegin + oldfst - - 2]; - wgap[wbegin + oldfst - 2] = std::max(d__1,d__2); - } - if (wbegin + oldlst - 1 < wend) { -/* Computing MAX */ - d__1 = wgap[wbegin + oldlst - 1], d__2 = w[wbegin + - oldlst] - werr[wbegin + oldlst] - w[wbegin + - oldlst - 1] - werr[wbegin + oldlst - 1]; - wgap[wbegin + oldlst - 1] = std::max(d__1,d__2); - } -/* Each time the eigenvalues in WORK get refined, we store */ -/* the newly found approximation with all shifts applied in W */ - i__3 = oldlst; - for (j = oldfst; j <= i__3; ++j) { - w[wbegin + j - 1] = work[wbegin + j - 1] + sigma; -/* L53: */ - } - } -/* Process the current node. */ - newfst = oldfst; - i__3 = oldlst; - for (j = oldfst; j <= i__3; ++j) { - if (j == oldlst) { -/* we are at the right end of the cluster, this is also the */ -/* boundary of the child cluster */ - newlst = j; - } else if (wgap[wbegin + j - 1] >= *minrgp * (d__1 = work[ - wbegin + j - 1], abs(d__1))) { -/* the right relative gap is big enough, the child cluster */ -/* (NEWFST,..,NEWLST) is well separated from the following */ - newlst = j; - } else { -/* inside a child cluster, the relative gap is not */ -/* big enough. */ - goto L140; - } -/* Compute size of child cluster found */ - newsiz = newlst - newfst + 1; -/* NEWFTT is the place in Z where the new RRR or the computed */ -/* eigenvector is to be stored */ - if (*dol == 1 && *dou == *m) { -/* Store representation at location of the leftmost evalue */ -/* of the cluster */ - newftt = wbegin + newfst - 1; - } else { - if (wbegin + newfst - 1 < *dol) { -/* Store representation at the left end of Z array */ - newftt = *dol - 1; - } else if (wbegin + newfst - 1 > *dou) { -/* Store representation at the right end of Z array */ - newftt = *dou; - } else { - newftt = wbegin + newfst - 1; - } - } - if (newsiz > 1) { - -/* Current child is not a singleton but a cluster. */ -/* Compute and store new representation of child. */ - - -/* Compute left and right cluster gap. */ - -/* LGAP and RGAP are not computed from WORK because */ -/* the eigenvalue approximations may stem from RRRs */ -/* different shifts. However, W hold all eigenvalues */ -/* of the unshifted matrix. Still, the entries in WGAP */ -/* have to be computed from WORK since the entries */ -/* in W might be of the same order so that gaps are not */ -/* exhibited correctly for very close eigenvalues. */ - if (newfst == 1) { -/* Computing MAX */ - d__1 = 0., d__2 = w[wbegin] - werr[wbegin] - *vl; - lgap = std::max(d__1,d__2); - } else { - lgap = wgap[wbegin + newfst - 2]; - } - rgap = wgap[wbegin + newlst - 1]; - -/* Compute left- and rightmost eigenvalue of child */ -/* to high precision in order to shift as close */ -/* as possible and obtain as large relative gaps */ -/* as possible */ - - for (k = 1; k <= 2; ++k) { - if (k == 1) { - p = indexw[wbegin - 1 + newfst]; - } else { - p = indexw[wbegin - 1 + newlst]; - } - offset = indexw[wbegin] - 1; - dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - - 1], &p, &p, &rqtol, &rqtol, &offset, & - work[wbegin], &wgap[wbegin], &werr[wbegin] -, &work[indwrk], &iwork[iindwk], pivmin, & - spdiam, &in, &iinfo); -/* L55: */ - } - - if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1 - > *dou) { -/* if the cluster contains no desired eigenvalues */ -/* skip the computation of that branch of the rep. tree */ - -/* We could skip before the refinement of the extremal */ -/* eigenvalues of the child, but then the representation */ -/* tree could be different from the one when nothing is */ -/* skipped. For this reason we skip at this place. */ - idone = idone + newlst - newfst + 1; - goto L139; - } - -/* Compute RRR of child cluster. */ -/* Note that the new RRR is stored in Z */ - -/* DLARRF needs LWORK = 2*N */ - dlarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld + - ibegin - 1], &newfst, &newlst, &work[wbegin], - &wgap[wbegin], &werr[wbegin], &spdiam, &lgap, - &rgap, pivmin, &tau, &z__[ibegin + newftt * - z_dim1], &z__[ibegin + (newftt + 1) * z_dim1], - &work[indwrk], &iinfo); - if (iinfo == 0) { -/* a new RRR for the cluster was found by DLARRF */ -/* update shift and store it */ - ssigma = sigma + tau; - z__[iend + (newftt + 1) * z_dim1] = ssigma; -/* WORK() are the midpoints and WERR() the semi-width */ -/* Note that the entries in W are unchanged. */ - i__4 = newlst; - for (k = newfst; k <= i__4; ++k) { - fudge = eps * 3. * (d__1 = work[wbegin + k - - 1], abs(d__1)); - work[wbegin + k - 1] -= tau; - fudge += eps * 4. * (d__1 = work[wbegin + k - - 1], abs(d__1)); -/* Fudge errors */ - werr[wbegin + k - 1] += fudge; -/* Gaps are not fudged. Provided that WERR is small */ -/* when eigenvalues are close, a zero gap indicates */ -/* that a new representation is needed for resolving */ -/* the cluster. A fudge could lead to a wrong decision */ -/* of judging eigenvalues 'separated' which in */ -/* reality are not. This could have a negative impact */ -/* on the orthogonality of the computed eigenvectors. */ -/* L116: */ - } - ++nclus; - k = newcls + (nclus << 1); - iwork[k - 1] = newfst; - iwork[k] = newlst; - } else { - *info = -2; - return 0; - } - } else { - -/* Compute eigenvector of singleton */ - - iter = 0; - - tol = log((double) in) * 4. * eps; - - k = newfst; - windex = wbegin + k - 1; -/* Computing MAX */ - i__4 = windex - 1; - windmn = std::max(i__4,1_integer); -/* Computing MIN */ - i__4 = windex + 1; - windpl = std::min(i__4,*m); - lambda = work[windex]; - ++done; -/* Check if eigenvector computation is to be skipped */ - if (windex < *dol || windex > *dou) { - eskip = true; - goto L125; - } else { - eskip = false; - } - left = work[windex] - werr[windex]; - right = work[windex] + werr[windex]; - indeig = indexw[windex]; -/* Note that since we compute the eigenpairs for a child, */ -/* all eigenvalue approximations are w.r.t the same shift. */ -/* In this case, the entries in WORK should be used for */ -/* computing the gaps since they exhibit even very small */ -/* differences in the eigenvalues, as opposed to the */ -/* entries in W which might "look" the same. */ - if (k == 1) { -/* In the case RANGE='I' and with not much initial */ -/* accuracy in LAMBDA and VL, the formula */ -/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */ -/* can lead to an overestimation of the left gap and */ -/* thus to inadequately early RQI 'convergence'. */ -/* Prevent this by forcing a small left gap. */ -/* Computing MAX */ - d__1 = abs(left), d__2 = abs(right); - lgap = eps * std::max(d__1,d__2); - } else { - lgap = wgap[windmn]; - } - if (k == im) { -/* In the case RANGE='I' and with not much initial */ -/* accuracy in LAMBDA and VU, the formula */ -/* can lead to an overestimation of the right gap and */ -/* thus to inadequately early RQI 'convergence'. */ -/* Prevent this by forcing a small right gap. */ -/* Computing MAX */ - d__1 = abs(left), d__2 = abs(right); - rgap = eps * std::max(d__1,d__2); - } else { - rgap = wgap[windex]; - } - gap = std::min(lgap,rgap); - if (k == 1 || k == im) { -/* The eigenvector support can become wrong */ -/* because significant entries could be cut off due to a */ -/* large GAPTOL parameter in LAR1V. Prevent this. */ - gaptol = 0.; - } else { - gaptol = gap * eps; - } - isupmn = in; - isupmx = 1; -/* Update WGAP so that it holds the minimum gap */ -/* to the left or the right. This is crucial in the */ -/* case where bisection is used to ensure that the */ -/* eigenvalue is refined up to the required precision. */ -/* The correct value is restored afterwards. */ - savgap = wgap[windex]; - wgap[windex] = gap; -/* We want to use the Rayleigh Quotient Correction */ -/* as often as possible since it converges quadratically */ -/* when we are close enough to the desired eigenvalue. */ -/* However, the Rayleigh Quotient can have the wrong sign */ -/* and lead us away from the desired eigenvalue. In this */ -/* case, the best we can do is to use bisection. */ - usedbs = false; - usedrq = false; -/* Bisection is initially turned off unless it is forced */ - needbs = ! tryrqc; -L120: -/* Check if bisection should be used to refine eigenvalue */ - if (needbs) { -/* Take the bisection as new iterate */ - usedbs = true; - itmp1 = iwork[iindr + windex]; - offset = indexw[wbegin] - 1; - d__1 = eps * 2.; - dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - - 1], &indeig, &indeig, &c_b5, &d__1, & - offset, &work[wbegin], &wgap[wbegin], & - werr[wbegin], &work[indwrk], &iwork[ - iindwk], pivmin, &spdiam, &itmp1, &iinfo); - if (iinfo != 0) { - *info = -3; - return 0; - } - lambda = work[windex]; -/* Reset twist index from inaccurate LAMBDA to */ -/* force computation of true MINGMA */ - iwork[iindr + windex] = 0; - } -/* Given LAMBDA, compute the eigenvector. */ - L__1 = ! usedbs; - dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[ - ibegin], &work[indld + ibegin - 1], &work[ - indlld + ibegin - 1], pivmin, &gaptol, &z__[ - ibegin + windex * z_dim1], &L__1, &negcnt, & - ztz, &mingma, &iwork[iindr + windex], &isuppz[ - (windex << 1) - 1], &nrminv, &resid, &rqcorr, - &work[indwrk]); - if (iter == 0) { - bstres = resid; - bstw = lambda; - } else if (resid < bstres) { - bstres = resid; - bstw = lambda; - } -/* Computing MIN */ - i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1]; - isupmn = std::min(i__4,i__5); -/* Computing MAX */ - i__4 = isupmx, i__5 = isuppz[windex * 2]; - isupmx = std::max(i__4,i__5); - ++iter; -/* sin alpha <= |resid|/gap */ -/* Note that both the residual and the gap are */ -/* proportional to the matrix, so ||T|| doesn't play */ -/* a role in the quotient */ - -/* Convergence test for Rayleigh-Quotient iteration */ -/* (omitted when Bisection has been used) */ - - if (resid > tol * gap && abs(rqcorr) > rqtol * abs( - lambda) && ! usedbs) { -/* We need to check that the RQCORR update doesn't */ -/* move the eigenvalue away from the desired one and */ -/* towards a neighbor. -> protection with bisection */ - if (indeig <= negcnt) { -/* The wanted eigenvalue lies to the left */ - sgndef = -1.; - } else { -/* The wanted eigenvalue lies to the right */ - sgndef = 1.; - } -/* We only use the RQCORR if it improves the */ -/* the iterate reasonably. */ - if (rqcorr * sgndef >= 0. && lambda + rqcorr <= - right && lambda + rqcorr >= left) { - usedrq = true; -/* Store new midpoint of bisection interval in WORK */ - if (sgndef == 1.) { -/* The current LAMBDA is on the left of the true */ -/* eigenvalue */ - left = lambda; -/* We prefer to assume that the error estimate */ -/* is correct. We could make the interval not */ -/* as a bracket but to be modified if the RQCORR */ -/* chooses to. In this case, the RIGHT side should */ -/* be modified as follows: */ -/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */ - } else { -/* The current LAMBDA is on the right of the true */ -/* eigenvalue */ - right = lambda; -/* See comment about assuming the error estimate is */ -/* correct above. */ -/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */ - } - work[windex] = (right + left) * .5; -/* Take RQCORR since it has the correct sign and */ -/* improves the iterate reasonably */ - lambda += rqcorr; -/* Update width of error interval */ - werr[windex] = (right - left) * .5; - } else { - needbs = true; - } - if (right - left < rqtol * abs(lambda)) { -/* The eigenvalue is computed to bisection accuracy */ -/* compute eigenvector and stop */ - usedbs = true; - goto L120; - } else if (iter < 10) { - goto L120; - } else if (iter == 10) { - needbs = true; - goto L120; - } else { - *info = 5; - return 0; - } - } else { - stp2ii = false; - if (usedrq && usedbs && bstres <= resid) { - lambda = bstw; - stp2ii = true; - } - if (stp2ii) { -/* improve error angle by second step */ - L__1 = ! usedbs; - dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin] -, &l[ibegin], &work[indld + ibegin - - 1], &work[indlld + ibegin - 1], - pivmin, &gaptol, &z__[ibegin + windex - * z_dim1], &L__1, &negcnt, &ztz, & - mingma, &iwork[iindr + windex], & - isuppz[(windex << 1) - 1], &nrminv, & - resid, &rqcorr, &work[indwrk]); - } - work[windex] = lambda; - } - -/* Compute FP-vector support w.r.t. whole matrix */ - - isuppz[(windex << 1) - 1] += oldien; - isuppz[windex * 2] += oldien; - zfrom = isuppz[(windex << 1) - 1]; - zto = isuppz[windex * 2]; - isupmn += oldien; - isupmx += oldien; -/* Ensure vector is ok if support in the RQI has changed */ - if (isupmn < zfrom) { - i__4 = zfrom - 1; - for (ii = isupmn; ii <= i__4; ++ii) { - z__[ii + windex * z_dim1] = 0.; -/* L122: */ - } - } - if (isupmx > zto) { - i__4 = isupmx; - for (ii = zto + 1; ii <= i__4; ++ii) { - z__[ii + windex * z_dim1] = 0.; -/* L123: */ - } - } - i__4 = zto - zfrom + 1; - dscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1], - &c__1); -L125: -/* Update W */ - w[windex] = lambda + sigma; -/* Recompute the gaps on the left and right */ -/* But only allow them to become larger and not */ -/* smaller (which can only happen through "bad" */ -/* cancellation and doesn't reflect the theory */ -/* where the initial gaps are underestimated due */ -/* to WERR being too crude.) */ - if (! eskip) { - if (k > 1) { -/* Computing MAX */ - d__1 = wgap[windmn], d__2 = w[windex] - werr[ - windex] - w[windmn] - werr[windmn]; - wgap[windmn] = std::max(d__1,d__2); - } - if (windex < wend) { -/* Computing MAX */ - d__1 = savgap, d__2 = w[windpl] - werr[windpl] - - w[windex] - werr[windex]; - wgap[windex] = std::max(d__1,d__2); - } - } - ++idone; - } -/* here ends the code for the current child */ - -L139: -/* Proceed to any remaining child nodes */ - newfst = j + 1; -L140: - ; - } -/* L150: */ - } - ++ndepth; - goto L40; - } - ibegin = iend + 1; - wbegin = wend + 1; -L170: - ; - } - - return 0; - -/* End of DLARRV */ - -} /* dlarrv_ */ diff --git a/external/clapack/lapack/dlarscl2.cpp b/external/clapack/lapack/dlarscl2.cpp deleted file mode 100644 index e466dc76..00000000 --- a/external/clapack/lapack/dlarscl2.cpp +++ /dev/null @@ -1,77 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dlarscl2_(integer *m, integer *n, double *d__, double *x, integer *ldx) -{ - /* System generated locals */ - integer x_dim1, x_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARSCL2 performs a reciprocal diagonal scaling on an vector: */ -/* x <-- inv(D) * x */ -/* where the diagonal matrix D is stored as a vector. */ - -/* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS */ -/* standard. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of D and X. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of D and X. N >= 0. */ - -/* D (input) DOUBLE PRECISION array, length M */ -/* Diagonal matrix D, stored as a vector of length M. */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */ -/* On entry, the vector X to be scaled by D. */ -/* On exit, the scaled vector. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the vector X. LDX >= 0. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --d__; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - - /* Function Body */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__ + j * x_dim1] /= d__[i__]; - } - } - return 0; -} /* dlarscl2_ */ diff --git a/external/clapack/lapack/dlartg.cpp b/external/clapack/lapack/dlartg.cpp deleted file mode 100644 index 07ca8bdc..00000000 --- a/external/clapack/lapack/dlartg.cpp +++ /dev/null @@ -1,175 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlartg_(double *f, double *g, double *cs, - double *sn, double *r__) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - integer i__; - double f1, g1, eps, scale; - integer count; - double safmn2, safmx2; - - double safmin; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARTG generate a plane rotation so that */ - -/* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */ -/* [ -SN CS ] [ G ] [ 0 ] */ - -/* This is a slower, more accurate version of the BLAS1 routine DROTG, */ -/* with the following other differences: */ -/* F and G are unchanged on return. */ -/* If G=0, then CS=1 and SN=0. */ -/* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */ -/* floating point operations (saves work in DBDSQR when */ -/* there are zeros on the diagonal). */ - -/* If F exceeds G in magnitude, CS will be positive. */ - -/* Arguments */ -/* ========= */ - -/* F (input) DOUBLE PRECISION */ -/* The first component of vector to be rotated. */ - -/* G (input) DOUBLE PRECISION */ -/* The second component of vector to be rotated. */ - -/* CS (output) DOUBLE PRECISION */ -/* The cosine of the rotation. */ - -/* SN (output) DOUBLE PRECISION */ -/* The sine of the rotation. */ - -/* R (output) DOUBLE PRECISION */ -/* The nonzero component of the rotated vector. */ - -/* This version has a few statements commented out for thread safety */ -/* (machine parameters are computed on each entry). 10 feb 03, SJH. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* LOGICAL FIRST */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */ -/* .. */ -/* .. Data statements .. */ -/* DATA FIRST / .TRUE. / */ -/* .. */ -/* .. Executable Statements .. */ - -/* IF( FIRST ) THEN */ - safmin = dlamch_("S"); - eps = dlamch_("E"); - d__1 = dlamch_("B"); - i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.); - safmn2 = pow_di(&d__1, &i__1); - safmx2 = 1. / safmn2; -/* FIRST = .FALSE. */ -/* END IF */ - if (*g == 0.) { - *cs = 1.; - *sn = 0.; - *r__ = *f; - } else if (*f == 0.) { - *cs = 0.; - *sn = 1.; - *r__ = *g; - } else { - f1 = *f; - g1 = *g; -/* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = std::max(d__1,d__2); - if (scale >= safmx2) { - count = 0; -L10: - ++count; - f1 *= safmn2; - g1 *= safmn2; -/* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = std::max(d__1,d__2); - if (scale >= safmx2) { - goto L10; - } -/* Computing 2nd power */ - d__1 = f1; -/* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - i__1 = count; - for (i__ = 1; i__ <= i__1; ++i__) { - *r__ *= safmx2; -/* L20: */ - } - } else if (scale <= safmn2) { - count = 0; -L30: - ++count; - f1 *= safmx2; - g1 *= safmx2; -/* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = std::max(d__1,d__2); - if (scale <= safmn2) { - goto L30; - } -/* Computing 2nd power */ - d__1 = f1; -/* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - i__1 = count; - for (i__ = 1; i__ <= i__1; ++i__) { - *r__ *= safmn2; -/* L40: */ - } - } else { -/* Computing 2nd power */ - d__1 = f1; -/* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - } - if (abs(*f) > abs(*g) && *cs < 0.) { - *cs = -(*cs); - *sn = -(*sn); - *r__ = -(*r__); - } - } - return 0; - -/* End of DLARTG */ - -} /* dlartg_ */ diff --git a/external/clapack/lapack/dlartv.cpp b/external/clapack/lapack/dlartv.cpp deleted file mode 100644 index 3c45a4c6..00000000 --- a/external/clapack/lapack/dlartv.cpp +++ /dev/null @@ -1,94 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlartv_(integer *n, double *x, integer *incx, - double *y, integer *incy, double *c__, double *s, integer - *incc) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, ic, ix, iy; - double xi, yi; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARTV applies a vector of real plane rotations to elements of the */ -/* real vectors x and y. For i = 1,2,...,n */ - -/* ( x(i) ) := ( c(i) s(i) ) ( x(i) ) */ -/* ( y(i) ) ( -s(i) c(i) ) ( y(i) ) */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of plane rotations to be applied. */ - -/* X (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCX) */ -/* The vector x. */ - -/* INCX (input) INTEGER */ -/* The increment between elements of X. INCX > 0. */ - -/* Y (input/output) DOUBLE PRECISION array, */ -/* dimension (1+(N-1)*INCY) */ -/* The vector y. */ - -/* INCY (input) INTEGER */ -/* The increment between elements of Y. INCY > 0. */ - -/* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ -/* The cosines of the plane rotations. */ - -/* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ -/* The sines of the plane rotations. */ - -/* INCC (input) INTEGER */ -/* The increment between elements of C and S. INCC > 0. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --s; - --c__; - --y; - --x; - - /* Function Body */ - ix = 1; - iy = 1; - ic = 1; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - xi = x[ix]; - yi = y[iy]; - x[ix] = c__[ic] * xi + s[ic] * yi; - y[iy] = c__[ic] * yi - s[ic] * xi; - ix += *incx; - iy += *incy; - ic += *incc; -/* L10: */ - } - return 0; - -/* End of DLARTV */ - -} /* dlartv_ */ diff --git a/external/clapack/lapack/dlaruv.cpp b/external/clapack/lapack/dlaruv.cpp deleted file mode 100644 index a4d75905..00000000 --- a/external/clapack/lapack/dlaruv.cpp +++ /dev/null @@ -1,180 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaruv_(integer *iseed, integer *n, double *x) -{ - /* Initialized data */ - - static integer mm[512] /* was [128][4] */ = { 494,2637,255,2008,1253, - 3344,4084,1739,3143,3468,688,1657,1238,3166,1292,3422,1270,2016, - 154,2862,697,1706,491,931,1444,444,3577,3944,2184,1661,3482,657, - 3023,3618,1267,1828,164,3798,3087,2400,2870,3876,1905,1593,1797, - 1234,3460,328,2861,1950,617,2070,3331,769,1558,2412,2800,189,287, - 2045,1227,2838,209,2770,3654,3993,192,2253,3491,2889,2857,2094, - 1818,688,1407,634,3231,815,3524,1914,516,164,303,2144,3480,119, - 3357,837,2826,2332,2089,3780,1700,3712,150,2000,3375,1621,3090, - 3765,1149,3146,33,3082,2741,359,3316,1749,185,2784,2202,2199,1364, - 1244,2020,3160,2785,2772,1217,1822,1245,2252,3904,2774,997,2573, - 1148,545,322,789,1440,752,2859,123,1848,643,2405,2638,2344,46, - 3814,913,3649,339,3808,822,2832,3078,3633,2970,637,2249,2081,4019, - 1478,242,481,2075,4058,622,3376,812,234,641,4005,1122,3135,2640, - 2302,40,1832,2247,2034,2637,1287,1691,496,1597,2394,2584,1843,336, - 1472,2407,433,2096,1761,2810,566,442,41,1238,1086,603,840,3168, - 1499,1084,3438,2408,1589,2391,288,26,512,1456,171,1677,2657,2270, - 2587,2961,1970,1817,676,1410,3723,2803,3185,184,663,499,3784,1631, - 1925,3912,1398,1349,1441,2224,2411,1907,3192,2786,382,37,759,2948, - 1862,3802,2423,2051,2295,1332,1832,2405,3638,3661,327,3660,716, - 1842,3987,1368,1848,2366,2508,3754,1766,3572,2893,307,1297,3966, - 758,2598,3406,2922,1038,2934,2091,2451,1580,1958,2055,1507,1078, - 3273,17,854,2916,3971,2889,3831,2621,1541,893,736,3992,787,2125, - 2364,2460,257,1574,3912,1216,3248,3401,2124,2762,149,2245,166,466, - 4018,1399,190,2879,153,2320,18,712,2159,2318,2091,3443,1510,449, - 1956,2201,3137,3399,1321,2271,3667,2703,629,2365,2431,1113,3922, - 2554,184,2099,3228,4012,1921,3452,3901,572,3309,3171,817,3039, - 1696,1256,3715,2077,3019,1497,1101,717,51,981,1978,1813,3881,76, - 3846,3694,1682,124,1660,3997,479,1141,886,3514,1301,3604,1888, - 1836,1990,2058,692,1194,20,3285,2046,2107,3508,3525,3801,2549, - 1145,2253,305,3301,1065,3133,2913,3285,1241,1197,3729,2501,1673, - 541,2753,949,2361,1165,4081,2725,3305,3069,3617,3733,409,2157, - 1361,3973,1865,2525,1409,3445,3577,77,3761,2149,1449,3005,225,85, - 3673,3117,3089,1349,2057,413,65,1845,697,3085,3441,1573,3689,2941, - 929,533,2841,4077,721,2821,2249,2397,2817,245,1913,1997,3121,997, - 1833,2877,1633,981,2009,941,2449,197,2441,285,1473,2741,3129,909, - 2801,421,4073,2813,2337,1429,1177,1901,81,1669,2633,2269,129,1141, - 249,3917,2481,3941,2217,2749,3041,1877,345,2861,1809,3141,2825, - 157,2881,3637,1465,2829,2161,3365,361,2685,3745,2325,3609,3821, - 3537,517,3017,2141,1537 }; - - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, i1, i2, i3, i4, it1, it2, it3, it4; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARUV returns a vector of n random real numbers from a uniform (0,1) */ -/* distribution (n <= 128). */ - -/* This is an auxiliary routine called by DLARNV and ZLARNV. */ - -/* Arguments */ -/* ========= */ - -/* ISEED (input/output) INTEGER array, dimension (4) */ -/* On entry, the seed of the random number generator; the array */ -/* elements must be between 0 and 4095, and ISEED(4) must be */ -/* odd. */ -/* On exit, the seed is updated. */ - -/* N (input) INTEGER */ -/* The number of random numbers to be generated. N <= 128. */ - -/* X (output) DOUBLE PRECISION array, dimension (N) */ -/* The generated random numbers. */ - -/* Further Details */ -/* =============== */ - -/* This routine uses a multiplicative congruential method with modulus */ -/* 2**48 and multiplier 33952834046453 (see G.S.Fishman, */ -/* 'Multiplicative congruential random number generators with modulus */ -/* 2**b: an exhaustive analysis for b = 32 and a partial analysis for */ -/* b = 48', Math. Comp. 189, pp 331-344, 1990). */ - -/* 48-bit integers are stored in 4 integer array elements with 12 bits */ -/* per element. Hence the routine is portable across machines with */ -/* integers of 32 bits or more. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - --iseed; - --x; - - /* Function Body */ -/* .. */ -/* .. Executable Statements .. */ - - i1 = iseed[1]; - i2 = iseed[2]; - i3 = iseed[3]; - i4 = iseed[4]; - - i__1 = std::min(*n,128_integer); - for (i__ = 1; i__ <= i__1; ++i__) { - -L20: - -/* Multiply the seed by i-th power of the multiplier modulo 2**48 */ - - it4 = i4 * mm[i__ + 383]; - it3 = it4 / 4096; - it4 -= it3 << 12; - it3 = it3 + i3 * mm[i__ + 383] + i4 * mm[i__ + 255]; - it2 = it3 / 4096; - it3 -= it2 << 12; - it2 = it2 + i2 * mm[i__ + 383] + i3 * mm[i__ + 255] + i4 * mm[i__ + - 127]; - it1 = it2 / 4096; - it2 -= it1 << 12; - it1 = it1 + i1 * mm[i__ + 383] + i2 * mm[i__ + 255] + i3 * mm[i__ + - 127] + i4 * mm[i__ - 1]; - it1 %= 4096; - -/* Convert 48-bit integer to a real number in the interval (0,1) */ - - x[i__] = ((double) it1 + ((double) it2 + ((double) it3 + ( - double) it4 * 2.44140625e-4) * 2.44140625e-4) * - 2.44140625e-4) * 2.44140625e-4; - - if (x[i__] == 1.) { -/* If a real number has n bits of precision, and the first */ -/* n bits of the 48-bit integer above happen to be all 1 (which */ -/* will occur about once every 2**n calls), then X( I ) will */ -/* be rounded to exactly 1.0. */ -/* Since X( I ) is not supposed to return exactly 0.0 or 1.0, */ -/* the statistically correct thing to do in this situation is */ -/* simply to iterate again. */ -/* N.B. the case X( I ) = 0.0 should not be possible. */ - i1 += 2; - i2 += 2; - i3 += 2; - i4 += 2; - goto L20; - } - -/* L10: */ - } - -/* Return final value of seed */ - - iseed[1] = it1; - iseed[2] = it2; - iseed[3] = it3; - iseed[4] = it4; - return 0; - -/* End of DLARUV */ - -} /* dlaruv_ */ diff --git a/external/clapack/lapack/dlarz.cpp b/external/clapack/lapack/dlarz.cpp deleted file mode 100644 index 90222041..00000000 --- a/external/clapack/lapack/dlarz.cpp +++ /dev/null @@ -1,169 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b5 = 1.; - -/* Subroutine */ int dlarz_(const char *side, integer *m, integer *n, integer *l, - double *v, integer *incv, double *tau, double *c__, - integer *ldc, double *work) -{ - /* System generated locals */ - integer c_dim1, c_offset; - double d__1; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARZ 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. */ - - -/* H is a product of k elementary reflectors as returned by DTZRZF. */ - -/* 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. */ - -/* L (input) INTEGER */ -/* The number of entries of the vector V containing */ -/* the meaningful part of the Householder vectors. */ -/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ - -/* V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV)) */ -/* The vector v in the representation of H as returned by */ -/* DTZRZF. 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' */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --v; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - if (lsame_(side, "L")) { - -/* Form H * C */ - - if (*tau != 0.) { - -/* w( 1:n ) = C( 1, 1:n ) */ - - dcopy_(n, &c__[c_offset], ldc, &work[1], &c__1); - -/* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) */ - - dgemv_("Transpose", l, n, &c_b5, &c__[*m - *l + 1 + c_dim1], ldc, - &v[1], incv, &c_b5, &work[1], &c__1); - -/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */ - - d__1 = -(*tau); - daxpy_(n, &d__1, &work[1], &c__1, &c__[c_offset], ldc); - -/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */ -/* tau * v( 1:l ) * w( 1:n )' */ - - d__1 = -(*tau); - dger_(l, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l + 1 - + c_dim1], ldc); - } - - } else { - -/* Form C * H */ - - if (*tau != 0.) { - -/* w( 1:m ) = C( 1:m, 1 ) */ - - dcopy_(m, &c__[c_offset], &c__1, &work[1], &c__1); - -/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */ - - dgemv_("No transpose", m, l, &c_b5, &c__[(*n - *l + 1) * c_dim1 + - 1], ldc, &v[1], incv, &c_b5, &work[1], &c__1); - -/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */ - - d__1 = -(*tau); - daxpy_(m, &d__1, &work[1], &c__1, &c__[c_offset], &c__1); - -/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */ -/* tau * w( 1:m ) * v( 1:l )' */ - - d__1 = -(*tau); - dger_(m, l, &d__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l + - 1) * c_dim1 + 1], ldc); - - } - - } - - return 0; - -/* End of DLARZ */ - -} /* dlarz_ */ diff --git a/external/clapack/lapack/dlarzb.cpp b/external/clapack/lapack/dlarzb.cpp deleted file mode 100644 index 60552094..00000000 --- a/external/clapack/lapack/dlarzb.cpp +++ /dev/null @@ -1,267 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b13 = 1.; -static double c_b23 = -1.; - -/* Subroutine */ int dlarzb_(const char *side, const char *trans, const char *direct, const char * - storev, integer *m, integer *n, integer *k, integer *l, double *v, - integer *ldv, double *t, integer *ldt, double *c__, integer * - ldc, double *work, integer *ldwork) -{ - /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, info; - char transt[1]; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARZB applies a real block reflector H or its transpose H**T to */ -/* a real distributed M-by-N C from the left or the right. */ - -/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */ - -/* 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) */ -/* = 'C': 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, not supported yet) */ -/* = '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 (not supported yet) */ -/* = '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). */ - -/* L (input) INTEGER */ -/* The number of columns of the matrix V containing the */ -/* meaningful part of the Householder reflectors. */ -/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ - -/* V (input) DOUBLE PRECISION array, dimension (LDV,NV). */ -/* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */ - -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. */ -/* If STOREV = 'C', LDV >= L; 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. LDC >= 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). */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - work_dim1 = *ldwork; - work_offset = 1 + work_dim1; - work -= work_offset; - - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } - -/* Check for currently supported options */ - - info = 0; - if (! lsame_(direct, "B")) { - info = -3; - } else if (! lsame_(storev, "R")) { - info = -4; - } - if (info != 0) { - i__1 = -info; - xerbla_("DLARZB", &i__1); - return 0; - } - - if (lsame_(trans, "N")) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C */ - -/* W( 1:n, 1:k ) = C( 1:k, 1:n )' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); -/* L10: */ - } - -/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */ -/* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )' */ - - if (*l > 0) { - dgemm_("Transpose", "Transpose", n, k, l, &c_b13, &c__[*m - *l + - 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b13, &work[ - work_offset], ldwork); - } - -/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T */ - - dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b13, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )' */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *k; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[j + i__ * work_dim1]; -/* L20: */ - } -/* L30: */ - } - -/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */ -/* V( 1:k, 1:l )' * W( 1:n, 1:k )' */ - - if (*l > 0) { - dgemm_("Transpose", "Transpose", l, n, k, &c_b23, &v[v_offset], - ldv, &work[work_offset], ldwork, &c_b13, &c__[*m - *l + 1 - + c_dim1], ldc); - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' */ - -/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], & - c__1); -/* L40: */ - } - -/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */ -/* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )' */ - - if (*l > 0) { - dgemm_("No transpose", "Transpose", m, k, l, &c_b13, &c__[(*n - * - l + 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b13, & - work[work_offset], ldwork); - } - -/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T' */ - - dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b13, &t[t_offset] -, ldt, &work[work_offset], ldwork); - -/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; -/* L50: */ - } -/* L60: */ - } - -/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */ -/* W( 1:m, 1:k ) * V( 1:k, 1:l ) */ - - if (*l > 0) { - dgemm_("No transpose", "No transpose", m, l, k, &c_b23, &work[ - work_offset], ldwork, &v[v_offset], ldv, &c_b13, &c__[(*n - - *l + 1) * c_dim1 + 1], ldc); - } - - } - - return 0; - -/* End of DLARZB */ - -} /* dlarzb_ */ diff --git a/external/clapack/lapack/dlarzt.cpp b/external/clapack/lapack/dlarzt.cpp deleted file mode 100644 index a8d44c1e..00000000 --- a/external/clapack/lapack/dlarzt.cpp +++ /dev/null @@ -1,210 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b8 = 0.; -static integer c__1 = 1; - -/* Subroutine */ int dlarzt_(const char *direct, const char *storev, integer *n, integer * - k, double *v, integer *ldv, double *tau, double *t, - integer *ldt) -{ - /* System generated locals */ - integer t_dim1, t_offset, v_dim1, v_offset, i__1; - double d__1; - - /* Local variables */ - integer i__, j, info; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLARZT 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 */ - -/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */ - -/* 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, not supported yet) */ -/* = '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 (not supported yet) */ -/* = '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 */ -/* =============== */ - -/* Based on contributions by */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* 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_____ */ -/* ( v1 v2 v3 ) / \ */ -/* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */ -/* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */ -/* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */ -/* ( v1 v2 v3 ) */ -/* . . . */ -/* . . . */ -/* 1 . . */ -/* 1 . */ -/* 1 */ - -/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ - -/* ______V_____ */ -/* 1 / \ */ -/* . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */ -/* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */ -/* . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */ -/* . . . */ -/* ( v1 v2 v3 ) */ -/* ( v1 v2 v3 ) */ -/* V = ( v1 v2 v3 ) */ -/* ( v1 v2 v3 ) */ -/* ( v1 v2 v3 ) */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Check for currently supported options */ - - /* Parameter adjustments */ - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - --tau; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - - /* Function Body */ - info = 0; - if (! lsame_(direct, "B")) { - info = -1; - } else if (! lsame_(storev, "R")) { - info = -2; - } - if (info != 0) { - i__1 = -info; - xerbla_("DLARZT", &i__1); - return 0; - } - - for (i__ = *k; i__ >= 1; --i__) { - if (tau[i__] == 0.) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t[j + i__ * t_dim1] = 0.; -/* L10: */ - } - } else { - -/* general case */ - - if (i__ < *k) { - -/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' */ - - i__1 = *k - i__; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__1, n, &d__1, &v[i__ + 1 + v_dim1], - ldv, &v[i__ + v_dim1], ldv, &c_b8, &t[i__ + 1 + i__ * - t_dim1], &c__1); - -/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 - + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1] -, &c__1); - } - t[i__ + i__ * t_dim1] = tau[i__]; - } -/* L20: */ - } - return 0; - -/* End of DLARZT */ - -} /* dlarzt_ */ diff --git a/external/clapack/lapack/dlas2.cpp b/external/clapack/lapack/dlas2.cpp deleted file mode 100644 index cf659bca..00000000 --- a/external/clapack/lapack/dlas2.cpp +++ /dev/null @@ -1,132 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlas2_(double *f, double *g, double *h__, - double *ssmin, double *ssmax) -{ - /* System generated locals */ - double d__1, d__2; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - double c__, fa, ga, ha, as, at, au, fhmn, fhmx; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAS2 computes the singular values of the 2-by-2 matrix */ -/* [ F G ] */ -/* [ 0 H ]. */ -/* On return, SSMIN is the smaller singular value and SSMAX is the */ -/* larger singular value. */ - -/* Arguments */ -/* ========= */ - -/* F (input) DOUBLE PRECISION */ -/* The (1,1) element of the 2-by-2 matrix. */ - -/* G (input) DOUBLE PRECISION */ -/* The (1,2) element of the 2-by-2 matrix. */ - -/* H (input) DOUBLE PRECISION */ -/* The (2,2) element of the 2-by-2 matrix. */ - -/* SSMIN (output) DOUBLE PRECISION */ -/* The smaller singular value. */ - -/* SSMAX (output) DOUBLE PRECISION */ -/* The larger singular value. */ - -/* Further Details */ -/* =============== */ - -/* Barring over/underflow, all output quantities are correct to within */ -/* a few units in the last place (ulps), even in the absence of a guard */ -/* digit in addition/subtraction. */ - -/* In IEEE arithmetic, the code works correctly if one matrix element is */ -/* infinite. */ - -/* Overflow will not occur unless the largest singular value itself */ -/* overflows, or is within a few ulps of overflow. (On machines with */ -/* partial overflow, like the Cray, overflow may occur if the largest */ -/* singular value is within a factor of 2 of overflow.) */ - -/* Underflow is harmless if underflow is gradual. Otherwise, results */ -/* may correspond to a matrix modified by perturbations of size near */ -/* the underflow threshold. */ - -/* ==================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - fa = abs(*f); - ga = abs(*g); - ha = abs(*h__); - fhmn = std::min(fa,ha); - fhmx = std::max(fa,ha); - if (fhmn == 0.) { - *ssmin = 0.; - if (fhmx == 0.) { - *ssmax = ga; - } else { -/* Computing 2nd power */ - d__1 = std::min(fhmx,ga) / std::max(fhmx,ga); - *ssmax = std::max(fhmx,ga) * sqrt(d__1 * d__1 + 1.); - } - } else { - if (ga < fhmx) { - as = fhmn / fhmx + 1.; - at = (fhmx - fhmn) / fhmx; -/* Computing 2nd power */ - d__1 = ga / fhmx; - au = d__1 * d__1; - c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au)); - *ssmin = fhmn * c__; - *ssmax = fhmx / c__; - } else { - au = fhmx / ga; - if (au == 0.) { - -/* Avoid possible harmful underflow if exponent range */ -/* asymmetric (true SSMIN may not underflow even if */ -/* AU underflows) */ - - *ssmin = fhmn * fhmx / ga; - *ssmax = ga; - } else { - as = fhmn / fhmx + 1.; - at = (fhmx - fhmn) / fhmx; -/* Computing 2nd power */ - d__1 = as * au; -/* Computing 2nd power */ - d__2 = at * au; - c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.)); - *ssmin = fhmn * c__ * au; - *ssmin += *ssmin; - *ssmax = ga / (c__ + c__); - } - } - } - return 0; - -/* End of DLAS2 */ - -} /* dlas2_ */ diff --git a/external/clapack/lapack/dlascl.cpp b/external/clapack/lapack/dlascl.cpp deleted file mode 100644 index 72dffe99..00000000 --- a/external/clapack/lapack/dlascl.cpp +++ /dev/null @@ -1,338 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - - -int dlascl_(const char *type__, integer *kl, integer *ku, double *cfrom, double *cto, - integer *m, integer *n, double *a, integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - - /* Local variables */ - integer i__, j, k1, k2, k3, k4; - double mul, cto1; - bool done; - double ctoc; - integer itype; - double cfrom1; - double cfromc; - double bignum, smlnum; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASCL multiplies the M by N real matrix A by the real scalar */ -/* CTO/CFROM. This is done without over/underflow as long as the final */ -/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */ -/* A may be full, upper triangular, lower triangular, upper Hessenberg, */ -/* or banded. */ - -/* Arguments */ -/* ========= */ - -/* TYPE (input) CHARACTER*1 */ -/* TYPE indices the storage type of the input matrix. */ -/* = 'G': A is a full matrix. */ -/* = 'L': A is a lower triangular matrix. */ -/* = 'U': A is an upper triangular matrix. */ -/* = 'H': A is an upper Hessenberg matrix. */ -/* = 'B': A is a symmetric band matrix with lower bandwidth KL */ -/* and upper bandwidth KU and with the only the lower */ -/* half stored. */ -/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */ -/* and upper bandwidth KU and with the only the upper */ -/* half stored. */ -/* = 'Z': A is a band matrix with lower bandwidth KL and upper */ -/* bandwidth KU. */ - -/* KL (input) INTEGER */ -/* The lower bandwidth of A. Referenced only if TYPE = 'B', */ -/* 'Q' or 'Z'. */ - -/* KU (input) INTEGER */ -/* The upper bandwidth of A. Referenced only if TYPE = 'B', */ -/* 'Q' or 'Z'. */ - -/* CFROM (input) DOUBLE PRECISION */ -/* CTO (input) DOUBLE PRECISION */ -/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */ -/* without over/underflow if the final result CTO*A(I,J)/CFROM */ -/* can be represented without over/underflow. CFROM must be */ -/* nonzero. */ - -/* 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) */ -/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */ -/* storage type. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* INFO (output) INTEGER */ -/* 0 - successful exit */ -/* <0 - if INFO = -i, the i-th argument had an illegal value. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - - if (lsame_(type__, "G")) { - itype = 0; - } else if (lsame_(type__, "L")) { - itype = 1; - } else if (lsame_(type__, "U")) { - itype = 2; - } else if (lsame_(type__, "H")) { - itype = 3; - } else if (lsame_(type__, "B")) { - itype = 4; - } else if (lsame_(type__, "Q")) { - itype = 5; - } else if (lsame_(type__, "Z")) { - itype = 6; - } else { - itype = -1; - } - - if (itype == -1) { - *info = -1; - } else if (*cfrom == 0. || disnan_(cfrom)) { - *info = -4; - } else if (disnan_(cto)) { - *info = -5; - } else if (*m < 0) { - *info = -6; - } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { - *info = -7; - } else if (itype <= 3 && *lda < std::max(1_integer,*m)) { - *info = -9; - } else if (itype >= 4) { -/* Computing MAX */ - i__1 = *m - 1; - if (*kl < 0 || *kl > std::max(i__1,0_integer)) { - *info = -2; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = *n - 1; - if (*ku < 0 || *ku > std::max(i__1,0_integer) || (itype == 4 || itype == 5) && - *kl != *ku) { - *info = -3; - } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * - ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { - *info = -9; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASCL", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *m == 0) { - return 0; - } - -/* Get machine parameters */ - - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - - cfromc = *cfrom; - ctoc = *cto; - -L10: - cfrom1 = cfromc * smlnum; - if (cfrom1 == cfromc) { -/* CFROMC is an inf. Multiply by a correctly signed zero for */ -/* finite CTOC, or a NaN if CTOC is infinite. */ - mul = ctoc / cfromc; - done = true; - cto1 = ctoc; - } else { - cto1 = ctoc / bignum; - if (cto1 == ctoc) { -/* CTOC is either 0 or an inf. In both cases, CTOC itself */ -/* serves as the correct multiplication factor. */ - mul = ctoc; - done = true; - cfromc = 1.; - } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { - mul = smlnum; - done = false; - cfromc = cfrom1; - } else if (abs(cto1) > abs(cfromc)) { - mul = bignum; - done = false; - ctoc = cto1; - } else { - mul = ctoc / cfromc; - done = true; - } - } - - if (itype == 0) { - -/* Full matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; -/* L20: */ - } -/* L30: */ - } - - } else if (itype == 1) { - -/* Lower triangular matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; -/* L40: */ - } -/* L50: */ - } - - } else if (itype == 2) { - -/* Upper triangular matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = std::min(j,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; -/* L60: */ - } -/* L70: */ - } - - } else if (itype == 3) { - -/* Upper Hessenberg matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = j + 1; - i__2 = std::min(i__3,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; -/* L80: */ - } -/* L90: */ - } - - } else if (itype == 4) { - -/* Lower half of a symmetric band matrix */ - - k3 = *kl + 1; - k4 = *n + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = k3, i__4 = k4 - j; - i__2 = std::min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; -/* L100: */ - } -/* L110: */ - } - - } else if (itype == 5) { - -/* Upper half of a symmetric band matrix */ - - k1 = *ku + 2; - k3 = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = k1 - j; - i__3 = k3; - for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { - a[i__ + j * a_dim1] *= mul; -/* L120: */ - } -/* L130: */ - } - - } else if (itype == 6) { - -/* Band matrix */ - - k1 = *kl + *ku + 2; - k2 = *kl + 1; - k3 = (*kl << 1) + *ku + 1; - k4 = *kl + *ku + 1 + *m; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__3 = k1 - j; -/* Computing MIN */ - i__4 = k3, i__5 = k4 - j; - i__2 = std::min(i__4,i__5); - for (i__ = std::max(i__3,k2); i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] *= mul; -/* L140: */ - } -/* L150: */ - } - - } - - if (! done) { - goto L10; - } - - return 0; - -/* End of DLASCL */ - -} /* dlascl_ */ diff --git a/external/clapack/lapack/dlascl2.cpp b/external/clapack/lapack/dlascl2.cpp deleted file mode 100644 index a41883e4..00000000 --- a/external/clapack/lapack/dlascl2.cpp +++ /dev/null @@ -1,77 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dlascl2_(integer *m, integer *n, double *d__, double *x, integer *ldx) -{ - /* System generated locals */ - integer x_dim1, x_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASCL2 performs a diagonal scaling on a vector: */ -/* x <-- D * x */ -/* where the diagonal matrix D is stored as a vector. */ - -/* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS */ -/* standard. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of D and X. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of D and X. N >= 0. */ - -/* D (input) DOUBLE PRECISION array, length M */ -/* Diagonal matrix D, stored as a vector of length M. */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */ -/* On entry, the vector X to be scaled by D. */ -/* On exit, the scaled vector. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the vector X. LDX >= 0. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --d__; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - - /* Function Body */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__ + j * x_dim1] *= d__[i__]; - } - } - return 0; -} /* dlascl2_ */ diff --git a/external/clapack/lapack/dlasd0.cpp b/external/clapack/lapack/dlasd0.cpp deleted file mode 100644 index 3841dcd3..00000000 --- a/external/clapack/lapack/dlasd0.cpp +++ /dev/null @@ -1,266 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__0 = 0; -static integer c__2 = 2; - -/* Subroutine */ int dlasd0_(integer *n, integer *sqre, double *d__, - double *e, double *u, integer *ldu, double *vt, integer * - ldvt, integer *smlsiz, integer *iwork, double *work, integer * - info) -{ - /* System generated locals */ - integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, m, i1, ic, lf, nd, ll, nl, nr, im1, ncc, nlf, nrf, iwk, - lvl, ndb1, nlp1, nrp1; - double beta; - integer idxq, nlvl; - double alpha; - integer inode, ndiml, idxqc, ndimr, itemp, sqrei; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Using a divide and conquer approach, DLASD0 computes the singular */ -/* value decomposition (SVD) of a real upper bidiagonal N-by-M */ -/* matrix B with diagonal D and offdiagonal E, where M = N + SQRE. */ -/* The algorithm computes orthogonal matrices U and VT such that */ -/* B = U * S * VT. The singular values S are overwritten on D. */ - -/* A related subroutine, DLASDA, computes only the singular values, */ -/* and optionally, the singular vectors in compact form. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* On entry, the row dimension of the upper bidiagonal matrix. */ -/* This is also the dimension of the main diagonal array D. */ - -/* SQRE (input) INTEGER */ -/* Specifies the column dimension of the bidiagonal matrix. */ -/* = 0: The bidiagonal matrix has column dimension M = N; */ -/* = 1: The bidiagonal matrix has column dimension M = N+1; */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry D contains the main diagonal of the bidiagonal */ -/* matrix. */ -/* On exit D, if INFO = 0, contains its singular values. */ - -/* E (input) DOUBLE PRECISION array, dimension (M-1) */ -/* Contains the subdiagonal entries of the bidiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N) */ -/* On exit, U contains the left singular vectors. */ - -/* LDU (input) INTEGER */ -/* On entry, leading dimension of U. */ - -/* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M) */ -/* On exit, VT' contains the right singular vectors. */ - -/* LDVT (input) INTEGER */ -/* On entry, leading dimension of VT. */ - -/* SMLSIZ (input) INTEGER */ -/* On entry, maximum size of the subproblems at the */ -/* bottom of the computation tree. */ - -/* IWORK (workspace) INTEGER work array. */ -/* Dimension must be at least (8 * N) */ - -/* WORK (workspace) DOUBLE PRECISION work array. */ -/* Dimension must be at least (3 * M**2 + 2 * M) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an singular value did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - --iwork; - --work; - - /* Function Body */ - *info = 0; - - if (*n < 0) { - *info = -1; - } else if (*sqre < 0 || *sqre > 1) { - *info = -2; - } - - m = *n + *sqre; - - if (*ldu < *n) { - *info = -6; - } else if (*ldvt < m) { - *info = -8; - } else if (*smlsiz < 3) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASD0", &i__1); - return 0; - } - -/* If the input matrix is too small, call DLASDQ to find the SVD. */ - - if (*n <= *smlsiz) { - dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset], - ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], info); - return 0; - } - -/* Set up the computation tree. */ - - inode = 1; - ndiml = inode + *n; - ndimr = ndiml + *n; - idxq = ndimr + *n; - iwk = idxq + *n; - dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], - smlsiz); - -/* For the nodes on bottom level of the tree, solve */ -/* their subproblems by DLASDQ. */ - - ndb1 = (nd + 1) / 2; - ncc = 0; - i__1 = nd; - for (i__ = ndb1; i__ <= i__1; ++i__) { - -/* IC : center row of each node */ -/* NL : number of rows of left subproblem */ -/* NR : number of rows of right subproblem */ -/* NLF: starting row of the left subproblem */ -/* NRF: starting row of the right subproblem */ - - i1 = i__ - 1; - ic = iwork[inode + i1]; - nl = iwork[ndiml + i1]; - nlp1 = nl + 1; - nr = iwork[ndimr + i1]; - nrp1 = nr + 1; - nlf = ic - nl; - nrf = ic + 1; - sqrei = 1; - dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[ - nlf + nlf * vt_dim1], ldvt, &u[nlf + nlf * u_dim1], ldu, &u[ - nlf + nlf * u_dim1], ldu, &work[1], info); - if (*info != 0) { - return 0; - } - itemp = idxq + nlf - 2; - i__2 = nl; - for (j = 1; j <= i__2; ++j) { - iwork[itemp + j] = j; -/* L10: */ - } - if (i__ == nd) { - sqrei = *sqre; - } else { - sqrei = 1; - } - nrp1 = nr + sqrei; - dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[ - nrf + nrf * vt_dim1], ldvt, &u[nrf + nrf * u_dim1], ldu, &u[ - nrf + nrf * u_dim1], ldu, &work[1], info); - if (*info != 0) { - return 0; - } - itemp = idxq + ic; - i__2 = nr; - for (j = 1; j <= i__2; ++j) { - iwork[itemp + j - 1] = j; -/* L20: */ - } -/* L30: */ - } - -/* Now conquer each subproblem bottom-up. */ - - for (lvl = nlvl; lvl >= 1; --lvl) { - -/* Find the first node LF and last node LL on the */ -/* current level LVL. */ - - if (lvl == 1) { - lf = 1; - ll = 1; - } else { - i__1 = lvl - 1; - lf = pow_ii(&c__2, &i__1); - ll = (lf << 1) - 1; - } - i__1 = ll; - for (i__ = lf; i__ <= i__1; ++i__) { - im1 = i__ - 1; - ic = iwork[inode + im1]; - nl = iwork[ndiml + im1]; - nr = iwork[ndimr + im1]; - nlf = ic - nl; - if (*sqre == 0 && i__ == ll) { - sqrei = *sqre; - } else { - sqrei = 1; - } - idxqc = idxq + nlf - 1; - alpha = d__[ic]; - beta = e[ic]; - dlasd1_(&nl, &nr, &sqrei, &d__[nlf], &alpha, &beta, &u[nlf + nlf * - u_dim1], ldu, &vt[nlf + nlf * vt_dim1], ldvt, &iwork[ - idxqc], &iwork[iwk], &work[1], info); - if (*info != 0) { - return 0; - } -/* L40: */ - } -/* L50: */ - } - - return 0; - -/* End of DLASD0 */ - -} /* dlasd0_ */ diff --git a/external/clapack/lapack/dlasd1.cpp b/external/clapack/lapack/dlasd1.cpp deleted file mode 100644 index a01b0a43..00000000 --- a/external/clapack/lapack/dlasd1.cpp +++ /dev/null @@ -1,262 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__0 = 0; -static double c_b7 = 1.; -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dlasd1_(integer *nl, integer *nr, integer *sqre, - double *d__, double *alpha, double *beta, double *u, - integer *ldu, double *vt, integer *ldvt, integer *idxq, integer * - iwork, double *work, integer *info) -{ - /* System generated locals */ - integer u_dim1, u_offset, vt_dim1, vt_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc, - idxp, ldvt2; - integer isigma; - double orgnrm; - integer coltyp; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, */ -/* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. */ - -/* A related subroutine DLASD7 handles the case in which the singular */ -/* values (and the singular vectors in factored form) are desired. */ - -/* DLASD1 computes the SVD as follows: */ - -/* ( D1(in) 0 0 0 ) */ -/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */ -/* ( 0 0 D2(in) 0 ) */ - -/* = U(out) * ( D(out) 0) * VT(out) */ - -/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */ -/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */ -/* elsewhere; and the entry b is empty if SQRE = 0. */ - -/* The left singular vectors of the original matrix are stored in U, and */ -/* the transpose of the right singular vectors are stored in VT, and the */ -/* singular values are in D. The algorithm consists of three stages: */ - -/* The first stage consists of deflating the size of the problem */ -/* when there are multiple singular values or when there are zeros in */ -/* the Z vector. For each such occurence the dimension of the */ -/* secular equation problem is reduced by one. This stage is */ -/* performed by the routine DLASD2. */ - -/* The second stage consists of calculating the updated */ -/* singular values. This is done by finding the square roots of the */ -/* roots of the secular equation via the routine DLASD4 (as called */ -/* by DLASD3). This routine also calculates the singular vectors of */ -/* the current problem. */ - -/* The final stage consists of computing the updated singular vectors */ -/* directly using the updated singular values. The singular vectors */ -/* for the current problem are multiplied with the singular vectors */ -/* from the overall problem. */ - -/* Arguments */ -/* ========= */ - -/* NL (input) INTEGER */ -/* The row dimension of the upper block. NL >= 1. */ - -/* NR (input) INTEGER */ -/* The row dimension of the lower block. NR >= 1. */ - -/* SQRE (input) INTEGER */ -/* = 0: the lower block is an NR-by-NR square matrix. */ -/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ - -/* The bidiagonal matrix has row dimension N = NL + NR + 1, */ -/* and column dimension M = N + SQRE. */ - -/* D (input/output) DOUBLE PRECISION array, */ -/* dimension (N = NL+NR+1). */ -/* On entry D(1:NL,1:NL) contains the singular values of the */ -/* upper block; and D(NL+2:N) contains the singular values of */ -/* the lower block. On exit D(1:N) contains the singular values */ -/* of the modified matrix. */ - -/* ALPHA (input/output) DOUBLE PRECISION */ -/* Contains the diagonal element associated with the added row. */ - -/* BETA (input/output) DOUBLE PRECISION */ -/* Contains the off-diagonal element associated with the added */ -/* row. */ - -/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */ -/* On entry U(1:NL, 1:NL) contains the left singular vectors of */ -/* the upper block; U(NL+2:N, NL+2:N) contains the left singular */ -/* vectors of the lower block. On exit U contains the left */ -/* singular vectors of the bidiagonal matrix. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= max( 1, N ). */ - -/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */ -/* where M = N + SQRE. */ -/* On entry VT(1:NL+1, 1:NL+1)' contains the right singular */ -/* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains */ -/* the right singular vectors of the lower block. On exit */ -/* VT' contains the right singular vectors of the */ -/* bidiagonal matrix. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. LDVT >= max( 1, M ). */ - -/* IDXQ (output) INTEGER array, dimension(N) */ -/* This contains the permutation which will reintegrate the */ -/* subproblem just solved back into sorted order, i.e. */ -/* D( IDXQ( I = 1, N ) ) will be in ascending order. */ - -/* IWORK (workspace) INTEGER array, dimension( 4 * N ) */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an singular value did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ - -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - --idxq; - --iwork; - --work; - - /* Function Body */ - *info = 0; - - if (*nl < 1) { - *info = -1; - } else if (*nr < 1) { - *info = -2; - } else if (*sqre < 0 || *sqre > 1) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASD1", &i__1); - return 0; - } - - n = *nl + *nr + 1; - m = n + *sqre; - -/* The following values are for bookkeeping purposes only. They are */ -/* integer pointers which indicate the portion of the workspace */ -/* used by a particular array in DLASD2 and DLASD3. */ - - ldu2 = n; - ldvt2 = m; - - iz = 1; - isigma = iz + m; - iu2 = isigma + n; - ivt2 = iu2 + ldu2 * n; - iq = ivt2 + ldvt2 * m; - - idx = 1; - idxc = idx + n; - coltyp = idxc + n; - idxp = coltyp + n; - -/* Scale. */ - -/* Computing MAX */ - d__1 = abs(*alpha), d__2 = abs(*beta); - orgnrm = std::max(d__1,d__2); - d__[*nl + 1] = 0.; - i__1 = n; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) > orgnrm) { - orgnrm = (d__1 = d__[i__], abs(d__1)); - } -/* L10: */ - } - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info); - *alpha /= orgnrm; - *beta /= orgnrm; - -/* Deflate singular values. */ - - dlasd2_(nl, nr, sqre, &k, &d__[1], &work[iz], alpha, beta, &u[u_offset], - ldu, &vt[vt_offset], ldvt, &work[isigma], &work[iu2], &ldu2, & - work[ivt2], &ldvt2, &iwork[idxp], &iwork[idx], &iwork[idxc], & - idxq[1], &iwork[coltyp], info); - -/* Solve Secular Equation and update singular vectors. */ - - ldq = k; - dlasd3_(nl, nr, sqre, &k, &d__[1], &work[iq], &ldq, &work[isigma], &u[ - u_offset], ldu, &work[iu2], &ldu2, &vt[vt_offset], ldvt, &work[ - ivt2], &ldvt2, &iwork[idxc], &iwork[coltyp], &work[iz], info); - if (*info != 0) { - return 0; - } - -/* Unscale. */ - - dlascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info); - -/* Prepare the IDXQ sorting permutation. */ - - n1 = k; - n2 = n - k; - dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]); - - return 0; - -/* End of DLASD1 */ - -} /* dlasd1_ */ diff --git a/external/clapack/lapack/dlasd2.cpp b/external/clapack/lapack/dlasd2.cpp deleted file mode 100644 index 82af41ee..00000000 --- a/external/clapack/lapack/dlasd2.cpp +++ /dev/null @@ -1,587 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b30 = 0.; - -/* Subroutine */ int dlasd2_(integer *nl, integer *nr, integer *sqre, integer - *k, double *d__, double *z__, double *alpha, double * - beta, double *u, integer *ldu, double *vt, integer *ldvt, - double *dsigma, double *u2, integer *ldu2, double *vt2, - integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer * - idxq, integer *coltyp, integer *info) -{ - /* System generated locals */ - integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, - vt2_dim1, vt2_offset, i__1; - double d__1, d__2; - - /* Local variables */ - double c__; - integer i__, j, m, n; - double s; - integer k2; - double z1; - integer ct, jp; - double eps, tau, tol; - integer psm[4], nlp1, nlp2, idxi, idxj; - integer ctot[4], idxjp; - integer jprev; - double hlftol; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASD2 merges the two sets of singular values together into a single */ -/* sorted set. Then it tries to deflate the size of the problem. */ -/* There are two ways in which deflation can occur: when two or more */ -/* singular values are close together or if there is a tiny entry in the */ -/* Z vector. For each such occurrence the order of the related secular */ -/* equation problem is reduced by one. */ - -/* DLASD2 is called from DLASD1. */ - -/* Arguments */ -/* ========= */ - -/* NL (input) INTEGER */ -/* The row dimension of the upper block. NL >= 1. */ - -/* NR (input) INTEGER */ -/* The row dimension of the lower block. NR >= 1. */ - -/* SQRE (input) INTEGER */ -/* = 0: the lower block is an NR-by-NR square matrix. */ -/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ - -/* The bidiagonal matrix has N = NL + NR + 1 rows and */ -/* M = N + SQRE >= N columns. */ - -/* K (output) INTEGER */ -/* Contains the dimension of the non-deflated matrix, */ -/* This is the order of the related secular equation. 1 <= K <=N. */ - -/* D (input/output) DOUBLE PRECISION array, dimension(N) */ -/* On entry D contains the singular values of the two submatrices */ -/* to be combined. On exit D contains the trailing (N-K) updated */ -/* singular values (those which were deflated) sorted into */ -/* increasing order. */ - -/* Z (output) DOUBLE PRECISION array, dimension(N) */ -/* On exit Z contains the updating row vector in the secular */ -/* equation. */ - -/* ALPHA (input) DOUBLE PRECISION */ -/* Contains the diagonal element associated with the added row. */ - -/* BETA (input) DOUBLE PRECISION */ -/* Contains the off-diagonal element associated with the added */ -/* row. */ - -/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */ -/* On entry U contains the left singular vectors of two */ -/* submatrices in the two square blocks with corners at (1,1), */ -/* (NL, NL), and (NL+2, NL+2), (N,N). */ -/* On exit U contains the trailing (N-K) updated left singular */ -/* vectors (those which were deflated) in its last N-K columns. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= N. */ - -/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */ -/* On entry VT' contains the right singular vectors of two */ -/* submatrices in the two square blocks with corners at (1,1), */ -/* (NL+1, NL+1), and (NL+2, NL+2), (M,M). */ -/* On exit VT' contains the trailing (N-K) updated right singular */ -/* vectors (those which were deflated) in its last N-K columns. */ -/* In case SQRE =1, the last row of VT spans the right null */ -/* space. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. LDVT >= M. */ - -/* DSIGMA (output) DOUBLE PRECISION array, dimension (N) */ -/* Contains a copy of the diagonal elements (K-1 singular values */ -/* and one zero) in the secular equation. */ - -/* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N) */ -/* Contains a copy of the first K-1 left singular vectors which */ -/* will be used by DLASD3 in a matrix multiply (DGEMM) to solve */ -/* for the new left singular vectors. U2 is arranged into four */ -/* blocks. The first block contains a column with 1 at NL+1 and */ -/* zero everywhere else; the second block contains non-zero */ -/* entries only at and above NL; the third contains non-zero */ -/* entries only below NL+1; and the fourth is dense. */ - -/* LDU2 (input) INTEGER */ -/* The leading dimension of the array U2. LDU2 >= N. */ - -/* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N) */ -/* VT2' contains a copy of the first K right singular vectors */ -/* which will be used by DLASD3 in a matrix multiply (DGEMM) to */ -/* solve for the new right singular vectors. VT2 is arranged into */ -/* three blocks. The first block contains a row that corresponds */ -/* to the special 0 diagonal element in SIGMA; the second block */ -/* contains non-zeros only at and before NL +1; the third block */ -/* contains non-zeros only at and after NL +2. */ - -/* LDVT2 (input) INTEGER */ -/* The leading dimension of the array VT2. LDVT2 >= M. */ - -/* IDXP (workspace) INTEGER array dimension(N) */ -/* This will contain the permutation used to place deflated */ -/* values of D at the end of the array. On output IDXP(2:K) */ -/* points to the nondeflated D-values and IDXP(K+1:N) */ -/* points to the deflated singular values. */ - -/* IDX (workspace) INTEGER array dimension(N) */ -/* This will contain the permutation used to sort the contents of */ -/* D into ascending order. */ - -/* IDXC (output) INTEGER array dimension(N) */ -/* This will contain the permutation used to arrange the columns */ -/* of the deflated U matrix into three groups: the first group */ -/* contains non-zero entries only at and above NL, the second */ -/* contains non-zero entries only below NL+2, and the third is */ -/* dense. */ - -/* IDXQ (input/output) INTEGER array dimension(N) */ -/* This contains the permutation which separately sorts the two */ -/* sub-problems in D into ascending order. Note that entries in */ -/* the first hlaf of this permutation must first be moved one */ -/* position backward; and entries in the second half */ -/* must first have NL+1 added to their values. */ - -/* COLTYP (workspace/output) INTEGER array dimension(N) */ -/* As workspace, this will contain a label which will indicate */ -/* which of the following types a column in the U2 matrix or a */ -/* row in the VT2 matrix is: */ -/* 1 : non-zero in the upper half only */ -/* 2 : non-zero in the lower half only */ -/* 3 : dense */ -/* 4 : deflated */ - -/* On exit, it is an array of dimension 4, with COLTYP(I) being */ -/* the dimension of the I-th type columns. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --z__; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - --dsigma; - u2_dim1 = *ldu2; - u2_offset = 1 + u2_dim1; - u2 -= u2_offset; - vt2_dim1 = *ldvt2; - vt2_offset = 1 + vt2_dim1; - vt2 -= vt2_offset; - --idxp; - --idx; - --idxc; - --idxq; - --coltyp; - - /* Function Body */ - *info = 0; - - if (*nl < 1) { - *info = -1; - } else if (*nr < 1) { - *info = -2; - } else if (*sqre != 1 && *sqre != 0) { - *info = -3; - } - - n = *nl + *nr + 1; - m = n + *sqre; - - if (*ldu < n) { - *info = -10; - } else if (*ldvt < m) { - *info = -12; - } else if (*ldu2 < n) { - *info = -15; - } else if (*ldvt2 < m) { - *info = -17; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASD2", &i__1); - return 0; - } - - nlp1 = *nl + 1; - nlp2 = *nl + 2; - -/* Generate the first part of the vector Z; and move the singular */ -/* values in the first part of D one position backward. */ - - z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1]; - z__[1] = z1; - for (i__ = *nl; i__ >= 1; --i__) { - z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1]; - d__[i__ + 1] = d__[i__]; - idxq[i__ + 1] = idxq[i__] + 1; -/* L10: */ - } - -/* Generate the second part of the vector Z. */ - - i__1 = m; - for (i__ = nlp2; i__ <= i__1; ++i__) { - z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1]; -/* L20: */ - } - -/* Initialize some reference arrays. */ - - i__1 = nlp1; - for (i__ = 2; i__ <= i__1; ++i__) { - coltyp[i__] = 1; -/* L30: */ - } - i__1 = n; - for (i__ = nlp2; i__ <= i__1; ++i__) { - coltyp[i__] = 2; -/* L40: */ - } - -/* Sort the singular values into increasing order */ - - i__1 = n; - for (i__ = nlp2; i__ <= i__1; ++i__) { - idxq[i__] += nlp1; -/* L50: */ - } - -/* DSIGMA, IDXC, IDXC, and the first column of U2 */ -/* are used as storage space. */ - - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - dsigma[i__] = d__[idxq[i__]]; - u2[i__ + u2_dim1] = z__[idxq[i__]]; - idxc[i__] = coltyp[idxq[i__]]; -/* L60: */ - } - - dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]); - - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - idxi = idx[i__] + 1; - d__[i__] = dsigma[idxi]; - z__[i__] = u2[idxi + u2_dim1]; - coltyp[i__] = idxc[idxi]; -/* L70: */ - } - -/* Calculate the allowable deflation tolerance */ - - eps = dlamch_("Epsilon"); -/* Computing MAX */ - d__1 = abs(*alpha), d__2 = abs(*beta); - tol = std::max(d__1,d__2); -/* Computing MAX */ - d__2 = (d__1 = d__[n], abs(d__1)); - tol = eps * 8. * std::max(d__2,tol); - -/* There are 2 kinds of deflation -- first a value in the z-vector */ -/* is small, second two (or more) singular values are very close */ -/* together (their difference is small). */ - -/* If the value in the z-vector is small, we simply permute the */ -/* array so that the corresponding singular value is moved to the */ -/* end. */ - -/* If two values in the D-vector are close, we perform a two-sided */ -/* rotation designed to make one of the corresponding z-vector */ -/* entries zero, and then permute the array so that the deflated */ -/* singular value is moved to the end. */ - -/* If there are multiple singular values then the problem deflates. */ -/* Here the number of equal singular values are found. As each equal */ -/* singular value is found, an elementary reflector is computed to */ -/* rotate the corresponding singular subspace so that the */ -/* corresponding components of Z are zero in this new basis. */ - - *k = 1; - k2 = n + 1; - i__1 = n; - for (j = 2; j <= i__1; ++j) { - if ((d__1 = z__[j], abs(d__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - idxp[k2] = j; - coltyp[j] = 4; - if (j == n) { - goto L120; - } - } else { - jprev = j; - goto L90; - } -/* L80: */ - } -L90: - j = jprev; -L100: - ++j; - if (j > n) { - goto L110; - } - if ((d__1 = z__[j], abs(d__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - idxp[k2] = j; - coltyp[j] = 4; - } else { - -/* Check if singular values are close enough to allow deflation. */ - - if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) { - -/* Deflation is possible. */ - - s = z__[jprev]; - c__ = z__[j]; - -/* Find sqrt(a**2+b**2) without overflow or */ -/* destructive underflow. */ - - tau = dlapy2_(&c__, &s); - c__ /= tau; - s = -s / tau; - z__[j] = tau; - z__[jprev] = 0.; - -/* Apply back the Givens rotation to the left and right */ -/* singular vector matrices. */ - - idxjp = idxq[idx[jprev] + 1]; - idxj = idxq[idx[j] + 1]; - if (idxjp <= nlp1) { - --idxjp; - } - if (idxj <= nlp1) { - --idxj; - } - drot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], & - c__1, &c__, &s); - drot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, & - c__, &s); - if (coltyp[j] != coltyp[jprev]) { - coltyp[j] = 3; - } - coltyp[jprev] = 4; - --k2; - idxp[k2] = jprev; - jprev = j; - } else { - ++(*k); - u2[*k + u2_dim1] = z__[jprev]; - dsigma[*k] = d__[jprev]; - idxp[*k] = jprev; - jprev = j; - } - } - goto L100; -L110: - -/* Record the last singular value. */ - - ++(*k); - u2[*k + u2_dim1] = z__[jprev]; - dsigma[*k] = d__[jprev]; - idxp[*k] = jprev; - -L120: - -/* Count up the total number of the various types of columns, then */ -/* form a permutation which positions the four column types into */ -/* four groups of uniform structure (although one or more of these */ -/* groups may be empty). */ - - for (j = 1; j <= 4; ++j) { - ctot[j - 1] = 0; -/* L130: */ - } - i__1 = n; - for (j = 2; j <= i__1; ++j) { - ct = coltyp[j]; - ++ctot[ct - 1]; -/* L140: */ - } - -/* PSM(*) = Position in SubMatrix (of types 1 through 4) */ - - psm[0] = 2; - psm[1] = ctot[0] + 2; - psm[2] = psm[1] + ctot[1]; - psm[3] = psm[2] + ctot[2]; - -/* Fill out the IDXC array so that the permutation which it induces */ -/* will place all type-1 columns first, all type-2 columns next, */ -/* then all type-3's, and finally all type-4's, starting from the */ -/* second column. This applies similarly to the rows of VT. */ - - i__1 = n; - for (j = 2; j <= i__1; ++j) { - jp = idxp[j]; - ct = coltyp[jp]; - idxc[psm[ct - 1]] = j; - ++psm[ct - 1]; -/* L150: */ - } - -/* Sort the singular values and corresponding singular vectors into */ -/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */ -/* which were not deflated go into the first K slots of DSIGMA, U2, */ -/* and VT2 respectively, while those which were deflated go into the */ -/* last N - K slots, except that the first column/row will be treated */ -/* separately. */ - - i__1 = n; - for (j = 2; j <= i__1; ++j) { - jp = idxp[j]; - dsigma[j] = d__[jp]; - idxj = idxq[idx[idxp[idxc[j]]] + 1]; - if (idxj <= nlp1) { - --idxj; - } - dcopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1); - dcopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2); -/* L160: */ - } - -/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */ - - dsigma[1] = 0.; - hlftol = tol / 2.; - if (abs(dsigma[2]) <= hlftol) { - dsigma[2] = hlftol; - } - if (m > n) { - z__[1] = dlapy2_(&z1, &z__[m]); - if (z__[1] <= tol) { - c__ = 1.; - s = 0.; - z__[1] = tol; - } else { - c__ = z1 / z__[1]; - s = z__[m] / z__[1]; - } - } else { - if (abs(z1) <= tol) { - z__[1] = tol; - } else { - z__[1] = z1; - } - } - -/* Move the rest of the updating row to Z. */ - - i__1 = *k - 1; - dcopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1); - -/* Determine the first column of U2, the first row of VT2 and the */ -/* last row of VT. */ - - dlaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2); - u2[nlp1 + u2_dim1] = 1.; - if (m > n) { - i__1 = nlp1; - for (i__ = 1; i__ <= i__1; ++i__) { - vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1]; - vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1]; -/* L170: */ - } - i__1 = m; - for (i__ = nlp2; i__ <= i__1; ++i__) { - vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1]; - vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1]; -/* L180: */ - } - } else { - dcopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2); - } - if (m > n) { - dcopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2); - } - -/* The deflated singular values and their corresponding vectors go */ -/* into the back of D, U, and V respectively. */ - - if (n > *k) { - i__1 = n - *k; - dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1); - i__1 = n - *k; - dlacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1) - * u_dim1 + 1], ldu); - i__1 = n - *k; - dlacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 + - vt_dim1], ldvt); - } - -/* Copy CTOT into COLTYP for referencing in DLASD3. */ - - for (j = 1; j <= 4; ++j) { - coltyp[j] = ctot[j - 1]; -/* L190: */ - } - - return 0; - -/* End of DLASD2 */ - -} /* dlasd2_ */ diff --git a/external/clapack/lapack/dlasd3.cpp b/external/clapack/lapack/dlasd3.cpp deleted file mode 100644 index 78e66277..00000000 --- a/external/clapack/lapack/dlasd3.cpp +++ /dev/null @@ -1,422 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static double c_b13 = 1.; -static double c_b26 = 0.; - -/* Subroutine */ int dlasd3_(integer *nl, integer *nr, integer *sqre, integer - *k, double *d__, double *q, integer *ldq, double *dsigma, - double *u, integer *ldu, double *u2, integer *ldu2, - double *vt, integer *ldvt, double *vt2, integer *ldvt2, - integer *idxc, integer *ctot, double *z__, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, - vt_offset, vt2_dim1, vt2_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, m, n, jc; - double rho; - integer nlp1, nlp2, nrp1; - double temp; - integer ctemp; - integer ktemp; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASD3 finds all the square roots of the roots of the secular */ -/* equation, as defined by the values in D and Z. It makes the */ -/* appropriate calls to DLASD4 and then updates the singular */ -/* vectors by matrix multiplication. */ - -/* This code makes very mild assumptions about floating point */ -/* arithmetic. It will work on machines with a guard digit in */ -/* add/subtract, or on those binary machines without guard digits */ -/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */ -/* It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* DLASD3 is called from DLASD1. */ - -/* Arguments */ -/* ========= */ - -/* NL (input) INTEGER */ -/* The row dimension of the upper block. NL >= 1. */ - -/* NR (input) INTEGER */ -/* The row dimension of the lower block. NR >= 1. */ - -/* SQRE (input) INTEGER */ -/* = 0: the lower block is an NR-by-NR square matrix. */ -/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ - -/* The bidiagonal matrix has N = NL + NR + 1 rows and */ -/* M = N + SQRE >= N columns. */ - -/* K (input) INTEGER */ -/* The size of the secular equation, 1 =< K = < N. */ - -/* D (output) DOUBLE PRECISION array, dimension(K) */ -/* On exit the square roots of the roots of the secular equation, */ -/* in ascending order. */ - -/* Q (workspace) DOUBLE PRECISION array, */ -/* dimension at least (LDQ,K). */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= K. */ - -/* DSIGMA (input) DOUBLE PRECISION array, dimension(K) */ -/* The first K elements of this array contain the old roots */ -/* of the deflated updating problem. These are the poles */ -/* of the secular equation. */ - -/* U (output) DOUBLE PRECISION array, dimension (LDU, N) */ -/* The last N - K columns of this matrix contain the deflated */ -/* left singular vectors. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= N. */ - -/* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N) */ -/* The first K columns of this matrix contain the non-deflated */ -/* left singular vectors for the split problem. */ - -/* LDU2 (input) INTEGER */ -/* The leading dimension of the array U2. LDU2 >= N. */ - -/* VT (output) DOUBLE PRECISION array, dimension (LDVT, M) */ -/* The last M - K columns of VT' contain the deflated */ -/* right singular vectors. */ - -/* LDVT (input) INTEGER */ -/* The leading dimension of the array VT. LDVT >= N. */ - -/* VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N) */ -/* The first K columns of VT2' contain the non-deflated */ -/* right singular vectors for the split problem. */ - -/* LDVT2 (input) INTEGER */ -/* The leading dimension of the array VT2. LDVT2 >= N. */ - -/* IDXC (input) INTEGER array, dimension ( N ) */ -/* The permutation used to arrange the columns of U (and rows of */ -/* VT) into three groups: the first group contains non-zero */ -/* entries only at and above (or before) NL +1; the second */ -/* contains non-zero entries only at and below (or after) NL+2; */ -/* and the third is dense. The first column of U and the row of */ -/* VT are treated separately, however. */ - -/* The rows of the singular vectors found by DLASD4 */ -/* must be likewise permuted before the matrix multiplies can */ -/* take place. */ - -/* CTOT (input) INTEGER array, dimension ( 4 ) */ -/* A count of the total number of the various types of columns */ -/* in U (or rows in VT), as described in IDXC. The fourth column */ -/* type is any column which has been deflated. */ - -/* Z (input) DOUBLE PRECISION array, dimension (K) */ -/* The first K elements of this array contain the components */ -/* of the deflation-adjusted updating row vector. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an singular value did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --dsigma; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - u2_dim1 = *ldu2; - u2_offset = 1 + u2_dim1; - u2 -= u2_offset; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - vt2_dim1 = *ldvt2; - vt2_offset = 1 + vt2_dim1; - vt2 -= vt2_offset; - --idxc; - --ctot; - --z__; - - /* Function Body */ - *info = 0; - - if (*nl < 1) { - *info = -1; - } else if (*nr < 1) { - *info = -2; - } else if (*sqre != 1 && *sqre != 0) { - *info = -3; - } - - n = *nl + *nr + 1; - m = n + *sqre; - nlp1 = *nl + 1; - nlp2 = *nl + 2; - - if (*k < 1 || *k > n) { - *info = -4; - } else if (*ldq < *k) { - *info = -7; - } else if (*ldu < n) { - *info = -10; - } else if (*ldu2 < n) { - *info = -12; - } else if (*ldvt < m) { - *info = -14; - } else if (*ldvt2 < m) { - *info = -16; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASD3", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*k == 1) { - d__[1] = abs(z__[1]); - dcopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt); - if (z__[1] > 0.) { - dcopy_(&n, &u2[u2_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1); - } else { - i__1 = n; - for (i__ = 1; i__ <= i__1; ++i__) { - u[i__ + u_dim1] = -u2[i__ + u2_dim1]; -/* L10: */ - } - } - return 0; - } - -/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */ -/* be computed with high relative accuracy (barring over/underflow). */ -/* This is a problem on machines without a guard digit in */ -/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ -/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */ -/* which on any of these machines zeros out the bottommost */ -/* bit of DSIGMA(I) if it is 1; this makes the subsequent */ -/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */ -/* occurs. On binary machines with a guard digit (almost all */ -/* machines) it does not change DSIGMA(I) at all. On hexadecimal */ -/* and decimal machines with a guard digit, it slightly */ -/* changes the bottommost bits of DSIGMA(I). It does not account */ -/* for hexadecimal or decimal machines without guard digits */ -/* (we know of none). We use a subroutine call to compute */ -/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */ -/* this code. */ - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; -/* L20: */ - } - -/* Keep a copy of Z. */ - - dcopy_(k, &z__[1], &c__1, &q[q_offset], &c__1); - -/* Normalize Z. */ - - rho = dnrm2_(k, &z__[1], &c__1); - dlascl_("G", &c__0, &c__0, &rho, &c_b13, k, &c__1, &z__[1], k, info); - rho *= rho; - -/* Find the new singular values. */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dlasd4_(k, &j, &dsigma[1], &z__[1], &u[j * u_dim1 + 1], &rho, &d__[j], - &vt[j * vt_dim1 + 1], info); - -/* If the zero finder fails, the computation is terminated. */ - - if (*info != 0) { - return 0; - } -/* L30: */ - } - -/* Compute updated Z. */ - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - z__[i__] = u[i__ + *k * u_dim1] * vt[i__ + *k * vt_dim1]; - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[ - i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]); -/* L40: */ - } - i__2 = *k - 1; - for (j = i__; j <= i__2; ++j) { - z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[ - i__] - dsigma[j + 1]) / (dsigma[i__] + dsigma[j + 1]); -/* L50: */ - } - d__2 = sqrt((d__1 = z__[i__], abs(d__1))); - z__[i__] = d_sign(&d__2, &q[i__ + q_dim1]); -/* L60: */ - } - -/* Compute left singular vectors of the modified diagonal matrix, */ -/* and store related information for the right singular vectors. */ - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - vt[i__ * vt_dim1 + 1] = z__[1] / u[i__ * u_dim1 + 1] / vt[i__ * - vt_dim1 + 1]; - u[i__ * u_dim1 + 1] = -1.; - i__2 = *k; - for (j = 2; j <= i__2; ++j) { - vt[j + i__ * vt_dim1] = z__[j] / u[j + i__ * u_dim1] / vt[j + i__ - * vt_dim1]; - u[j + i__ * u_dim1] = dsigma[j] * vt[j + i__ * vt_dim1]; -/* L70: */ - } - temp = dnrm2_(k, &u[i__ * u_dim1 + 1], &c__1); - q[i__ * q_dim1 + 1] = u[i__ * u_dim1 + 1] / temp; - i__2 = *k; - for (j = 2; j <= i__2; ++j) { - jc = idxc[j]; - q[j + i__ * q_dim1] = u[jc + i__ * u_dim1] / temp; -/* L80: */ - } -/* L90: */ - } - -/* Update the left singular vector matrix. */ - - if (*k == 2) { - dgemm_("N", "N", &n, k, k, &c_b13, &u2[u2_offset], ldu2, &q[q_offset], - ldq, &c_b26, &u[u_offset], ldu); - goto L100; - } - if (ctot[1] > 0) { - dgemm_("N", "N", nl, k, &ctot[1], &c_b13, &u2[(u2_dim1 << 1) + 1], - ldu2, &q[q_dim1 + 2], ldq, &c_b26, &u[u_dim1 + 1], ldu); - if (ctot[3] > 0) { - ktemp = ctot[1] + 2 + ctot[2]; - dgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1] -, ldu2, &q[ktemp + q_dim1], ldq, &c_b13, &u[u_dim1 + 1], - ldu); - } - } else if (ctot[3] > 0) { - ktemp = ctot[1] + 2 + ctot[2]; - dgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1], - ldu2, &q[ktemp + q_dim1], ldq, &c_b26, &u[u_dim1 + 1], ldu); - } else { - dlacpy_("F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu); - } - dcopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu); - ktemp = ctot[1] + 2; - ctemp = ctot[2] + ctot[3]; - dgemm_("N", "N", nr, k, &ctemp, &c_b13, &u2[nlp2 + ktemp * u2_dim1], ldu2, - &q[ktemp + q_dim1], ldq, &c_b26, &u[nlp2 + u_dim1], ldu); - -/* Generate the right singular vectors. */ - -L100: - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = dnrm2_(k, &vt[i__ * vt_dim1 + 1], &c__1); - q[i__ + q_dim1] = vt[i__ * vt_dim1 + 1] / temp; - i__2 = *k; - for (j = 2; j <= i__2; ++j) { - jc = idxc[j]; - q[i__ + j * q_dim1] = vt[jc + i__ * vt_dim1] / temp; -/* L110: */ - } -/* L120: */ - } - -/* Update the right singular vector matrix. */ - - if (*k == 2) { - dgemm_("N", "N", k, &m, k, &c_b13, &q[q_offset], ldq, &vt2[vt2_offset] -, ldvt2, &c_b26, &vt[vt_offset], ldvt); - return 0; - } - ktemp = ctot[1] + 1; - dgemm_("N", "N", k, &nlp1, &ktemp, &c_b13, &q[q_dim1 + 1], ldq, &vt2[ - vt2_dim1 + 1], ldvt2, &c_b26, &vt[vt_dim1 + 1], ldvt); - ktemp = ctot[1] + 2 + ctot[2]; - if (ktemp <= *ldvt2) { - dgemm_("N", "N", k, &nlp1, &ctot[3], &c_b13, &q[ktemp * q_dim1 + 1], - ldq, &vt2[ktemp + vt2_dim1], ldvt2, &c_b13, &vt[vt_dim1 + 1], - ldvt); - } - - ktemp = ctot[1] + 1; - nrp1 = *nr + *sqre; - if (ktemp > 1) { - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - q[i__ + ktemp * q_dim1] = q[i__ + q_dim1]; -/* L130: */ - } - i__1 = m; - for (i__ = nlp2; i__ <= i__1; ++i__) { - vt2[ktemp + i__ * vt2_dim1] = vt2[i__ * vt2_dim1 + 1]; -/* L140: */ - } - } - ctemp = ctot[2] + 1 + ctot[3]; - dgemm_("N", "N", k, &nrp1, &ctemp, &c_b13, &q[ktemp * q_dim1 + 1], ldq, & - vt2[ktemp + nlp2 * vt2_dim1], ldvt2, &c_b26, &vt[nlp2 * vt_dim1 + - 1], ldvt); - - return 0; - -/* End of DLASD3 */ - -} /* dlasd3_ */ diff --git a/external/clapack/lapack/dlasd4.cpp b/external/clapack/lapack/dlasd4.cpp deleted file mode 100644 index 073d5e55..00000000 --- a/external/clapack/lapack/dlasd4.cpp +++ /dev/null @@ -1,993 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlasd4_(integer *n, integer *i__, double *d__, - double *z__, double *delta, double *rho, double * - sigma, double *work, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - double a, b, c__; - integer j; - double w, dd[3]; - integer ii; - double dw, zz[3]; - integer ip1; - double eta, phi, eps, tau, psi; - integer iim1, iip1; - double dphi, dpsi; - integer iter; - double temp, prew, sg2lb, sg2ub, temp1, temp2, dtiim, delsq, dtiip; - integer niter; - double dtisq; - bool swtch; - double dtnsq; - double delsq2, dtnsq1; - bool swtch3; - bool orgati; - double erretm, dtipsq, rhoinv; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This subroutine computes the square root of the I-th updated */ -/* eigenvalue of a positive symmetric rank-one modification to */ -/* a positive diagonal matrix whose entries are given as the squares */ -/* of the corresponding entries in the array d, and that */ - -/* 0 <= D(i) < D(j) for i < j */ - -/* and that RHO > 0. This is arranged by the calling routine, and is */ -/* no loss in generality. The rank-one modified system is thus */ - -/* diag( D ) * diag( D ) + RHO * Z * Z_transpose. */ - -/* where we assume the Euclidean norm of Z is 1. */ - -/* The method consists of approximating the rational functions in the */ -/* secular equation by simpler interpolating rational functions. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The length of all arrays. */ - -/* I (input) INTEGER */ -/* The index of the eigenvalue to be computed. 1 <= I <= N. */ - -/* D (input) DOUBLE PRECISION array, dimension ( N ) */ -/* The original eigenvalues. It is assumed that they are in */ -/* order, 0 <= D(I) < D(J) for I < J. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( N ) */ -/* The components of the updating vector. */ - -/* DELTA (output) DOUBLE PRECISION array, dimension ( N ) */ -/* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th */ -/* component. If N = 1, then DELTA(1) = 1. The vector DELTA */ -/* contains the information necessary to construct the */ -/* (singular) eigenvectors. */ - -/* RHO (input) DOUBLE PRECISION */ -/* The scalar in the symmetric updating formula. */ - -/* SIGMA (output) DOUBLE PRECISION */ -/* The computed sigma_I, the I-th updated eigenvalue. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension ( N ) */ -/* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th */ -/* component. If N = 1, then WORK( 1 ) = 1. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* > 0: if INFO = 1, the updating process failed. */ - -/* Internal Parameters */ -/* =================== */ - -/* Logical variable ORGATI (origin-at-i?) is used for distinguishing */ -/* whether D(i) or D(i+1) is treated as the origin. */ - -/* ORGATI = .true. origin at i */ -/* ORGATI = .false. origin at i+1 */ - -/* Logical variable SWTCH3 (switch-for-3-poles?) is for noting */ -/* if we are working with THREE poles! */ - -/* MAXIT is the maximum number of iterations allowed for each */ -/* eigenvalue. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ren-Cang Li, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Since this routine is called in an inner loop, we do no argument */ -/* checking. */ - -/* Quick return for N=1 and 2. */ - - /* Parameter adjustments */ - --work; - --delta; - --z__; - --d__; - - /* Function Body */ - *info = 0; - if (*n == 1) { - -/* Presumably, I=1 upon entry */ - - *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]); - delta[1] = 1.; - work[1] = 1.; - return 0; - } - if (*n == 2) { - dlasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]); - return 0; - } - -/* Compute machine epsilon */ - - eps = dlamch_("Epsilon"); - rhoinv = 1. / *rho; - -/* The case I = N */ - - if (*i__ == *n) { - -/* Initialize some basic variables */ - - ii = *n - 1; - niter = 1; - -/* Calculate initial guess */ - - temp = *rho / 2.; - -/* If ||Z||_2 is not one, then TEMP should be set to */ -/* RHO * ||Z||_2^2 / TWO */ - - temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp)); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*n] + temp1; - delta[j] = d__[j] - d__[*n] - temp1; -/* L10: */ - } - - psi = 0.; - i__1 = *n - 2; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / (delta[j] * work[j]); -/* L20: */ - } - - c__ = rhoinv + psi; - w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[* - n] / (delta[*n] * work[*n]); - - if (w <= 0.) { - temp1 = sqrt(d__[*n] * d__[*n] + *rho); - temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[* - n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] * - z__[*n] / *rho; - -/* The following TAU is to approximate */ -/* SIGMA_n^2 - D( N )*D( N ) */ - - if (c__ <= temp) { - tau = *rho; - } else { - delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); - a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[* - n]; - b = z__[*n] * z__[*n] * delsq; - if (a < 0.) { - tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); - } - } - -/* It can be proved that */ -/* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO */ - - } else { - delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); - a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; - b = z__[*n] * z__[*n] * delsq; - -/* The following TAU is to approximate */ -/* SIGMA_n^2 - D( N )*D( N ) */ - - if (a < 0.) { - tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); - } else { - tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); - } - -/* It can be proved that */ -/* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 */ - - } - -/* The following ETA is to approximate SIGMA_n - D( N ) */ - - eta = tau / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau)); - - *sigma = d__[*n] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] = d__[j] - d__[*i__] - eta; - work[j] = d__[j] + d__[*i__] + eta; -/* L30: */ - } - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (delta[j] * work[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L40: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / (delta[*n] * work[*n]); - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi - + dphi); - - w = rhoinv + phi + psi; - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - goto L240; - } - -/* Calculate the new step */ - - ++niter; - dtnsq1 = work[*n - 1] * delta[*n - 1]; - dtnsq = work[*n] * delta[*n]; - c__ = w - dtnsq1 * dpsi - dtnsq * dphi; - a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi); - b = dtnsq * dtnsq1 * w; - if (c__ < 0.) { - c__ = abs(c__); - } - if (c__ == 0.) { - eta = *rho - *sigma * *sigma; - } else if (a >= 0.) { - eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ - * 2.); - } else { - eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) - ); - } - -/* Note, eta should be positive if w is negative, and */ -/* eta should be negative otherwise. However, */ -/* if for some reason caused by roundoff, eta*w > 0, */ -/* we simply use one Newton step instead. This way */ -/* will guarantee eta*w < 0. */ - - if (w * eta > 0.) { - eta = -w / (dpsi + dphi); - } - temp = eta - dtnsq; - if (temp > *rho) { - eta = *rho + dtnsq; - } - - tau += eta; - eta /= *sigma + sqrt(eta + *sigma * *sigma); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; - work[j] += eta; -/* L50: */ - } - - *sigma += eta; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L60: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / (work[*n] * delta[*n]); - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi - + dphi); - - w = rhoinv + phi + psi; - -/* Main loop to update the values of the array DELTA */ - - iter = niter + 1; - - for (niter = iter; niter <= 20; ++niter) { - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - goto L240; - } - -/* Calculate the new step */ - - dtnsq1 = work[*n - 1] * delta[*n - 1]; - dtnsq = work[*n] * delta[*n]; - c__ = w - dtnsq1 * dpsi - dtnsq * dphi; - a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi); - b = dtnsq1 * dtnsq * w; - if (a >= 0.) { - eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } - -/* Note, eta should be positive if w is negative, and */ -/* eta should be negative otherwise. However, */ -/* if for some reason caused by roundoff, eta*w > 0, */ -/* we simply use one Newton step instead. This way */ -/* will guarantee eta*w < 0. */ - - if (w * eta > 0.) { - eta = -w / (dpsi + dphi); - } - temp = eta - dtnsq; - if (temp <= 0.) { - eta /= 2.; - } - - tau += eta; - eta /= *sigma + sqrt(eta + *sigma * *sigma); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - delta[j] -= eta; - work[j] += eta; -/* L70: */ - } - - *sigma += eta; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = ii; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L80: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - temp = z__[*n] / (work[*n] * delta[*n]); - phi = z__[*n] * temp; - dphi = temp * temp; - erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * ( - dpsi + dphi); - - w = rhoinv + phi + psi; -/* L90: */ - } - -/* Return with INFO = 1, NITER = MAXIT and not converged */ - - *info = 1; - goto L240; - -/* End for the case I = N */ - - } else { - -/* The case for I < N */ - - niter = 1; - ip1 = *i__ + 1; - -/* Calculate initial guess */ - - delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]); - delsq2 = delsq / 2.; - temp = delsq2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + delsq2)); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*i__] + temp; - delta[j] = d__[j] - d__[*i__] - temp; -/* L100: */ - } - - psi = 0.; - i__1 = *i__ - 1; - for (j = 1; j <= i__1; ++j) { - psi += z__[j] * z__[j] / (work[j] * delta[j]); -/* L110: */ - } - - phi = 0.; - i__1 = *i__ + 2; - for (j = *n; j >= i__1; --j) { - phi += z__[j] * z__[j] / (work[j] * delta[j]); -/* L120: */ - } - c__ = rhoinv + psi + phi; - w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[ - ip1] * z__[ip1] / (work[ip1] * delta[ip1]); - - if (w > 0.) { - -/* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 */ - -/* We choose d(i) as origin. */ - - orgati = true; - sg2lb = 0.; - sg2ub = delsq2; - a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; - b = z__[*i__] * z__[*i__] * delsq; - if (a > 0.) { - tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } else { - tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } - -/* TAU now is an estimation of SIGMA^2 - D( I )^2. The */ -/* following, however, is the corresponding estimation of */ -/* SIGMA - D( I ). */ - - eta = tau / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau)); - } else { - -/* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 */ - -/* We choose d(i+1) as origin. */ - - orgati = false; - sg2lb = -delsq2; - sg2ub = 0.; - a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; - b = z__[ip1] * z__[ip1] * delsq; - if (a < 0.) { - tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( - d__1)))); - } else { - tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / - (c__ * 2.); - } - -/* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The */ -/* following, however, is the corresponding estimation of */ -/* SIGMA - D( IP1 ). */ - - eta = tau / (d__[ip1] + sqrt((d__1 = d__[ip1] * d__[ip1] + tau, - abs(d__1)))); - } - - if (orgati) { - ii = *i__; - *sigma = d__[*i__] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[*i__] + eta; - delta[j] = d__[j] - d__[*i__] - eta; -/* L130: */ - } - } else { - ii = *i__ + 1; - *sigma = d__[ip1] + eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] = d__[j] + d__[ip1] + eta; - delta[j] = d__[j] - d__[ip1] - eta; -/* L140: */ - } - } - iim1 = ii - 1; - iip1 = ii + 1; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L150: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L160: */ - } - - w = rhoinv + phi + psi; - -/* W is the value of the secular function with */ -/* its ii-th element removed. */ - - swtch3 = false; - if (orgati) { - if (w < 0.) { - swtch3 = true; - } - } else { - if (w > 0.) { - swtch3 = true; - } - } - if (ii == 1 || ii == *n) { - swtch3 = false; - } - - temp = z__[ii] / (work[ii] * delta[ii]); - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w += temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + - abs(tau) * dw; - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - goto L240; - } - - if (w <= 0.) { - sg2lb = std::max(sg2lb,tau); - } else { - sg2ub = std::min(sg2ub,tau); - } - -/* Calculate the new step */ - - ++niter; - if (! swtch3) { - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (orgati) { -/* Computing 2nd power */ - d__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (d__1 * d__1); - } else { -/* Computing 2nd power */ - d__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (d__1 * d__1); - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.) { - if (a == 0.) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + - dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + - dphi); - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( - c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( - d__1)))); - } - } else { - -/* Interpolation using THREE most relevant poles */ - - dtiim = work[iim1] * delta[iim1]; - dtiip = work[iip1] * delta[iip1]; - temp = rhoinv + psi + phi; - if (orgati) { - temp1 = z__[iim1] / dtiim; - temp1 *= temp1; - c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * - (d__[iim1] + d__[iip1]) * temp1; - zz[0] = z__[iim1] * z__[iim1]; - if (dpsi < temp1) { - zz[2] = dtiip * dtiip * dphi; - } else { - zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); - } - } else { - temp1 = z__[iip1] / dtiip; - temp1 *= temp1; - c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * - (d__[iim1] + d__[iip1]) * temp1; - if (dphi < temp1) { - zz[0] = dtiim * dtiim * dpsi; - } else { - zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); - } - zz[2] = z__[iip1] * z__[iip1]; - } - zz[1] = z__[ii] * z__[ii]; - dd[0] = dtiim; - dd[1] = delta[ii] * work[ii]; - dd[2] = dtiip; - dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); - if (*info != 0) { - goto L240; - } - } - -/* Note, eta should be positive if w is negative, and */ -/* eta should be negative otherwise. However, */ -/* if for some reason caused by roundoff, eta*w > 0, */ -/* we simply use one Newton step instead. This way */ -/* will guarantee eta*w < 0. */ - - if (w * eta >= 0.) { - eta = -w / dw; - } - if (orgati) { - temp1 = work[*i__] * delta[*i__]; - temp = eta - temp1; - } else { - temp1 = work[ip1] * delta[ip1]; - temp = eta - temp1; - } - if (temp > sg2ub || temp < sg2lb) { - if (w < 0.) { - eta = (sg2ub - tau) / 2.; - } else { - eta = (sg2lb - tau) / 2.; - } - } - - tau += eta; - eta /= *sigma + sqrt(*sigma * *sigma + eta); - - prew = w; - - *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += eta; - delta[j] -= eta; -/* L170: */ - } - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L180: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L190: */ - } - - temp = z__[ii] / (work[ii] * delta[ii]); - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + - abs(tau) * dw; - - if (w <= 0.) { - sg2lb = std::max(sg2lb,tau); - } else { - sg2ub = std::min(sg2ub,tau); - } - - swtch = false; - if (orgati) { - if (-w > abs(prew) / 10.) { - swtch = true; - } - } else { - if (w > abs(prew) / 10.) { - swtch = true; - } - } - -/* Main loop to update the values of the array DELTA and WORK */ - - iter = niter + 1; - - for (niter = iter; niter <= 20; ++niter) { - -/* Test for convergence */ - - if (abs(w) <= eps * erretm) { - goto L240; - } - -/* Calculate the new step */ - - if (! swtch3) { - dtipsq = work[ip1] * delta[ip1]; - dtisq = work[*i__] * delta[*i__]; - if (! swtch) { - if (orgati) { -/* Computing 2nd power */ - d__1 = z__[*i__] / dtisq; - c__ = w - dtipsq * dw + delsq * (d__1 * d__1); - } else { -/* Computing 2nd power */ - d__1 = z__[ip1] / dtipsq; - c__ = w - dtisq * dw - delsq * (d__1 * d__1); - } - } else { - temp = z__[ii] / (work[ii] * delta[ii]); - if (orgati) { - dpsi += temp * temp; - } else { - dphi += temp * temp; - } - c__ = w - dtisq * dpsi - dtipsq * dphi; - } - a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; - b = dtipsq * dtisq * w; - if (c__ == 0.) { - if (a == 0.) { - if (! swtch) { - if (orgati) { - a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * - (dpsi + dphi); - } else { - a = z__[ip1] * z__[ip1] + dtisq * dtisq * ( - dpsi + dphi); - } - } else { - a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi; - } - } - eta = b / a; - } else if (a <= 0.) { - eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) - / (c__ * 2.); - } else { - eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, - abs(d__1)))); - } - } else { - -/* Interpolation using THREE most relevant poles */ - - dtiim = work[iim1] * delta[iim1]; - dtiip = work[iip1] * delta[iip1]; - temp = rhoinv + psi + phi; - if (swtch) { - c__ = temp - dtiim * dpsi - dtiip * dphi; - zz[0] = dtiim * dtiim * dpsi; - zz[2] = dtiip * dtiip * dphi; - } else { - if (orgati) { - temp1 = z__[iim1] / dtiim; - temp1 *= temp1; - temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[ - iip1]) * temp1; - c__ = temp - dtiip * (dpsi + dphi) - temp2; - zz[0] = z__[iim1] * z__[iim1]; - if (dpsi < temp1) { - zz[2] = dtiip * dtiip * dphi; - } else { - zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); - } - } else { - temp1 = z__[iip1] / dtiip; - temp1 *= temp1; - temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[ - iip1]) * temp1; - c__ = temp - dtiim * (dpsi + dphi) - temp2; - if (dphi < temp1) { - zz[0] = dtiim * dtiim * dpsi; - } else { - zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); - } - zz[2] = z__[iip1] * z__[iip1]; - } - } - dd[0] = dtiim; - dd[1] = delta[ii] * work[ii]; - dd[2] = dtiip; - dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); - if (*info != 0) { - goto L240; - } - } - -/* Note, eta should be positive if w is negative, and */ -/* eta should be negative otherwise. However, */ -/* if for some reason caused by roundoff, eta*w > 0, */ -/* we simply use one Newton step instead. This way */ -/* will guarantee eta*w < 0. */ - - if (w * eta >= 0.) { - eta = -w / dw; - } - if (orgati) { - temp1 = work[*i__] * delta[*i__]; - temp = eta - temp1; - } else { - temp1 = work[ip1] * delta[ip1]; - temp = eta - temp1; - } - if (temp > sg2ub || temp < sg2lb) { - if (w < 0.) { - eta = (sg2ub - tau) / 2.; - } else { - eta = (sg2lb - tau) / 2.; - } - } - - tau += eta; - eta /= *sigma + sqrt(*sigma * *sigma + eta); - - *sigma += eta; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += eta; - delta[j] -= eta; -/* L200: */ - } - - prew = w; - -/* Evaluate PSI and the derivative DPSI */ - - dpsi = 0.; - psi = 0.; - erretm = 0.; - i__1 = iim1; - for (j = 1; j <= i__1; ++j) { - temp = z__[j] / (work[j] * delta[j]); - psi += z__[j] * temp; - dpsi += temp * temp; - erretm += psi; -/* L210: */ - } - erretm = abs(erretm); - -/* Evaluate PHI and the derivative DPHI */ - - dphi = 0.; - phi = 0.; - i__1 = iip1; - for (j = *n; j >= i__1; --j) { - temp = z__[j] / (work[j] * delta[j]); - phi += z__[j] * temp; - dphi += temp * temp; - erretm += phi; -/* L220: */ - } - - temp = z__[ii] / (work[ii] * delta[ii]); - dw = dpsi + dphi + temp * temp; - temp = z__[ii] * temp; - w = rhoinv + phi + psi + temp; - erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. - + abs(tau) * dw; - if (w * prew > 0. && abs(w) > abs(prew) / 10.) { - swtch = ! swtch; - } - - if (w <= 0.) { - sg2lb = std::max(sg2lb,tau); - } else { - sg2ub = std::min(sg2ub,tau); - } - -/* L230: */ - } - -/* Return with INFO = 1, NITER = MAXIT and not converged */ - - *info = 1; - - } - -L240: - return 0; - -/* End of DLASD4 */ - -} /* dlasd4_ */ diff --git a/external/clapack/lapack/dlasd5.cpp b/external/clapack/lapack/dlasd5.cpp deleted file mode 100644 index 523e768f..00000000 --- a/external/clapack/lapack/dlasd5.cpp +++ /dev/null @@ -1,177 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlasd5_(integer *i__, double *d__, double *z__, - double *delta, double *rho, double *dsigma, double * - work) -{ - /* System generated locals */ - double d__1; - - /* Builtin functions - double sqrt(double); */ - - /* Local variables */ - double b, c__, w, del, tau, delsq; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This subroutine computes the square root of the I-th eigenvalue */ -/* of a positive symmetric rank-one modification of a 2-by-2 diagonal */ -/* matrix */ - -/* diag( D ) * diag( D ) + RHO * Z * transpose(Z) . */ - -/* The diagonal entries in the array D are assumed to satisfy */ - -/* 0 <= D(i) < D(j) for i < j . */ - -/* We also assume RHO > 0 and that the Euclidean norm of the vector */ -/* Z is one. */ - -/* Arguments */ -/* ========= */ - -/* I (input) INTEGER */ -/* The index of the eigenvalue to be computed. I = 1 or I = 2. */ - -/* D (input) DOUBLE PRECISION array, dimension ( 2 ) */ -/* The original eigenvalues. We assume 0 <= D(1) < D(2). */ - -/* Z (input) DOUBLE PRECISION array, dimension ( 2 ) */ -/* The components of the updating vector. */ - -/* DELTA (output) DOUBLE PRECISION array, dimension ( 2 ) */ -/* Contains (D(j) - sigma_I) in its j-th component. */ -/* The vector DELTA contains the information necessary */ -/* to construct the eigenvectors. */ - -/* RHO (input) DOUBLE PRECISION */ -/* The scalar in the symmetric updating formula. */ - -/* DSIGMA (output) DOUBLE PRECISION */ -/* The computed sigma_I, the I-th updated eigenvalue. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 ) */ -/* WORK contains (D(j) + sigma_I) in its j-th component. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ren-Cang Li, Computer Science Division, University of California */ -/* at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --work; - --delta; - --z__; - --d__; - - /* Function Body */ - del = d__[2] - d__[1]; - delsq = del * (d__[2] + d__[1]); - if (*i__ == 1) { - w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] * - z__[1] / (d__[1] * 3. + d__[2])) / del + 1.; - if (w > 0.) { - b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[1] * z__[1] * delsq; - -/* B > ZERO, always */ - -/* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */ - - tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); - -/* The following TAU is DSIGMA - D( 1 ) */ - - tau /= d__[1] + sqrt(d__[1] * d__[1] + tau); - *dsigma = d__[1] + tau; - delta[1] = -tau; - delta[2] = del - tau; - work[1] = d__[1] * 2. + tau; - work[2] = d__[1] + tau + d__[2]; -/* DELTA( 1 ) = -Z( 1 ) / TAU */ -/* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */ - } else { - b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[2] * z__[2] * delsq; - -/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ - - if (b > 0.) { - tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); - } else { - tau = (b - sqrt(b * b + c__ * 4.)) / 2.; - } - -/* The following TAU is DSIGMA - D( 2 ) */ - - tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1))); - *dsigma = d__[2] + tau; - delta[1] = -(del + tau); - delta[2] = -tau; - work[1] = d__[1] + tau + d__[2]; - work[2] = d__[2] * 2. + tau; -/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ -/* DELTA( 2 ) = -Z( 2 ) / TAU */ - } -/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ -/* DELTA( 1 ) = DELTA( 1 ) / TEMP */ -/* DELTA( 2 ) = DELTA( 2 ) / TEMP */ - } else { - -/* Now I=2 */ - - b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); - c__ = *rho * z__[2] * z__[2] * delsq; - -/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ - - if (b > 0.) { - tau = (b + sqrt(b * b + c__ * 4.)) / 2.; - } else { - tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); - } - -/* The following TAU is DSIGMA - D( 2 ) */ - - tau /= d__[2] + sqrt(d__[2] * d__[2] + tau); - *dsigma = d__[2] + tau; - delta[1] = -(del + tau); - delta[2] = -tau; - work[1] = d__[1] + tau + d__[2]; - work[2] = d__[2] * 2. + tau; -/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ -/* DELTA( 2 ) = -Z( 2 ) / TAU */ -/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ -/* DELTA( 1 ) = DELTA( 1 ) / TEMP */ -/* DELTA( 2 ) = DELTA( 2 ) / TEMP */ - } - return 0; - -/* End of DLASD5 */ - -} /* dlasd5_ */ diff --git a/external/clapack/lapack/dlasd6.cpp b/external/clapack/lapack/dlasd6.cpp deleted file mode 100644 index 04b95853..00000000 --- a/external/clapack/lapack/dlasd6.cpp +++ /dev/null @@ -1,341 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__0 = 0; -static double c_b7 = 1.; -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr, - integer *sqre, double *d__, double *vf, double *vl, - double *alpha, double *beta, integer *idxq, integer *perm, - integer *givptr, integer *givcol, integer *ldgcol, double *givnum, - integer *ldgnum, double *poles, double *difl, double * - difr, double *z__, integer *k, double *c__, double *s, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, - poles_dim1, poles_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw; - integer isigma; - double orgnrm; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASD6 computes the SVD of an updated upper bidiagonal matrix B */ -/* obtained by merging two smaller ones by appending a row. This */ -/* routine is used only for the problem which requires all singular */ -/* values and optionally singular vector matrices in factored form. */ -/* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. */ -/* A related subroutine, DLASD1, handles the case in which all singular */ -/* values and singular vectors of the bidiagonal matrix are desired. */ - -/* DLASD6 computes the SVD as follows: */ - -/* ( D1(in) 0 0 0 ) */ -/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */ -/* ( 0 0 D2(in) 0 ) */ - -/* = U(out) * ( D(out) 0) * VT(out) */ - -/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */ -/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */ -/* elsewhere; and the entry b is empty if SQRE = 0. */ - -/* The singular values of B can be computed using D1, D2, the first */ -/* components of all the right singular vectors of the lower block, and */ -/* the last components of all the right singular vectors of the upper */ -/* block. These components are stored and updated in VF and VL, */ -/* respectively, in DLASD6. Hence U and VT are not explicitly */ -/* referenced. */ - -/* The singular values are stored in D. The algorithm consists of two */ -/* stages: */ - -/* The first stage consists of deflating the size of the problem */ -/* when there are multiple singular values or if there is a zero */ -/* in the Z vector. For each such occurence the dimension of the */ -/* secular equation problem is reduced by one. This stage is */ -/* performed by the routine DLASD7. */ - -/* The second stage consists of calculating the updated */ -/* singular values. This is done by finding the roots of the */ -/* secular equation via the routine DLASD4 (as called by DLASD8). */ -/* This routine also updates VF and VL and computes the distances */ -/* between the updated singular values and the old singular */ -/* values. */ - -/* DLASD6 is called from DLASDA. */ - -/* Arguments */ -/* ========= */ - -/* ICOMPQ (input) INTEGER */ -/* Specifies whether singular vectors are to be computed in */ -/* factored form: */ -/* = 0: Compute singular values only. */ -/* = 1: Compute singular vectors in factored form as well. */ - -/* NL (input) INTEGER */ -/* The row dimension of the upper block. NL >= 1. */ - -/* NR (input) INTEGER */ -/* The row dimension of the lower block. NR >= 1. */ - -/* SQRE (input) INTEGER */ -/* = 0: the lower block is an NR-by-NR square matrix. */ -/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ - -/* The bidiagonal matrix has row dimension N = NL + NR + 1, */ -/* and column dimension M = N + SQRE. */ - -/* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ). */ -/* On entry D(1:NL,1:NL) contains the singular values of the */ -/* upper block, and D(NL+2:N) contains the singular values */ -/* of the lower block. On exit D(1:N) contains the singular */ -/* values of the modified matrix. */ - -/* VF (input/output) DOUBLE PRECISION array, dimension ( M ) */ -/* On entry, VF(1:NL+1) contains the first components of all */ -/* right singular vectors of the upper block; and VF(NL+2:M) */ -/* contains the first components of all right singular vectors */ -/* of the lower block. On exit, VF contains the first components */ -/* of all right singular vectors of the bidiagonal matrix. */ - -/* VL (input/output) DOUBLE PRECISION array, dimension ( M ) */ -/* On entry, VL(1:NL+1) contains the last components of all */ -/* right singular vectors of the upper block; and VL(NL+2:M) */ -/* contains the last components of all right singular vectors of */ -/* the lower block. On exit, VL contains the last components of */ -/* all right singular vectors of the bidiagonal matrix. */ - -/* ALPHA (input/output) DOUBLE PRECISION */ -/* Contains the diagonal element associated with the added row. */ - -/* BETA (input/output) DOUBLE PRECISION */ -/* Contains the off-diagonal element associated with the added */ -/* row. */ - -/* IDXQ (output) INTEGER array, dimension ( N ) */ -/* This contains the permutation which will reintegrate the */ -/* subproblem just solved back into sorted order, i.e. */ -/* D( IDXQ( I = 1, N ) ) will be in ascending order. */ - -/* PERM (output) INTEGER array, dimension ( N ) */ -/* The permutations (from deflation and sorting) to be applied */ -/* to each block. Not referenced if ICOMPQ = 0. */ - -/* GIVPTR (output) INTEGER */ -/* The number of Givens rotations which took place in this */ -/* subproblem. Not referenced if ICOMPQ = 0. */ - -/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */ -/* Each pair of numbers indicates a pair of columns to take place */ -/* in a Givens rotation. Not referenced if ICOMPQ = 0. */ - -/* LDGCOL (input) INTEGER */ -/* leading dimension of GIVCOL, must be at least N. */ - -/* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ -/* Each number indicates the C or S value to be used in the */ -/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */ - -/* LDGNUM (input) INTEGER */ -/* The leading dimension of GIVNUM and POLES, must be at least N. */ - -/* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ -/* On exit, POLES(1,*) is an array containing the new singular */ -/* values obtained from solving the secular equation, and */ -/* POLES(2,*) is an array containing the poles in the secular */ -/* equation. Not referenced if ICOMPQ = 0. */ - -/* DIFL (output) DOUBLE PRECISION array, dimension ( N ) */ -/* On exit, DIFL(I) is the distance between I-th updated */ -/* (undeflated) singular value and the I-th (undeflated) old */ -/* singular value. */ - -/* DIFR (output) DOUBLE PRECISION array, */ -/* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and */ -/* dimension ( N ) if ICOMPQ = 0. */ -/* On exit, DIFR(I, 1) is the distance between I-th updated */ -/* (undeflated) singular value and the I+1-th (undeflated) old */ -/* singular value. */ - -/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */ -/* normalizing factors for the right singular vector matrix. */ - -/* See DLASD8 for details on DIFL and DIFR. */ - -/* Z (output) DOUBLE PRECISION array, dimension ( M ) */ -/* The first elements of this array contain the components */ -/* of the deflation-adjusted updating row vector. */ - -/* K (output) INTEGER */ -/* Contains the dimension of the non-deflated matrix, */ -/* This is the order of the related secular equation. 1 <= K <=N. */ - -/* C (output) DOUBLE PRECISION */ -/* C contains garbage if SQRE =0 and the C-value of a Givens */ -/* rotation related to the right null space if SQRE = 1. */ - -/* S (output) DOUBLE PRECISION */ -/* S contains garbage if SQRE =0 and the S-value of a Givens */ -/* rotation related to the right null space if SQRE = 1. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M ) */ - -/* IWORK (workspace) INTEGER array, dimension ( 3 * N ) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an singular value did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --vf; - --vl; - --idxq; - --perm; - givcol_dim1 = *ldgcol; - givcol_offset = 1 + givcol_dim1; - givcol -= givcol_offset; - poles_dim1 = *ldgnum; - poles_offset = 1 + poles_dim1; - poles -= poles_offset; - givnum_dim1 = *ldgnum; - givnum_offset = 1 + givnum_dim1; - givnum -= givnum_offset; - --difl; - --difr; - --z__; - --work; - --iwork; - - /* Function Body */ - *info = 0; - n = *nl + *nr + 1; - m = n + *sqre; - - if (*icompq < 0 || *icompq > 1) { - *info = -1; - } else if (*nl < 1) { - *info = -2; - } else if (*nr < 1) { - *info = -3; - } else if (*sqre < 0 || *sqre > 1) { - *info = -4; - } else if (*ldgcol < n) { - *info = -14; - } else if (*ldgnum < n) { - *info = -16; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASD6", &i__1); - return 0; - } - -/* The following values are for bookkeeping purposes only. They are */ -/* integer pointers which indicate the portion of the workspace */ -/* used by a particular array in DLASD7 and DLASD8. */ - - isigma = 1; - iw = isigma + n; - ivfw = iw + m; - ivlw = ivfw + m; - - idx = 1; - idxc = idx + n; - idxp = idxc + n; - -/* Scale. */ - -/* Computing MAX */ - d__1 = abs(*alpha), d__2 = abs(*beta); - orgnrm = std::max(d__1,d__2); - d__[*nl + 1] = 0.; - i__1 = n; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = d__[i__], abs(d__1)) > orgnrm) { - orgnrm = (d__1 = d__[i__], abs(d__1)); - } -/* L10: */ - } - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info); - *alpha /= orgnrm; - *beta /= orgnrm; - -/* Sort and Deflate singular values. */ - - dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], & - work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], & - iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[ - givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s, - info); - -/* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */ - - dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1], - ldgnum, &work[isigma], &work[iw], info); - -/* Save the poles if ICOMPQ = 1. */ - - if (*icompq == 1) { - dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1); - dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1); - } - -/* Unscale. */ - - dlascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info); - -/* Prepare the IDXQ sorting permutation. */ - - n1 = *k; - n2 = n - *k; - dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]); - - return 0; - -/* End of DLASD6 */ - -} /* dlasd6_ */ diff --git a/external/clapack/lapack/dlasd7.cpp b/external/clapack/lapack/dlasd7.cpp deleted file mode 100644 index 2cdce3c8..00000000 --- a/external/clapack/lapack/dlasd7.cpp +++ /dev/null @@ -1,499 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr, - integer *sqre, integer *k, double *d__, double *z__, - double *zw, double *vf, double *vfw, double *vl, - double *vlw, double *alpha, double *beta, double * - dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm, - integer *givptr, integer *givcol, integer *ldgcol, double *givnum, - integer *ldgnum, double *c__, double *s, integer *info) -{ - /* System generated locals */ - integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer i__, j, m, n, k2; - double z1; - integer jp; - double eps, tau, tol; - integer nlp1, nlp2, idxi, idxj; - integer idxjp; - integer jprev; - double hlftol; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASD7 merges the two sets of singular values together into a single */ -/* sorted set. Then it tries to deflate the size of the problem. There */ -/* are two ways in which deflation can occur: when two or more singular */ -/* values are close together or if there is a tiny entry in the Z */ -/* vector. For each such occurrence the order of the related */ -/* secular equation problem is reduced by one. */ - -/* DLASD7 is called from DLASD6. */ - -/* Arguments */ -/* ========= */ - -/* ICOMPQ (input) INTEGER */ -/* Specifies whether singular vectors are to be computed */ -/* in compact form, as follows: */ -/* = 0: Compute singular values only. */ -/* = 1: Compute singular vectors of upper */ -/* bidiagonal matrix in compact form. */ - -/* NL (input) INTEGER */ -/* The row dimension of the upper block. NL >= 1. */ - -/* NR (input) INTEGER */ -/* The row dimension of the lower block. NR >= 1. */ - -/* SQRE (input) INTEGER */ -/* = 0: the lower block is an NR-by-NR square matrix. */ -/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ - -/* The bidiagonal matrix has */ -/* N = NL + NR + 1 rows and */ -/* M = N + SQRE >= N columns. */ - -/* K (output) INTEGER */ -/* Contains the dimension of the non-deflated matrix, this is */ -/* the order of the related secular equation. 1 <= K <=N. */ - -/* D (input/output) DOUBLE PRECISION array, dimension ( N ) */ -/* On entry D contains the singular values of the two submatrices */ -/* to be combined. On exit D contains the trailing (N-K) updated */ -/* singular values (those which were deflated) sorted into */ -/* increasing order. */ - -/* Z (output) DOUBLE PRECISION array, dimension ( M ) */ -/* On exit Z contains the updating row vector in the secular */ -/* equation. */ - -/* ZW (workspace) DOUBLE PRECISION array, dimension ( M ) */ -/* Workspace for Z. */ - -/* VF (input/output) DOUBLE PRECISION array, dimension ( M ) */ -/* On entry, VF(1:NL+1) contains the first components of all */ -/* right singular vectors of the upper block; and VF(NL+2:M) */ -/* contains the first components of all right singular vectors */ -/* of the lower block. On exit, VF contains the first components */ -/* of all right singular vectors of the bidiagonal matrix. */ - -/* VFW (workspace) DOUBLE PRECISION array, dimension ( M ) */ -/* Workspace for VF. */ - -/* VL (input/output) DOUBLE PRECISION array, dimension ( M ) */ -/* On entry, VL(1:NL+1) contains the last components of all */ -/* right singular vectors of the upper block; and VL(NL+2:M) */ -/* contains the last components of all right singular vectors */ -/* of the lower block. On exit, VL contains the last components */ -/* of all right singular vectors of the bidiagonal matrix. */ - -/* VLW (workspace) DOUBLE PRECISION array, dimension ( M ) */ -/* Workspace for VL. */ - -/* ALPHA (input) DOUBLE PRECISION */ -/* Contains the diagonal element associated with the added row. */ - -/* BETA (input) DOUBLE PRECISION */ -/* Contains the off-diagonal element associated with the added */ -/* row. */ - -/* DSIGMA (output) DOUBLE PRECISION array, dimension ( N ) */ -/* Contains a copy of the diagonal elements (K-1 singular values */ -/* and one zero) in the secular equation. */ - -/* IDX (workspace) INTEGER array, dimension ( N ) */ -/* This will contain the permutation used to sort the contents of */ -/* D into ascending order. */ - -/* IDXP (workspace) INTEGER array, dimension ( N ) */ -/* This will contain the permutation used to place deflated */ -/* values of D at the end of the array. On output IDXP(2:K) */ -/* points to the nondeflated D-values and IDXP(K+1:N) */ -/* points to the deflated singular values. */ - -/* IDXQ (input) INTEGER array, dimension ( N ) */ -/* This contains the permutation which separately sorts the two */ -/* sub-problems in D into ascending order. Note that entries in */ -/* the first half of this permutation must first be moved one */ -/* position backward; and entries in the second half */ -/* must first have NL+1 added to their values. */ - -/* PERM (output) INTEGER array, dimension ( N ) */ -/* The permutations (from deflation and sorting) to be applied */ -/* to each singular block. Not referenced if ICOMPQ = 0. */ - -/* GIVPTR (output) INTEGER */ -/* The number of Givens rotations which took place in this */ -/* subproblem. Not referenced if ICOMPQ = 0. */ - -/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */ -/* Each pair of numbers indicates a pair of columns to take place */ -/* in a Givens rotation. Not referenced if ICOMPQ = 0. */ - -/* LDGCOL (input) INTEGER */ -/* The leading dimension of GIVCOL, must be at least N. */ - -/* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ -/* Each number indicates the C or S value to be used in the */ -/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */ - -/* LDGNUM (input) INTEGER */ -/* The leading dimension of GIVNUM, must be at least N. */ - -/* C (output) DOUBLE PRECISION */ -/* C contains garbage if SQRE =0 and the C-value of a Givens */ -/* rotation related to the right null space if SQRE = 1. */ - -/* S (output) DOUBLE PRECISION */ -/* S contains garbage if SQRE =0 and the S-value of a Givens */ -/* rotation related to the right null space if SQRE = 1. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ - -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --z__; - --zw; - --vf; - --vfw; - --vl; - --vlw; - --dsigma; - --idx; - --idxp; - --idxq; - --perm; - givcol_dim1 = *ldgcol; - givcol_offset = 1 + givcol_dim1; - givcol -= givcol_offset; - givnum_dim1 = *ldgnum; - givnum_offset = 1 + givnum_dim1; - givnum -= givnum_offset; - - /* Function Body */ - *info = 0; - n = *nl + *nr + 1; - m = n + *sqre; - - if (*icompq < 0 || *icompq > 1) { - *info = -1; - } else if (*nl < 1) { - *info = -2; - } else if (*nr < 1) { - *info = -3; - } else if (*sqre < 0 || *sqre > 1) { - *info = -4; - } else if (*ldgcol < n) { - *info = -22; - } else if (*ldgnum < n) { - *info = -24; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASD7", &i__1); - return 0; - } - - nlp1 = *nl + 1; - nlp2 = *nl + 2; - if (*icompq == 1) { - *givptr = 0; - } - -/* Generate the first part of the vector Z and move the singular */ -/* values in the first part of D one position backward. */ - - z1 = *alpha * vl[nlp1]; - vl[nlp1] = 0.; - tau = vf[nlp1]; - for (i__ = *nl; i__ >= 1; --i__) { - z__[i__ + 1] = *alpha * vl[i__]; - vl[i__] = 0.; - vf[i__ + 1] = vf[i__]; - d__[i__ + 1] = d__[i__]; - idxq[i__ + 1] = idxq[i__] + 1; -/* L10: */ - } - vf[1] = tau; - -/* Generate the second part of the vector Z. */ - - i__1 = m; - for (i__ = nlp2; i__ <= i__1; ++i__) { - z__[i__] = *beta * vf[i__]; - vf[i__] = 0.; -/* L20: */ - } - -/* Sort the singular values into increasing order */ - - i__1 = n; - for (i__ = nlp2; i__ <= i__1; ++i__) { - idxq[i__] += nlp1; -/* L30: */ - } - -/* DSIGMA, IDXC, IDXC, and ZW are used as storage space. */ - - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - dsigma[i__] = d__[idxq[i__]]; - zw[i__] = z__[idxq[i__]]; - vfw[i__] = vf[idxq[i__]]; - vlw[i__] = vl[idxq[i__]]; -/* L40: */ - } - - dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]); - - i__1 = n; - for (i__ = 2; i__ <= i__1; ++i__) { - idxi = idx[i__] + 1; - d__[i__] = dsigma[idxi]; - z__[i__] = zw[idxi]; - vf[i__] = vfw[idxi]; - vl[i__] = vlw[idxi]; -/* L50: */ - } - -/* Calculate the allowable deflation tolerence */ - - eps = dlamch_("Epsilon"); -/* Computing MAX */ - d__1 = abs(*alpha), d__2 = abs(*beta); - tol = std::max(d__1,d__2); -/* Computing MAX */ - d__2 = (d__1 = d__[n], abs(d__1)); - tol = eps * 64. * std::max(d__2,tol); - -/* There are 2 kinds of deflation -- first a value in the z-vector */ -/* is small, second two (or more) singular values are very close */ -/* together (their difference is small). */ - -/* If the value in the z-vector is small, we simply permute the */ -/* array so that the corresponding singular value is moved to the */ -/* end. */ - -/* If two values in the D-vector are close, we perform a two-sided */ -/* rotation designed to make one of the corresponding z-vector */ -/* entries zero, and then permute the array so that the deflated */ -/* singular value is moved to the end. */ - -/* If there are multiple singular values then the problem deflates. */ -/* Here the number of equal singular values are found. As each equal */ -/* singular value is found, an elementary reflector is computed to */ -/* rotate the corresponding singular subspace so that the */ -/* corresponding components of Z are zero in this new basis. */ - - *k = 1; - k2 = n + 1; - i__1 = n; - for (j = 2; j <= i__1; ++j) { - if ((d__1 = z__[j], abs(d__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - idxp[k2] = j; - if (j == n) { - goto L100; - } - } else { - jprev = j; - goto L70; - } -/* L60: */ - } -L70: - j = jprev; -L80: - ++j; - if (j > n) { - goto L90; - } - if ((d__1 = z__[j], abs(d__1)) <= tol) { - -/* Deflate due to small z component. */ - - --k2; - idxp[k2] = j; - } else { - -/* Check if singular values are close enough to allow deflation. */ - - if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) { - -/* Deflation is possible. */ - - *s = z__[jprev]; - *c__ = z__[j]; - -/* Find sqrt(a**2+b**2) without overflow or */ -/* destructive underflow. */ - - tau = dlapy2_(c__, s); - z__[j] = tau; - z__[jprev] = 0.; - *c__ /= tau; - *s = -(*s) / tau; - -/* Record the appropriate Givens rotation */ - - if (*icompq == 1) { - ++(*givptr); - idxjp = idxq[idx[jprev] + 1]; - idxj = idxq[idx[j] + 1]; - if (idxjp <= nlp1) { - --idxjp; - } - if (idxj <= nlp1) { - --idxj; - } - givcol[*givptr + (givcol_dim1 << 1)] = idxjp; - givcol[*givptr + givcol_dim1] = idxj; - givnum[*givptr + (givnum_dim1 << 1)] = *c__; - givnum[*givptr + givnum_dim1] = *s; - } - drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s); - drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s); - --k2; - idxp[k2] = jprev; - jprev = j; - } else { - ++(*k); - zw[*k] = z__[jprev]; - dsigma[*k] = d__[jprev]; - idxp[*k] = jprev; - jprev = j; - } - } - goto L80; -L90: - -/* Record the last singular value. */ - - ++(*k); - zw[*k] = z__[jprev]; - dsigma[*k] = d__[jprev]; - idxp[*k] = jprev; - -L100: - -/* Sort the singular values into DSIGMA. The singular values which */ -/* were not deflated go into the first K slots of DSIGMA, except */ -/* that DSIGMA(1) is treated separately. */ - - i__1 = n; - for (j = 2; j <= i__1; ++j) { - jp = idxp[j]; - dsigma[j] = d__[jp]; - vfw[j] = vf[jp]; - vlw[j] = vl[jp]; -/* L110: */ - } - if (*icompq == 1) { - i__1 = n; - for (j = 2; j <= i__1; ++j) { - jp = idxp[j]; - perm[j] = idxq[idx[jp] + 1]; - if (perm[j] <= nlp1) { - --perm[j]; - } -/* L120: */ - } - } - -/* The deflated singular values go back into the last N - K slots of */ -/* D. */ - - i__1 = n - *k; - dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1); - -/* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and */ -/* VL(M). */ - - dsigma[1] = 0.; - hlftol = tol / 2.; - if (abs(dsigma[2]) <= hlftol) { - dsigma[2] = hlftol; - } - if (m > n) { - z__[1] = dlapy2_(&z1, &z__[m]); - if (z__[1] <= tol) { - *c__ = 1.; - *s = 0.; - z__[1] = tol; - } else { - *c__ = z1 / z__[1]; - *s = -z__[m] / z__[1]; - } - drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s); - drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s); - } else { - if (abs(z1) <= tol) { - z__[1] = tol; - } else { - z__[1] = z1; - } - } - -/* Restore Z, VF, and VL. */ - - i__1 = *k - 1; - dcopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1); - i__1 = n - 1; - dcopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1); - i__1 = n - 1; - dcopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1); - - return 0; - -/* End of DLASD7 */ - -} /* dlasd7_ */ diff --git a/external/clapack/lapack/dlasd8.cpp b/external/clapack/lapack/dlasd8.cpp deleted file mode 100644 index f420a9c2..00000000 --- a/external/clapack/lapack/dlasd8.cpp +++ /dev/null @@ -1,295 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static double c_b8 = 1.; - -/* Subroutine */ int dlasd8_(integer *icompq, integer *k, double *d__, - double *z__, double *vf, double *vl, double *difl, - double *difr, integer *lddifr, double *dsigma, double * - work, integer *info) -{ - /* System generated locals */ - integer difr_dim1, difr_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double dj, rho; - integer iwk1, iwk2, iwk3; - double temp; - integer iwk2i, iwk3i; - double diflj, difrj, dsigj; - double dsigjp; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASD8 finds the square roots of the roots of the secular equation, */ -/* as defined by the values in DSIGMA and Z. It makes the appropriate */ -/* calls to DLASD4, and stores, for each element in D, the distance */ -/* to its two nearest poles (elements in DSIGMA). It also updates */ -/* the arrays VF and VL, the first and last components of all the */ -/* right singular vectors of the original bidiagonal matrix. */ - -/* DLASD8 is called from DLASD6. */ - -/* Arguments */ -/* ========= */ - -/* ICOMPQ (input) INTEGER */ -/* Specifies whether singular vectors are to be computed in */ -/* factored form in the calling routine: */ -/* = 0: Compute singular values only. */ -/* = 1: Compute singular vectors in factored form as well. */ - -/* K (input) INTEGER */ -/* The number of terms in the rational function to be solved */ -/* by DLASD4. K >= 1. */ - -/* D (output) DOUBLE PRECISION array, dimension ( K ) */ -/* On output, D contains the updated singular values. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( K ) */ -/* The first K elements of this array contain the components */ -/* of the deflation-adjusted updating row vector. */ - -/* VF (input/output) DOUBLE PRECISION array, dimension ( K ) */ -/* On entry, VF contains information passed through DBEDE8. */ -/* On exit, VF contains the first K components of the first */ -/* components of all right singular vectors of the bidiagonal */ -/* matrix. */ - -/* VL (input/output) DOUBLE PRECISION array, dimension ( K ) */ -/* On entry, VL contains information passed through DBEDE8. */ -/* On exit, VL contains the first K components of the last */ -/* components of all right singular vectors of the bidiagonal */ -/* matrix. */ - -/* DIFL (output) DOUBLE PRECISION array, dimension ( K ) */ -/* On exit, DIFL(I) = D(I) - DSIGMA(I). */ - -/* DIFR (output) DOUBLE PRECISION array, */ -/* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */ -/* dimension ( K ) if ICOMPQ = 0. */ -/* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */ -/* defined and will not be referenced. */ - -/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */ -/* normalizing factors for the right singular vector matrix. */ - -/* LDDIFR (input) INTEGER */ -/* The leading dimension of DIFR, must be at least K. */ - -/* DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) */ -/* The first K elements of this array contain the old roots */ -/* of the deflated updating problem. These are the poles */ -/* of the secular equation. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an singular value did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --z__; - --vf; - --vl; - --difl; - difr_dim1 = *lddifr; - difr_offset = 1 + difr_dim1; - difr -= difr_offset; - --dsigma; - --work; - - /* Function Body */ - *info = 0; - - if (*icompq < 0 || *icompq > 1) { - *info = -1; - } else if (*k < 1) { - *info = -2; - } else if (*lddifr < *k) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASD8", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*k == 1) { - d__[1] = abs(z__[1]); - difl[1] = d__[1]; - if (*icompq == 1) { - difl[2] = 1.; - difr[(difr_dim1 << 1) + 1] = 1.; - } - return 0; - } - -/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */ -/* be computed with high relative accuracy (barring over/underflow). */ -/* This is a problem on machines without a guard digit in */ -/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ -/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */ -/* which on any of these machines zeros out the bottommost */ -/* bit of DSIGMA(I) if it is 1; this makes the subsequent */ -/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */ -/* occurs. On binary machines with a guard digit (almost all */ -/* machines) it does not change DSIGMA(I) at all. On hexadecimal */ -/* and decimal machines with a guard digit, it slightly */ -/* changes the bottommost bits of DSIGMA(I). It does not account */ -/* for hexadecimal or decimal machines without guard digits */ -/* (we know of none). We use a subroutine call to compute */ -/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */ -/* this code. */ - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; -/* L10: */ - } - -/* Book keeping. */ - - iwk1 = 1; - iwk2 = iwk1 + *k; - iwk3 = iwk2 + *k; - iwk2i = iwk2 - 1; - iwk3i = iwk3 - 1; - -/* Normalize Z. */ - - rho = dnrm2_(k, &z__[1], &c__1); - dlascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info); - rho *= rho; - -/* Initialize WORK(IWK3). */ - - dlaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k); - -/* Compute the updated singular values, the arrays DIFL, DIFR, */ -/* and the updated Z. */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[ - iwk2], info); - -/* If the root finder fails, the computation is terminated. */ - - if (*info != 0) { - return 0; - } - work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j]; - difl[j] = -work[j]; - difr[j + difr_dim1] = -work[j + 1]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + - i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ - j]); -/* L20: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + - i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ - j]); -/* L30: */ - } -/* L40: */ - } - -/* Compute updated Z. */ - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1))); - z__[i__] = d_sign(&d__2, &z__[i__]); -/* L50: */ - } - -/* Update VF and VL. */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - diflj = difl[j]; - dj = d__[j]; - dsigj = -dsigma[j]; - if (j < *k) { - difrj = -difr[j + difr_dim1]; - dsigjp = -dsigma[j + 1]; - } - work[j] = -z__[j] / diflj / (dsigma[j] + dj); - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / ( - dsigma[i__] + dj); -/* L60: */ - } - i__2 = *k; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) / - (dsigma[i__] + dj); -/* L70: */ - } - temp = dnrm2_(k, &work[1], &c__1); - work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp; - work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp; - if (*icompq == 1) { - difr[j + (difr_dim1 << 1)] = temp; - } -/* L80: */ - } - - dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1); - dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1); - - return 0; - -/* End of DLASD8 */ - -} /* dlasd8_ */ diff --git a/external/clapack/lapack/dlasda.cpp b/external/clapack/lapack/dlasda.cpp deleted file mode 100644 index 6702f94e..00000000 --- a/external/clapack/lapack/dlasda.cpp +++ /dev/null @@ -1,458 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__0 = 0; -static double c_b11 = 0.; -static double c_b12 = 1.; -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n, - integer *sqre, double *d__, double *e, double *u, integer - *ldu, double *vt, integer *k, double *difl, double *difr, - double *z__, double *poles, integer *givptr, integer *givcol, - integer *ldgcol, integer *perm, double *givnum, double *c__, - double *s, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, - difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, - poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, - z_dim1, z_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf, - vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1; - double beta; - integer idxq, nlvl; - double alpha; - integer inode, ndiml, ndimr, idxqi, itemp; - integer sqrei; - integer nwork1, nwork2; - integer smlszp; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Using a divide and conquer approach, DLASDA computes the singular */ -/* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix */ -/* B with diagonal D and offdiagonal E, where M = N + SQRE. The */ -/* algorithm computes the singular values in the SVD B = U * S * VT. */ -/* The orthogonal matrices U and VT are optionally computed in */ -/* compact form. */ - -/* A related subroutine, DLASD0, computes the singular values and */ -/* the singular vectors in explicit form. */ - -/* Arguments */ -/* ========= */ - -/* ICOMPQ (input) INTEGER */ -/* Specifies whether singular vectors are to be computed */ -/* in compact form, as follows */ -/* = 0: Compute singular values only. */ -/* = 1: Compute singular vectors of upper bidiagonal */ -/* matrix in compact form. */ - -/* SMLSIZ (input) INTEGER */ -/* The maximum size of the subproblems at the bottom of the */ -/* computation tree. */ - -/* N (input) INTEGER */ -/* The row dimension of the upper bidiagonal matrix. This is */ -/* also the dimension of the main diagonal array D. */ - -/* SQRE (input) INTEGER */ -/* Specifies the column dimension of the bidiagonal matrix. */ -/* = 0: The bidiagonal matrix has column dimension M = N; */ -/* = 1: The bidiagonal matrix has column dimension M = N + 1. */ - -/* D (input/output) DOUBLE PRECISION array, dimension ( N ) */ -/* On entry D contains the main diagonal of the bidiagonal */ -/* matrix. On exit D, if INFO = 0, contains its singular values. */ - -/* E (input) DOUBLE PRECISION array, dimension ( M-1 ) */ -/* Contains the subdiagonal entries of the bidiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* U (output) DOUBLE PRECISION array, */ -/* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced */ -/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left */ -/* singular vector matrices of all subproblems at the bottom */ -/* level. */ - -/* LDU (input) INTEGER, LDU = > N. */ -/* The leading dimension of arrays U, VT, DIFL, DIFR, POLES, */ -/* GIVNUM, and Z. */ - -/* VT (output) DOUBLE PRECISION array, */ -/* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced */ -/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right */ -/* singular vector matrices of all subproblems at the bottom */ -/* level. */ - -/* K (output) INTEGER array, */ -/* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. */ -/* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th */ -/* secular equation on the computation tree. */ - -/* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ), */ -/* where NLVL = floor(log_2 (N/SMLSIZ))). */ - -/* DIFR (output) DOUBLE PRECISION array, */ -/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and */ -/* dimension ( N ) if ICOMPQ = 0. */ -/* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) */ -/* record distances between singular values on the I-th */ -/* level and singular values on the (I -1)-th level, and */ -/* DIFR(1:N, 2 * I ) contains the normalizing factors for */ -/* the right singular vector matrix. See DLASD8 for details. */ - -/* Z (output) DOUBLE PRECISION array, */ -/* dimension ( LDU, NLVL ) if ICOMPQ = 1 and */ -/* dimension ( N ) if ICOMPQ = 0. */ -/* The first K elements of Z(1, I) contain the components of */ -/* the deflation-adjusted updating row vector for subproblems */ -/* on the I-th level. */ - -/* POLES (output) DOUBLE PRECISION array, */ -/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced */ -/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and */ -/* POLES(1, 2*I) contain the new and old singular values */ -/* involved in the secular equations on the I-th level. */ - -/* GIVPTR (output) INTEGER array, */ -/* dimension ( N ) if ICOMPQ = 1, and not referenced if */ -/* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records */ -/* the number of Givens rotations performed on the I-th */ -/* problem on the computation tree. */ - -/* GIVCOL (output) INTEGER array, */ -/* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not */ -/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */ -/* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations */ -/* of Givens rotations performed on the I-th level on the */ -/* computation tree. */ - -/* LDGCOL (input) INTEGER, LDGCOL = > N. */ -/* The leading dimension of arrays GIVCOL and PERM. */ - -/* PERM (output) INTEGER array, */ -/* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced */ -/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records */ -/* permutations done on the I-th level of the computation tree. */ - -/* GIVNUM (output) DOUBLE PRECISION array, */ -/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not */ -/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */ -/* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- */ -/* values of Givens rotations performed on the I-th level on */ -/* the computation tree. */ - -/* C (output) DOUBLE PRECISION array, */ -/* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. */ -/* If ICOMPQ = 1 and the I-th subproblem is not square, on exit, */ -/* C( I ) contains the C-value of a Givens rotation related to */ -/* the right null space of the I-th subproblem. */ - -/* S (output) DOUBLE PRECISION array, dimension ( N ) if */ -/* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 */ -/* and the I-th subproblem is not square, on exit, S( I ) */ -/* contains the S-value of a Givens rotation related to */ -/* the right null space of the I-th subproblem. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension */ -/* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */ - -/* IWORK (workspace) INTEGER array. */ -/* Dimension must be at least (7 * N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = 1, an singular value did not converge */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - givnum_dim1 = *ldu; - givnum_offset = 1 + givnum_dim1; - givnum -= givnum_offset; - poles_dim1 = *ldu; - poles_offset = 1 + poles_dim1; - poles -= poles_offset; - z_dim1 = *ldu; - z_offset = 1 + z_dim1; - z__ -= z_offset; - difr_dim1 = *ldu; - difr_offset = 1 + difr_dim1; - difr -= difr_offset; - difl_dim1 = *ldu; - difl_offset = 1 + difl_dim1; - difl -= difl_offset; - vt_dim1 = *ldu; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - --k; - --givptr; - perm_dim1 = *ldgcol; - perm_offset = 1 + perm_dim1; - perm -= perm_offset; - givcol_dim1 = *ldgcol; - givcol_offset = 1 + givcol_dim1; - givcol -= givcol_offset; - --c__; - --s; - --work; - --iwork; - - /* Function Body */ - *info = 0; - - if (*icompq < 0 || *icompq > 1) { - *info = -1; - } else if (*smlsiz < 3) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*sqre < 0 || *sqre > 1) { - *info = -4; - } else if (*ldu < *n + *sqre) { - *info = -8; - } else if (*ldgcol < *n) { - *info = -17; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASDA", &i__1); - return 0; - } - - m = *n + *sqre; - -/* If the input matrix is too small, call DLASDQ to find the SVD. */ - - if (*n <= *smlsiz) { - if (*icompq == 0) { - dlasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ - vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, & - work[1], info); - } else { - dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset] -, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], - info); - } - return 0; - } - -/* Book-keeping and set up the computation tree. */ - - inode = 1; - ndiml = inode + *n; - ndimr = ndiml + *n; - idxq = ndimr + *n; - iwk = idxq + *n; - - ncc = 0; - nru = 0; - - smlszp = *smlsiz + 1; - vf = 1; - vl = vf + m; - nwork1 = vl + m; - nwork2 = nwork1 + smlszp * smlszp; - - dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], - smlsiz); - -/* for the nodes on bottom level of the tree, solve */ -/* their subproblems by DLASDQ. */ - - ndb1 = (nd + 1) / 2; - i__1 = nd; - for (i__ = ndb1; i__ <= i__1; ++i__) { - -/* IC : center row of each node */ -/* NL : number of rows of left subproblem */ -/* NR : number of rows of right subproblem */ -/* NLF: starting row of the left subproblem */ -/* NRF: starting row of the right subproblem */ - - i1 = i__ - 1; - ic = iwork[inode + i1]; - nl = iwork[ndiml + i1]; - nlp1 = nl + 1; - nr = iwork[ndimr + i1]; - nlf = ic - nl; - nrf = ic + 1; - idxqi = idxq + nlf - 2; - vfi = vf + nlf - 1; - vli = vl + nlf - 1; - sqrei = 1; - if (*icompq == 0) { - dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp); - dlasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], & - work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2], - &nl, &work[nwork2], info); - itemp = nwork1 + nl * smlszp; - dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1); - dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1); - } else { - dlaset_("A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu); - dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], - ldu); - dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], & - vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf + - u_dim1], ldu, &work[nwork1], info); - dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1); - dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1) - ; - } - if (*info != 0) { - return 0; - } - i__2 = nl; - for (j = 1; j <= i__2; ++j) { - iwork[idxqi + j] = j; -/* L10: */ - } - if (i__ == nd && *sqre == 0) { - sqrei = 0; - } else { - sqrei = 1; - } - idxqi += nlp1; - vfi += nlp1; - vli += nlp1; - nrp1 = nr + sqrei; - if (*icompq == 0) { - dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp); - dlasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], & - work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2], - &nr, &work[nwork2], info); - itemp = nwork1 + (nrp1 - 1) * smlszp; - dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1); - dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1); - } else { - dlaset_("A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu); - dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], - ldu); - dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], & - vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf + - u_dim1], ldu, &work[nwork1], info); - dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1); - dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1) - ; - } - if (*info != 0) { - return 0; - } - i__2 = nr; - for (j = 1; j <= i__2; ++j) { - iwork[idxqi + j] = j; -/* L20: */ - } -/* L30: */ - } - -/* Now conquer each subproblem bottom-up. */ - - j = pow_ii(&c__2, &nlvl); - for (lvl = nlvl; lvl >= 1; --lvl) { - lvl2 = (lvl << 1) - 1; - -/* Find the first node LF and last node LL on */ -/* the current level LVL. */ - - if (lvl == 1) { - lf = 1; - ll = 1; - } else { - i__1 = lvl - 1; - lf = pow_ii(&c__2, &i__1); - ll = (lf << 1) - 1; - } - i__1 = ll; - for (i__ = lf; i__ <= i__1; ++i__) { - im1 = i__ - 1; - ic = iwork[inode + im1]; - nl = iwork[ndiml + im1]; - nr = iwork[ndimr + im1]; - nlf = ic - nl; - nrf = ic + 1; - if (i__ == ll) { - sqrei = *sqre; - } else { - sqrei = 1; - } - vfi = vf + nlf - 1; - vli = vl + nlf - 1; - idxqi = idxq + nlf - 1; - alpha = d__[ic]; - beta = e[ic]; - if (*icompq == 0) { - dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & - work[vli], &alpha, &beta, &iwork[idxqi], &perm[ - perm_offset], &givptr[1], &givcol[givcol_offset], - ldgcol, &givnum[givnum_offset], ldu, &poles[ - poles_offset], &difl[difl_offset], &difr[difr_offset], - &z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1], - &iwork[iwk], info); - } else { - --j; - dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & - work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf + - lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * - givcol_dim1], ldgcol, &givnum[nlf + lvl2 * - givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], & - difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * - difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j], - &s[j], &work[nwork1], &iwork[iwk], info); - } - if (*info != 0) { - return 0; - } -/* L40: */ - } -/* L50: */ - } - - return 0; - -/* End of DLASDA */ - -} /* dlasda_ */ diff --git a/external/clapack/lapack/dlasdq.cpp b/external/clapack/lapack/dlasdq.cpp deleted file mode 100644 index 9ac5ef8a..00000000 --- a/external/clapack/lapack/dlasdq.cpp +++ /dev/null @@ -1,358 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dlasdq_(const char *uplo, integer *sqre, integer *n, integer * - ncvt, integer *nru, integer *ncc, double *d__, double *e, - double *vt, integer *ldvt, double *u, integer *ldu, - double *c__, integer *ldc, double *work, integer *info) -{ - /* System generated locals */ - integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2; - - /* Local variables */ - integer i__, j; - double r__, cs, sn; - integer np1, isub; - double smin; - integer sqre1; - integer iuplo; - bool rotate; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASDQ computes the singular value decomposition (SVD) of a real */ -/* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal */ -/* E, accumulating the transformations if desired. Letting B denote */ -/* the input bidiagonal matrix, the algorithm computes orthogonal */ -/* matrices Q and P such that B = Q * S * P' (P' denotes the transpose */ -/* of P). The singular values S are overwritten on D. */ - -/* The input matrix U is changed to U * Q if desired. */ -/* The input matrix VT is changed to P' * VT if desired. */ -/* The input matrix C is changed to Q' * C if desired. */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices With */ -/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */ -/* LAPACK Working Note #3, for a detailed description of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* On entry, UPLO specifies whether the input bidiagonal matrix */ -/* is upper or lower bidiagonal, and wether it is square are */ -/* not. */ -/* UPLO = 'U' or 'u' B is upper bidiagonal. */ -/* UPLO = 'L' or 'l' B is lower bidiagonal. */ - -/* SQRE (input) INTEGER */ -/* = 0: then the input matrix is N-by-N. */ -/* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and */ -/* (N+1)-by-N if UPLU = 'L'. */ - -/* The bidiagonal matrix has */ -/* N = NL + NR + 1 rows and */ -/* M = N + SQRE >= N columns. */ - -/* N (input) INTEGER */ -/* On entry, N specifies the number of rows and columns */ -/* in the matrix. N must be at least 0. */ - -/* NCVT (input) INTEGER */ -/* On entry, NCVT specifies the number of columns of */ -/* the matrix VT. NCVT must be at least 0. */ - -/* NRU (input) INTEGER */ -/* On entry, NRU specifies the number of rows of */ -/* the matrix U. NRU must be at least 0. */ - -/* NCC (input) INTEGER */ -/* On entry, NCC specifies the number of columns of */ -/* the matrix C. NCC must be at least 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, D contains the diagonal entries of the */ -/* bidiagonal matrix whose SVD is desired. On normal exit, */ -/* D contains the singular values in ascending order. */ - -/* E (input/output) DOUBLE PRECISION array. */ -/* dimension is (N-1) if SQRE = 0 and N if SQRE = 1. */ -/* On entry, the entries of E contain the offdiagonal entries */ -/* of the bidiagonal matrix whose SVD is desired. On normal */ -/* exit, E will contain 0. If the algorithm does not converge, */ -/* D and E will contain the diagonal and superdiagonal entries */ -/* of a bidiagonal matrix orthogonally equivalent to the one */ -/* given as input. */ - -/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */ -/* On entry, contains a matrix which on exit has been */ -/* premultiplied by P', dimension N-by-NCVT if SQRE = 0 */ -/* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). */ - -/* LDVT (input) INTEGER */ -/* On entry, LDVT specifies the leading dimension of VT as */ -/* declared in the calling (sub) program. LDVT must be at */ -/* least 1. If NCVT is nonzero LDVT must also be at least N. */ - -/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */ -/* On entry, contains a matrix which on exit has been */ -/* postmultiplied by Q, dimension NRU-by-N if SQRE = 0 */ -/* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). */ - -/* LDU (input) INTEGER */ -/* On entry, LDU specifies the leading dimension of U as */ -/* declared in the calling (sub) program. LDU must be at */ -/* least max( 1, NRU ) . */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */ -/* On entry, contains an N-by-NCC matrix which on exit */ -/* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 */ -/* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). */ - -/* LDC (input) INTEGER */ -/* On entry, LDC specifies the leading dimension of C as */ -/* declared in the calling (sub) program. LDC must be at */ -/* least 1. If NCC is nonzero, LDC must also be at least N. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ -/* Workspace. Only referenced if one of NCVT, NRU, or NCC is */ -/* nonzero, and if N is at least 2. */ - -/* INFO (output) INTEGER */ -/* On exit, a value of 0 indicates a successful exit. */ -/* If INFO < 0, argument number -INFO is illegal. */ -/* If INFO > 0, the algorithm did not converge, and INFO */ -/* specifies how many superdiagonals did not converge. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1; - vt -= vt_offset; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - iuplo = 0; - if (lsame_(uplo, "U")) { - iuplo = 1; - } - if (lsame_(uplo, "L")) { - iuplo = 2; - } - if (iuplo == 0) { - *info = -1; - } else if (*sqre < 0 || *sqre > 1) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ncvt < 0) { - *info = -4; - } else if (*nru < 0) { - *info = -5; - } else if (*ncc < 0) { - *info = -6; - } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < std::max(1_integer,*n)) { - *info = -10; - } else if (*ldu < std::max(1_integer,*nru)) { - *info = -12; - } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < std::max(1_integer,*n)) { - *info = -14; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASDQ", &i__1); - return 0; - } - if (*n == 0) { - return 0; - } - -/* ROTATE is true if any singular vectors desired, false otherwise */ - - rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; - np1 = *n + 1; - sqre1 = *sqre; - -/* If matrix non-square upper bidiagonal, rotate to be lower */ -/* bidiagonal. The rotations are on the right. */ - - if (iuplo == 1 && sqre1 == 1) { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - if (rotate) { - work[i__] = cs; - work[*n + i__] = sn; - } -/* L10: */ - } - dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); - d__[*n] = r__; - e[*n] = 0.; - if (rotate) { - work[*n] = cs; - work[*n + *n] = sn; - } - iuplo = 2; - sqre1 = 0; - -/* Update singular vectors if desired. */ - - if (*ncvt > 0) { - dlasr_("L", "V", "F", &np1, ncvt, &work[1], &work[np1], &vt[ - vt_offset], ldvt); - } - } - -/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ -/* by applying Givens rotations on the left. */ - - if (iuplo == 2) { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - if (rotate) { - work[i__] = cs; - work[*n + i__] = sn; - } -/* L20: */ - } - -/* If matrix (N+1)-by-N lower bidiagonal, one additional */ -/* rotation is needed. */ - - if (sqre1 == 1) { - dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); - d__[*n] = r__; - if (rotate) { - work[*n] = cs; - work[*n + *n] = sn; - } - } - -/* Update singular vectors if desired. */ - - if (*nru > 0) { - if (sqre1 == 0) { - dlasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[ - u_offset], ldu); - } else { - dlasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[ - u_offset], ldu); - } - } - if (*ncc > 0) { - if (sqre1 == 0) { - dlasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[ - c_offset], ldc); - } else { - dlasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[ - c_offset], ldc); - } - } - } - -/* Call DBDSQR to compute the SVD of the reduced real */ -/* N-by-N upper bidiagonal matrix. */ - - dbdsqr_("U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[ - u_offset], ldu, &c__[c_offset], ldc, &work[1], info); - -/* Sort the singular values into ascending order (insertion sort on */ -/* singular values, but only one transposition per singular vector) */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Scan for smallest D(I). */ - - isub = i__; - smin = d__[i__]; - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - if (d__[j] < smin) { - isub = j; - smin = d__[j]; - } -/* L30: */ - } - if (isub != i__) { - -/* Swap singular values and vectors. */ - - d__[isub] = d__[i__]; - d__[i__] = smin; - if (*ncvt > 0) { - dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], - ldvt); - } - if (*nru > 0) { - dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1] -, &c__1); - } - if (*ncc > 0) { - dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc) - ; - } - } -/* L40: */ - } - - return 0; - -/* End of DLASDQ */ - -} /* dlasdq_ */ diff --git a/external/clapack/lapack/dlasdt.cpp b/external/clapack/lapack/dlasdt.cpp deleted file mode 100644 index 9ee5dc53..00000000 --- a/external/clapack/lapack/dlasdt.cpp +++ /dev/null @@ -1,121 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer * - inode, integer *ndiml, integer *ndimr, integer *msub) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, il, ir, maxn; - double temp; - integer nlvl, llst, ncrnt; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASDT creates a tree of subproblems for bidiagonal divide and */ -/* conquer. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* On entry, the number of diagonal elements of the */ -/* bidiagonal matrix. */ - -/* LVL (output) INTEGER */ -/* On exit, the number of levels on the computation tree. */ - -/* ND (output) INTEGER */ -/* On exit, the number of nodes on the tree. */ - -/* INODE (output) INTEGER array, dimension ( N ) */ -/* On exit, centers of subproblems. */ - -/* NDIML (output) INTEGER array, dimension ( N ) */ -/* On exit, row dimensions of left children. */ - -/* NDIMR (output) INTEGER array, dimension ( N ) */ -/* On exit, row dimensions of right children. */ - -/* MSUB (input) INTEGER. */ -/* On entry, the maximum row dimension each subproblem at the */ -/* bottom of the tree can be of. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Ming Gu and Huan Ren, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Find the number of levels on the tree. */ - - /* Parameter adjustments */ - --ndimr; - --ndiml; - --inode; - - /* Function Body */ - maxn = std::max(1_integer,*n); - temp = log((double) maxn / (double) (*msub + 1)) / log(2.); - *lvl = (integer) temp + 1; - - i__ = *n / 2; - inode[1] = i__ + 1; - ndiml[1] = i__; - ndimr[1] = *n - i__ - 1; - il = 0; - ir = 1; - llst = 1; - i__1 = *lvl - 1; - for (nlvl = 1; nlvl <= i__1; ++nlvl) { - -/* Constructing the tree at (NLVL+1)-st level. The number of */ -/* nodes created on this level is LLST * 2. */ - - i__2 = llst - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - il += 2; - ir += 2; - ncrnt = llst + i__; - ndiml[il] = ndiml[ncrnt] / 2; - ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1; - inode[il] = inode[ncrnt] - ndimr[il] - 1; - ndiml[ir] = ndimr[ncrnt] / 2; - ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1; - inode[ir] = inode[ncrnt] + ndiml[ir] + 1; -/* L10: */ - } - llst <<= 1; -/* L20: */ - } - *nd = (llst << 1) - 1; - - return 0; - -/* End of DLASDT */ - -} /* dlasdt_ */ diff --git a/external/clapack/lapack/dlaset.cpp b/external/clapack/lapack/dlaset.cpp deleted file mode 100644 index e271c38e..00000000 --- a/external/clapack/lapack/dlaset.cpp +++ /dev/null @@ -1,140 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaset_(const char *uplo, integer *m, integer *n, double * - alpha, double *beta, double *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASET initializes an m-by-n matrix A to BETA on the diagonal and */ -/* ALPHA on the offdiagonals. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies the part of the matrix A to be set. */ -/* = 'U': Upper triangular part is set; the strictly lower */ -/* triangular part of A is not changed. */ -/* = 'L': Lower triangular part is set; the strictly upper */ -/* triangular part of A is not changed. */ -/* Otherwise: All of the matrix A is set. */ - -/* 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. */ - -/* ALPHA (input) DOUBLE PRECISION */ -/* The constant to which the offdiagonal elements are to be set. */ - -/* BETA (input) DOUBLE PRECISION */ -/* The constant to which the diagonal elements are to be set. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On exit, the leading m-by-n submatrix of A is set as follows: */ - -/* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */ -/* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */ -/* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */ - -/* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - if (lsame_(uplo, "U")) { - -/* Set the strictly upper triangular or trapezoidal part of the */ -/* array to ALPHA. */ - - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = j - 1; - i__2 = std::min(i__3,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = *alpha; -/* L10: */ - } -/* L20: */ - } - - } else if (lsame_(uplo, "L")) { - -/* Set the strictly lower triangular or trapezoidal part of the */ -/* array to ALPHA. */ - - i__1 = std::min(*m,*n); - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = *alpha; -/* L30: */ - } -/* L40: */ - } - - } else { - -/* Set the leading m-by-n submatrix to ALPHA. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = *alpha; -/* L50: */ - } -/* L60: */ - } - } - -/* Set the first min(M,N) diagonal elements to BETA. */ - - i__1 = std::min(*m,*n); - for (i__ = 1; i__ <= i__1; ++i__) { - a[i__ + i__ * a_dim1] = *beta; -/* L70: */ - } - - return 0; - -/* End of DLASET */ - -} /* dlaset_ */ diff --git a/external/clapack/lapack/dlasq1.cpp b/external/clapack/lapack/dlasq1.cpp deleted file mode 100644 index d4119530..00000000 --- a/external/clapack/lapack/dlasq1.cpp +++ /dev/null @@ -1,187 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__2 = 2; -static integer c__0 = 0; - -/* Subroutine */ int dlasq1_(integer *n, double *d__, double *e, - double *work, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__; - double eps; - double scale; - integer iinfo; - double sigmn; - double sigmx; - double safmin; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASQ1 computes the singular values of a real N-by-N bidiagonal */ -/* matrix with diagonal D and off-diagonal E. The singular values */ -/* are computed to high relative accuracy, in the absence of */ -/* denormalization, underflow and overflow. The algorithm was first */ -/* presented in */ - -/* "Accurate singular values and differential qd algorithms" by K. V. */ -/* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, */ -/* 1994, */ - -/* and the present implementation is described in "An implementation of */ -/* the dqds Algorithm (Positive Case)", LAPACK Working Note. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of rows and columns in the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, D contains the diagonal elements of the */ -/* bidiagonal matrix whose SVD is desired. On normal exit, */ -/* D contains the singular values in decreasing order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, elements E(1:N-1) contain the off-diagonal elements */ -/* of the bidiagonal matrix whose SVD is desired. */ -/* On exit, E is overwritten. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: the algorithm failed */ -/* = 1, a split was marked by a positive value in E */ -/* = 2, current block of Z not diagonalized after 30*N */ -/* iterations (in inner while loop) */ -/* = 3, termination criterion of outer while loop not met */ -/* (program created more than N unreduced blocks) */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --work; - --e; - --d__; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -2; - i__1 = -(*info); - xerbla_("DLASQ1", &i__1); - return 0; - } else if (*n == 0) { - return 0; - } else if (*n == 1) { - d__[1] = abs(d__[1]); - return 0; - } else if (*n == 2) { - dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); - d__[1] = sigmx; - d__[2] = sigmn; - return 0; - } - -/* Estimate the largest singular value. */ - - sigmx = 0.; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = (d__1 = d__[i__], abs(d__1)); -/* Computing MAX */ - d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1)); - sigmx = std::max(d__2,d__3); -/* L10: */ - } - d__[*n] = (d__1 = d__[*n], abs(d__1)); - -/* Early return if SIGMX is zero (matrix is already diagonal). */ - - if (sigmx == 0.) { - dlasrt_("D", n, &d__[1], &iinfo); - return 0; - } - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = sigmx, d__2 = d__[i__]; - sigmx = std::max(d__1,d__2); -/* L20: */ - } - -/* Copy D and E into WORK (in the Z format) and scale (squaring the */ -/* input data makes scaling by a power of the radix pointless). */ - - eps = dlamch_("Precision"); - safmin = dlamch_("Safe minimum"); - scale = sqrt(eps / safmin); - dcopy_(n, &d__[1], &c__1, &work[1], &c__2); - i__1 = *n - 1; - dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2); - i__1 = (*n << 1) - 1; - i__2 = (*n << 1) - 1; - dlascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, - &iinfo); - -/* Compute the q's and e's. */ - - i__1 = (*n << 1) - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing 2nd power */ - d__1 = work[i__]; - work[i__] = d__1 * d__1; -/* L30: */ - } - work[*n * 2] = 0.; - - dlasq2_(n, &work[1], info); - - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = sqrt(work[i__]); -/* L40: */ - } - dlascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & - iinfo); - } - - return 0; - -/* End of DLASQ1 */ - -} /* dlasq1_ */ diff --git a/external/clapack/lapack/dlasq2.cpp b/external/clapack/lapack/dlasq2.cpp deleted file mode 100644 index 4eecfe38..00000000 --- a/external/clapack/lapack/dlasq2.cpp +++ /dev/null @@ -1,576 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__2 = 2; -static integer c__10 = 10; -static integer c__3 = 3; -static integer c__4 = 4; -static integer c__11 = 11; - -int dlasq2_(integer *n, double *z__, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - double d__1, d__2; - - /* Local variables */ - double d__, e, g; - integer k; - double s, t; - integer i0, i4, n0; - double dn; - integer pp; - double dn1, dn2, dee, eps, tau, tol; - integer ipn4; - double tol2; - bool ieee; - integer nbig; - double dmin__, emin, emax; - integer kmin, ndiv, iter; - double qmin, temp, qmax, zmax; - integer splt; - double dmin1, dmin2; - integer nfail; - double desig, trace, sigma; - integer iinfo, ttype; - double deemin; - integer iwhila, iwhilb; - double oldemn, safmin; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */ -/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */ -/* -- Berkeley -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASQ2 computes all the eigenvalues of the symmetric positive */ -/* definite tridiagonal matrix associated with the qd array Z to high */ -/* relative accuracy are computed to high relative accuracy, in the */ -/* absence of denormalization, underflow and overflow. */ - -/* To see the relation of Z to the tridiagonal matrix, let L be a */ -/* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and */ -/* let U be an upper bidiagonal matrix with 1's above and diagonal */ -/* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the */ -/* symmetric tridiagonal to which it is similar. */ - -/* Note : DLASQ2 defines a logical variable, IEEE, which is true */ -/* on machines which follow ieee-754 floating-point standard in their */ -/* handling of infinities and NaNs, and false otherwise. This variable */ -/* is passed to DLASQ3. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of rows and columns in the matrix. N >= 0. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension ( 4*N ) */ -/* On entry Z holds the qd array. On exit, entries 1 to N hold */ -/* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the */ -/* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If */ -/* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) */ -/* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of */ -/* shifts that failed. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if the i-th argument is a scalar and had an illegal */ -/* value, then INFO = -i, if the i-th argument is an */ -/* array and the j-entry had an illegal value, then */ -/* INFO = -(i*100+j) */ -/* > 0: the algorithm failed */ -/* = 1, a split was marked by a positive value in E */ -/* = 2, current block of Z not diagonalized after 30*N */ -/* iterations (in inner while loop) */ -/* = 3, termination criterion of outer while loop not met */ -/* (program created more than N unreduced blocks) */ - -/* Further Details */ -/* =============== */ -/* Local Variables: I0:N0 defines a current unreduced segment of Z. */ -/* The shifts are accumulated in SIGMA. Iteration count is in ITER. */ -/* Ping-pong is controlled by PP (alternates between 0 and 1). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments. */ -/* (in case DLASQ2 is not called by DLASQ1) */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - *info = 0; - eps = dlamch_("Precision"); - safmin = dlamch_("Safe minimum"); - tol = eps * 100.; -/* Computing 2nd power */ - d__1 = tol; - tol2 = d__1 * d__1; - - if (*n < 0) { - *info = -1; - xerbla_("DLASQ2", &c__1); - return 0; - } else if (*n == 0) { - return 0; - } else if (*n == 1) { - -/* 1-by-1 case. */ - - if (z__[1] < 0.) { - *info = -201; - xerbla_("DLASQ2", &c__2); - } - return 0; - } else if (*n == 2) { - -/* 2-by-2 case. */ - - if (z__[2] < 0. || z__[3] < 0.) { - *info = -2; - xerbla_("DLASQ2", &c__2); - return 0; - } else if (z__[3] > z__[1]) { - d__ = z__[3]; - z__[3] = z__[1]; - z__[1] = d__; - } - z__[5] = z__[1] + z__[2] + z__[3]; - if (z__[2] > z__[3] * tol2) { - t = (z__[1] - z__[3] + z__[2]) * .5; - s = z__[3] * (z__[2] / t); - if (s <= t) { - s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.))); - } else { - s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s))); - } - t = z__[1] + (s + z__[2]); - z__[3] *= z__[1] / t; - z__[1] = t; - } - z__[2] = z__[3]; - z__[6] = z__[2] + z__[1]; - return 0; - } - -/* Check for negative data and compute sums of q's and e's. */ - - z__[*n * 2] = 0.; - emin = z__[2]; - qmax = 0.; - zmax = 0.; - d__ = 0.; - e = 0.; - - i__1 = *n - 1 << 1; - for (k = 1; k <= i__1; k += 2) { - if (z__[k] < 0.) { - *info = -(k + 200); - xerbla_("DLASQ2", &c__2); - return 0; - } else if (z__[k + 1] < 0.) { - *info = -(k + 201); - xerbla_("DLASQ2", &c__2); - return 0; - } - d__ += z__[k]; - e += z__[k + 1]; -/* Computing MAX */ - d__1 = qmax, d__2 = z__[k]; - qmax = std::max (d__1,d__2); -/* Computing MIN */ - d__1 = emin, d__2 = z__[k + 1]; - emin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = std::max (qmax,zmax), d__2 = z__[k + 1]; - zmax = std::max (d__1,d__2); -/* L10: */ - } - if (z__[(*n << 1) - 1] < 0.) { - *info = -((*n << 1) + 199); - xerbla_("DLASQ2", &c__2); - return 0; - } - d__ += z__[(*n << 1) - 1]; -/* Computing MAX */ - d__1 = qmax, d__2 = z__[(*n << 1) - 1]; - qmax = std::max (d__1,d__2); - zmax = std::max (qmax,zmax); - -/* Check for diagonality. */ - - if (e == 0.) { - i__1 = *n; - for (k = 2; k <= i__1; ++k) { - z__[k] = z__[(k << 1) - 1]; -/* L20: */ - } - dlasrt_("D", n, &z__[1], &iinfo); - z__[(*n << 1) - 1] = d__; - return 0; - } - - trace = d__ + e; - -/* Check for zero data. */ - - if (trace == 0.) { - z__[(*n << 1) - 1] = 0.; - return 0; - } - -/* Check whether the machine is IEEE conformable. */ - - ieee = ilaenv_(&c__10, "DLASQ2", "N", &c__1, &c__2, &c__3, &c__4) == 1 && ilaenv_(&c__11, "DLASQ2", "N", &c__1, &c__2, - &c__3, &c__4) == 1; - -/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */ - - for (k = *n << 1; k >= 2; k += -2) { - z__[k * 2] = 0.; - z__[(k << 1) - 1] = z__[k]; - z__[(k << 1) - 2] = 0.; - z__[(k << 1) - 3] = z__[k - 1]; -/* L30: */ - } - - i0 = 1; - n0 = *n; - -/* Reverse the qd-array, if warranted. */ - - if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) { - ipn4 = i0 + n0 << 2; - i__1 = i0 + n0 - 1 << 1; - for (i4 = i0 << 2; i4 <= i__1; i4 += 4) { - temp = z__[i4 - 3]; - z__[i4 - 3] = z__[ipn4 - i4 - 3]; - z__[ipn4 - i4 - 3] = temp; - temp = z__[i4 - 1]; - z__[i4 - 1] = z__[ipn4 - i4 - 5]; - z__[ipn4 - i4 - 5] = temp; -/* L40: */ - } - } - -/* Initial split checking via dqd and Li's test. */ - - pp = 0; - - for (k = 1; k <= 2; ++k) { - - d__ = z__[(n0 << 2) + pp - 3]; - i__1 = (i0 << 2) + pp; - for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) { - if (z__[i4 - 1] <= tol2 * d__) { - z__[i4 - 1] = -0.; - d__ = z__[i4 - 3]; - } else { - d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1])); - } -/* L50: */ - } - -/* dqd maps Z to ZZ plus Li's test. */ - - emin = z__[(i0 << 2) + pp + 1]; - d__ = z__[(i0 << 2) + pp - 3]; - i__1 = (n0 - 1 << 2) + pp; - for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) { - z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1]; - if (z__[i4 - 1] <= tol2 * d__) { - z__[i4 - 1] = -0.; - z__[i4 - (pp << 1) - 2] = d__; - z__[i4 - (pp << 1)] = 0.; - d__ = z__[i4 + 1]; - } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] && - safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) { - temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2]; - z__[i4 - (pp << 1)] = z__[i4 - 1] * temp; - d__ *= temp; - } else { - z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - ( - pp << 1) - 2]); - d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]); - } -/* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - (pp << 1)]; - emin = std::min(d__1,d__2); -/* L60: */ - } - z__[(n0 << 2) - pp - 2] = d__; - -/* Now find qmax. */ - - qmax = z__[(i0 << 2) - pp - 2]; - i__1 = (n0 << 2) - pp - 2; - for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) { -/* Computing MAX */ - d__1 = qmax, d__2 = z__[i4]; - qmax = std::max (d__1,d__2); -/* L70: */ - } - -/* Prepare for the next iteration on K. */ - - pp = 1 - pp; -/* L80: */ - } - -/* Initialise variables to pass to DLASQ3. */ - - ttype = 0; - dmin1 = 0.; - dmin2 = 0.; - dn = 0.; - dn1 = 0.; - dn2 = 0.; - g = 0.; - tau = 0.; - - iter = 2; - nfail = 0; - ndiv = n0 - i0 << 1; - - i__1 = *n + 1; - for (iwhila = 1; iwhila <= i__1; ++iwhila) { - if (n0 < 1) { - goto L170; - } - -/* While array unfinished do */ - -/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */ -/* splits from the rest of the array, but is negated. */ - - desig = 0.; - if (n0 == *n) { - sigma = 0.; - } else { - sigma = -z__[(n0 << 2) - 1]; - } - if (sigma < 0.) { - *info = 1; - return 0; - } - -/* Find last unreduced submatrix's top index I0, find QMAX and */ -/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */ - - emax = 0.; - if (n0 > i0) { - emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1)); - } else { - emin = 0.; - } - qmin = z__[(n0 << 2) - 3]; - qmax = qmin; - for (i4 = n0 << 2; i4 >= 8; i4 += -4) { - if (z__[i4 - 5] <= 0.) { - goto L100; - } - if (qmin >= emax * 4.) { -/* Computing MIN */ - d__1 = qmin, d__2 = z__[i4 - 3]; - qmin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = emax, d__2 = z__[i4 - 5]; - emax = std::max (d__1,d__2); - } -/* Computing MAX */ - d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5]; - qmax = std::max (d__1,d__2); -/* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - 5]; - emin = std::min(d__1,d__2); -/* L90: */ - } - i4 = 4; - -L100: - i0 = i4 / 4; - pp = 0; - - if (n0 - i0 > 1) { - dee = z__[(i0 << 2) - 3]; - deemin = dee; - kmin = i0; - i__2 = (n0 << 2) - 3; - for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) { - dee = z__[i4] * (dee / (dee + z__[i4 - 2])); - if (dee <= deemin) { - deemin = dee; - kmin = (i4 + 3) / 4; - } -/* L110: */ - } - if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] * - .5) { - ipn4 = i0 + n0 << 2; - pp = 2; - i__2 = i0 + n0 - 1 << 1; - for (i4 = i0 << 2; i4 <= i__2; i4 += 4) { - temp = z__[i4 - 3]; - z__[i4 - 3] = z__[ipn4 - i4 - 3]; - z__[ipn4 - i4 - 3] = temp; - temp = z__[i4 - 2]; - z__[i4 - 2] = z__[ipn4 - i4 - 2]; - z__[ipn4 - i4 - 2] = temp; - temp = z__[i4 - 1]; - z__[i4 - 1] = z__[ipn4 - i4 - 5]; - z__[ipn4 - i4 - 5] = temp; - temp = z__[i4]; - z__[i4] = z__[ipn4 - i4 - 4]; - z__[ipn4 - i4 - 4] = temp; -/* L120: */ - } - } - } - -/* Put -(initial shift) into DMIN. */ - -/* Computing MAX */ - d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax); - dmin__ = -std::max (d__1,d__2); - -/* Now I0:N0 is unreduced. */ -/* PP = 0 for ping, PP = 1 for pong. */ -/* PP = 2 indicates that flipping was applied to the Z array and */ -/* and that the tests for deflation upon entry in DLASQ3 */ -/* should not be performed. */ - - nbig = (n0 - i0 + 1) * 30; - i__2 = nbig; - for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) { - if (i0 > n0) { - goto L150; - } - -/* While submatrix unfinished take a good dqds step. */ - - dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, & - nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, & - dn1, &dn2, &g, &tau); - - pp = 1 - pp; - -/* When EMIN is very small check for splits. */ - - if (pp == 0 && n0 - i0 >= 3) { - if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * - sigma) { - splt = i0 - 1; - qmax = z__[(i0 << 2) - 3]; - emin = z__[(i0 << 2) - 1]; - oldemn = z__[i0 * 4]; - i__3 = n0 - 3 << 2; - for (i4 = i0 << 2; i4 <= i__3; i4 += 4) { - if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= - tol2 * sigma) { - z__[i4 - 1] = -sigma; - splt = i4 / 4; - qmax = 0.; - emin = z__[i4 + 3]; - oldemn = z__[i4 + 4]; - } else { -/* Computing MAX */ - d__1 = qmax, d__2 = z__[i4 + 1]; - qmax = std::max (d__1,d__2); -/* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - 1]; - emin = std::min(d__1,d__2); -/* Computing MIN */ - d__1 = oldemn, d__2 = z__[i4]; - oldemn = std::min(d__1,d__2); - } -/* L130: */ - } - z__[(n0 << 2) - 1] = emin; - z__[n0 * 4] = oldemn; - i0 = splt + 1; - } - } - -/* L140: */ - } - - *info = 2; - return 0; - -/* end IWHILB */ - -L150: - -/* L160: */ - ; - } - - *info = 3; - return 0; - -/* end IWHILA */ - -L170: - -/* Move q's to the front. */ - - i__1 = *n; - for (k = 2; k <= i__1; ++k) { - z__[k] = z__[(k << 2) - 3]; -/* L180: */ - } - -/* Sort and compute sum of eigenvalues. */ - - dlasrt_("D", n, &z__[1], &iinfo); - - e = 0.; - for (k = *n; k >= 1; --k) { - e += z__[k]; -/* L190: */ - } - -/* Store trace, sum(eigenvalues) and information on performance. */ - - z__[(*n << 1) + 1] = trace; - z__[(*n << 1) + 2] = e; - z__[(*n << 1) + 3] = (double) iter; -/* Computing 2nd power */ - i__1 = *n; - z__[(*n << 1) + 4] = (double) ndiv / (double) (i__1 * i__1); - z__[(*n << 1) + 5] = nfail * 100. / (double) iter; - return 0; - -/* End of DLASQ2 */ - -} /* dlasq2_ */ diff --git a/external/clapack/lapack/dlasq3.cpp b/external/clapack/lapack/dlasq3.cpp deleted file mode 100644 index 2cca4a83..00000000 --- a/external/clapack/lapack/dlasq3.cpp +++ /dev/null @@ -1,321 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dlasq3_(integer *i0, integer *n0, double *z__, integer *pp, double *dmin__, double *sigma, - double *desig, double *qmax, integer *nfail, integer *iter, integer *ndiv, bool *ieee, - integer *ttype, double *dmin1, double *dmin2, double *dn, double *dn1, double *dn2, - double *g, double *tau) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - double s, t; - integer j4, nn; - double eps, tol; - integer n0in, ipn4; - double tol2, temp; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */ -/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */ -/* -- Berkeley -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */ -/* In case of failure it changes shifts, and tries again until output */ -/* is positive. */ - -/* Arguments */ -/* ========= */ - -/* I0 (input) INTEGER */ -/* First index. */ - -/* N0 (input) INTEGER */ -/* Last index. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ -/* Z holds the qd array. */ - -/* PP (input/output) INTEGER */ -/* PP=0 for ping, PP=1 for pong. */ -/* PP=2 indicates that flipping was applied to the Z array */ -/* and that the initial tests for deflation should not be */ -/* performed. */ - -/* DMIN (output) DOUBLE PRECISION */ -/* Minimum value of d. */ - -/* SIGMA (output) DOUBLE PRECISION */ -/* Sum of shifts used in current segment. */ - -/* DESIG (input/output) DOUBLE PRECISION */ -/* Lower order part of SIGMA */ - -/* QMAX (input) DOUBLE PRECISION */ -/* Maximum value of q. */ - -/* NFAIL (output) INTEGER */ -/* Number of times shift was too big. */ - -/* ITER (output) INTEGER */ -/* Number of iterations. */ - -/* NDIV (output) INTEGER */ -/* Number of divisions. */ - -/* IEEE (input) LOGICAL */ -/* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). */ - -/* TTYPE (input/output) INTEGER */ -/* Shift type. */ - -/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) DOUBLE PRECISION */ -/* These are passed as arguments in order to save their values */ -/* between calls to DLASQ3. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Function .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - n0in = *n0; - eps = dlamch_("Precision"); - tol = eps * 100.; -/* Computing 2nd power */ - d__1 = tol; - tol2 = d__1 * d__1; - -/* Check for deflation. */ - -L10: - - if (*n0 < *i0) { - return 0; - } - if (*n0 == *i0) { - goto L20; - } - nn = (*n0 << 2) + *pp; - if (*n0 == *i0 + 1) { - goto L40; - } - -/* Check whether E(N0-1) is negligible, 1 eigenvalue. */ - - if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - - 4] > tol2 * z__[nn - 7]) { - goto L30; - } - -L20: - - z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma; - --(*n0); - goto L10; - -/* Check whether E(N0-2) is negligible, 2 eigenvalues. */ - -L30: - - if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ - nn - 11]) { - goto L50; - } - -L40: - - if (z__[nn - 3] > z__[nn - 7]) { - s = z__[nn - 3]; - z__[nn - 3] = z__[nn - 7]; - z__[nn - 7] = s; - } - if (z__[nn - 5] > z__[nn - 3] * tol2) { - t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; - s = z__[nn - 3] * (z__[nn - 5] / t); - if (s <= t) { - s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); - } else { - s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); - } - t = z__[nn - 7] + (s + z__[nn - 5]); - z__[nn - 3] *= z__[nn - 7] / t; - z__[nn - 7] = t; - } - z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; - z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; - *n0 += -2; - goto L10; - -L50: - if (*pp == 2) { - *pp = 0; - } - -/* Reverse the qd-array, if warranted. */ - - if (*dmin__ <= 0. || *n0 < n0in) { - if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { - ipn4 = *i0 + *n0 << 2; - i__1 = *i0 + *n0 - 1 << 1; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - temp = z__[j4 - 3]; - z__[j4 - 3] = z__[ipn4 - j4 - 3]; - z__[ipn4 - j4 - 3] = temp; - temp = z__[j4 - 2]; - z__[j4 - 2] = z__[ipn4 - j4 - 2]; - z__[ipn4 - j4 - 2] = temp; - temp = z__[j4 - 1]; - z__[j4 - 1] = z__[ipn4 - j4 - 5]; - z__[ipn4 - j4 - 5] = temp; - temp = z__[j4]; - z__[j4] = z__[ipn4 - j4 - 4]; - z__[ipn4 - j4 - 4] = temp; -/* L60: */ - } - if (*n0 - *i0 <= 4) { - z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; - z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; - } -/* Computing MIN */ - d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; - *dmin2 = std::min(d__1,d__2); -/* Computing MIN */ - d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1] - , d__1 = std::min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; - z__[(*n0 << 2) + *pp - 1] = std::min(d__1,d__2); -/* Computing MIN */ - d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = - std::min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4]; - z__[(*n0 << 2) - *pp] = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = std::max(d__1, - d__2), d__2 = z__[(*i0 << 2) + *pp + 1]; - *qmax = std::max(d__1,d__2); - *dmin__ = -0.; - } - } - -/* Choose a shift. */ - - dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g); - -/* Call dqds until DMIN > 0. */ - -L70: - - dlasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2, - ieee); - - *ndiv += *n0 - *i0 + 2; - ++(*iter); - -/* Check status. */ - - if (*dmin__ >= 0. && *dmin1 > 0.) { - -/* Success. */ - - goto L90; - - } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol - * (*sigma + *dn1) && abs(*dn) < tol * *sigma) { - -/* Convergence hidden by negative DN. */ - - z__[(*n0 - 1 << 2) - *pp + 2] = 0.; - *dmin__ = 0.; - goto L90; - } else if (*dmin__ < 0.) { - -/* TAU too big. Select new TAU and try again. */ - - ++(*nfail); - if (*ttype < -22) { - -/* Failed twice. Play it safe. */ - - *tau = 0.; - } else if (*dmin1 > 0.) { - -/* Late failure. Gives excellent shift. */ - - *tau = (*tau + *dmin__) * (1. - eps * 2.); - *ttype += -11; - } else { - -/* Early failure. Divide by 4. */ - - *tau *= .25; - *ttype += -12; - } - goto L70; - } else if (disnan_(dmin__)) { - -/* NaN. */ - - if (*tau == 0.) { - goto L80; - } else { - *tau = 0.; - goto L70; - } - } else { - -/* Possible underflow. Play it safe. */ - - goto L80; - } - -/* Risk of underflow. */ - -L80: - dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2); - *ndiv += *n0 - *i0 + 2; - ++(*iter); - *tau = 0.; - -L90: - if (*tau < *sigma) { - *desig += *tau; - t = *sigma + *desig; - *desig -= t - *sigma; - } else { - t = *sigma + *tau; - *desig = *sigma - (t - *tau) + *desig; - } - *sigma = t; - - return 0; - -/* End of DLASQ3 */ - -} /* dlasq3_ */ diff --git a/external/clapack/lapack/dlasq4.cpp b/external/clapack/lapack/dlasq4.cpp deleted file mode 100644 index e450404e..00000000 --- a/external/clapack/lapack/dlasq4.cpp +++ /dev/null @@ -1,388 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dlasq4_(integer *i0, integer *n0, double *z__, - integer *pp, integer *n0in, double *dmin__, double *dmin1, - double *dmin2, double *dn, double *dn1, double *dn2, - double *tau, integer *ttype, double *g) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - double s, a2, b1, b2; - integer i4, nn, np; - double gam, gap1, gap2; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */ -/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */ -/* -- Berkeley -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASQ4 computes an approximation TAU to the smallest eigenvalue */ -/* using values of d from the previous transform. */ - -/* I0 (input) INTEGER */ -/* First index. */ - -/* N0 (input) INTEGER */ -/* Last index. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ -/* Z holds the qd array. */ - -/* PP (input) INTEGER */ -/* PP=0 for ping, PP=1 for pong. */ - -/* NOIN (input) INTEGER */ -/* The value of N0 at start of EIGTEST. */ - -/* DMIN (input) DOUBLE PRECISION */ -/* Minimum value of d. */ - -/* DMIN1 (input) DOUBLE PRECISION */ -/* Minimum value of d, excluding D( N0 ). */ - -/* DMIN2 (input) DOUBLE PRECISION */ -/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ - -/* DN (input) DOUBLE PRECISION */ -/* d(N) */ - -/* DN1 (input) DOUBLE PRECISION */ -/* d(N-1) */ - -/* DN2 (input) DOUBLE PRECISION */ -/* d(N-2) */ - -/* TAU (output) DOUBLE PRECISION */ -/* This is the shift. */ - -/* TTYPE (output) INTEGER */ -/* Shift type. */ - -/* G (input/output) REAL */ -/* G is passed as an argument in order to save its value between */ -/* calls to DLASQ4. */ - -/* Further Details */ -/* =============== */ -/* CNST1 = 9/16 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* A negative DMIN forces the shift to take that absolute value */ -/* TTYPE records the type of shift. */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - if (*dmin__ <= 0.) { - *tau = -(*dmin__); - *ttype = -1; - return 0; - } - - nn = (*n0 << 2) + *pp; - if (*n0in == *n0) { - -/* No eigenvalues deflated. */ - - if (*dmin__ == *dn || *dmin__ == *dn1) { - - b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); - b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); - a2 = z__[nn - 7] + z__[nn - 5]; - -/* Cases 2 and 3. */ - - if (*dmin__ == *dn && *dmin1 == *dn1) { - gap2 = *dmin2 - a2 - *dmin2 * .25; - if (gap2 > 0. && gap2 > b2) { - gap1 = a2 - *dn - b2 / gap2 * b2; - } else { - gap1 = a2 - *dn - (b1 + b2); - } - if (gap1 > 0. && gap1 > b1) { -/* Computing MAX */ - d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; - s = std::max(d__1,d__2); - *ttype = -2; - } else { - s = 0.; - if (*dn > b1) { - s = *dn - b1; - } - if (a2 > b1 + b2) { -/* Computing MIN */ - d__1 = s, d__2 = a2 - (b1 + b2); - s = std::min(d__1,d__2); - } -/* Computing MAX */ - d__1 = s, d__2 = *dmin__ * .333; - s = std::max(d__1,d__2); - *ttype = -3; - } - } else { - -/* Case 4. */ - - *ttype = -4; - s = *dmin__ * .25; - if (*dmin__ == *dn) { - gam = *dn; - a2 = 0.; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b2 = z__[nn - 5] / z__[nn - 7]; - np = nn - 9; - } else { - np = nn - (*pp << 1); - b2 = z__[np - 2]; - gam = *dn1; - if (z__[np - 4] > z__[np - 2]) { - return 0; - } - a2 = z__[np - 4] / z__[np - 2]; - if (z__[nn - 9] > z__[nn - 11]) { - return 0; - } - b2 = z__[nn - 9] / z__[nn - 11]; - np = nn - 13; - } - -/* Approximate contribution to norm squared from I < NN-1. */ - - a2 += b2; - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = np; i4 >= i__1; i4 += -4) { - if (b2 == 0.) { - goto L20; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (std::max(b2,b1) * 100. < a2 || .563 < a2) { - goto L20; - } -/* L10: */ - } -L20: - a2 *= 1.05; - -/* Rayleigh quotient residual bound. */ - - if (a2 < .563) { - s = gam * (1. - sqrt(a2)) / (a2 + 1.); - } - } - } else if (*dmin__ == *dn2) { - -/* Case 5. */ - - *ttype = -5; - s = *dmin__ * .25; - -/* Compute contribution to norm squared from I > NN-2. */ - - np = nn - (*pp << 1); - b1 = z__[np - 2]; - b2 = z__[np - 6]; - gam = *dn2; - if (z__[np - 8] > b2 || z__[np - 4] > b1) { - return 0; - } - a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); - -/* Approximate contribution to norm squared from I < NN-2. */ - - if (*n0 - *i0 > 2) { - b2 = z__[nn - 13] / z__[nn - 15]; - a2 += b2; - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = nn - 17; i4 >= i__1; i4 += -4) { - if (b2 == 0.) { - goto L40; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (std::max(b2,b1) * 100. < a2 || .563 < a2) { - goto L40; - } -/* L30: */ - } -L40: - a2 *= 1.05; - } - - if (a2 < .563) { - s = gam * (1. - sqrt(a2)) / (a2 + 1.); - } - } else { - -/* Case 6, no information to guide us. */ - - if (*ttype == -6) { - *g += (1. - *g) * .333; - } else if (*ttype == -18) { - *g = .083250000000000005; - } else { - *g = .25; - } - s = *g * *dmin__; - *ttype = -6; - } - - } else if (*n0in == *n0 + 1) { - -/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */ - - if (*dmin1 == *dn1 && *dmin2 == *dn2) { - -/* Cases 7 and 8. */ - - *ttype = -7; - s = *dmin1 * .333; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.) { - goto L60; - } - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { - a2 = b1; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b1 *= z__[i4] / z__[i4 - 2]; - b2 += b1; - if (std::max(b1,a2) * 100. < b2) { - goto L60; - } -/* L50: */ - } -L60: - b2 = sqrt(b2 * 1.05); -/* Computing 2nd power */ - d__1 = b2; - a2 = *dmin1 / (d__1 * d__1 + 1.); - gap2 = *dmin2 * .5 - a2; - if (gap2 > 0. && gap2 > b2 * a2) { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); - s = std::max(d__1,d__2); - } else { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - b2 * 1.01); - s = std::max(d__1,d__2); - *ttype = -8; - } - } else { - -/* Case 9. */ - - s = *dmin1 * .25; - if (*dmin1 == *dn1) { - s = *dmin1 * .5; - } - *ttype = -9; - } - - } else if (*n0in == *n0 + 2) { - -/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */ - -/* Cases 10 and 11. */ - - if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { - *ttype = -10; - s = *dmin2 * .333; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.) { - goto L80; - } - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b1 *= z__[i4] / z__[i4 - 2]; - b2 += b1; - if (b1 * 100. < b2) { - goto L80; - } -/* L70: */ - } -L80: - b2 = sqrt(b2 * 1.05); -/* Computing 2nd power */ - d__1 = b2; - a2 = *dmin2 / (d__1 * d__1 + 1.); - gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ - nn - 9]) - a2; - if (gap2 > 0. && gap2 > b2 * a2) { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); - s = std::max(d__1,d__2); - } else { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - b2 * 1.01); - s = std::max(d__1,d__2); - } - } else { - s = *dmin2 * .25; - *ttype = -11; - } - } else if (*n0in > *n0 + 2) { - -/* Case 12, more than two eigenvalues deflated. No information. */ - - s = 0.; - *ttype = -12; - } - - *tau = s; - return 0; - -/* End of DLASQ4 */ - -} /* dlasq4_ */ diff --git a/external/clapack/lapack/dlasq5.cpp b/external/clapack/lapack/dlasq5.cpp deleted file mode 100644 index a5480e69..00000000 --- a/external/clapack/lapack/dlasq5.cpp +++ /dev/null @@ -1,222 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlasq5_(integer *i0, integer *n0, double *z__, - integer *pp, double *tau, double *dmin__, double *dmin1, - double *dmin2, double *dn, double *dnm1, double *dnm2, - bool *ieee) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - double d__; - integer j4, j4p2; - double emin, temp; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASQ5 computes one dqds transform in ping-pong form, one */ -/* version for IEEE machines another for non IEEE machines. */ - -/* Arguments */ -/* ========= */ - -/* I0 (input) INTEGER */ -/* First index. */ - -/* N0 (input) INTEGER */ -/* Last index. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ -/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */ -/* an extra argument. */ - -/* PP (input) INTEGER */ -/* PP=0 for ping, PP=1 for pong. */ - -/* TAU (input) DOUBLE PRECISION */ -/* This is the shift. */ - -/* DMIN (output) DOUBLE PRECISION */ -/* Minimum value of d. */ - -/* DMIN1 (output) DOUBLE PRECISION */ -/* Minimum value of d, excluding D( N0 ). */ - -/* DMIN2 (output) DOUBLE PRECISION */ -/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ - -/* DN (output) DOUBLE PRECISION */ -/* d(N0), the last value of d. */ - -/* DNM1 (output) DOUBLE PRECISION */ -/* d(N0-1). */ - -/* DNM2 (output) DOUBLE PRECISION */ -/* d(N0-2). */ - -/* IEEE (input) LOGICAL */ -/* Flag for IEEE or non IEEE arithmetic. */ - -/* ===================================================================== */ - -/* .. Parameter .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - if (*n0 - *i0 - 1 <= 0) { - return 0; - } - - j4 = (*i0 << 2) + *pp - 3; - emin = z__[j4 + 4]; - d__ = z__[j4] - *tau; - *dmin__ = d__; - *dmin1 = -z__[j4]; - - if (*ieee) { - -/* Code for IEEE arithmetic. */ - - if (*pp == 0) { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - temp = z__[j4 + 1] / z__[j4 - 2]; - d__ = d__ * temp - *tau; - *dmin__ = std::min(*dmin__,d__); - z__[j4] = z__[j4 - 1] * temp; -/* Computing MIN */ - d__1 = z__[j4]; - emin = std::min(d__1,emin); -/* L10: */ - } - } else { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - temp = z__[j4 + 2] / z__[j4 - 3]; - d__ = d__ * temp - *tau; - *dmin__ = std::min(*dmin__,d__); - z__[j4 - 1] = z__[j4] * temp; -/* Computing MIN */ - d__1 = z__[j4 - 1]; - emin = std::min(d__1,emin); -/* L20: */ - } - } - -/* Unroll last two steps. */ - - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = (*n0 - 2 << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - *dmin__ = std::min(*dmin__,*dnm1); - - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - *dmin__ = std::min(*dmin__,*dn); - - } else { - -/* Code for non IEEE arithmetic. */ - - if (*pp == 0) { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - if (d__ < 0.) { - return 0; - } else { - z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); - d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; - } - *dmin__ = std::min(*dmin__,d__); -/* Computing MIN */ - d__1 = emin, d__2 = z__[j4]; - emin = std::min(d__1,d__2); -/* L30: */ - } - } else { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - if (d__ < 0.) { - return 0; - } else { - z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); - d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; - } - *dmin__ = std::min(*dmin__,d__); -/* Computing MIN */ - d__1 = emin, d__2 = z__[j4 - 1]; - emin = std::min(d__1,d__2); -/* L40: */ - } - } - -/* Unroll last two steps. */ - - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = (*n0 - 2 << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - if (*dnm2 < 0.) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - } - *dmin__ = std::min(*dmin__,*dnm1); - - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - if (*dnm1 < 0.) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - } - *dmin__ = std::min(*dmin__,*dn); - - } - - z__[j4 + 2] = *dn; - z__[(*n0 << 2) - *pp] = emin; - return 0; - -/* End of DLASQ5 */ - -} /* dlasq5_ */ diff --git a/external/clapack/lapack/dlasq6.cpp b/external/clapack/lapack/dlasq6.cpp deleted file mode 100644 index 976f91ed..00000000 --- a/external/clapack/lapack/dlasq6.cpp +++ /dev/null @@ -1,194 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlasq6_(integer *i0, integer *n0, double *z__, - integer *pp, double *dmin__, double *dmin1, double *dmin2, - double *dn, double *dnm1, double *dnm2) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - double d__; - integer j4, j4p2; - double emin, temp; - - double safmin; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASQ6 computes one dqd (shift equal to zero) transform in */ -/* ping-pong form, with protection against underflow and overflow. */ - -/* Arguments */ -/* ========= */ - -/* I0 (input) INTEGER */ -/* First index. */ - -/* N0 (input) INTEGER */ -/* Last index. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ -/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */ -/* an extra argument. */ - -/* PP (input) INTEGER */ -/* PP=0 for ping, PP=1 for pong. */ - -/* DMIN (output) DOUBLE PRECISION */ -/* Minimum value of d. */ - -/* DMIN1 (output) DOUBLE PRECISION */ -/* Minimum value of d, excluding D( N0 ). */ - -/* DMIN2 (output) DOUBLE PRECISION */ -/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ - -/* DN (output) DOUBLE PRECISION */ -/* d(N0), the last value of d. */ - -/* DNM1 (output) DOUBLE PRECISION */ -/* d(N0-1). */ - -/* DNM2 (output) DOUBLE PRECISION */ -/* d(N0-2). */ - -/* ===================================================================== */ - -/* .. Parameter .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Function .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - if (*n0 - *i0 - 1 <= 0) { - return 0; - } - - safmin = dlamch_("Safe minimum"); - j4 = (*i0 << 2) + *pp - 3; - emin = z__[j4 + 4]; - d__ = z__[j4]; - *dmin__ = d__; - - if (*pp == 0) { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - d__ = z__[j4 + 1]; - *dmin__ = d__; - emin = 0.; - } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 - - 2] < z__[j4 + 1]) { - temp = z__[j4 + 1] / z__[j4 - 2]; - z__[j4] = z__[j4 - 1] * temp; - d__ *= temp; - } else { - z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); - d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); - } - *dmin__ = std::min(*dmin__,d__); -/* Computing MIN */ - d__1 = emin, d__2 = z__[j4]; - emin = std::min(d__1,d__2); -/* L10: */ - } - } else { - i__1 = *n0 - 3 << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - if (z__[j4 - 3] == 0.) { - z__[j4 - 1] = 0.; - d__ = z__[j4 + 2]; - *dmin__ = d__; - emin = 0.; - } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 - - 3] < z__[j4 + 2]) { - temp = z__[j4 + 2] / z__[j4 - 3]; - z__[j4 - 1] = z__[j4] * temp; - d__ *= temp; - } else { - z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); - d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); - } - *dmin__ = std::min(*dmin__,d__); -/* Computing MIN */ - d__1 = emin, d__2 = z__[j4 - 1]; - emin = std::min(d__1,d__2); -/* L20: */ - } - } - -/* Unroll last two steps. */ - - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = (*n0 - 2 << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - *dnm1 = z__[j4p2 + 2]; - *dmin__ = *dnm1; - emin = 0.; - } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < - z__[j4p2 + 2]) { - temp = z__[j4p2 + 2] / z__[j4 - 2]; - z__[j4] = z__[j4p2] * temp; - *dnm1 = *dnm2 * temp; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); - } - *dmin__ = std::min(*dmin__,*dnm1); - - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - *dn = z__[j4p2 + 2]; - *dmin__ = *dn; - emin = 0.; - } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < - z__[j4p2 + 2]) { - temp = z__[j4p2 + 2] / z__[j4 - 2]; - z__[j4] = z__[j4p2] * temp; - *dn = *dnm1 * temp; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); - } - *dmin__ = std::min(*dmin__,*dn); - - z__[j4 + 2] = *dn; - z__[(*n0 << 2) - *pp] = emin; - return 0; - -/* End of DLASQ6 */ - -} /* dlasq6_ */ diff --git a/external/clapack/lapack/dlasr.cpp b/external/clapack/lapack/dlasr.cpp deleted file mode 100644 index 78f7e56a..00000000 --- a/external/clapack/lapack/dlasr.cpp +++ /dev/null @@ -1,441 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlasr_(const char *side, const char *pivot, const char *direct, integer *m, - integer *n, double *c__, double *s, double *a, integer * - lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, info; - double temp; - - double ctemp, stemp; - - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASR applies a sequence of plane rotations to a real matrix A, */ -/* from either the left or the right. */ - -/* When SIDE = 'L', the transformation takes the form */ - -/* A := P*A */ - -/* and when SIDE = 'R', the transformation takes the form */ - -/* A := A*P**T */ - -/* where P is an orthogonal matrix consisting of a sequence of z plane */ -/* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */ -/* and P**T is the transpose of P. */ - -/* When DIRECT = 'F' (Forward sequence), then */ - -/* P = P(z-1) * ... * P(2) * P(1) */ - -/* and when DIRECT = 'B' (Backward sequence), then */ - -/* P = P(1) * P(2) * ... * P(z-1) */ - -/* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */ - -/* R(k) = ( c(k) s(k) ) */ -/* = ( -s(k) c(k) ). */ - -/* When PIVOT = 'V' (Variable pivot), the rotation is performed */ -/* for the plane (k,k+1), i.e., P(k) has the form */ - -/* P(k) = ( 1 ) */ -/* ( ... ) */ -/* ( 1 ) */ -/* ( c(k) s(k) ) */ -/* ( -s(k) c(k) ) */ -/* ( 1 ) */ -/* ( ... ) */ -/* ( 1 ) */ - -/* where R(k) appears as a rank-2 modification to the identity matrix in */ -/* rows and columns k and k+1. */ - -/* When PIVOT = 'T' (Top pivot), the rotation is performed for the */ -/* plane (1,k+1), so P(k) has the form */ - -/* P(k) = ( c(k) s(k) ) */ -/* ( 1 ) */ -/* ( ... ) */ -/* ( 1 ) */ -/* ( -s(k) c(k) ) */ -/* ( 1 ) */ -/* ( ... ) */ -/* ( 1 ) */ - -/* where R(k) appears in rows and columns 1 and k+1. */ - -/* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */ -/* performed for the plane (k,z), giving P(k) the form */ - -/* P(k) = ( 1 ) */ -/* ( ... ) */ -/* ( 1 ) */ -/* ( c(k) s(k) ) */ -/* ( 1 ) */ -/* ( ... ) */ -/* ( 1 ) */ -/* ( -s(k) c(k) ) */ - -/* where R(k) appears in rows and columns k and z. The rotations are */ -/* performed without ever forming P(k) explicitly. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* Specifies whether the plane rotation matrix P is applied to */ -/* A on the left or the right. */ -/* = 'L': Left, compute A := P*A */ -/* = 'R': Right, compute A:= A*P**T */ - -/* PIVOT (input) CHARACTER*1 */ -/* Specifies the plane for which P(k) is a plane rotation */ -/* matrix. */ -/* = 'V': Variable pivot, the plane (k,k+1) */ -/* = 'T': Top pivot, the plane (1,k+1) */ -/* = 'B': Bottom pivot, the plane (k,z) */ - -/* DIRECT (input) CHARACTER*1 */ -/* Specifies whether P is a forward or backward sequence of */ -/* plane rotations. */ -/* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */ -/* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. If m <= 1, an immediate */ -/* return is effected. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. If n <= 1, an */ -/* immediate return is effected. */ - -/* C (input) DOUBLE PRECISION array, dimension */ -/* (M-1) if SIDE = 'L' */ -/* (N-1) if SIDE = 'R' */ -/* The cosines c(k) of the plane rotations. */ - -/* S (input) DOUBLE PRECISION array, dimension */ -/* (M-1) if SIDE = 'L' */ -/* (N-1) if SIDE = 'R' */ -/* The sines s(k) of the plane rotations. The 2-by-2 plane */ -/* rotation part of the matrix P(k), R(k), has the form */ -/* R(k) = ( c(k) s(k) ) */ -/* ( -s(k) c(k) ). */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The M-by-N matrix A. On exit, A is overwritten by P*A if */ -/* SIDE = 'R' or by A*P**T if SIDE = 'L'. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - --c__; - --s; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - info = 0; - if (! (lsame_(side, "L") || lsame_(side, "R"))) { - info = 1; - } else if (! (lsame_(pivot, "V") || lsame_(pivot, - "T") || lsame_(pivot, "B"))) { - info = 2; - } else if (! (lsame_(direct, "F") || lsame_(direct, - "B"))) { - info = 3; - } else if (*m < 0) { - info = 4; - } else if (*n < 0) { - info = 5; - } else if (*lda < std::max(1_integer,*m)) { - info = 9; - } - if (info != 0) { - xerbla_("DLASR ", &info); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - if (lsame_(side, "L")) { - -/* Form P * A */ - - if (lsame_(pivot, "V")) { - if (lsame_(direct, "F")) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[j + 1 + i__ * a_dim1]; - a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * - a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j - + i__ * a_dim1]; -/* L10: */ - } - } -/* L20: */ - } - } else if (lsame_(direct, "B")) { - for (j = *m - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[j + 1 + i__ * a_dim1]; - a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * - a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j - + i__ * a_dim1]; -/* L30: */ - } - } -/* L40: */ - } - } - } else if (lsame_(pivot, "T")) { - if (lsame_(direct, "F")) { - i__1 = *m; - for (j = 2; j <= i__1; ++j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ - i__ * a_dim1 + 1]; - a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ - i__ * a_dim1 + 1]; -/* L50: */ - } - } -/* L60: */ - } - } else if (lsame_(direct, "B")) { - for (j = *m; j >= 2; --j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ - i__ * a_dim1 + 1]; - a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ - i__ * a_dim1 + 1]; -/* L70: */ - } - } -/* L80: */ - } - } - } else if (lsame_(pivot, "B")) { - if (lsame_(direct, "F")) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] - + ctemp * temp; - a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * - a_dim1] - stemp * temp; -/* L90: */ - } - } -/* L100: */ - } - } else if (lsame_(direct, "B")) { - for (j = *m - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[j + i__ * a_dim1]; - a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] - + ctemp * temp; - a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * - a_dim1] - stemp * temp; -/* L110: */ - } - } -/* L120: */ - } - } - } - } else if (lsame_(side, "R")) { - -/* Form A * P' */ - - if (lsame_(pivot, "V")) { - if (lsame_(direct, "F")) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[i__ + (j + 1) * a_dim1]; - a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * - a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ - i__ + j * a_dim1]; -/* L130: */ - } - } -/* L140: */ - } - } else if (lsame_(direct, "B")) { - for (j = *n - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[i__ + (j + 1) * a_dim1]; - a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * - a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ - i__ + j * a_dim1]; -/* L150: */ - } - } -/* L160: */ - } - } - } else if (lsame_(pivot, "T")) { - if (lsame_(direct, "F")) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ - i__ + a_dim1]; - a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + - a_dim1]; -/* L170: */ - } - } -/* L180: */ - } - } else if (lsame_(direct, "B")) { - for (j = *n; j >= 2; --j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ - i__ + a_dim1]; - a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + - a_dim1]; -/* L190: */ - } - } -/* L200: */ - } - } - } else if (lsame_(pivot, "B")) { - if (lsame_(direct, "F")) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] - + ctemp * temp; - a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * - a_dim1] - stemp * temp; -/* L210: */ - } - } -/* L220: */ - } - } else if (lsame_(direct, "B")) { - for (j = *n - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a[i__ + j * a_dim1]; - a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] - + ctemp * temp; - a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * - a_dim1] - stemp * temp; -/* L230: */ - } - } -/* L240: */ - } - } - } - } - - return 0; - -/* End of DLASR */ - -} /* dlasr_ */ diff --git a/external/clapack/lapack/dlasrt.cpp b/external/clapack/lapack/dlasrt.cpp deleted file mode 100644 index c9aee5bf..00000000 --- a/external/clapack/lapack/dlasrt.cpp +++ /dev/null @@ -1,274 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlasrt_(const char *id, integer *n, double *d__, integer * - info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, j; - double d1, d2, d3; - integer dir; - double tmp; - integer endd; - - integer stack[64] /* was [2][32] */; - double dmnmx; - integer start; - - integer stkpnt; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Sort the numbers in D in increasing order (if ID = 'I') or */ -/* in decreasing order (if ID = 'D' ). */ - -/* Use Quick Sort, reverting to Insertion sort on arrays of */ -/* size <= 20. Dimension of STACK limits N to about 2**32. */ - -/* Arguments */ -/* ========= */ - -/* ID (input) CHARACTER*1 */ -/* = 'I': sort D in increasing order; */ -/* = 'D': sort D in decreasing order. */ - -/* N (input) INTEGER */ -/* The length of the array D. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the array to be sorted. */ -/* On exit, D has been sorted into increasing order */ -/* (D(1) <= ... <= D(N) ) or into decreasing order */ -/* (D(1) >= ... >= D(N) ), depending on ID. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input paramters. */ - - /* Parameter adjustments */ - --d__; - - /* Function Body */ - *info = 0; - dir = -1; - if (lsame_(id, "D")) { - dir = 0; - } else if (lsame_(id, "I")) { - dir = 1; - } - if (dir == -1) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASRT", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 1) { - return 0; - } - - stkpnt = 1; - stack[0] = 1; - stack[1] = *n; -L10: - start = stack[(stkpnt << 1) - 2]; - endd = stack[(stkpnt << 1) - 1]; - --stkpnt; - if (endd - start <= 20 && endd - start > 0) { - -/* Do Insertion sort on D( START:ENDD ) */ - - if (dir == 0) { - -/* Sort into decreasing order */ - - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] > d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L30; - } -/* L20: */ - } -L30: - ; - } - - } else { - -/* Sort into increasing order */ - - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] < d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L50; - } -/* L40: */ - } -L50: - ; - } - - } - - } else if (endd - start > 20) { - -/* Partition D( START:ENDD ) and stack parts, largest one first */ - -/* Choose partition entry as median of 3 */ - - d1 = d__[start]; - d2 = d__[endd]; - i__ = (start + endd) / 2; - d3 = d__[i__]; - if (d1 < d2) { - if (d3 < d1) { - dmnmx = d1; - } else if (d3 < d2) { - dmnmx = d3; - } else { - dmnmx = d2; - } - } else { - if (d3 < d2) { - dmnmx = d2; - } else if (d3 < d1) { - dmnmx = d3; - } else { - dmnmx = d1; - } - } - - if (dir == 0) { - -/* Sort into decreasing order */ - - i__ = start - 1; - j = endd + 1; -L60: -L70: - --j; - if (d__[j] < dmnmx) { - goto L70; - } -L80: - ++i__; - if (d__[i__] > dmnmx) { - goto L80; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L60; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - } else { - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - } - } else { - -/* Sort into increasing order */ - - i__ = start - 1; - j = endd + 1; -L90: -L100: - --j; - if (d__[j] > dmnmx) { - goto L100; - } -L110: - ++i__; - if (d__[i__] < dmnmx) { - goto L110; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L90; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - } else { - ++stkpnt; - stack[(stkpnt << 1) - 2] = j + 1; - stack[(stkpnt << 1) - 1] = endd; - ++stkpnt; - stack[(stkpnt << 1) - 2] = start; - stack[(stkpnt << 1) - 1] = j; - } - } - } - if (stkpnt > 0) { - goto L10; - } - return 0; - -/* End of DLASRT */ - -} /* dlasrt_ */ diff --git a/external/clapack/lapack/dlassq.cpp b/external/clapack/lapack/dlassq.cpp deleted file mode 100644 index 81ec1ac5..00000000 --- a/external/clapack/lapack/dlassq.cpp +++ /dev/null @@ -1,104 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlassq_(integer *n, double *x, integer *incx, - double *scale, double *sumsq) -{ - /* System generated locals */ - integer i__1, i__2; - double d__1; - - /* Local variables */ - integer ix; - double absxi; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASSQ returns the values scl and smsq such that */ - -/* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */ - -/* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */ -/* assumed to be non-negative and scl returns the value */ - -/* scl = max( scale, abs( x( i ) ) ). */ - -/* scale and sumsq must be supplied in SCALE and SUMSQ and */ -/* scl and smsq are overwritten on SCALE and SUMSQ respectively. */ - -/* The routine makes only one pass through the vector x. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of elements to be used from the vector X. */ - -/* X (input) DOUBLE PRECISION array, dimension (N) */ -/* The vector for which a scaled sum of squares is computed. */ -/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */ - -/* INCX (input) INTEGER */ -/* The increment between successive values of the vector X. */ -/* INCX > 0. */ - -/* SCALE (input/output) DOUBLE PRECISION */ -/* On entry, the value scale in the equation above. */ -/* On exit, SCALE is overwritten with scl , the scaling factor */ -/* for the sum of squares. */ - -/* SUMSQ (input/output) DOUBLE PRECISION */ -/* On entry, the value sumsq in the equation above. */ -/* On exit, SUMSQ is overwritten with smsq , the basic sum of */ -/* squares from which scl has been factored out. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --x; - - /* Function Body */ - if (*n > 0) { - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.) { - absxi = (d__1 = x[ix], abs(d__1)); - if (*scale < absxi) { -/* Computing 2nd power */ - d__1 = *scale / absxi; - *sumsq = *sumsq * (d__1 * d__1) + 1; - *scale = absxi; - } else { -/* Computing 2nd power */ - d__1 = absxi / *scale; - *sumsq += d__1 * d__1; - } - } -/* L10: */ - } - } - return 0; - -/* End of DLASSQ */ - -} /* dlassq_ */ diff --git a/external/clapack/lapack/dlasv2.cpp b/external/clapack/lapack/dlasv2.cpp deleted file mode 100644 index f04697ab..00000000 --- a/external/clapack/lapack/dlasv2.cpp +++ /dev/null @@ -1,259 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b3 = 2.; -static double c_b4 = 1.; - -/* Subroutine */ int dlasv2_(double *f, double *g, double *h__, - double *ssmin, double *ssmax, double *snr, double * - csr, double *snl, double *csl) -{ - /* System generated locals */ - double d__1; - - /* Local variables */ - double a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, - crt, slt, srt; - integer pmax; - double temp; - bool swap; - double tsign; - - bool gasmal; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASV2 computes the singular value decomposition of a 2-by-2 */ -/* triangular matrix */ -/* [ F G ] */ -/* [ 0 H ]. */ -/* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */ -/* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */ -/* right singular vectors for abs(SSMAX), giving the decomposition */ - -/* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */ -/* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */ - -/* Arguments */ -/* ========= */ - -/* F (input) DOUBLE PRECISION */ -/* The (1,1) element of the 2-by-2 matrix. */ - -/* G (input) DOUBLE PRECISION */ -/* The (1,2) element of the 2-by-2 matrix. */ - -/* H (input) DOUBLE PRECISION */ -/* The (2,2) element of the 2-by-2 matrix. */ - -/* SSMIN (output) DOUBLE PRECISION */ -/* abs(SSMIN) is the smaller singular value. */ - -/* SSMAX (output) DOUBLE PRECISION */ -/* abs(SSMAX) is the larger singular value. */ - -/* SNL (output) DOUBLE PRECISION */ -/* CSL (output) DOUBLE PRECISION */ -/* The vector (CSL, SNL) is a unit left singular vector for the */ -/* singular value abs(SSMAX). */ - -/* SNR (output) DOUBLE PRECISION */ -/* CSR (output) DOUBLE PRECISION */ -/* The vector (CSR, SNR) is a unit right singular vector for the */ -/* singular value abs(SSMAX). */ - -/* Further Details */ -/* =============== */ - -/* Any input parameter may be aliased with any output parameter. */ - -/* Barring over/underflow and assuming a guard digit in subtraction, all */ -/* output quantities are correct to within a few units in the last */ -/* place (ulps). */ - -/* In IEEE arithmetic, the code works correctly if one matrix element is */ -/* infinite. */ - -/* Overflow will not occur unless the largest singular value itself */ -/* overflows or is within a few ulps of overflow. (On machines with */ -/* partial overflow, like the Cray, overflow may occur if the largest */ -/* singular value is within a factor of 2 of overflow.) */ - -/* Underflow is harmless if underflow is gradual. Otherwise, results */ -/* may correspond to a matrix modified by perturbations of size near */ -/* the underflow threshold. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - ft = *f; - fa = abs(ft); - ht = *h__; - ha = abs(*h__); - -/* PMAX points to the maximum absolute element of matrix */ -/* PMAX = 1 if F largest in absolute values */ -/* PMAX = 2 if G largest in absolute values */ -/* PMAX = 3 if H largest in absolute values */ - - pmax = 1; - swap = ha > fa; - if (swap) { - pmax = 3; - temp = ft; - ft = ht; - ht = temp; - temp = fa; - fa = ha; - ha = temp; - -/* Now FA .ge. HA */ - - } - gt = *g; - ga = abs(gt); - if (ga == 0.) { - -/* Diagonal matrix */ - - *ssmin = ha; - *ssmax = fa; - clt = 1.; - crt = 1.; - slt = 0.; - srt = 0.; - } else { - gasmal = true; - if (ga > fa) { - pmax = 2; - if (fa / ga < dlamch_("EPS")) { - -/* Case of very large GA */ - - gasmal = false; - *ssmax = ga; - if (ha > 1.) { - *ssmin = fa / (ga / ha); - } else { - *ssmin = fa / ga * ha; - } - clt = 1.; - slt = ht / gt; - srt = 1.; - crt = ft / gt; - } - } - if (gasmal) { - -/* Normal case */ - - d__ = fa - ha; - if (d__ == fa) { - -/* Copes with infinite F or H */ - - l = 1.; - } else { - l = d__ / fa; - } - -/* Note that 0 .le. L .le. 1 */ - - m = gt / ft; - -/* Note that abs(M) .le. 1/macheps */ - - t = 2. - l; - -/* Note that T .ge. 1 */ - - mm = m * m; - tt = t * t; - s = sqrt(tt + mm); - -/* Note that 1 .le. S .le. 1 + 1/macheps */ - - if (l == 0.) { - r__ = abs(m); - } else { - r__ = sqrt(l * l + mm); - } - -/* Note that 0 .le. R .le. 1 + 1/macheps */ - - a = (s + r__) * .5; - -/* Note that 1 .le. A .le. 1 + abs(M) */ - - *ssmin = ha / a; - *ssmax = fa * a; - if (mm == 0.) { - -/* Note that M is very tiny */ - - if (l == 0.) { - t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >); - } else { - t = gt / d_sign(&d__, &ft) + m / t; - } - } else { - t = (m / (s + t) + m / (r__ + l)) * (a + 1.); - } - l = sqrt(t * t + 4.); - crt = 2. / l; - srt = t / l; - clt = (crt + srt * m) / a; - slt = ht / ft * srt / a; - } - } - if (swap) { - *csl = srt; - *snl = crt; - *csr = slt; - *snr = clt; - } else { - *csl = clt; - *snl = slt; - *csr = crt; - *snr = srt; - } - -/* Correct signs of SSMAX and SSMIN */ - - if (pmax == 1) { - tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f); - } - if (pmax == 2) { - tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g); - } - if (pmax == 3) { - tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__); - } - *ssmax = d_sign(ssmax, &tsign); - d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__); - *ssmin = d_sign(ssmin, &d__1); - return 0; - -/* End of DLASV2 */ - -} /* dlasv2_ */ diff --git a/external/clapack/lapack/dlaswp.cpp b/external/clapack/lapack/dlaswp.cpp deleted file mode 100644 index 395be71e..00000000 --- a/external/clapack/lapack/dlaswp.cpp +++ /dev/null @@ -1,146 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlaswp_(integer *n, double *a, integer *lda, integer - *k1, integer *k2, integer *ipiv, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; - double temp; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASWP performs a series of row interchanges on the matrix A. */ -/* One row interchange is initiated for each of rows K1 through K2 of A. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the matrix of column dimension N to which the row */ -/* interchanges will be applied. */ -/* On exit, the permuted matrix. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ - -/* K1 (input) INTEGER */ -/* The first element of IPIV for which a row interchange will */ -/* be done. */ - -/* K2 (input) INTEGER */ -/* The last element of IPIV for which a row interchange will */ -/* be done. */ - -/* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) */ -/* The vector of pivot indices. Only the elements in positions */ -/* K1 through K2 of IPIV are accessed. */ -/* IPIV(K) = L implies rows K and L are to be interchanged. */ - -/* INCX (input) INTEGER */ -/* The increment between successive values of IPIV. If IPIV */ -/* is negative, the pivots are applied in reverse order. */ - -/* Further Details */ -/* =============== */ - -/* Modified by */ -/* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Interchange row I with row IPIV(I) for each of rows K1 through K2. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - - /* Function Body */ - if (*incx > 0) { - ix0 = *k1; - i1 = *k1; - i2 = *k2; - inc = 1; - } else if (*incx < 0) { - ix0 = (1 - *k2) * *incx + 1; - i1 = *k2; - i2 = *k1; - inc = -1; - } else { - return 0; - } - - n32 = *n / 32 << 5; - if (n32 != 0) { - i__1 = n32; - for (j = 1; j <= i__1; j += 32) { - ix = ix0; - i__2 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) - { - ip = ipiv[ix]; - if (ip != i__) { - i__4 = j + 31; - for (k = j; k <= i__4; ++k) { - temp = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = a[ip + k * a_dim1]; - a[ip + k * a_dim1] = temp; -/* L10: */ - } - } - ix += *incx; -/* L20: */ - } -/* L30: */ - } - } - if (n32 != *n) { - ++n32; - ix = ix0; - i__1 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { - ip = ipiv[ix]; - if (ip != i__) { - i__2 = *n; - for (k = n32; k <= i__2; ++k) { - temp = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = a[ip + k * a_dim1]; - a[ip + k * a_dim1] = temp; -/* L40: */ - } - } - ix += *incx; -/* L50: */ - } - } - - return 0; - -/* End of DLASWP */ - -} /* dlaswp_ */ diff --git a/external/clapack/lapack/dlasy2.cpp b/external/clapack/lapack/dlasy2.cpp deleted file mode 100644 index dce08d5f..00000000 --- a/external/clapack/lapack/dlasy2.cpp +++ /dev/null @@ -1,461 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__4 = 4; -static integer c__1 = 1; -static integer c__16 = 16; -static integer c__0 = 0; - -/* Subroutine */ int dlasy2_(bool *ltranl, bool *ltranr, integer *isgn, - integer *n1, integer *n2, double *tl, integer *ldtl, double * - tr, integer *ldtr, double *b, integer *ldb, double *scale, - double *x, integer *ldx, double *xnorm, integer *info) -{ - /* Initialized data */ - - static integer locu12[4] = { 3,4,1,2 }; - static integer locl21[4] = { 2,1,4,3 }; - static integer locu22[4] = { 4,3,2,1 }; - static bool xswpiv[4] = { false,false,true,true }; - static bool bswpiv[4] = { false,true,false,true }; - - /* System generated locals */ - integer b_dim1, b_offset, tl_dim1, tl_offset, tr_dim1, tr_offset, x_dim1, - x_offset; - double d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8; - - /* Local variables */ - integer i__, j, k; - double x2[2], l21, u11, u12; - integer ip, jp; - double u22, t16[16] /* was [4][4] */, gam, bet, eps, sgn, tmp[4], - tau1, btmp[4], smin; - integer ipiv; - double temp; - integer jpiv[4]; - double xmax; - integer ipsv, jpsv; - bool bswap; - bool xswap; - double smlnum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in */ - -/* op(TL)*X + ISGN*X*op(TR) = SCALE*B, */ - -/* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or */ -/* -1. op(T) = T or T', where T' denotes the transpose of T. */ - -/* Arguments */ -/* ========= */ - -/* LTRANL (input) LOGICAL */ -/* On entry, LTRANL specifies the op(TL): */ -/* = .FALSE., op(TL) = TL, */ -/* = .TRUE., op(TL) = TL'. */ - -/* LTRANR (input) LOGICAL */ -/* On entry, LTRANR specifies the op(TR): */ -/* = .FALSE., op(TR) = TR, */ -/* = .TRUE., op(TR) = TR'. */ - -/* ISGN (input) INTEGER */ -/* On entry, ISGN specifies the sign of the equation */ -/* as described before. ISGN may only be 1 or -1. */ - -/* N1 (input) INTEGER */ -/* On entry, N1 specifies the order of matrix TL. */ -/* N1 may only be 0, 1 or 2. */ - -/* N2 (input) INTEGER */ -/* On entry, N2 specifies the order of matrix TR. */ -/* N2 may only be 0, 1 or 2. */ - -/* TL (input) DOUBLE PRECISION array, dimension (LDTL,2) */ -/* On entry, TL contains an N1 by N1 matrix. */ - -/* LDTL (input) INTEGER */ -/* The leading dimension of the matrix TL. LDTL >= max(1,N1). */ - -/* TR (input) DOUBLE PRECISION array, dimension (LDTR,2) */ -/* On entry, TR contains an N2 by N2 matrix. */ - -/* LDTR (input) INTEGER */ -/* The leading dimension of the matrix TR. LDTR >= max(1,N2). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,2) */ -/* On entry, the N1 by N2 matrix B contains the right-hand */ -/* side of the equation. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the matrix B. LDB >= max(1,N1). */ - -/* SCALE (output) DOUBLE PRECISION */ -/* On exit, SCALE contains the scale factor. SCALE is chosen */ -/* less than or equal to 1 to prevent the solution overflowing. */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,2) */ -/* On exit, X contains the N1 by N2 solution. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the matrix X. LDX >= max(1,N1). */ - -/* XNORM (output) DOUBLE PRECISION */ -/* On exit, XNORM is the infinity-norm of the solution. */ - -/* INFO (output) INTEGER */ -/* On exit, INFO is set to */ -/* 0: successful exit. */ -/* 1: TL and TR have too close eigenvalues, so TL or */ -/* TR is perturbed to get a nonsingular equation. */ -/* NOTE: In the interests of speed, this routine does not */ -/* check the inputs for errors. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Data statements .. */ - /* Parameter adjustments */ - tl_dim1 = *ldtl; - tl_offset = 1 + tl_dim1; - tl -= tl_offset; - tr_dim1 = *ldtr; - tr_offset = 1 + tr_dim1; - tr -= tr_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - - /* Function Body */ -/* .. */ -/* .. Executable Statements .. */ - -/* Do not check the input parameters for errors */ - - *info = 0; - -/* Quick return if possible */ - - if (*n1 == 0 || *n2 == 0) { - return 0; - } - -/* Set constants to control overflow */ - - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; - sgn = (double) (*isgn); - - k = *n1 + *n1 + *n2 - 2; - switch (k) { - case 1: goto L10; - case 2: goto L20; - case 3: goto L30; - case 4: goto L50; - } - -/* 1 by 1: TL11*X + SGN*X*TR11 = B11 */ - -L10: - tau1 = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; - bet = abs(tau1); - if (bet <= smlnum) { - tau1 = smlnum; - bet = smlnum; - *info = 1; - } - - *scale = 1.; - gam = (d__1 = b[b_dim1 + 1], abs(d__1)); - if (smlnum * gam > bet) { - *scale = 1. / gam; - } - - x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / tau1; - *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)); - return 0; - -/* 1 by 2: */ -/* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] */ -/* [TR21 TR22] */ - -L20: - -/* Computing MAX */ -/* Computing MAX */ - d__7 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__8 = (d__2 = tr[tr_dim1 + 1] - , abs(d__2)), d__7 = std::max(d__7,d__8), d__8 = (d__3 = tr[(tr_dim1 << - 1) + 1], abs(d__3)), d__7 = std::max(d__7,d__8), d__8 = (d__4 = tr[ - tr_dim1 + 2], abs(d__4)), d__7 = std::max(d__7,d__8), d__8 = (d__5 = - tr[(tr_dim1 << 1) + 2], abs(d__5)); - d__6 = eps * std::max(d__7,d__8); - smin = std::max(d__6,smlnum); - tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; - tmp[3] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2]; - if (*ltranr) { - tmp[1] = sgn * tr[tr_dim1 + 2]; - tmp[2] = sgn * tr[(tr_dim1 << 1) + 1]; - } else { - tmp[1] = sgn * tr[(tr_dim1 << 1) + 1]; - tmp[2] = sgn * tr[tr_dim1 + 2]; - } - btmp[0] = b[b_dim1 + 1]; - btmp[1] = b[(b_dim1 << 1) + 1]; - goto L40; - -/* 2 by 1: */ -/* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] */ -/* [TL21 TL22] [X21] [X21] [B21] */ - -L30: -/* Computing MAX */ -/* Computing MAX */ - d__7 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__8 = (d__2 = tl[tl_dim1 + 1] - , abs(d__2)), d__7 = std::max(d__7,d__8), d__8 = (d__3 = tl[(tl_dim1 << - 1) + 1], abs(d__3)), d__7 = std::max(d__7,d__8), d__8 = (d__4 = tl[ - tl_dim1 + 2], abs(d__4)), d__7 = std::max(d__7,d__8), d__8 = (d__5 = - tl[(tl_dim1 << 1) + 2], abs(d__5)); - d__6 = eps * std::max(d__7,d__8); - smin = std::max(d__6,smlnum); - tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; - tmp[3] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1]; - if (*ltranl) { - tmp[1] = tl[(tl_dim1 << 1) + 1]; - tmp[2] = tl[tl_dim1 + 2]; - } else { - tmp[1] = tl[tl_dim1 + 2]; - tmp[2] = tl[(tl_dim1 << 1) + 1]; - } - btmp[0] = b[b_dim1 + 1]; - btmp[1] = b[b_dim1 + 2]; -L40: - -/* Solve 2 by 2 system using complete pivoting. */ -/* Set pivots less than SMIN to SMIN. */ - - ipiv = idamax_(&c__4, tmp, &c__1); - u11 = tmp[ipiv - 1]; - if (abs(u11) <= smin) { - *info = 1; - u11 = smin; - } - u12 = tmp[locu12[ipiv - 1] - 1]; - l21 = tmp[locl21[ipiv - 1] - 1] / u11; - u22 = tmp[locu22[ipiv - 1] - 1] - u12 * l21; - xswap = xswpiv[ipiv - 1]; - bswap = bswpiv[ipiv - 1]; - if (abs(u22) <= smin) { - *info = 1; - u22 = smin; - } - if (bswap) { - temp = btmp[1]; - btmp[1] = btmp[0] - l21 * temp; - btmp[0] = temp; - } else { - btmp[1] -= l21 * btmp[0]; - } - *scale = 1.; - if (smlnum * 2. * abs(btmp[1]) > abs(u22) || smlnum * 2. * abs(btmp[0]) > - abs(u11)) { -/* Computing MAX */ - d__1 = abs(btmp[0]), d__2 = abs(btmp[1]); - *scale = .5 / std::max(d__1,d__2); - btmp[0] *= *scale; - btmp[1] *= *scale; - } - x2[1] = btmp[1] / u22; - x2[0] = btmp[0] / u11 - u12 / u11 * x2[1]; - if (xswap) { - temp = x2[1]; - x2[1] = x2[0]; - x2[0] = temp; - } - x[x_dim1 + 1] = x2[0]; - if (*n1 == 1) { - x[(x_dim1 << 1) + 1] = x2[1]; - *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << 1) - + 1], abs(d__2)); - } else { - x[x_dim1 + 2] = x2[1]; -/* Computing MAX */ - d__3 = (d__1 = x[x_dim1 + 1], abs(d__1)), d__4 = (d__2 = x[x_dim1 + 2] - , abs(d__2)); - *xnorm = std::max(d__3,d__4); - } - return 0; - -/* 2 by 2: */ -/* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] */ -/* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] */ - -/* Solve equivalent 4 by 4 system using complete pivoting. */ -/* Set pivots less than SMIN to SMIN. */ - -L50: -/* Computing MAX */ - d__5 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__6 = (d__2 = tr[(tr_dim1 << - 1) + 1], abs(d__2)), d__5 = std::max(d__5,d__6), d__6 = (d__3 = tr[ - tr_dim1 + 2], abs(d__3)), d__5 = std::max(d__5,d__6), d__6 = (d__4 = - tr[(tr_dim1 << 1) + 2], abs(d__4)); - smin = std::max(d__5,d__6); -/* Computing MAX */ - d__5 = smin, d__6 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__5 = std::max(d__5, - d__6), d__6 = (d__2 = tl[(tl_dim1 << 1) + 1], abs(d__2)), d__5 = - std::max(d__5,d__6), d__6 = (d__3 = tl[tl_dim1 + 2], abs(d__3)), d__5 = - std::max(d__5,d__6), d__6 = (d__4 = tl[(tl_dim1 << 1) + 2], abs(d__4)) - ; - smin = std::max(d__5,d__6); -/* Computing MAX */ - d__1 = eps * smin; - smin = std::max(d__1,smlnum); - btmp[0] = 0.; - dcopy_(&c__16, btmp, &c__0, t16, &c__1); - t16[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; - t16[5] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1]; - t16[10] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2]; - t16[15] = tl[(tl_dim1 << 1) + 2] + sgn * tr[(tr_dim1 << 1) + 2]; - if (*ltranl) { - t16[4] = tl[tl_dim1 + 2]; - t16[1] = tl[(tl_dim1 << 1) + 1]; - t16[14] = tl[tl_dim1 + 2]; - t16[11] = tl[(tl_dim1 << 1) + 1]; - } else { - t16[4] = tl[(tl_dim1 << 1) + 1]; - t16[1] = tl[tl_dim1 + 2]; - t16[14] = tl[(tl_dim1 << 1) + 1]; - t16[11] = tl[tl_dim1 + 2]; - } - if (*ltranr) { - t16[8] = sgn * tr[(tr_dim1 << 1) + 1]; - t16[13] = sgn * tr[(tr_dim1 << 1) + 1]; - t16[2] = sgn * tr[tr_dim1 + 2]; - t16[7] = sgn * tr[tr_dim1 + 2]; - } else { - t16[8] = sgn * tr[tr_dim1 + 2]; - t16[13] = sgn * tr[tr_dim1 + 2]; - t16[2] = sgn * tr[(tr_dim1 << 1) + 1]; - t16[7] = sgn * tr[(tr_dim1 << 1) + 1]; - } - btmp[0] = b[b_dim1 + 1]; - btmp[1] = b[b_dim1 + 2]; - btmp[2] = b[(b_dim1 << 1) + 1]; - btmp[3] = b[(b_dim1 << 1) + 2]; - -/* Perform elimination */ - - for (i__ = 1; i__ <= 3; ++i__) { - xmax = 0.; - for (ip = i__; ip <= 4; ++ip) { - for (jp = i__; jp <= 4; ++jp) { - if ((d__1 = t16[ip + (jp << 2) - 5], abs(d__1)) >= xmax) { - xmax = (d__1 = t16[ip + (jp << 2) - 5], abs(d__1)); - ipsv = ip; - jpsv = jp; - } -/* L60: */ - } -/* L70: */ - } - if (ipsv != i__) { - dswap_(&c__4, &t16[ipsv - 1], &c__4, &t16[i__ - 1], &c__4); - temp = btmp[i__ - 1]; - btmp[i__ - 1] = btmp[ipsv - 1]; - btmp[ipsv - 1] = temp; - } - if (jpsv != i__) { - dswap_(&c__4, &t16[(jpsv << 2) - 4], &c__1, &t16[(i__ << 2) - 4], - &c__1); - } - jpiv[i__ - 1] = jpsv; - if ((d__1 = t16[i__ + (i__ << 2) - 5], abs(d__1)) < smin) { - *info = 1; - t16[i__ + (i__ << 2) - 5] = smin; - } - for (j = i__ + 1; j <= 4; ++j) { - t16[j + (i__ << 2) - 5] /= t16[i__ + (i__ << 2) - 5]; - btmp[j - 1] -= t16[j + (i__ << 2) - 5] * btmp[i__ - 1]; - for (k = i__ + 1; k <= 4; ++k) { - t16[j + (k << 2) - 5] -= t16[j + (i__ << 2) - 5] * t16[i__ + ( - k << 2) - 5]; -/* L80: */ - } -/* L90: */ - } -/* L100: */ - } - if (abs(t16[15]) < smin) { - t16[15] = smin; - } - *scale = 1.; - if (smlnum * 8. * abs(btmp[0]) > abs(t16[0]) || smlnum * 8. * abs(btmp[1]) - > abs(t16[5]) || smlnum * 8. * abs(btmp[2]) > abs(t16[10]) || - smlnum * 8. * abs(btmp[3]) > abs(t16[15])) { -/* Computing MAX */ - d__1 = abs(btmp[0]), d__2 = abs(btmp[1]), d__1 = std::max(d__1,d__2), d__2 - = abs(btmp[2]), d__1 = std::max(d__1,d__2), d__2 = abs(btmp[3]); - *scale = .125 / std::max(d__1,d__2); - btmp[0] *= *scale; - btmp[1] *= *scale; - btmp[2] *= *scale; - btmp[3] *= *scale; - } - for (i__ = 1; i__ <= 4; ++i__) { - k = 5 - i__; - temp = 1. / t16[k + (k << 2) - 5]; - tmp[k - 1] = btmp[k - 1] * temp; - for (j = k + 1; j <= 4; ++j) { - tmp[k - 1] -= temp * t16[k + (j << 2) - 5] * tmp[j - 1]; -/* L110: */ - } -/* L120: */ - } - for (i__ = 1; i__ <= 3; ++i__) { - if (jpiv[4 - i__ - 1] != 4 - i__) { - temp = tmp[4 - i__ - 1]; - tmp[4 - i__ - 1] = tmp[jpiv[4 - i__ - 1] - 1]; - tmp[jpiv[4 - i__ - 1] - 1] = temp; - } -/* L130: */ - } - x[x_dim1 + 1] = tmp[0]; - x[x_dim1 + 2] = tmp[1]; - x[(x_dim1 << 1) + 1] = tmp[2]; - x[(x_dim1 << 1) + 2] = tmp[3]; -/* Computing MAX */ - d__1 = abs(tmp[0]) + abs(tmp[2]), d__2 = abs(tmp[1]) + abs(tmp[3]); - *xnorm = std::max(d__1,d__2); - return 0; - -/* End of DLASY2 */ - -} /* dlasy2_ */ diff --git a/external/clapack/lapack/dlasyf.cpp b/external/clapack/lapack/dlasyf.cpp deleted file mode 100644 index c2846556..00000000 --- a/external/clapack/lapack/dlasyf.cpp +++ /dev/null @@ -1,695 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b8 = -1.; -static double c_b9 = 1.; - -/* Subroutine */ int dlasyf_(const char *uplo, integer *n, integer *nb, integer *kb, - double *a, integer *lda, integer *ipiv, double *w, integer * - ldw, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; - double d__1, d__2, d__3; - - /* Local variables */ - integer j, k; - double t, r1, d11, d21, d22; - integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax; - double alpha; - integer kstep; - double absakk; - double colmax, rowmax; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLASYF computes a partial factorization of a real symmetric matrix A */ -/* using the Bunch-Kaufman diagonal pivoting method. The partial */ -/* factorization has the form: */ - -/* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ -/* ( 0 U22 ) ( 0 D ) ( U12' U22' ) */ - -/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L' */ -/* ( L21 I ) ( 0 A22 ) ( 0 I ) */ - -/* where the order of D is at most NB. The actual order is returned in */ -/* the argument KB, and is either NB or NB-1, or N if N <= NB. */ - -/* DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code */ -/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */ -/* A22 (if UPLO = 'L'). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NB (input) INTEGER */ -/* The maximum number of columns of the matrix A that should be */ -/* factored. NB should be at least 2 to allow for 2-by-2 pivot */ -/* blocks. */ - -/* KB (output) INTEGER */ -/* The number of columns of A that were actually factored. */ -/* KB is either NB-1 or NB, or N if N <= NB. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n-by-n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n-by-n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ -/* On exit, A contains details of the partial factorization. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D. */ -/* If UPLO = 'U', only the last KB elements of IPIV are set; */ -/* if UPLO = 'L', only the first KB elements are set. */ - -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB) */ - -/* LDW (input) INTEGER */ -/* The leading dimension of the array W. LDW >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - w_dim1 = *ldw; - w_offset = 1 + w_dim1; - w -= w_offset; - - /* Function Body */ - *info = 0; - -/* Initialize ALPHA for use in choosing pivot block size. */ - - alpha = (sqrt(17.) + 1.) / 8.; - - if (lsame_(uplo, "U")) { - -/* Factorize the trailing columns of A using the upper triangle */ -/* of A and working backwards, and compute the matrix W = U12*D */ -/* for use in updating A11 */ - -/* K is the main loop index, decreasing from N in steps of 1 or 2 */ - -/* KW is the column of W which corresponds to column K of A */ - - k = *n; -L10: - kw = *nb + k - *n; - -/* Exit from loop */ - - if (k <= *n - *nb + 1 && *nb < *n || k < 1) { - goto L30; - } - -/* Copy column K of A to column KW of W and update it */ - - dcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); - if (k < *n) { - i__1 = *n - k; - dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1], - lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw * - w_dim1 + 1], &c__1); - } - - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = w[k + kw * w_dim1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k > 1) { - i__1 = k - 1; - imax = idamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); - colmax = (d__1 = w[imax + kw * w_dim1], abs(d__1)); - } else { - colmax = 0.; - } - - if (std::max(absakk,colmax) == 0.) { - -/* Column K is zero: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* Copy column IMAX to column KW-1 of W and update it */ - - dcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * - w_dim1 + 1], &c__1); - i__1 = k - imax; - dcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + - 1 + (kw - 1) * w_dim1], &c__1); - if (k < *n) { - i__1 = *n - k; - dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * - a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], - ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1); - } - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - i__1 = k - imax; - jmax = imax + idamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], - &c__1); - rowmax = (d__1 = w[jmax + (kw - 1) * w_dim1], abs(d__1)); - if (imax > 1) { - i__1 = imax - 1; - jmax = idamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = w[jmax + (kw - 1) * w_dim1], - abs(d__1)); - rowmax = std::max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = w[imax + (kw - 1) * w_dim1], abs(d__1)) >= - alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - -/* copy column KW-1 of W to column KW */ - - dcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * - w_dim1 + 1], &c__1); - } else { - -/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k - kstep + 1; - kkw = *nb + kk - *n; - -/* Updated column KP is already stored in column KKW of W */ - - if (kp != kk) { - -/* Copy non-updated column KK to column KP */ - - a[kp + k * a_dim1] = a[kk + k * a_dim1]; - i__1 = k - 1 - kp; - dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + - 1) * a_dim1], lda); - dcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & - c__1); - -/* Interchange rows KK and KP in last KK columns of A and W */ - - i__1 = *n - kk + 1; - dswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], - lda); - i__1 = *n - kk + 1; - dswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * - w_dim1], ldw); - } - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column KW of W now holds */ - -/* W(k) = U(k)*D(k) */ - -/* where U(k) is the k-th column of U */ - -/* Store U(k) in column k of A */ - - dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & - c__1); - r1 = 1. / a[k + k * a_dim1]; - i__1 = k - 1; - dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); - } else { - -/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ -/* hold */ - -/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ - -/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ -/* of U */ - - if (k > 2) { - -/* Store U(k) and U(k-1) in columns k and k-1 of A */ - - d21 = w[k - 1 + kw * w_dim1]; - d11 = w[k + kw * w_dim1] / d21; - d22 = w[k - 1 + (kw - 1) * w_dim1] / d21; - t = 1. / (d11 * d22 - 1.); - d21 = t / d21; - i__1 = k - 2; - for (j = 1; j <= i__1; ++j) { - a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1) - * w_dim1] - w[j + kw * w_dim1]); - a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] - - w[j + (kw - 1) * w_dim1]); -/* L20: */ - } - } - -/* Copy D(k) to A */ - - a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; - a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; - a[k + k * a_dim1] = w[k + kw * w_dim1]; - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k - 1] = -kp; - } - -/* Decrease K and return to the start of the main loop */ - - k -= kstep; - goto L10; - -L30: - -/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ - -/* A11 := A11 - U12*D*U12' = A11 - U12*W' */ - -/* computing blocks of NB columns at a time */ - - i__1 = -(*nb); - for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += - i__1) { -/* Computing MIN */ - i__2 = *nb, i__3 = k - j + 1; - jb = std::min(i__2,i__3); - -/* Update the upper triangle of the diagonal block */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = jj - j + 1; - i__4 = *n - k; - dgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) * - a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9, - &a[j + jj * a_dim1], &c__1); -/* L40: */ - } - -/* Update the rectangular superdiagonal block */ - - i__2 = j - 1; - i__3 = *n - k; - dgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[( - k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, - &c_b9, &a[j * a_dim1 + 1], lda); -/* L50: */ - } - -/* Put U12 in standard form by partially undoing the interchanges */ -/* in columns k+1:n */ - - j = k + 1; -L60: - jj = j; - jp = ipiv[j]; - if (jp < 0) { - jp = -jp; - ++j; - } - ++j; - if (jp != jj && j <= *n) { - i__1 = *n - j + 1; - dswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); - } - if (j <= *n) { - goto L60; - } - -/* Set KB to the number of columns factorized */ - - *kb = *n - k; - - } else { - -/* Factorize the leading columns of A using the lower triangle */ -/* of A and working forwards, and compute the matrix W = L21*D */ -/* for use in updating A22 */ - -/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ - - k = 1; -L70: - -/* Exit from loop */ - - if (k >= *nb && *nb < *n || k > *n) { - goto L90; - } - -/* Copy column K of A to column K of W and update it */ - - i__1 = *n - k + 1; - dcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); - i__1 = *n - k + 1; - i__2 = k - 1; - dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k - + w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1); - - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = w[k + k * w_dim1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k < *n) { - i__1 = *n - k; - imax = k + idamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); - colmax = (d__1 = w[imax + k * w_dim1], abs(d__1)); - } else { - colmax = 0.; - } - - if (std::max(absakk,colmax) == 0.) { - -/* Column K is zero: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* Copy column IMAX to column K+1 of W and update it */ - - i__1 = imax - k; - dcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * - w_dim1], &c__1); - i__1 = *n - imax + 1; - dcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + - 1) * w_dim1], &c__1); - i__1 = *n - k + 1; - i__2 = k - 1; - dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], - lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) * - w_dim1], &c__1); - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - i__1 = imax - k; - jmax = k - 1 + idamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) - ; - rowmax = (d__1 = w[jmax + (k + 1) * w_dim1], abs(d__1)); - if (imax < *n) { - i__1 = *n - imax; - jmax = imax + idamax_(&i__1, &w[imax + 1 + (k + 1) * - w_dim1], &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = w[jmax + (k + 1) * w_dim1], - abs(d__1)); - rowmax = std::max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = w[imax + (k + 1) * w_dim1], abs(d__1)) >= - alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - -/* copy column K+1 of W to column K */ - - i__1 = *n - k + 1; - dcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * - w_dim1], &c__1); - } else { - -/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k + kstep - 1; - -/* Updated column KP is already stored in column KK of W */ - - if (kp != kk) { - -/* Copy non-updated column KK to column KP */ - - a[kp + k * a_dim1] = a[kk + k * a_dim1]; - i__1 = kp - k - 1; - dcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) - * a_dim1], lda); - i__1 = *n - kp + 1; - dcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * - a_dim1], &c__1); - -/* Interchange rows KK and KP in first KK columns of A and W */ - - dswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); - dswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); - } - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column k of W now holds */ - -/* W(k) = L(k)*D(k) */ - -/* where L(k) is the k-th column of L */ - -/* Store L(k) in column k of A */ - - i__1 = *n - k + 1; - dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & - c__1); - if (k < *n) { - r1 = 1. / a[k + k * a_dim1]; - i__1 = *n - k; - dscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); - } - } else { - -/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ - -/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ - -/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ -/* of L */ - - if (k < *n - 1) { - -/* Store L(k) and L(k+1) in columns k and k+1 of A */ - - d21 = w[k + 1 + k * w_dim1]; - d11 = w[k + 1 + (k + 1) * w_dim1] / d21; - d22 = w[k + k * w_dim1] / d21; - t = 1. / (d11 * d22 - 1.); - d21 = t / d21; - i__1 = *n; - for (j = k + 2; j <= i__1; ++j) { - a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] - - w[j + (k + 1) * w_dim1]); - a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) * - w_dim1] - w[j + k * w_dim1]); -/* L80: */ - } - } - -/* Copy D(k) to A */ - - a[k + k * a_dim1] = w[k + k * w_dim1]; - a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; - a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k + 1] = -kp; - } - -/* Increase K and return to the start of the main loop */ - - k += kstep; - goto L70; - -L90: - -/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ - -/* A22 := A22 - L21*D*L21' = A22 - L21*W' */ - -/* computing blocks of NB columns at a time */ - - i__1 = *n; - i__2 = *nb; - for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nb, i__4 = *n - j + 1; - jb = std::min(i__3,i__4); - -/* Update the lower triangle of the diagonal block */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - i__4 = j + jb - jj; - i__5 = k - 1; - dgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1], - lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1] -, &c__1); -/* L100: */ - } - -/* Update the rectangular subdiagonal block */ - - if (j + jb <= *n) { - i__3 = *n - j - jb + 1; - i__4 = k - 1; - dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8, - &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9, - &a[j + jb + j * a_dim1], lda); - } -/* L110: */ - } - -/* Put L21 in standard form by partially undoing the interchanges */ -/* in columns 1:k-1 */ - - j = k - 1; -L120: - jj = j; - jp = ipiv[j]; - if (jp < 0) { - jp = -jp; - --j; - } - --j; - if (jp != jj && j >= 1) { - dswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); - } - if (j >= 1) { - goto L120; - } - -/* Set KB to the number of columns factorized */ - - *kb = k - 1; - - } - return 0; - -/* End of DLASYF */ - -} /* dlasyf_ */ diff --git a/external/clapack/lapack/dlat2s.cpp b/external/clapack/lapack/dlat2s.cpp deleted file mode 100644 index 02fa048d..00000000 --- a/external/clapack/lapack/dlat2s.cpp +++ /dev/null @@ -1,124 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - - -int dlat2s_(const char *uplo, integer *n, double *a, integer *lda, float *sa, integer *ldsa, integer *info) -{ - /* System generated locals */ - integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j; - double rmax; - bool upper; - - - -/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* May 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE */ -/* PRECISION triangular matrix, A. */ - -/* RMAX is the overflow for the SINGLE PRECISION arithmetic */ -/* DLAS2S checks that all the entries of A are between -RMAX and */ -/* RMAX. If not the convertion is aborted and a flag is raised. */ - -/* This is an auxiliary routine so there is no argument checking. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* N (input) INTEGER */ -/* The number of rows and columns of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the N-by-N triangular coefficient matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* SA (output) REAL array, dimension (LDSA,N) */ -/* Only the UPLO part of SA is referenced. On exit, if INFO=0, */ -/* the N-by-N coefficient matrix SA; if INFO>0, the content of */ -/* the UPLO part of SA is unspecified. */ - -/* LDSA (input) INTEGER */ -/* The leading dimension of the array SA. LDSA >= max(1,M). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* = 1: an entry of the matrix A is greater than the SINGLE */ -/* PRECISION overflow threshold, in this case, the content */ -/* of the UPLO part of SA in exit is unspecified. */ - -/* ========= */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - sa_dim1 = *ldsa; - sa_offset = 1 + sa_dim1; - sa -= sa_offset; - - /* Function Body */ - rmax = slamch_("O"); - upper = lsame_(uplo, "U"); - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax) - { - *info = 1; - goto L50; - } - sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1]; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax) - { - *info = 1; - goto L50; - } - sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1]; -/* L30: */ - } -/* L40: */ - } - } -L50: - - return 0; - -/* End of DLAT2S */ - -} /* dlat2s_ */ diff --git a/external/clapack/lapack/dlatbs.cpp b/external/clapack/lapack/dlatbs.cpp deleted file mode 100644 index 5689e7e5..00000000 --- a/external/clapack/lapack/dlatbs.cpp +++ /dev/null @@ -1,826 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b36 = .5; - -/* Subroutine */ int dlatbs_(const char *uplo, const char *trans, const char *diag, const char * - normin, integer *n, integer *kd, double *ab, integer *ldab, - double *x, double *scale, double *cnorm, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j; - double xj, rec, tjj; - integer jinc, jlen; - double xbnd; - integer imax; - double tmax, tjjs, xmax, grow, sumj; - integer maind; - double tscal, uscal; - integer jlast; - bool upper; - double bignum; - bool notran; - integer jfirst; - double smlnum; - bool nounit; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLATBS solves one of the triangular systems */ - -/* A *x = s*b or A'*x = s*b */ - -/* with scaling to prevent overflow, where A is an upper or lower */ -/* triangular band matrix. Here A' denotes the transpose of A, x and b */ -/* are n-element vectors, and s is a scaling factor, usually less than */ -/* or equal to 1, chosen so that the components of x will be less than */ -/* the overflow threshold. If the unscaled problem will not cause */ -/* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A */ -/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ -/* non-trivial solution to A*x = 0 is returned. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the operation applied to A. */ -/* = 'N': Solve A * x = s*b (No transpose) */ -/* = 'T': Solve A'* x = s*b (Transpose) */ -/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* NORMIN (input) CHARACTER*1 */ -/* Specifies whether CNORM has been set or not. */ -/* = 'Y': CNORM contains the column norms on entry */ -/* = 'N': CNORM is not set on entry. On exit, the norms will */ -/* be computed and stored in CNORM. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of subdiagonals or superdiagonals in the */ -/* triangular matrix A. KD >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangular band matrix A, stored in the */ -/* first KD+1 rows of the array. The j-th column of A is stored */ -/* in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* X (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the right hand side b of the triangular system. */ -/* On exit, X is overwritten by the solution vector x. */ - -/* SCALE (output) DOUBLE PRECISION */ -/* The scaling factor s for the triangular system */ -/* A * x = s*b or A'* x = s*b. */ -/* If SCALE = 0, the matrix A is singular or badly scaled, and */ -/* the vector x is an exact or approximate solution to A*x = 0. */ - -/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ - -/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ -/* contains the norm of the off-diagonal part of the j-th column */ -/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ -/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ -/* must be greater than or equal to the 1-norm. */ - -/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ -/* returns the 1-norm of the offdiagonal part of the j-th column */ -/* of A. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* Further Details */ -/* ======= ======= */ - -/* A rough bound on x is computed; if that is less than overflow, DTBSV */ -/* is called, otherwise, specific code is used which checks for possible */ -/* overflow or divide-by-zero at every operation. */ - -/* A columnwise scheme is used for solving A*x = b. The basic algorithm */ -/* if A is lower triangular is */ - -/* x[1:n] := b[1:n] */ -/* for j = 1, ..., n */ -/* x(j) := x(j) / A(j,j) */ -/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ -/* end */ - -/* Define bounds on the components of x after j iterations of the loop: */ -/* M(j) = bound on x[1:j] */ -/* G(j) = bound on x[j+1:n] */ -/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ - -/* Then for iteration j+1 we have */ -/* M(j+1) <= G(j) / | A(j+1,j+1) | */ -/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ -/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ - -/* where CNORM(j+1) is greater than or equal to the infinity-norm of */ -/* column j+1 of A, not counting the diagonal. Hence */ - -/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ -/* 1<=i<=j */ -/* and */ - -/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ -/* 1<=i< j */ - -/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the */ -/* reciprocal of the largest M(j), j=1,..,n, is larger than */ -/* max(underflow, 1/overflow). */ - -/* The bound on x(j) is also used to determine when a step in the */ -/* columnwise method can be performed without fear of overflow. If */ -/* the computed bound is greater than a large constant, x is scaled to */ -/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ -/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ - -/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */ -/* algorithm for A upper triangular is */ - -/* for j = 1, ..., n */ -/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ -/* end */ - -/* We simultaneously compute two bounds */ -/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ -/* M(j) = bound on x(i), 1<=i<=j */ - -/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ -/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ -/* Then the bound on x(j) is */ - -/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ - -/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ -/* 1<=i<=j */ - -/* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater */ -/* than max(underflow, 1/overflow). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --x; - --cnorm; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - notran = lsame_(trans, "N"); - nounit = lsame_(diag, "N"); - -/* Test the input parameters. */ - - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (! lsame_(normin, "Y") && ! lsame_(normin, - "N")) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*kd < 0) { - *info = -6; - } else if (*ldab < *kd + 1) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLATBS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine machine dependent parameters to control overflow. */ - - smlnum = dlamch_("Safe minimum") / dlamch_("Precision"); - bignum = 1. / smlnum; - *scale = 1.; - - if (lsame_(normin, "N")) { - -/* Compute the 1-norm of each column, not including the diagonal. */ - - if (upper) { - -/* A is upper triangular. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *kd, i__3 = j - 1; - jlen = std::min(i__2,i__3); - cnorm[j] = dasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], & - c__1); -/* L10: */ - } - } else { - -/* A is lower triangular. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *kd, i__3 = *n - j; - jlen = std::min(i__2,i__3); - if (jlen > 0) { - cnorm[j] = dasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1); - } else { - cnorm[j] = 0.; - } -/* L20: */ - } - } - } - -/* Scale the column norms by TSCAL if the maximum element in CNORM is */ -/* greater than BIGNUM. */ - - imax = idamax_(n, &cnorm[1], &c__1); - tmax = cnorm[imax]; - if (tmax <= bignum) { - tscal = 1.; - } else { - tscal = 1. / (smlnum * tmax); - dscal_(n, &tscal, &cnorm[1], &c__1); - } - -/* Compute a bound on the computed solution vector to see if the */ -/* Level 2 BLAS routine DTBSV can be used. */ - - j = idamax_(n, &x[1], &c__1); - xmax = (d__1 = x[j], abs(d__1)); - xbnd = xmax; - if (notran) { - -/* Compute the growth in A * x = b. */ - - if (upper) { - jfirst = *n; - jlast = 1; - jinc = -1; - maind = *kd + 1; - } else { - jfirst = 1; - jlast = *n; - jinc = 1; - maind = 1; - } - - if (tscal != 1.) { - grow = 0.; - goto L50; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, G(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / std::max(xbnd,smlnum); - xbnd = grow; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* M(j) = G(j-1) / abs(A(j,j)) */ - - tjj = (d__1 = ab[maind + j * ab_dim1], abs(d__1)); -/* Computing MIN */ - d__1 = xbnd, d__2 = std::min(1.,tjj) * grow; - xbnd = std::min(d__1,d__2); - if (tjj + cnorm[j] >= smlnum) { - -/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ - - grow *= tjj / (tjj + cnorm[j]); - } else { - -/* G(j) could overflow, set GROW to 0. */ - - grow = 0.; - } -/* L30: */ - } - grow = xbnd; - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); - grow = std::min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ - - grow *= 1. / (cnorm[j] + 1.); -/* L40: */ - } - } -L50: - - ; - } else { - -/* Compute the growth in A' * x = b. */ - - if (upper) { - jfirst = 1; - jlast = *n; - jinc = 1; - maind = *kd + 1; - } else { - jfirst = *n; - jlast = 1; - jinc = -1; - maind = 1; - } - - if (tscal != 1.) { - grow = 0.; - goto L80; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, M(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / std::max(xbnd,smlnum); - xbnd = grow; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ - - xj = cnorm[j] + 1.; -/* Computing MIN */ - d__1 = grow, d__2 = xbnd / xj; - grow = std::min(d__1,d__2); - -/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ - - tjj = (d__1 = ab[maind + j * ab_dim1], abs(d__1)); - if (xj > tjj) { - xbnd *= tjj / xj; - } -/* L60: */ - } - grow = std::min(grow,xbnd); - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); - grow = std::min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ - - xj = cnorm[j] + 1.; - grow /= xj; -/* L70: */ - } - } -L80: - ; - } - - if (grow * tscal > smlnum) { - -/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ -/* elements of X is not too small. */ - - dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1); - } else { - -/* Use a Level 1 BLAS solve, scaling intermediate results. */ - - if (xmax > bignum) { - -/* Scale X so that its components are less than or equal to */ -/* BIGNUM in absolute value. */ - - *scale = bignum / xmax; - dscal_(n, scale, &x[1], &c__1); - xmax = bignum; - } - - if (notran) { - -/* Solve A * x = b */ - - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ - - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = ab[maind + j * ab_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L100; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale x by 1/b(j). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ -/* to avoid overflow when dividing by A(j,j). */ - - rec = tjj * bignum / xj; - if (cnorm[j] > 1.) { - -/* Scale by 1/CNORM(j) to avoid overflow when */ -/* multiplying x(j) times column j. */ - - rec /= cnorm[j]; - } - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L90: */ - } - x[j] = 1.; - xj = 1.; - *scale = 0.; - xmax = 0.; - } -L100: - -/* Scale x if necessary to avoid overflow when adding a */ -/* multiple of column j of A. */ - - if (xj > 1.) { - rec = 1. / xj; - if (cnorm[j] > (bignum - xmax) * rec) { - -/* Scale x by 1/(2*abs(x(j))). */ - - rec *= .5; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - } - } else if (xj * cnorm[j] > bignum - xmax) { - -/* Scale x by 1/2. */ - - dscal_(n, &c_b36, &x[1], &c__1); - *scale *= .5; - } - - if (upper) { - if (j > 1) { - -/* Compute the update */ -/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */ -/* x(j)* A(max(1,j-kd):j-1,j) */ - -/* Computing MIN */ - i__3 = *kd, i__4 = j - 1; - jlen = std::min(i__3,i__4); - d__1 = -x[j] * tscal; - daxpy_(&jlen, &d__1, &ab[*kd + 1 - jlen + j * ab_dim1] -, &c__1, &x[j - jlen], &c__1); - i__3 = j - 1; - i__ = idamax_(&i__3, &x[1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - } else if (j < *n) { - -/* Compute the update */ -/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */ -/* x(j) * A(j+1:min(j+kd,n),j) */ - -/* Computing MIN */ - i__3 = *kd, i__4 = *n - j; - jlen = std::min(i__3,i__4); - if (jlen > 0) { - d__1 = -x[j] * tscal; - daxpy_(&jlen, &d__1, &ab[j * ab_dim1 + 2], &c__1, &x[ - j + 1], &c__1); - } - i__3 = *n - j; - i__ = j + idamax_(&i__3, &x[j + 1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } -/* L110: */ - } - - } else { - -/* Solve A' * x = b */ - - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ -/* k<>j */ - - xj = (d__1 = x[j], abs(d__1)); - uscal = tscal; - rec = 1. / std::max(xmax,1.); - if (cnorm[j] > (bignum - xj) * rec) { - -/* If x(j) could overflow, scale x by 1/(2*XMAX). */ - - rec *= .5; - if (nounit) { - tjjs = ab[maind + j * ab_dim1] * tscal; - } else { - tjjs = tscal; - } - tjj = abs(tjjs); - if (tjj > 1.) { - -/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ - -/* Computing MIN */ - d__1 = 1., d__2 = rec * tjj; - rec = std::min(d__1,d__2); - uscal /= tjjs; - } - if (rec < 1.) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - sumj = 0.; - if (uscal == 1.) { - -/* If the scaling needed for A in the dot product is 1, */ -/* call DDOT to perform the dot product. */ - - if (upper) { -/* Computing MIN */ - i__3 = *kd, i__4 = j - 1; - jlen = std::min(i__3,i__4); - sumj = ddot_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], - &c__1, &x[j - jlen], &c__1); - } else { -/* Computing MIN */ - i__3 = *kd, i__4 = *n - j; - jlen = std::min(i__3,i__4); - if (jlen > 0) { - sumj = ddot_(&jlen, &ab[j * ab_dim1 + 2], &c__1, & - x[j + 1], &c__1); - } - } - } else { - -/* Otherwise, use in-line code for the dot product. */ - - if (upper) { -/* Computing MIN */ - i__3 = *kd, i__4 = j - 1; - jlen = std::min(i__3,i__4); - i__3 = jlen; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += ab[*kd + i__ - jlen + j * ab_dim1] * - uscal * x[j - jlen - 1 + i__]; -/* L120: */ - } - } else { -/* Computing MIN */ - i__3 = *kd, i__4 = *n - j; - jlen = std::min(i__3,i__4); - i__3 = jlen; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += ab[i__ + 1 + j * ab_dim1] * uscal * x[j + - i__]; -/* L130: */ - } - } - } - - if (uscal == tscal) { - -/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ -/* was not used to scale the dotproduct. */ - - x[j] -= sumj; - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - -/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ - - tjjs = ab[maind + j * ab_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L150; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale X by 1/abs(x(j)). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ - - rec = tjj * bignum / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A'*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L140: */ - } - x[j] = 1.; - *scale = 0.; - xmax = 0.; - } -L150: - ; - } else { - -/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ -/* product has already been divided by 1/A(j,j). */ - - x[j] = x[j] / tjjs - sumj; - } -/* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); - xmax = std::max(d__2,d__3); -/* L160: */ - } - } - *scale /= tscal; - } - -/* Scale the column norms by 1/TSCAL for return. */ - - if (tscal != 1.) { - d__1 = 1. / tscal; - dscal_(n, &d__1, &cnorm[1], &c__1); - } - - return 0; - -/* End of DLATBS */ - -} /* dlatbs_ */ diff --git a/external/clapack/lapack/dlatdf.cpp b/external/clapack/lapack/dlatdf.cpp deleted file mode 100644 index cbcfc523..00000000 --- a/external/clapack/lapack/dlatdf.cpp +++ /dev/null @@ -1,272 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b23 = 1.; -static double c_b37 = -1.; - -/* Subroutine */ int dlatdf_(integer *ijob, integer *n, double *z__, - integer *ldz, double *rhs, double *rdsum, double *rdscal, - integer *ipiv, integer *jpiv) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j, k; - double bm, bp, xm[8], xp[8]; - integer info; - double temp, work[32]; - double pmone; - double sminu; - integer iwork[8]; - double splus; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLATDF uses the LU factorization of the n-by-n matrix Z computed by */ -/* DGETC2 and computes a contribution to the reciprocal Dif-estimate */ -/* by solving Z * x = b for x, and choosing the r.h.s. b such that */ -/* the norm of x is as large as possible. On entry RHS = b holds the */ -/* contribution from earlier solved sub-systems, and on return RHS = x. */ - -/* The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q, */ -/* where P and Q are permutation matrices. L is lower triangular with */ -/* unit diagonal elements and U is upper triangular. */ - -/* Arguments */ -/* ========= */ - -/* IJOB (input) INTEGER */ -/* IJOB = 2: First compute an approximative null-vector e */ -/* of Z using DGECON, e is normalized and solve for */ -/* Zx = +-e - f with the sign giving the greater value */ -/* of 2-norm(x). About 5 times as expensive as Default. */ -/* IJOB .ne. 2: Local look ahead strategy where all entries of */ -/* the r.h.s. b is choosen as either +1 or -1 (Default). */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Z. */ - -/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* On entry, the LU part of the factorization of the n-by-n */ -/* matrix Z computed by DGETC2: Z = P * L * U * Q */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDA >= max(1, N). */ - -/* RHS (input/output) DOUBLE PRECISION array, dimension N. */ -/* On entry, RHS contains contributions from other subsystems. */ -/* On exit, RHS contains the solution of the subsystem with */ -/* entries acoording to the value of IJOB (see above). */ - -/* RDSUM (input/output) DOUBLE PRECISION */ -/* On entry, the sum of squares of computed contributions to */ -/* the Dif-estimate under computation by DTGSYL, where the */ -/* scaling factor RDSCAL (see below) has been factored out. */ -/* On exit, the corresponding sum of squares updated with the */ -/* contributions from the current sub-system. */ -/* If TRANS = 'T' RDSUM is not touched. */ -/* NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL. */ - -/* RDSCAL (input/output) DOUBLE PRECISION */ -/* On entry, scaling factor used to prevent overflow in RDSUM. */ -/* On exit, RDSCAL is updated w.r.t. the current contributions */ -/* in RDSUM. */ -/* If TRANS = 'T', RDSCAL is not touched. */ -/* NOTE: RDSCAL only makes sense when DTGSY2 is called by */ -/* DTGSYL. */ - -/* IPIV (input) INTEGER array, dimension (N). */ -/* The pivot indices; for 1 <= i <= N, row i of the */ -/* matrix has been interchanged with row IPIV(i). */ - -/* JPIV (input) INTEGER array, dimension (N). */ -/* The pivot indices; for 1 <= j <= N, column j of the */ -/* matrix has been interchanged with column JPIV(j). */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* This routine is a further developed implementation of algorithm */ -/* BSOLVE in [1] using complete pivoting in the LU factorization. */ - -/* [1] Bo Kagstrom and Lars Westin, */ -/* Generalized Schur Methods with Condition Estimators for */ -/* Solving the Generalized Sylvester Equation, IEEE Transactions */ -/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */ - -/* [2] Peter Poromaa, */ -/* On Efficient and Robust Estimators for the Separation */ -/* between two Regular Matrix Pairs with Applications in */ -/* Condition Estimation. Report IMINF-95.05, Departement of */ -/* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --rhs; - --ipiv; - --jpiv; - - /* Function Body */ - if (*ijob != 2) { - -/* Apply permutations IPIV to RHS */ - - i__1 = *n - 1; - dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1); - -/* Solve for L-part choosing RHS either to +1 or -1. */ - - pmone = -1.; - - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - bp = rhs[j] + 1.; - bm = rhs[j] - 1.; - splus = 1.; - -/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and */ -/* SMIN computed more efficiently than in BSOLVE [1]. */ - - i__2 = *n - j; - splus += ddot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1 - + j * z_dim1], &c__1); - i__2 = *n - j; - sminu = ddot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], - &c__1); - splus *= rhs[j]; - if (splus > sminu) { - rhs[j] = bp; - } else if (sminu > splus) { - rhs[j] = bm; - } else { - -/* In this case the updating sums are equal and we can */ -/* choose RHS(J) +1 or -1. The first time this happens */ -/* we choose -1, thereafter +1. This is a simple way to */ -/* get good estimates of matrices like Byers well-known */ -/* example (see [1]). (Not done in BSOLVE.) */ - - rhs[j] += pmone; - pmone = 1.; - } - -/* Compute the remaining r.h.s. */ - - temp = -rhs[j]; - i__2 = *n - j; - daxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], - &c__1); - -/* L10: */ - } - -/* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done */ -/* in BSOLVE and will hopefully give us a better estimate because */ -/* any ill-conditioning of the original matrix is transfered to U */ -/* and not to L. U(N, N) is an approximation to sigma_min(LU). */ - - i__1 = *n - 1; - dcopy_(&i__1, &rhs[1], &c__1, xp, &c__1); - xp[*n - 1] = rhs[*n] + 1.; - rhs[*n] += -1.; - splus = 0.; - sminu = 0.; - for (i__ = *n; i__ >= 1; --i__) { - temp = 1. / z__[i__ + i__ * z_dim1]; - xp[i__ - 1] *= temp; - rhs[i__] *= temp; - i__1 = *n; - for (k = i__ + 1; k <= i__1; ++k) { - xp[i__ - 1] -= xp[k - 1] * (z__[i__ + k * z_dim1] * temp); - rhs[i__] -= rhs[k] * (z__[i__ + k * z_dim1] * temp); -/* L20: */ - } - splus += (d__1 = xp[i__ - 1], abs(d__1)); - sminu += (d__1 = rhs[i__], abs(d__1)); -/* L30: */ - } - if (splus > sminu) { - dcopy_(n, xp, &c__1, &rhs[1], &c__1); - } - -/* Apply the permutations JPIV to the computed solution (RHS) */ - - i__1 = *n - 1; - dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1); - -/* Compute the sum of squares */ - - dlassq_(n, &rhs[1], &c__1, rdscal, rdsum); - - } else { - -/* IJOB = 2, Compute approximate nullvector XM of Z */ - - dgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, & - info); - dcopy_(n, &work[*n], &c__1, xm, &c__1); - -/* Compute RHS */ - - i__1 = *n - 1; - dlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1); - temp = 1. / sqrt(ddot_(n, xm, &c__1, xm, &c__1)); - dscal_(n, &temp, xm, &c__1); - dcopy_(n, xm, &c__1, xp, &c__1); - daxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1); - daxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1); - dgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp); - dgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp); - if (dasum_(n, xp, &c__1) > dasum_(n, &rhs[1], &c__1)) { - dcopy_(n, xp, &c__1, &rhs[1], &c__1); - } - -/* Compute the sum of squares */ - - dlassq_(n, &rhs[1], &c__1, rdscal, rdsum); - - } - - return 0; - -/* End of DLATDF */ - -} /* dlatdf_ */ diff --git a/external/clapack/lapack/dlatps.cpp b/external/clapack/lapack/dlatps.cpp deleted file mode 100644 index dd6077e4..00000000 --- a/external/clapack/lapack/dlatps.cpp +++ /dev/null @@ -1,799 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b36 = .5; - -/* Subroutine */ int dlatps_(const char *uplo, const char *trans, const char *diag, const char * - normin, integer *n, double *ap, double *x, double *scale, - double *cnorm, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, ip; - double xj, rec, tjj; - integer jinc, jlen; - double xbnd; - integer imax; - double tmax, tjjs, xmax, grow, sumj; - double tscal, uscal; - integer jlast; - bool upper; - double bignum; - bool notran; - integer jfirst; - double smlnum; - bool nounit; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLATPS solves one of the triangular systems */ - -/* A *x = s*b or A'*x = s*b */ - -/* with scaling to prevent overflow, where A is an upper or lower */ -/* triangular matrix stored in packed form. Here A' denotes the */ -/* transpose of A, x and b are n-element vectors, and s is a scaling */ -/* factor, usually less than or equal to 1, chosen so that the */ -/* components of x will be less than the overflow threshold. If the */ -/* unscaled problem will not cause overflow, the Level 2 BLAS routine */ -/* DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */ -/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the operation applied to A. */ -/* = 'N': Solve A * x = s*b (No transpose) */ -/* = 'T': Solve A'* x = s*b (Transpose) */ -/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* NORMIN (input) CHARACTER*1 */ -/* Specifies whether CNORM has been set or not. */ -/* = 'Y': CNORM contains the column norms on entry */ -/* = 'N': CNORM is not set on entry. On exit, the norms will */ -/* be computed and stored in CNORM. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangular matrix A, packed columnwise in */ -/* a linear array. The j-th column of A is stored in the array */ -/* AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* X (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the right hand side b of the triangular system. */ -/* On exit, X is overwritten by the solution vector x. */ - -/* SCALE (output) DOUBLE PRECISION */ -/* The scaling factor s for the triangular system */ -/* A * x = s*b or A'* x = s*b. */ -/* If SCALE = 0, the matrix A is singular or badly scaled, and */ -/* the vector x is an exact or approximate solution to A*x = 0. */ - -/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ - -/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ -/* contains the norm of the off-diagonal part of the j-th column */ -/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ -/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ -/* must be greater than or equal to the 1-norm. */ - -/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ -/* returns the 1-norm of the offdiagonal part of the j-th column */ -/* of A. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* Further Details */ -/* ======= ======= */ - -/* A rough bound on x is computed; if that is less than overflow, DTPSV */ -/* is called, otherwise, specific code is used which checks for possible */ -/* overflow or divide-by-zero at every operation. */ - -/* A columnwise scheme is used for solving A*x = b. The basic algorithm */ -/* if A is lower triangular is */ - -/* x[1:n] := b[1:n] */ -/* for j = 1, ..., n */ -/* x(j) := x(j) / A(j,j) */ -/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ -/* end */ - -/* Define bounds on the components of x after j iterations of the loop: */ -/* M(j) = bound on x[1:j] */ -/* G(j) = bound on x[j+1:n] */ -/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ - -/* Then for iteration j+1 we have */ -/* M(j+1) <= G(j) / | A(j+1,j+1) | */ -/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ -/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ - -/* where CNORM(j+1) is greater than or equal to the infinity-norm of */ -/* column j+1 of A, not counting the diagonal. Hence */ - -/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ -/* 1<=i<=j */ -/* and */ - -/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ -/* 1<=i< j */ - -/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the */ -/* reciprocal of the largest M(j), j=1,..,n, is larger than */ -/* max(underflow, 1/overflow). */ - -/* The bound on x(j) is also used to determine when a step in the */ -/* columnwise method can be performed without fear of overflow. If */ -/* the computed bound is greater than a large constant, x is scaled to */ -/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ -/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ - -/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */ -/* algorithm for A upper triangular is */ - -/* for j = 1, ..., n */ -/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ -/* end */ - -/* We simultaneously compute two bounds */ -/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ -/* M(j) = bound on x(i), 1<=i<=j */ - -/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ -/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ -/* Then the bound on x(j) is */ - -/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ - -/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ -/* 1<=i<=j */ - -/* and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater */ -/* than max(underflow, 1/overflow). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --cnorm; - --x; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - notran = lsame_(trans, "N"); - nounit = lsame_(diag, "N"); - -/* Test the input parameters. */ - - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (! lsame_(normin, "Y") && ! lsame_(normin, - "N")) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLATPS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine machine dependent parameters to control overflow. */ - - smlnum = dlamch_("Safe minimum") / dlamch_("Precision"); - bignum = 1. / smlnum; - *scale = 1.; - - if (lsame_(normin, "N")) { - -/* Compute the 1-norm of each column, not including the diagonal. */ - - if (upper) { - -/* A is upper triangular. */ - - ip = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - cnorm[j] = dasum_(&i__2, &ap[ip], &c__1); - ip += j; -/* L10: */ - } - } else { - -/* A is lower triangular. */ - - ip = 1; - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - cnorm[j] = dasum_(&i__2, &ap[ip + 1], &c__1); - ip = ip + *n - j + 1; -/* L20: */ - } - cnorm[*n] = 0.; - } - } - -/* Scale the column norms by TSCAL if the maximum element in CNORM is */ -/* greater than BIGNUM. */ - - imax = idamax_(n, &cnorm[1], &c__1); - tmax = cnorm[imax]; - if (tmax <= bignum) { - tscal = 1.; - } else { - tscal = 1. / (smlnum * tmax); - dscal_(n, &tscal, &cnorm[1], &c__1); - } - -/* Compute a bound on the computed solution vector to see if the */ -/* Level 2 BLAS routine DTPSV can be used. */ - - j = idamax_(n, &x[1], &c__1); - xmax = (d__1 = x[j], abs(d__1)); - xbnd = xmax; - if (notran) { - -/* Compute the growth in A * x = b. */ - - if (upper) { - jfirst = *n; - jlast = 1; - jinc = -1; - } else { - jfirst = 1; - jlast = *n; - jinc = 1; - } - - if (tscal != 1.) { - grow = 0.; - goto L50; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, G(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / std::max(xbnd,smlnum); - xbnd = grow; - ip = jfirst * (jfirst + 1) / 2; - jlen = *n; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* M(j) = G(j-1) / abs(A(j,j)) */ - - tjj = (d__1 = ap[ip], abs(d__1)); -/* Computing MIN */ - d__1 = xbnd, d__2 = std::min(1.,tjj) * grow; - xbnd = std::min(d__1,d__2); - if (tjj + cnorm[j] >= smlnum) { - -/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ - - grow *= tjj / (tjj + cnorm[j]); - } else { - -/* G(j) could overflow, set GROW to 0. */ - - grow = 0.; - } - ip += jinc * jlen; - --jlen; -/* L30: */ - } - grow = xbnd; - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); - grow = std::min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ - - grow *= 1. / (cnorm[j] + 1.); -/* L40: */ - } - } -L50: - - ; - } else { - -/* Compute the growth in A' * x = b. */ - - if (upper) { - jfirst = 1; - jlast = *n; - jinc = 1; - } else { - jfirst = *n; - jlast = 1; - jinc = -1; - } - - if (tscal != 1.) { - grow = 0.; - goto L80; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, M(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / std::max(xbnd,smlnum); - xbnd = grow; - ip = jfirst * (jfirst + 1) / 2; - jlen = 1; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ - - xj = cnorm[j] + 1.; -/* Computing MIN */ - d__1 = grow, d__2 = xbnd / xj; - grow = std::min(d__1,d__2); - -/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ - - tjj = (d__1 = ap[ip], abs(d__1)); - if (xj > tjj) { - xbnd *= tjj / xj; - } - ++jlen; - ip += jinc * jlen; -/* L60: */ - } - grow = std::min(grow,xbnd); - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); - grow = std::min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ - - xj = cnorm[j] + 1.; - grow /= xj; -/* L70: */ - } - } -L80: - ; - } - - if (grow * tscal > smlnum) { - -/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ -/* elements of X is not too small. */ - - dtpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1); - } else { - -/* Use a Level 1 BLAS solve, scaling intermediate results. */ - - if (xmax > bignum) { - -/* Scale X so that its components are less than or equal to */ -/* BIGNUM in absolute value. */ - - *scale = bignum / xmax; - dscal_(n, scale, &x[1], &c__1); - xmax = bignum; - } - - if (notran) { - -/* Solve A * x = b */ - - ip = jfirst * (jfirst + 1) / 2; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ - - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = ap[ip] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L100; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale x by 1/b(j). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ -/* to avoid overflow when dividing by A(j,j). */ - - rec = tjj * bignum / xj; - if (cnorm[j] > 1.) { - -/* Scale by 1/CNORM(j) to avoid overflow when */ -/* multiplying x(j) times column j. */ - - rec /= cnorm[j]; - } - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L90: */ - } - x[j] = 1.; - xj = 1.; - *scale = 0.; - xmax = 0.; - } -L100: - -/* Scale x if necessary to avoid overflow when adding a */ -/* multiple of column j of A. */ - - if (xj > 1.) { - rec = 1. / xj; - if (cnorm[j] > (bignum - xmax) * rec) { - -/* Scale x by 1/(2*abs(x(j))). */ - - rec *= .5; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - } - } else if (xj * cnorm[j] > bignum - xmax) { - -/* Scale x by 1/2. */ - - dscal_(n, &c_b36, &x[1], &c__1); - *scale *= .5; - } - - if (upper) { - if (j > 1) { - -/* Compute the update */ -/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ - - i__3 = j - 1; - d__1 = -x[j] * tscal; - daxpy_(&i__3, &d__1, &ap[ip - j + 1], &c__1, &x[1], & - c__1); - i__3 = j - 1; - i__ = idamax_(&i__3, &x[1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - ip -= j; - } else { - if (j < *n) { - -/* Compute the update */ -/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ - - i__3 = *n - j; - d__1 = -x[j] * tscal; - daxpy_(&i__3, &d__1, &ap[ip + 1], &c__1, &x[j + 1], & - c__1); - i__3 = *n - j; - i__ = j + idamax_(&i__3, &x[j + 1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - ip = ip + *n - j + 1; - } -/* L110: */ - } - - } else { - -/* Solve A' * x = b */ - - ip = jfirst * (jfirst + 1) / 2; - jlen = 1; - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ -/* k<>j */ - - xj = (d__1 = x[j], abs(d__1)); - uscal = tscal; - rec = 1. / std::max(xmax,1.); - if (cnorm[j] > (bignum - xj) * rec) { - -/* If x(j) could overflow, scale x by 1/(2*XMAX). */ - - rec *= .5; - if (nounit) { - tjjs = ap[ip] * tscal; - } else { - tjjs = tscal; - } - tjj = abs(tjjs); - if (tjj > 1.) { - -/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ - -/* Computing MIN */ - d__1 = 1., d__2 = rec * tjj; - rec = std::min(d__1,d__2); - uscal /= tjjs; - } - if (rec < 1.) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - sumj = 0.; - if (uscal == 1.) { - -/* If the scaling needed for A in the dot product is 1, */ -/* call DDOT to perform the dot product. */ - - if (upper) { - i__3 = j - 1; - sumj = ddot_(&i__3, &ap[ip - j + 1], &c__1, &x[1], & - c__1); - } else if (j < *n) { - i__3 = *n - j; - sumj = ddot_(&i__3, &ap[ip + 1], &c__1, &x[j + 1], & - c__1); - } - } else { - -/* Otherwise, use in-line code for the dot product. */ - - if (upper) { - i__3 = j - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += ap[ip - j + i__] * uscal * x[i__]; -/* L120: */ - } - } else if (j < *n) { - i__3 = *n - j; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += ap[ip + i__] * uscal * x[j + i__]; -/* L130: */ - } - } - } - - if (uscal == tscal) { - -/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ -/* was not used to scale the dotproduct. */ - - x[j] -= sumj; - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - -/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ - - tjjs = ap[ip] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L150; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale X by 1/abs(x(j)). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ - - rec = tjj * bignum / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A'*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L140: */ - } - x[j] = 1.; - *scale = 0.; - xmax = 0.; - } -L150: - ; - } else { - -/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ -/* product has already been divided by 1/A(j,j). */ - - x[j] = x[j] / tjjs - sumj; - } -/* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); - xmax = std::max(d__2,d__3); - ++jlen; - ip += jinc * jlen; -/* L160: */ - } - } - *scale /= tscal; - } - -/* Scale the column norms by 1/TSCAL for return. */ - - if (tscal != 1.) { - d__1 = 1. / tscal; - dscal_(n, &d__1, &cnorm[1], &c__1); - } - - return 0; - -/* End of DLATPS */ - -} /* dlatps_ */ diff --git a/external/clapack/lapack/dlatrd.cpp b/external/clapack/lapack/dlatrd.cpp deleted file mode 100644 index 9c280adc..00000000 --- a/external/clapack/lapack/dlatrd.cpp +++ /dev/null @@ -1,330 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b5 = -1.; -static double c_b6 = 1.; -static integer c__1 = 1; -static double c_b16 = 0.; - -/* Subroutine */ int dlatrd_(const char *uplo, integer *n, integer *nb, double * - a, integer *lda, double *e, double *tau, double *w, - integer *ldw) -{ - /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, iw; - double alpha; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLATRD reduces NB rows and columns of a real symmetric matrix A to */ -/* symmetric tridiagonal form by an orthogonal similarity */ -/* transformation Q' * A * Q, and returns the matrices V and W which are */ -/* needed to apply the transformation to the unreduced part of A. */ - -/* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a */ -/* matrix, of which the upper triangle is supplied; */ -/* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a */ -/* matrix, of which the lower triangle is supplied. */ - -/* This is an auxiliary routine called by DSYTRD. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. */ - -/* NB (input) INTEGER */ -/* The number of rows and columns to be reduced. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n-by-n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n-by-n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ -/* On exit: */ -/* if UPLO = 'U', the last NB columns have been reduced to */ -/* tridiagonal form, with the diagonal elements overwriting */ -/* the diagonal elements of A; the elements above the diagonal */ -/* with the array TAU, represent the orthogonal matrix Q as a */ -/* product of elementary reflectors; */ -/* if UPLO = 'L', the first NB columns have been reduced to */ -/* tridiagonal form, with the diagonal elements overwriting */ -/* the diagonal elements of A; 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 >= (1,N). */ - -/* E (output) DOUBLE PRECISION array, dimension (N-1) */ -/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */ -/* elements of the last NB columns of the reduced matrix; */ -/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */ -/* the first NB columns of the reduced matrix. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors, stored in */ -/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */ -/* See Further Details. */ - -/* W (output) DOUBLE PRECISION array, dimension (LDW,NB) */ -/* The n-by-nb matrix W required to update the unreduced part */ -/* of A. */ - -/* LDW (input) INTEGER */ -/* The leading dimension of the array W. LDW >= max(1,N). */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n) H(n-1) . . . H(n-nb+1). */ - -/* 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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */ -/* and tau in TAU(i-1). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(nb). */ - -/* 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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ -/* and tau in TAU(i). */ - -/* The elements of the vectors v together form the n-by-nb matrix V */ -/* which is needed, with W, to apply the transformation to the unreduced */ -/* part of the matrix, using a symmetric rank-2k update of the form: */ -/* A := A - V*W' - W*V'. */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5 and nb = 2: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( a a a v4 v5 ) ( d ) */ -/* ( a a v4 v5 ) ( 1 d ) */ -/* ( a 1 v5 ) ( v1 1 a ) */ -/* ( d 1 ) ( v1 v2 a a ) */ -/* ( d ) ( v1 v2 a a a ) */ - -/* where d denotes a diagonal element of the reduced matrix, a denotes */ -/* an element of the original matrix that is unchanged, and vi denotes */ -/* an element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --e; - --tau; - w_dim1 = *ldw; - w_offset = 1 + w_dim1; - w -= w_offset; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - - if (lsame_(uplo, "U")) { - -/* Reduce last NB columns of upper triangle */ - - i__1 = *n - *nb + 1; - for (i__ = *n; i__ >= i__1; --i__) { - iw = i__ - *n + *nb; - if (i__ < *n) { - -/* Update A(1:i,i) */ - - i__2 = *n - i__; - dgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & - c_b6, &a[i__ * a_dim1 + 1], &c__1); - i__2 = *n - i__; - dgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & - c_b6, &a[i__ * a_dim1 + 1], &c__1); - } - if (i__ > 1) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(1:i-2,i) */ - - i__2 = i__ - 1; - dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + - 1], &c__1, &tau[i__ - 1]); - e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; - a[i__ - 1 + i__ * a_dim1] = 1.; - -/* Compute W(1:i-1,i) */ - - i__2 = i__ - 1; - dsymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * - a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], & - c__1); - if (i__ < *n) { - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * - w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, & - c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * - a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, & - c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * - w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & - c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); - } - i__2 = i__ - 1; - dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); - i__2 = i__ - 1; - alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1], - &c__1, &a[i__ * a_dim1 + 1], &c__1); - i__2 = i__ - 1; - daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * - w_dim1 + 1], &c__1); - } - -/* L10: */ - } - } else { - -/* Reduce first NB columns of lower triangle */ - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Update A(i:n,i) */ - - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, - &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], & - c__1); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, - &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], & - c__1); - if (i__ < *n) { - -/* Generate elementary reflector H(i) to annihilate */ -/* A(i+2:n,i) */ - - i__2 = *n - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *n)+ - i__ * a_dim1], &c__1, &tau[i__]); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - a[i__ + 1 + i__ * a_dim1] = 1.; - -/* Compute W(i+1:n,i) */ - - i__2 = *n - i__; - dsymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1] -, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], - ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ * w_dim1 + 1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + - a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ - i__ * w_dim1 + 1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + - w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); - i__2 = *n - i__; - alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ * - w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - i__2 = *n - i__; - daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ - i__ + 1 + i__ * w_dim1], &c__1); - } - -/* L20: */ - } - } - - return 0; - -/* End of DLATRD */ - -} /* dlatrd_ */ diff --git a/external/clapack/lapack/dlatrs.cpp b/external/clapack/lapack/dlatrs.cpp deleted file mode 100644 index d9181216..00000000 --- a/external/clapack/lapack/dlatrs.cpp +++ /dev/null @@ -1,790 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b36 = .5; - -/* Subroutine */ int dlatrs_(const char *uplo, const char *trans, const char *diag, const char * - normin, integer *n, double *a, integer *lda, double *x, - double *scale, double *cnorm, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j; - double xj, rec, tjj; - integer jinc; - double xbnd; - integer imax; - double tmax, tjjs, xmax, grow, sumj; - double tscal, uscal; - integer jlast; - bool upper; - double bignum; - bool notran; - integer jfirst; - double smlnum; - bool nounit; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLATRS solves one of the triangular systems */ - -/* A *x = s*b or A'*x = s*b */ - -/* with scaling to prevent overflow. Here A is an upper or lower */ -/* triangular matrix, A' denotes the transpose of A, x and b are */ -/* n-element vectors, and s is a scaling factor, usually less than */ -/* or equal to 1, chosen so that the components of x will be less than */ -/* the overflow threshold. If the unscaled problem will not cause */ -/* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A */ -/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ -/* non-trivial solution to A*x = 0 is returned. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the operation applied to A. */ -/* = 'N': Solve A * x = s*b (No transpose) */ -/* = 'T': Solve A'* x = s*b (Transpose) */ -/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* NORMIN (input) CHARACTER*1 */ -/* Specifies whether CNORM has been set or not. */ -/* = 'Y': CNORM contains the column norms on entry */ -/* = 'N': CNORM is not set on entry. On exit, the norms will */ -/* be computed and stored in CNORM. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular matrix A. If UPLO = 'U', the leading n by n */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading n by n lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max (1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the right hand side b of the triangular system. */ -/* On exit, X is overwritten by the solution vector x. */ - -/* SCALE (output) DOUBLE PRECISION */ -/* The scaling factor s for the triangular system */ -/* A * x = s*b or A'* x = s*b. */ -/* If SCALE = 0, the matrix A is singular or badly scaled, and */ -/* the vector x is an exact or approximate solution to A*x = 0. */ - -/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ - -/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ -/* contains the norm of the off-diagonal part of the j-th column */ -/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ -/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ -/* must be greater than or equal to the 1-norm. */ - -/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ -/* returns the 1-norm of the offdiagonal part of the j-th column */ -/* of A. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* Further Details */ -/* ======= ======= */ - -/* A rough bound on x is computed; if that is less than overflow, DTRSV */ -/* is called, otherwise, specific code is used which checks for possible */ -/* overflow or divide-by-zero at every operation. */ - -/* A columnwise scheme is used for solving A*x = b. The basic algorithm */ -/* if A is lower triangular is */ - -/* x[1:n] := b[1:n] */ -/* for j = 1, ..., n */ -/* x(j) := x(j) / A(j,j) */ -/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ -/* end */ - -/* Define bounds on the components of x after j iterations of the loop: */ -/* M(j) = bound on x[1:j] */ -/* G(j) = bound on x[j+1:n] */ -/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ - -/* Then for iteration j+1 we have */ -/* M(j+1) <= G(j) / | A(j+1,j+1) | */ -/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ -/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ - -/* where CNORM(j+1) is greater than or equal to the infinity-norm of */ -/* column j+1 of A, not counting the diagonal. Hence */ - -/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ -/* 1<=i<=j */ -/* and */ - -/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ -/* 1<=i< j */ - -/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the */ -/* reciprocal of the largest M(j), j=1,..,n, is larger than */ -/* max(underflow, 1/overflow). */ - -/* The bound on x(j) is also used to determine when a step in the */ -/* columnwise method can be performed without fear of overflow. If */ -/* the computed bound is greater than a large constant, x is scaled to */ -/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ -/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ - -/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */ -/* algorithm for A upper triangular is */ - -/* for j = 1, ..., n */ -/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ -/* end */ - -/* We simultaneously compute two bounds */ -/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ -/* M(j) = bound on x(i), 1<=i<=j */ - -/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ -/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ -/* Then the bound on x(j) is */ - -/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ - -/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ -/* 1<=i<=j */ - -/* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater */ -/* than max(underflow, 1/overflow). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --cnorm; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - notran = lsame_(trans, "N"); - nounit = lsame_(diag, "N"); - -/* Test the input parameters. */ - - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (! lsame_(normin, "Y") && ! lsame_(normin, - "N")) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLATRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine machine dependent parameters to control overflow. */ - - smlnum = dlamch_("Safe minimum") / dlamch_("Precision"); - bignum = 1. / smlnum; - *scale = 1.; - - if (lsame_(normin, "N")) { - -/* Compute the 1-norm of each column, not including the diagonal. */ - - if (upper) { - -/* A is upper triangular. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1); -/* L10: */ - } - } else { - -/* A is lower triangular. */ - - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); -/* L20: */ - } - cnorm[*n] = 0.; - } - } - -/* Scale the column norms by TSCAL if the maximum element in CNORM is */ -/* greater than BIGNUM. */ - - imax = idamax_(n, &cnorm[1], &c__1); - tmax = cnorm[imax]; - if (tmax <= bignum) { - tscal = 1.; - } else { - tscal = 1. / (smlnum * tmax); - dscal_(n, &tscal, &cnorm[1], &c__1); - } - -/* Compute a bound on the computed solution vector to see if the */ -/* Level 2 BLAS routine DTRSV can be used. */ - - j = idamax_(n, &x[1], &c__1); - xmax = (d__1 = x[j], abs(d__1)); - xbnd = xmax; - if (notran) { - -/* Compute the growth in A * x = b. */ - - if (upper) { - jfirst = *n; - jlast = 1; - jinc = -1; - } else { - jfirst = 1; - jlast = *n; - jinc = 1; - } - - if (tscal != 1.) { - grow = 0.; - goto L50; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, G(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / std::max(xbnd,smlnum); - xbnd = grow; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* M(j) = G(j-1) / abs(A(j,j)) */ - - tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); -/* Computing MIN */ - d__1 = xbnd, d__2 = std::min(1.,tjj) * grow; - xbnd = std::min(d__1,d__2); - if (tjj + cnorm[j] >= smlnum) { - -/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ - - grow *= tjj / (tjj + cnorm[j]); - } else { - -/* G(j) could overflow, set GROW to 0. */ - - grow = 0.; - } -/* L30: */ - } - grow = xbnd; - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); - grow = std::min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ - - grow *= 1. / (cnorm[j] + 1.); -/* L40: */ - } - } -L50: - - ; - } else { - -/* Compute the growth in A' * x = b. */ - - if (upper) { - jfirst = 1; - jlast = *n; - jinc = 1; - } else { - jfirst = *n; - jlast = 1; - jinc = -1; - } - - if (tscal != 1.) { - grow = 0.; - goto L80; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, M(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / std::max(xbnd,smlnum); - xbnd = grow; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ - - xj = cnorm[j] + 1.; -/* Computing MIN */ - d__1 = grow, d__2 = xbnd / xj; - grow = std::min(d__1,d__2); - -/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ - - tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); - if (xj > tjj) { - xbnd *= tjj / xj; - } -/* L60: */ - } - grow = std::min(grow,xbnd); - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); - grow = std::min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ - - xj = cnorm[j] + 1.; - grow /= xj; -/* L70: */ - } - } -L80: - ; - } - - if (grow * tscal > smlnum) { - -/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ -/* elements of X is not too small. */ - - dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1); - } else { - -/* Use a Level 1 BLAS solve, scaling intermediate results. */ - - if (xmax > bignum) { - -/* Scale X so that its components are less than or equal to */ -/* BIGNUM in absolute value. */ - - *scale = bignum / xmax; - dscal_(n, scale, &x[1], &c__1); - xmax = bignum; - } - - if (notran) { - -/* Solve A * x = b */ - - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ - - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L100; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale x by 1/b(j). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ -/* to avoid overflow when dividing by A(j,j). */ - - rec = tjj * bignum / xj; - if (cnorm[j] > 1.) { - -/* Scale by 1/CNORM(j) to avoid overflow when */ -/* multiplying x(j) times column j. */ - - rec /= cnorm[j]; - } - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L90: */ - } - x[j] = 1.; - xj = 1.; - *scale = 0.; - xmax = 0.; - } -L100: - -/* Scale x if necessary to avoid overflow when adding a */ -/* multiple of column j of A. */ - - if (xj > 1.) { - rec = 1. / xj; - if (cnorm[j] > (bignum - xmax) * rec) { - -/* Scale x by 1/(2*abs(x(j))). */ - - rec *= .5; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - } - } else if (xj * cnorm[j] > bignum - xmax) { - -/* Scale x by 1/2. */ - - dscal_(n, &c_b36, &x[1], &c__1); - *scale *= .5; - } - - if (upper) { - if (j > 1) { - -/* Compute the update */ -/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ - - i__3 = j - 1; - d__1 = -x[j] * tscal; - daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1], - &c__1); - i__3 = j - 1; - i__ = idamax_(&i__3, &x[1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - } else { - if (j < *n) { - -/* Compute the update */ -/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ - - i__3 = *n - j; - d__1 = -x[j] * tscal; - daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, & - x[j + 1], &c__1); - i__3 = *n - j; - i__ = j + idamax_(&i__3, &x[j + 1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - } -/* L110: */ - } - - } else { - -/* Solve A' * x = b */ - - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ -/* k<>j */ - - xj = (d__1 = x[j], abs(d__1)); - uscal = tscal; - rec = 1. / std::max(xmax,1.); - if (cnorm[j] > (bignum - xj) * rec) { - -/* If x(j) could overflow, scale x by 1/(2*XMAX). */ - - rec *= .5; - if (nounit) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - } - tjj = abs(tjjs); - if (tjj > 1.) { - -/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ - -/* Computing MIN */ - d__1 = 1., d__2 = rec * tjj; - rec = std::min(d__1,d__2); - uscal /= tjjs; - } - if (rec < 1.) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - sumj = 0.; - if (uscal == 1.) { - -/* If the scaling needed for A in the dot product is 1, */ -/* call DDOT to perform the dot product. */ - - if (upper) { - i__3 = j - 1; - sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], - &c__1); - } else if (j < *n) { - i__3 = *n - j; - sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[ - j + 1], &c__1); - } - } else { - -/* Otherwise, use in-line code for the dot product. */ - - if (upper) { - i__3 = j - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += a[i__ + j * a_dim1] * uscal * x[i__]; -/* L120: */ - } - } else if (j < *n) { - i__3 = *n; - for (i__ = j + 1; i__ <= i__3; ++i__) { - sumj += a[i__ + j * a_dim1] * uscal * x[i__]; -/* L130: */ - } - } - } - - if (uscal == tscal) { - -/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ -/* was not used to scale the dotproduct. */ - - x[j] -= sumj; - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L150; - } - } - -/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ - - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale X by 1/abs(x(j)). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ - - rec = tjj * bignum / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A'*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L140: */ - } - x[j] = 1.; - *scale = 0.; - xmax = 0.; - } -L150: - ; - } else { - -/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ -/* product has already been divided by 1/A(j,j). */ - - x[j] = x[j] / tjjs - sumj; - } -/* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); - xmax = std::max(d__2,d__3); -/* L160: */ - } - } - *scale /= tscal; - } - -/* Scale the column norms by 1/TSCAL for return. */ - - if (tscal != 1.) { - d__1 = 1. / tscal; - dscal_(n, &d__1, &cnorm[1], &c__1); - } - - return 0; - -/* End of DLATRS */ - -} /* dlatrs_ */ diff --git a/external/clapack/lapack/dlatrz.cpp b/external/clapack/lapack/dlatrz.cpp deleted file mode 100644 index f368680c..00000000 --- a/external/clapack/lapack/dlatrz.cpp +++ /dev/null @@ -1,145 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dlatrz_(integer *m, integer *n, integer *l, double *a, integer *lda, double *tau, double *work) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__; - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix */ -/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means */ -/* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal */ -/* matrix and, R and A1 are M-by-M upper triangular matrices. */ - -/* 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. */ - -/* L (input) INTEGER */ -/* The number of columns of the matrix A containing the */ -/* meaningful part of the Householder vectors. N-M >= L >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the leading M-by-N upper trapezoidal part of the */ -/* array A must contain the matrix to be factorized. */ -/* On exit, the leading M-by-M upper triangular part of A */ -/* contains the upper triangular matrix R, and elements N-L+1 to */ -/* N of the first M rows of A, with the array TAU, represent the */ -/* orthogonal matrix Z as a product of M elementary reflectors. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* TAU (output) DOUBLE PRECISION array, dimension (M) */ -/* The scalar factors of the elementary reflectors. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* The factorization is obtained by Householder's method. The kth */ -/* transformation matrix, Z( k ), which is used to introduce zeros into */ -/* the ( m - k + 1 )th row of A, is given in the form */ - -/* Z( k ) = ( I 0 ), */ -/* ( 0 T( k ) ) */ - -/* where */ - -/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */ -/* ( 0 ) */ -/* ( z( k ) ) */ - -/* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */ -/* are chosen to annihilate the elements of the kth row of A2. */ - -/* The scalar tau is returned in the kth element of TAU and the vector */ -/* u( k ) in the kth row of A2, such that the elements of z( k ) are */ -/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */ -/* the upper triangular part of A1. */ - -/* Z is given by */ - -/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - if (*m == 0) { - return 0; - } else if (*m == *n) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - tau[i__] = 0.; -/* L10: */ - } - return 0; - } - - for (i__ = *m; i__ >= 1; --i__) { - -/* Generate elementary reflector H(i) to annihilate */ -/* [ A(i,i) A(i,n-l+1:n) ] */ - - i__1 = *l + 1; - dlarfp_(&i__1, &a[i__ + i__ * a_dim1], &a[i__ + (*n - *l + 1) * - a_dim1], lda, &tau[i__]); - -/* Apply H(i) to A(1:i-1,i:n) from the right */ - - i__1 = i__ - 1; - i__2 = *n - i__ + 1; - dlarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1], - lda, &tau[i__], &a[i__ * a_dim1 + 1], lda, &work[1]); - -/* L20: */ - } - - return 0; - -/* End of DLATRZ */ - -} /* dlatrz_ */ diff --git a/external/clapack/lapack/dlatzm.cpp b/external/clapack/lapack/dlatzm.cpp deleted file mode 100644 index c36417cb..00000000 --- a/external/clapack/lapack/dlatzm.cpp +++ /dev/null @@ -1,168 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b5 = 1.; - -/* Subroutine */ int dlatzm_(const char *side, integer *m, integer *n, double * - v, integer *incv, double *tau, double *c1, double *c2, - integer *ldc, double *work) -{ - /* System generated locals */ - integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1; - double d__1; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This routine is deprecated and has been replaced by routine DORMRZ. */ - -/* DLATZM applies a Householder matrix generated by DTZRQF to a matrix. */ - -/* Let P = I - tau*u*u', u = ( 1 ), */ -/* ( v ) */ -/* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */ -/* SIDE = 'R'. */ - -/* If SIDE equals 'L', let */ -/* C = [ C1 ] 1 */ -/* [ C2 ] m-1 */ -/* n */ -/* Then C is overwritten by P*C. */ - -/* If SIDE equals 'R', let */ -/* C = [ C1, C2 ] m */ -/* 1 n-1 */ -/* Then C is overwritten by C*P. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': form P * C */ -/* = 'R': form C * P */ - -/* 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' */ -/* (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ -/* The vector v in the representation of P. 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 P. */ - -/* C1 (input/output) DOUBLE PRECISION array, dimension */ -/* (LDC,N) if SIDE = 'L' */ -/* (M,1) if SIDE = 'R' */ -/* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */ -/* if SIDE = 'R'. */ - -/* On exit, the first row of P*C if SIDE = 'L', or the first */ -/* column of C*P if SIDE = 'R'. */ - -/* C2 (input/output) DOUBLE PRECISION array, dimension */ -/* (LDC, N) if SIDE = 'L' */ -/* (LDC, N-1) if SIDE = 'R' */ -/* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */ -/* m x (n - 1) matrix C2 if SIDE = 'R'. */ - -/* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */ -/* if SIDE = 'R'. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the arrays C1 and C2. LDC >= (1,M). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension */ -/* (N) if SIDE = 'L' */ -/* (M) if SIDE = 'R' */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --v; - c2_dim1 = *ldc; - c2_offset = 1 + c2_dim1; - c2 -= c2_offset; - c1_dim1 = *ldc; - c1_offset = 1 + c1_dim1; - c1 -= c1_offset; - --work; - - /* Function Body */ - if (std::min(*m,*n) == 0 || *tau == 0.) { - return 0; - } - - if (lsame_(side, "L")) { - -/* w := C1 + v' * C2 */ - - dcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1); - i__1 = *m - 1; - dgemv_("Transpose", &i__1, n, &c_b5, &c2[c2_offset], ldc, &v[1], incv, - &c_b5, &work[1], &c__1); - -/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' */ -/* [ C2 ] [ C2 ] [ v ] */ - - d__1 = -(*tau); - daxpy_(n, &d__1, &work[1], &c__1, &c1[c1_offset], ldc); - i__1 = *m - 1; - d__1 = -(*tau); - dger_(&i__1, n, &d__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], - ldc); - - } else if (lsame_(side, "R")) { - -/* w := C1 + C2 * v */ - - dcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1); - i__1 = *n - 1; - dgemv_("No transpose", m, &i__1, &c_b5, &c2[c2_offset], ldc, &v[1], - incv, &c_b5, &work[1], &c__1); - -/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */ - - d__1 = -(*tau); - daxpy_(m, &d__1, &work[1], &c__1, &c1[c1_offset], &c__1); - i__1 = *n - 1; - d__1 = -(*tau); - dger_(m, &i__1, &d__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], - ldc); - } - - return 0; - -/* End of DLATZM */ - -} /* dlatzm_ */ diff --git a/external/clapack/lapack/dlauu2.cpp b/external/clapack/lapack/dlauu2.cpp deleted file mode 100644 index 0faa4839..00000000 --- a/external/clapack/lapack/dlauu2.cpp +++ /dev/null @@ -1,162 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b7 = 1.; -static integer c__1 = 1; - -/* Subroutine */ int dlauu2_(const char *uplo, integer *n, double *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - double aii; - bool upper; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAUU2 computes the product U * U' or L' * L, where the triangular */ -/* factor U or L is stored in the upper or lower triangular part of */ -/* the array A. */ - -/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* overwriting the factor U in A. */ -/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* overwriting the factor L in A. */ - -/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the triangular factor stored in the array A */ -/* is upper or lower triangular: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the triangular factor U or L. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L. */ -/* On exit, if UPLO = 'U', the upper triangle of A is */ -/* overwritten with the upper triangle of the product U * U'; */ -/* if UPLO = 'L', the lower triangle of A is overwritten with */ -/* the lower triangle of the product L' * L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAUU2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the product U * U'. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - aii = a[i__ + i__ * a_dim1]; - if (i__ < *n) { - i__2 = *n - i__ + 1; - a[i__ + i__ * a_dim1] = ddot_(&i__2, &a[i__ + i__ * a_dim1], - lda, &a[i__ + i__ * a_dim1], lda); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b7, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & - aii, &a[i__ * a_dim1 + 1], &c__1); - } else { - dscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1); - } -/* L10: */ - } - - } else { - -/* Compute the product L' * L. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - aii = a[i__ + i__ * a_dim1]; - if (i__ < *n) { - i__2 = *n - i__ + 1; - a[i__ + i__ * a_dim1] = ddot_(&i__2, &a[i__ + i__ * a_dim1], & - c__1, &a[i__ + i__ * a_dim1], &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b7, &a[i__ + 1 + a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &aii, &a[i__ - + a_dim1], lda); - } else { - dscal_(&i__, &aii, &a[i__ + a_dim1], lda); - } -/* L20: */ - } - } - - return 0; - -/* End of DLAUU2 */ - -} /* dlauu2_ */ diff --git a/external/clapack/lapack/dlauum.cpp b/external/clapack/lapack/dlauum.cpp deleted file mode 100644 index e1e9fcbe..00000000 --- a/external/clapack/lapack/dlauum.cpp +++ /dev/null @@ -1,191 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b15 = 1.; - -/* Subroutine */ int dlauum_(const char *uplo, integer *n, double *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, ib, nb; - bool upper; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAUUM computes the product U * U' or L' * L, where the triangular */ -/* factor U or L is stored in the upper or lower triangular part of */ -/* the array A. */ - -/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* overwriting the factor U in A. */ -/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* overwriting the factor L in A. */ - -/* This is the blocked form of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the triangular factor stored in the array A */ -/* is upper or lower triangular: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the triangular factor U or L. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L. */ -/* On exit, if UPLO = 'U', the upper triangle of A is */ -/* overwritten with the upper triangle of the product U * U'; */ -/* if UPLO = 'L', the lower triangle of A is overwritten with */ -/* the lower triangle of the product L' * L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLAUUM", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DLAUUM", uplo, n, &c_n1, &c_n1, &c_n1); - - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - dlauu2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute the product U * U'. */ - - i__1 = *n; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = std::min(i__3,i__4); - i__3 = i__ - 1; - dtrmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, - &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 - + 1], lda) - ; - dlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - dgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & - c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + - (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * - a_dim1 + 1], lda); - i__3 = *n - i__ - ib + 1; - dsyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ - i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + - i__ * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the product L' * L. */ - - i__2 = *n; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = std::min(i__3,i__4); - i__3 = i__ - 1; - dtrmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & - c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], - lda); - dlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - dgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & - c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + - ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); - i__3 = *n - i__ - ib + 1; - dsyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + - ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * - a_dim1], lda); - } -/* L20: */ - } - } - } - - return 0; - -/* End of DLAUUM */ - -} /* dlauum_ */ diff --git a/external/clapack/lapack/dlazq3.cpp b/external/clapack/lapack/dlazq3.cpp deleted file mode 100644 index e79fa5f0..00000000 --- a/external/clapack/lapack/dlazq3.cpp +++ /dev/null @@ -1,326 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlazq3_(integer *i0, integer *n0, double *z__, - integer *pp, double *dmin__, double *sigma, double *desig, - double *qmax, integer *nfail, integer *iter, integer *ndiv, - bool *ieee, integer *ttype, double *dmin1, double *dmin2, - double *dn, double *dn1, double *dn2, double *tau) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - double g, s, t; - integer j4, nn; - double eps, tol; - integer n0in, ipn4; - double tol2, temp; - double safmin; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds. */ -/* In case of failure it changes shifts, and tries again until output */ -/* is positive. */ - -/* Arguments */ -/* ========= */ - -/* I0 (input) INTEGER */ -/* First index. */ - -/* N0 (input) INTEGER */ -/* Last index. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ -/* Z holds the qd array. */ - -/* PP (input) INTEGER */ -/* PP=0 for ping, PP=1 for pong. */ - -/* DMIN (output) DOUBLE PRECISION */ -/* Minimum value of d. */ - -/* SIGMA (output) DOUBLE PRECISION */ -/* Sum of shifts used in current segment. */ - -/* DESIG (input/output) DOUBLE PRECISION */ -/* Lower order part of SIGMA */ - -/* QMAX (input) DOUBLE PRECISION */ -/* Maximum value of q. */ - -/* NFAIL (output) INTEGER */ -/* Number of times shift was too big. */ - -/* ITER (output) INTEGER */ -/* Number of iterations. */ - -/* NDIV (output) INTEGER */ -/* Number of divisions. */ - -/* IEEE (input) LOGICAL */ -/* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). */ - -/* TTYPE (input/output) INTEGER */ -/* Shift type. TTYPE is passed as an argument in order to save */ -/* its value between calls to DLAZQ3 */ - -/* DMIN1 (input/output) REAL */ -/* DMIN2 (input/output) REAL */ -/* DN (input/output) REAL */ -/* DN1 (input/output) REAL */ -/* DN2 (input/output) REAL */ -/* TAU (input/output) REAL */ -/* These are passed as arguments in order to save their values */ -/* between calls to DLAZQ3 */ - -/* This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1, */ -/* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of */ -/* declaring them in a SAVE statment. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Function .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - n0in = *n0; - eps = dlamch_("Precision"); - safmin = dlamch_("Safe minimum"); - tol = eps * 100.; -/* Computing 2nd power */ - d__1 = tol; - tol2 = d__1 * d__1; - g = 0.; - -/* Check for deflation. */ - -L10: - - if (*n0 < *i0) { - return 0; - } - if (*n0 == *i0) { - goto L20; - } - nn = (*n0 << 2) + *pp; - if (*n0 == *i0 + 1) { - goto L40; - } - -/* Check whether E(N0-1) is negligible, 1 eigenvalue. */ - - if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - - 4] > tol2 * z__[nn - 7]) { - goto L30; - } - -L20: - - z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma; - --(*n0); - goto L10; - -/* Check whether E(N0-2) is negligible, 2 eigenvalues. */ - -L30: - - if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ - nn - 11]) { - goto L50; - } - -L40: - - if (z__[nn - 3] > z__[nn - 7]) { - s = z__[nn - 3]; - z__[nn - 3] = z__[nn - 7]; - z__[nn - 7] = s; - } - if (z__[nn - 5] > z__[nn - 3] * tol2) { - t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; - s = z__[nn - 3] * (z__[nn - 5] / t); - if (s <= t) { - s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); - } else { - s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); - } - t = z__[nn - 7] + (s + z__[nn - 5]); - z__[nn - 3] *= z__[nn - 7] / t; - z__[nn - 7] = t; - } - z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; - z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; - *n0 += -2; - goto L10; - -L50: - -/* Reverse the qd-array, if warranted. */ - - if (*dmin__ <= 0. || *n0 < n0in) { - if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { - ipn4 = *i0 + *n0 << 2; - i__1 = *i0 + *n0 - 1 << 1; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - temp = z__[j4 - 3]; - z__[j4 - 3] = z__[ipn4 - j4 - 3]; - z__[ipn4 - j4 - 3] = temp; - temp = z__[j4 - 2]; - z__[j4 - 2] = z__[ipn4 - j4 - 2]; - z__[ipn4 - j4 - 2] = temp; - temp = z__[j4 - 1]; - z__[j4 - 1] = z__[ipn4 - j4 - 5]; - z__[ipn4 - j4 - 5] = temp; - temp = z__[j4]; - z__[j4] = z__[ipn4 - j4 - 4]; - z__[ipn4 - j4 - 4] = temp; -/* L60: */ - } - if (*n0 - *i0 <= 4) { - z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; - z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; - } -/* Computing MIN */ - d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; - *dmin2 = std::min(d__1,d__2); -/* Computing MIN */ - d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1] - , d__1 = std::min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; - z__[(*n0 << 2) + *pp - 1] = std::min(d__1,d__2); -/* Computing MIN */ - d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = - std::min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4]; - z__[(*n0 << 2) - *pp] = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = std::max(d__1, - d__2), d__2 = z__[(*i0 << 2) + *pp + 1]; - *qmax = std::max(d__1,d__2); - *dmin__ = -0.; - } - } - -/* Computing MIN */ - d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*n0 << 2) + *pp - 9], d__1 = - std::min(d__1,d__2), d__2 = *dmin2 + z__[(*n0 << 2) - *pp]; - if (*dmin__ < 0. || safmin * *qmax < std::min(d__1,d__2)) { - -/* Choose a shift. */ - - dlazq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, - dn2, tau, ttype, &g); - -/* Call dqds until DMIN > 0. */ - -L80: - - dlasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2, - ieee); - - *ndiv += *n0 - *i0 + 2; - ++(*iter); - -/* Check status. */ - - if (*dmin__ >= 0. && *dmin1 > 0.) { - -/* Success. */ - - goto L100; - - } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < - tol * (*sigma + *dn1) && abs(*dn) < tol * *sigma) { - -/* Convergence hidden by negative DN. */ - - z__[(*n0 - 1 << 2) - *pp + 2] = 0.; - *dmin__ = 0.; - goto L100; - } else if (*dmin__ < 0.) { - -/* TAU too big. Select new TAU and try again. */ - - ++(*nfail); - if (*ttype < -22) { - -/* Failed twice. Play it safe. */ - - *tau = 0.; - } else if (*dmin1 > 0.) { - -/* Late failure. Gives excellent shift. */ - - *tau = (*tau + *dmin__) * (1. - eps * 2.); - *ttype += -11; - } else { - -/* Early failure. Divide by 4. */ - - *tau *= .25; - *ttype += -12; - } - goto L80; - } else if (*dmin__ != *dmin__) { - -/* NaN. */ - - *tau = 0.; - goto L80; - } else { - -/* Possible underflow. Play it safe. */ - - goto L90; - } - } - -/* Risk of underflow. */ - -L90: - dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2); - *ndiv += *n0 - *i0 + 2; - ++(*iter); - *tau = 0.; - -L100: - if (*tau < *sigma) { - *desig += *tau; - t = *sigma + *desig; - *desig -= t - *sigma; - } else { - t = *sigma + *tau; - *desig = *sigma - (t - *tau) + *desig; - } - *sigma = t; - - return 0; - -/* End of DLAZQ3 */ - -} /* dlazq3_ */ diff --git a/external/clapack/lapack/dlazq4.cpp b/external/clapack/lapack/dlazq4.cpp deleted file mode 100644 index fbd03098..00000000 --- a/external/clapack/lapack/dlazq4.cpp +++ /dev/null @@ -1,385 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dlazq4_(integer *i0, integer *n0, double *z__, - integer *pp, integer *n0in, double *dmin__, double *dmin1, - double *dmin2, double *dn, double *dn1, double *dn2, - double *tau, integer *ttype, double *g) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - double s, a2, b1, b2; - integer i4, nn, np; - double gam, gap1, gap2; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLAZQ4 computes an approximation TAU to the smallest eigenvalue */ -/* using values of d from the previous transform. */ - -/* I0 (input) INTEGER */ -/* First index. */ - -/* N0 (input) INTEGER */ -/* Last index. */ - -/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ -/* Z holds the qd array. */ - -/* PP (input) INTEGER */ -/* PP=0 for ping, PP=1 for pong. */ - -/* N0IN (input) INTEGER */ -/* The value of N0 at start of EIGTEST. */ - -/* DMIN (input) DOUBLE PRECISION */ -/* Minimum value of d. */ - -/* DMIN1 (input) DOUBLE PRECISION */ -/* Minimum value of d, excluding D( N0 ). */ - -/* DMIN2 (input) DOUBLE PRECISION */ -/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ - -/* DN (input) DOUBLE PRECISION */ -/* d(N) */ - -/* DN1 (input) DOUBLE PRECISION */ -/* d(N-1) */ - -/* DN2 (input) DOUBLE PRECISION */ -/* d(N-2) */ - -/* TAU (output) DOUBLE PRECISION */ -/* This is the shift. */ - -/* TTYPE (output) INTEGER */ -/* Shift type. */ - -/* G (input/output) DOUBLE PRECISION */ -/* G is passed as an argument in order to save its value between */ -/* calls to DLAZQ4 */ - -/* Further Details */ -/* =============== */ -/* CNST1 = 9/16 */ - -/* This is a thread safe version of DLASQ4, which passes G through the */ -/* argument list in place of declaring G in a SAVE statment. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* A negative DMIN forces the shift to take that absolute value */ -/* TTYPE records the type of shift. */ - - /* Parameter adjustments */ - --z__; - - /* Function Body */ - if (*dmin__ <= 0.) { - *tau = -(*dmin__); - *ttype = -1; - return 0; - } - - nn = (*n0 << 2) + *pp; - if (*n0in == *n0) { - -/* No eigenvalues deflated. */ - - if (*dmin__ == *dn || *dmin__ == *dn1) { - - b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); - b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); - a2 = z__[nn - 7] + z__[nn - 5]; - -/* Cases 2 and 3. */ - - if (*dmin__ == *dn && *dmin1 == *dn1) { - gap2 = *dmin2 - a2 - *dmin2 * .25; - if (gap2 > 0. && gap2 > b2) { - gap1 = a2 - *dn - b2 / gap2 * b2; - } else { - gap1 = a2 - *dn - (b1 + b2); - } - if (gap1 > 0. && gap1 > b1) { -/* Computing MAX */ - d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; - s = std::max(d__1,d__2); - *ttype = -2; - } else { - s = 0.; - if (*dn > b1) { - s = *dn - b1; - } - if (a2 > b1 + b2) { -/* Computing MIN */ - d__1 = s, d__2 = a2 - (b1 + b2); - s = std::min(d__1,d__2); - } -/* Computing MAX */ - d__1 = s, d__2 = *dmin__ * .333; - s = std::max(d__1,d__2); - *ttype = -3; - } - } else { - -/* Case 4. */ - - *ttype = -4; - s = *dmin__ * .25; - if (*dmin__ == *dn) { - gam = *dn; - a2 = 0.; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b2 = z__[nn - 5] / z__[nn - 7]; - np = nn - 9; - } else { - np = nn - (*pp << 1); - b2 = z__[np - 2]; - gam = *dn1; - if (z__[np - 4] > z__[np - 2]) { - return 0; - } - a2 = z__[np - 4] / z__[np - 2]; - if (z__[nn - 9] > z__[nn - 11]) { - return 0; - } - b2 = z__[nn - 9] / z__[nn - 11]; - np = nn - 13; - } - -/* Approximate contribution to norm squared from I < NN-1. */ - - a2 += b2; - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = np; i4 >= i__1; i4 += -4) { - if (b2 == 0.) { - goto L20; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (std::max(b2,b1) * 100. < a2 || .563 < a2) { - goto L20; - } -/* L10: */ - } -L20: - a2 *= 1.05; - -/* Rayleigh quotient residual bound. */ - - if (a2 < .563) { - s = gam * (1. - sqrt(a2)) / (a2 + 1.); - } - } - } else if (*dmin__ == *dn2) { - -/* Case 5. */ - - *ttype = -5; - s = *dmin__ * .25; - -/* Compute contribution to norm squared from I > NN-2. */ - - np = nn - (*pp << 1); - b1 = z__[np - 2]; - b2 = z__[np - 6]; - gam = *dn2; - if (z__[np - 8] > b2 || z__[np - 4] > b1) { - return 0; - } - a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); - -/* Approximate contribution to norm squared from I < NN-2. */ - - if (*n0 - *i0 > 2) { - b2 = z__[nn - 13] / z__[nn - 15]; - a2 += b2; - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = nn - 17; i4 >= i__1; i4 += -4) { - if (b2 == 0.) { - goto L40; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (std::max(b2,b1) * 100. < a2 || .563 < a2) { - goto L40; - } -/* L30: */ - } -L40: - a2 *= 1.05; - } - - if (a2 < .563) { - s = gam * (1. - sqrt(a2)) / (a2 + 1.); - } - } else { - -/* Case 6, no information to guide us. */ - - if (*ttype == -6) { - *g += (1. - *g) * .333; - } else if (*ttype == -18) { - *g = .083250000000000005; - } else { - *g = .25; - } - s = *g * *dmin__; - *ttype = -6; - } - - } else if (*n0in == *n0 + 1) { - -/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */ - - if (*dmin1 == *dn1 && *dmin2 == *dn2) { - -/* Cases 7 and 8. */ - - *ttype = -7; - s = *dmin1 * .333; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.) { - goto L60; - } - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { - a2 = b1; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b1 *= z__[i4] / z__[i4 - 2]; - b2 += b1; - if (std::max(b1,a2) * 100. < b2) { - goto L60; - } -/* L50: */ - } -L60: - b2 = sqrt(b2 * 1.05); -/* Computing 2nd power */ - d__1 = b2; - a2 = *dmin1 / (d__1 * d__1 + 1.); - gap2 = *dmin2 * .5 - a2; - if (gap2 > 0. && gap2 > b2 * a2) { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); - s = std::max(d__1,d__2); - } else { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - b2 * 1.01); - s = std::max(d__1,d__2); - *ttype = -8; - } - } else { - -/* Case 9. */ - - s = *dmin1 * .25; - if (*dmin1 == *dn1) { - s = *dmin1 * .5; - } - *ttype = -9; - } - - } else if (*n0in == *n0 + 2) { - -/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */ - -/* Cases 10 and 11. */ - - if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { - *ttype = -10; - s = *dmin2 * .333; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.) { - goto L80; - } - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b1 *= z__[i4] / z__[i4 - 2]; - b2 += b1; - if (b1 * 100. < b2) { - goto L80; - } -/* L70: */ - } -L80: - b2 = sqrt(b2 * 1.05); -/* Computing 2nd power */ - d__1 = b2; - a2 = *dmin2 / (d__1 * d__1 + 1.); - gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ - nn - 9]) - a2; - if (gap2 > 0. && gap2 > b2 * a2) { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); - s = std::max(d__1,d__2); - } else { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - b2 * 1.01); - s = std::max(d__1,d__2); - } - } else { - s = *dmin2 * .25; - *ttype = -11; - } - } else if (*n0in > *n0 + 2) { - -/* Case 12, more than two eigenvalues deflated. No information. */ - - s = 0.; - *ttype = -12; - } - - *tau = s; - return 0; - -/* End of DLAZQ4 */ - -} /* dlazq4_ */ diff --git a/external/clapack/lapack/dopgtr.cpp b/external/clapack/lapack/dopgtr.cpp deleted file mode 100644 index 3a4d5293..00000000 --- a/external/clapack/lapack/dopgtr.cpp +++ /dev/null @@ -1,193 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dopgtr_(const char *uplo, integer *n, double *ap, - double *tau, double *q, integer *ldq, double *work, - integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, ij; - integer iinfo; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DOPGTR generates a real orthogonal matrix Q which is defined as the */ -/* product of n-1 elementary reflectors H(i) of order n, as returned by */ -/* DSPTRD using packed storage: */ - -/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */ - -/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangular packed storage used in previous */ -/* call to DSPTRD; */ -/* = 'L': Lower triangular packed storage used in previous */ -/* call to DSPTRD. */ - -/* N (input) INTEGER */ -/* The order of the matrix Q. N >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The vectors which define the elementary reflectors, as */ -/* returned by DSPTRD. */ - -/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DSPTRD. */ - -/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* The N-by-N orthogonal matrix Q. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N-1) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - --ap; - --tau; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --work; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldq < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DOPGTR", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Q was determined by a call to DSPTRD with UPLO = 'U' */ - -/* Unpack the vectors which define the elementary reflectors and */ -/* set the last row and column of Q equal to those of the unit */ -/* matrix */ - - ij = 2; - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - q[i__ + j * q_dim1] = ap[ij]; - ++ij; -/* L10: */ - } - ij += 2; - q[*n + j * q_dim1] = 0.; -/* L20: */ - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - q[i__ + *n * q_dim1] = 0.; -/* L30: */ - } - q[*n + *n * q_dim1] = 1.; - -/* Generate Q(1:n-1,1:n-1) */ - - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & - iinfo); - - } else { - -/* Q was determined by a call to DSPTRD with UPLO = 'L'. */ - -/* Unpack the vectors which define the elementary reflectors and */ -/* set the first row and column of Q equal to those of the unit */ -/* matrix */ - - q[q_dim1 + 1] = 1.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - q[i__ + q_dim1] = 0.; -/* L40: */ - } - ij = 3; - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - q[j * q_dim1 + 1] = 0.; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - q[i__ + j * q_dim1] = ap[ij]; - ++ij; -/* L50: */ - } - ij += 2; -/* L60: */ - } - if (*n > 1) { - -/* Generate Q(2:n,2:n) */ - - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorg2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], - &work[1], &iinfo); - } - } - return 0; - -/* End of DOPGTR */ - -} /* dopgtr_ */ diff --git a/external/clapack/lapack/dopmtr.cpp b/external/clapack/lapack/dopmtr.cpp deleted file mode 100644 index 97c3276a..00000000 --- a/external/clapack/lapack/dopmtr.cpp +++ /dev/null @@ -1,279 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dopmtr_(const char *side, const char *uplo, const char *trans, integer *m, - integer *n, double *ap, double *tau, double *c__, integer - *ldc, double *work, integer *info) -{ - /* System generated locals */ - integer c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, ic, jc, ii, mi, ni, nq; - double aii; - bool left; - bool upper; - bool notran, forwrd; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DOPMTR 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 of order nq, with nq = m if */ -/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ -/* nq-1 elementary reflectors, as returned by DSPTRD using packed */ -/* storage: */ - -/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ - -/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangular packed storage used in previous */ -/* call to DSPTRD; */ -/* = 'L': Lower triangular packed storage used in previous */ -/* call to DSPTRD. */ - -/* 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. */ - -/* AP (input) DOUBLE PRECISION array, dimension */ -/* (M*(M+1)/2) if SIDE = 'L' */ -/* (N*(N+1)/2) if SIDE = 'R' */ -/* The vectors which define the elementary reflectors, as */ -/* returned by DSPTRD. AP is modified by the routine but */ -/* restored on exit. */ - -/* TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' */ -/* or (N-1) if SIDE = 'R' */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DSPTRD. */ - -/* 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 */ -/* (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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - --ap; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - upper = lsame_(uplo, "U"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DOPMTR", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - - if (upper) { - -/* Q was determined by a call to DSPTRD with UPLO = 'U' */ - - forwrd = left && notran || ! left && ! notran; - - if (forwrd) { - i1 = 1; - i2 = nq - 1; - i3 = 1; - ii = 2; - } else { - i1 = nq - 1; - i2 = 1; - i3 = -1; - ii = nq * (nq + 1) / 2 - 1; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(1:i,1:n) */ - - mi = i__; - } else { - -/* H(i) is applied to C(1:m,1:i) */ - - ni = i__; - } - -/* Apply H(i) */ - - aii = ap[ii]; - ap[ii] = 1.; - dlarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &tau[i__], &c__[ - c_offset], ldc, &work[1]); - ap[ii] = aii; - - if (forwrd) { - ii = ii + i__ + 2; - } else { - ii = ii - i__ - 1; - } -/* L10: */ - } - } else { - -/* Q was determined by a call to DSPTRD with UPLO = 'L'. */ - - forwrd = left && ! notran || ! left && notran; - - if (forwrd) { - i1 = 1; - i2 = nq - 1; - i3 = 1; - ii = 2; - } else { - i1 = nq - 1; - i2 = 1; - i3 = -1; - ii = nq * (nq + 1) / 2 - 1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__2 = i2; - i__1 = i3; - for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { - aii = ap[ii]; - ap[ii] = 1.; - if (left) { - -/* H(i) is applied to C(i+1:m,1:n) */ - - mi = *m - i__; - ic = i__ + 1; - } else { - -/* H(i) is applied to C(1:m,i+1:n) */ - - ni = *n - i__; - jc = i__ + 1; - } - -/* Apply H(i) */ - - dlarf_(side, &mi, &ni, &ap[ii], &c__1, &tau[i__], &c__[ic + jc * - c_dim1], ldc, &work[1]); - ap[ii] = aii; - - if (forwrd) { - ii = ii + nq - i__ + 1; - } else { - ii = ii - nq + i__ - 2; - } -/* L20: */ - } - } - return 0; - -/* End of DOPMTR */ - -} /* dopmtr_ */ diff --git a/external/clapack/lapack/dorg2l.cpp b/external/clapack/lapack/dorg2l.cpp deleted file mode 100644 index fb6d3792..00000000 --- a/external/clapack/lapack/dorg2l.cpp +++ /dev/null @@ -1,157 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, double * - a, integer *lda, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer i__, j, l, ii; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORG2L generates an m by n real matrix Q with orthonormal columns, */ -/* which is defined as the last n columns of a product of k elementary */ -/* reflectors of order m */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGEQLF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. M >= N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. N >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the (n-k+i)-th column must contain the vector which */ -/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ -/* returned by DGEQLF in the last k columns of its array */ -/* argument A. */ -/* On exit, the m by n matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQLF. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORG2L", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - -/* Initialise columns 1:n-k to columns of the unit matrix */ - - i__1 = *n - *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; -/* L10: */ - } - a[*m - *n + j + j * a_dim1] = 1.; -/* L20: */ - } - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - ii = *n - *k + i__; - -/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */ - - a[*m - *n + ii + ii * a_dim1] = 1.; - i__2 = *m - *n + ii; - i__3 = ii - 1; - dlarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], & - a[a_offset], lda, &work[1]); - i__2 = *m - *n + ii - 1; - d__1 = -tau[i__]; - dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1); - a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__]; - -/* Set A(m-k+i+1:m,n-k+i) to zero */ - - i__2 = *m; - for (l = *m - *n + ii + 1; l <= i__2; ++l) { - a[l + ii * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of DORG2L */ - -} /* dorg2l_ */ diff --git a/external/clapack/lapack/dorg2r.cpp b/external/clapack/lapack/dorg2r.cpp deleted file mode 100644 index 61c922ee..00000000 --- a/external/clapack/lapack/dorg2r.cpp +++ /dev/null @@ -1,160 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, double * - a, integer *lda, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j, l; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORG2R generates an m by n real matrix Q with orthonormal columns, */ -/* which is defined as the first n columns of a product of k elementary */ -/* reflectors of order m */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by DGEQRF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. M >= N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. N >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit, the m-by-n matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQRF. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORG2R", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - -/* Initialise columns k+1:n to columns of the unit matrix */ - - i__1 = *n; - for (j = *k + 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; -/* L10: */ - } - a[j + j * a_dim1] = 1.; -/* L20: */ - } - - for (i__ = *k; i__ >= 1; --i__) { - -/* Apply H(i) to A(i:m,i:n) from the left */ - - if (i__ < *n) { - a[i__ + i__ * a_dim1] = 1.; - i__1 = *m - i__ + 1; - i__2 = *n - i__; - dlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ - i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); - } - if (i__ < *m) { - i__1 = *m - i__; - d__1 = -tau[i__]; - dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1); - } - a[i__ + i__ * a_dim1] = 1. - tau[i__]; - -/* Set A(1:i-1,i) to zero */ - - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a[l + i__ * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of DORG2R */ - -} /* dorg2r_ */ diff --git a/external/clapack/lapack/dorgbr.cpp b/external/clapack/lapack/dorgbr.cpp deleted file mode 100644 index d202f9ac..00000000 --- a/external/clapack/lapack/dorgbr.cpp +++ /dev/null @@ -1,279 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dorgbr_(const char *vect, integer *m, integer *n, integer *k, - double *a, integer *lda, double *tau, double *work, - integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, nb, mn; - integer iinfo; - bool wantq; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGBR generates one of the real orthogonal matrices Q or P**T */ -/* determined by DGEBRD when reducing a real matrix A to bidiagonal */ -/* form: A = Q * B * P**T. Q and P**T are defined as products of */ -/* elementary reflectors H(i) or G(i) respectively. */ - -/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */ -/* is of order M: */ -/* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n */ -/* columns of Q, where m >= n >= k; */ -/* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an */ -/* M-by-M matrix. */ - -/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */ -/* is of order N: */ -/* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m */ -/* rows of P**T, where n >= m >= k; */ -/* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as */ -/* an N-by-N matrix. */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* Specifies whether the matrix Q or the matrix P**T is */ -/* required, as defined in the transformation applied by DGEBRD: */ -/* = 'Q': generate Q; */ -/* = 'P': generate P**T. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q or P**T to be returned. */ -/* M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q or P**T to be returned. */ -/* N >= 0. */ -/* If VECT = 'Q', M >= N >= min(M,K); */ -/* if VECT = 'P', N >= M >= min(N,K). */ - -/* K (input) INTEGER */ -/* If VECT = 'Q', the number of columns in the original M-by-K */ -/* matrix reduced by DGEBRD. */ -/* If VECT = 'P', the number of rows in the original K-by-N */ -/* matrix reduced by DGEBRD. */ -/* K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the vectors which define the elementary reflectors, */ -/* as returned by DGEBRD. */ -/* On exit, the M-by-N matrix Q or P**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension */ -/* (min(M,K)) if VECT = 'Q' */ -/* (min(N,K)) if VECT = 'P' */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i) or G(i), which determines Q or P**T, as */ -/* returned by DGEBRD in its array argument TAUQ or TAUP. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */ -/* For optimum performance LWORK >= min(M,N)*NB, where NB */ -/* is the optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - wantq = lsame_(vect, "Q"); - mn = std::min(*m,*n); - lquery = *lwork == -1; - if (! wantq && ! lsame_(vect, "P")) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0 || wantq && (*n > *m || *n < std::min(*m,*k)) || ! wantq && ( - *m > *n || *m < std::min(*n,*k))) { - *info = -3; - } else if (*k < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*m)) { - *info = -6; - } else if (*lwork < std::max(1_integer,mn) && ! lquery) { - *info = -9; - } - - if (*info == 0) { - if (wantq) { - nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1); - } else { - nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1); - } - lwkopt = std::max(1_integer,mn) * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGBR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - work[1] = 1.; - return 0; - } - - if (wantq) { - -/* Form Q, determined by a call to DGEBRD to reduce an m-by-k */ -/* matrix */ - - if (*m >= *k) { - -/* If m >= k, assume m >= n >= k */ - - dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); - - } else { - -/* If m < k, assume m = n */ - -/* Shift the vectors which define the elementary reflectors one */ -/* column to the right, and set the first row and column of Q */ -/* to those of the unit matrix */ - - for (j = *m; j >= 2; --j) { - a[j * a_dim1 + 1] = 0.; - i__1 = *m; - for (i__ = j + 1; i__ <= i__1; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; -/* L10: */ - } -/* L20: */ - } - a[a_dim1 + 1] = 1.; - i__1 = *m; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.; -/* L30: */ - } - if (*m > 1) { - -/* Form Q(2:m,2:m) */ - - i__1 = *m - 1; - i__2 = *m - 1; - i__3 = *m - 1; - dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ - 1], &work[1], lwork, &iinfo); - } - } - } else { - -/* Form P', determined by a call to DGEBRD to reduce a k-by-n */ -/* matrix */ - - if (*k < *n) { - -/* If k < n, assume k <= m <= n */ - - dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); - - } else { - -/* If k >= n, assume m = n */ - -/* Shift the vectors which define the elementary reflectors one */ -/* row downward, and set the first row and column of P' to */ -/* those of the unit matrix */ - - a[a_dim1 + 1] = 1.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.; -/* L40: */ - } - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - for (i__ = j - 1; i__ >= 2; --i__) { - a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1]; -/* L50: */ - } - a[j * a_dim1 + 1] = 0.; -/* L60: */ - } - if (*n > 1) { - -/* Form P'(2:n,2:n) */ - - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[ - 1], &work[1], lwork, &iinfo); - } - } - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORGBR */ - -} /* dorgbr_ */ diff --git a/external/clapack/lapack/dorghr.cpp b/external/clapack/lapack/dorghr.cpp deleted file mode 100644 index f49760e7..00000000 --- a/external/clapack/lapack/dorghr.cpp +++ /dev/null @@ -1,198 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dorghr_(integer *n, integer *ilo, integer *ihi, - double *a, integer *lda, double *tau, double *work, - integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, nb, nh, iinfo; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGHR generates a real orthogonal matrix Q which is defined as the */ -/* product of IHI-ILO elementary reflectors of order N, as returned by */ -/* DGEHRD: */ - -/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix Q. N >= 0. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* ILO and IHI must have the same values as in the previous call */ -/* of DGEHRD. Q is equal to the unit matrix except in the */ -/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */ -/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the vectors which define the elementary reflectors, */ -/* as returned by DGEHRD. */ -/* On exit, the N-by-N orthogonal matrix Q. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEHRD. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= IHI-ILO. */ -/* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */ -/* the optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nh = *ihi - *ilo; - lquery = *lwork == -1; - if (*n < 0) { - *info = -1; - } else if (*ilo < 1 || *ilo > std::max(1_integer,*n)) { - *info = -2; - } else if (*ihi < std::min(*ilo,*n) || *ihi > *n) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*lwork < std::max(1_integer,nh) && ! lquery) { - *info = -8; - } - - if (*info == 0) { - nb = ilaenv_(&c__1, "DORGQR", " ", &nh, &nh, &nh, &c_n1); - lwkopt = std::max(1_integer,nh) * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGHR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - work[1] = 1.; - return 0; - } - -/* Shift the vectors which define the elementary reflectors one */ -/* column to the right, and set the first ilo and the last n-ihi */ -/* rows and columns to those of the unit matrix */ - - i__1 = *ilo + 1; - for (j = *ihi; j >= i__1; --j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L10: */ - } - i__2 = *ihi; - for (i__ = j + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; -/* L20: */ - } - i__2 = *n; - for (i__ = *ihi + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - i__1 = *ilo; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L50: */ - } - a[j + j * a_dim1] = 1.; -/* L60: */ - } - i__1 = *n; - for (j = *ihi + 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L70: */ - } - a[j + j * a_dim1] = 1.; -/* L80: */ - } - - if (nh > 0) { - -/* Generate Q(ilo+1:ihi,ilo+1:ihi) */ - - dorgqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[* - ilo], &work[1], lwork, &iinfo); - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORGHR */ - -} /* dorghr_ */ diff --git a/external/clapack/lapack/dorgl2.cpp b/external/clapack/lapack/dorgl2.cpp deleted file mode 100644 index f555e7d2..00000000 --- a/external/clapack/lapack/dorgl2.cpp +++ /dev/null @@ -1,159 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, double * - a, integer *lda, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j, l; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGL2 generates an m by n real matrix Q with orthonormal rows, */ -/* which is defined as the first m rows of a product of k elementary */ -/* reflectors of order n */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGELQF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. N >= M. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. M >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the i-th row must contain the vector which defines */ -/* the elementary reflector H(i), for i = 1,2,...,k, as returned */ -/* by DGELQF in the first k rows of its array argument A. */ -/* On exit, the m-by-n matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGELQF. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGL2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - return 0; - } - - if (*k < *m) { - -/* Initialise rows k+1:m to rows of the unit matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = *k + 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; -/* L10: */ - } - if (j > *k && j <= *m) { - a[j + j * a_dim1] = 1.; - } -/* L20: */ - } - } - - for (i__ = *k; i__ >= 1; --i__) { - -/* Apply H(i) to A(i:m,i:n) from the right */ - - if (i__ < *n) { - if (i__ < *m) { - a[i__ + i__ * a_dim1] = 1.; - i__1 = *m - i__; - i__2 = *n - i__ + 1; - dlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, & - tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); - } - i__1 = *n - i__; - d__1 = -tau[i__]; - dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda); - } - a[i__ + i__ * a_dim1] = 1. - tau[i__]; - -/* Set A(i,1:i-1) to zero */ - - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a[i__ + l * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of DORGL2 */ - -} /* dorgl2_ */ diff --git a/external/clapack/lapack/dorglq.cpp b/external/clapack/lapack/dorglq.cpp deleted file mode 100644 index 0d685c3e..00000000 --- a/external/clapack/lapack/dorglq.cpp +++ /dev/null @@ -1,260 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, double * - a, integer *lda, double *tau, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGLQ generates an M-by-N real matrix Q with orthonormal rows, */ -/* which is defined as the first M rows of a product of K elementary */ -/* reflectors of order N */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGELQF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. N >= M. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. M >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the i-th row must contain the vector which defines */ -/* the elementary reflector H(i), for i = 1,2,...,k, as returned */ -/* by DGELQF in the first k rows of its array argument A. */ -/* On exit, the M-by-N matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGELQF. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,M). */ -/* For optimum performance LWORK >= M*NB, where NB is */ -/* the optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1); - lwkopt = std::max(1_integer,*m) * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else if (*lwork < std::max(1_integer,*m) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGLQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - nx = 0; - iws = *m; - if (nb > 1 && nb < *k) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DORGLQ", " ", m, n, k, &c_n1); - nx = std::max(i__1,i__2); - if (nx < *k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DORGLQ", " ", m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the last block. */ -/* The first kk rows are handled by the block method. */ - - ki = (*k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = std::min(i__1,i__2); - -/* Set A(kk+1:m,1:kk) to zero. */ - - i__1 = kk; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = kk + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the last or only block. */ - - if (kk < *m) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); - } - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = std::min(i__2,i__3); - if (i__ + ib <= *m) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__2 = *n - i__ + 1; - dlarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork); - -/* Apply H' to A(i+ib:m,i:n) from the right */ - - i__2 = *m - i__ - ib + 1; - i__3 = *n - i__ + 1; - dlarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, & - i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & - ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + - 1], &ldwork); - } - -/* Apply H' to columns i:n of current block */ - - i__2 = *n - i__ + 1; - dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); - -/* Set columns 1:i-1 of current block to zero */ - - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = i__ + ib - 1; - for (l = i__; l <= i__3; ++l) { - a[l + j * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (double) iws; - return 0; - -/* End of DORGLQ */ - -} /* dorglq_ */ diff --git a/external/clapack/lapack/dorgql.cpp b/external/clapack/lapack/dorgql.cpp deleted file mode 100644 index 5e5826a1..00000000 --- a/external/clapack/lapack/dorgql.cpp +++ /dev/null @@ -1,269 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, double * - a, integer *lda, double *tau, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGQL generates an M-by-N real matrix Q with orthonormal columns, */ -/* which is defined as the last N columns of a product of K elementary */ -/* reflectors of order M */ - -/* Q = H(k) . . . H(2) H(1) */ - -/* as returned by DGEQLF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. M >= N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. N >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the (n-k+i)-th column must contain the vector which */ -/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ -/* returned by DGEQLF in the last k columns of its array */ -/* argument A. */ -/* On exit, the M-by-N matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQLF. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } - - if (*info == 0) { - if (*n == 0) { - lwkopt = 1; - } else { - nb = ilaenv_(&c__1, "DORGQL", " ", m, n, k, &c_n1); - lwkopt = *n * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < std::max(1_integer,*n) && ! lquery) { - *info = -8; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGQL", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - - nbmin = 2; - nx = 0; - iws = *n; - if (nb > 1 && nb < *k) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQL", " ", m, n, k, &c_n1); - nx = std::max(i__1,i__2); - if (nx < *k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQL", " ", m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the first block. */ -/* The last kk columns are handled by the block method. */ - -/* Computing MIN */ - i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; - kk = std::min(i__1,i__2); - -/* Set A(m-kk+1:m,1:n-kk) to zero. */ - - i__1 = *n - kk; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = *m - kk + 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the first or only block. */ - - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) - ; - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = *k; - i__2 = nb; - for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *k - i__ + 1; - ib = std::min(i__3,i__4); - if (*n - *k + i__ > 1) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__3 = *m - *k + i__ + ib - 1; - dlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - *k + - i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork); - -/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ - - i__3 = *m - *k + i__ + ib - 1; - i__4 = *n - *k + i__ - 1; - dlarfb_("Left", "No transpose", "Backward", "Columnwise", & - i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1], - lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib + - 1], &ldwork); - } - -/* Apply H to rows 1:m-k+i+ib-1 of current block */ - - i__3 = *m - *k + i__ + ib - 1; - dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, & - tau[i__], &work[1], &iinfo); - -/* Set rows m-k+i+ib:m of current block to zero */ - - i__3 = *n - *k + i__ + ib - 1; - for (j = *n - *k + i__; j <= i__3; ++j) { - i__4 = *m; - for (l = *m - *k + i__ + ib; l <= i__4; ++l) { - a[l + j * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (double) iws; - return 0; - -/* End of DORGQL */ - -} /* dorgql_ */ diff --git a/external/clapack/lapack/dorgqr.cpp b/external/clapack/lapack/dorgqr.cpp deleted file mode 100644 index f4855e2d..00000000 --- a/external/clapack/lapack/dorgqr.cpp +++ /dev/null @@ -1,261 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, double * - a, integer *lda, double *tau, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGQR generates an M-by-N real matrix Q with orthonormal columns, */ -/* which is defined as the first N columns of a product of K elementary */ -/* reflectors of order M */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by DGEQRF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. M >= N >= 0. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. N >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, 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. */ -/* On exit, the M-by-N matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEQRF. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1); - lwkopt = std::max(1_integer,*n) * nb; - work[1] = (double) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else if (*lwork < std::max(1_integer,*n) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGQR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - nx = 0; - iws = *n; - if (nb > 1 && nb < *k) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQR", " ", m, n, k, &c_n1); - nx = std::max(i__1,i__2); - if (nx < *k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQR", " ", m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the last block. */ -/* The first kk columns are handled by the block method. */ - - ki = (*k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = std::min(i__1,i__2); - -/* Set A(1:kk,kk+1:n) to zero. */ - - i__1 = *n; - for (j = kk + 1; j <= i__1; ++j) { - i__2 = kk; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the last or only block. */ - - if (kk < *n) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, & - tau[kk + 1], &work[1], &iinfo); - } - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = std::min(i__2,i__3); - if (i__ + ib <= *n) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__2 = *m - i__ + 1; - dlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], &work[1], &ldwork); - -/* Apply H to A(i:m,i+ib:n) from the left */ - - i__2 = *m - i__ + 1; - i__3 = *n - i__ - ib + 1; - dlarfb_("Left", "No transpose", "Forward", "Columnwise", & - i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[ - 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, & - work[ib + 1], &ldwork); - } - -/* Apply H to rows i:m of current block */ - - i__2 = *m - i__ + 1; - dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & - work[1], &iinfo); - -/* Set rows 1:i-1 of current block to zero */ - - i__2 = i__ + ib - 1; - for (j = i__; j <= i__2; ++j) { - i__3 = i__ - 1; - for (l = 1; l <= i__3; ++l) { - a[l + j * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (double) iws; - return 0; - -/* End of DORGQR */ - -} /* dorgqr_ */ diff --git a/external/clapack/lapack/dorgr2.cpp b/external/clapack/lapack/dorgr2.cpp deleted file mode 100644 index 307fda00..00000000 --- a/external/clapack/lapack/dorgr2.cpp +++ /dev/null @@ -1,159 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dorgr2_(integer *m, integer *n, integer *k, double * - a, integer *lda, double *tau, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer i__, j, l, ii; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGR2 generates an m by n real matrix Q with orthonormal rows, */ -/* which is defined as the last m rows of a product of k elementary */ -/* reflectors of order n */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by DGERQF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. N >= M. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. M >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the (m-k+i)-th row must contain the vector which */ -/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ -/* returned by DGERQF in the last k rows of its array argument */ -/* A. */ -/* On exit, the m by n matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGERQF. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGR2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - return 0; - } - - if (*k < *m) { - -/* Initialise rows 1:m-k to rows of the unit matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m - *k; - for (l = 1; l <= i__2; ++l) { - a[l + j * a_dim1] = 0.; -/* L10: */ - } - if (j > *n - *m && j <= *n - *k) { - a[*m - *n + j + j * a_dim1] = 1.; - } -/* L20: */ - } - } - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - ii = *m - *k + i__; - -/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right */ - - a[ii + (*n - *m + ii) * a_dim1] = 1.; - i__2 = ii - 1; - i__3 = *n - *m + ii; - dlarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &tau[i__], &a[ - a_offset], lda, &work[1]); - i__2 = *n - *m + ii - 1; - d__1 = -tau[i__]; - dscal_(&i__2, &d__1, &a[ii + a_dim1], lda); - a[ii + (*n - *m + ii) * a_dim1] = 1. - tau[i__]; - -/* Set A(m-k+i,n-k+i+1:n) to zero */ - - i__2 = *n; - for (l = *n - *m + ii + 1; l <= i__2; ++l) { - a[ii + l * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of DORGR2 */ - -} /* dorgr2_ */ diff --git a/external/clapack/lapack/dorgrq.cpp b/external/clapack/lapack/dorgrq.cpp deleted file mode 100644 index 9f5d63ff..00000000 --- a/external/clapack/lapack/dorgrq.cpp +++ /dev/null @@ -1,269 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dorgrq_(integer *m, integer *n, integer *k, double * - a, integer *lda, double *tau, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, l, ib, nb, ii, kk, nx, iws, nbmin, iinfo; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGRQ generates an M-by-N real matrix Q with orthonormal rows, */ -/* which is defined as the last M rows of a product of K elementary */ -/* reflectors of order N */ - -/* Q = H(1) H(2) . . . H(k) */ - -/* as returned by DGERQF. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix Q. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix Q. N >= M. */ - -/* K (input) INTEGER */ -/* The number of elementary reflectors whose product defines the */ -/* matrix Q. M >= K >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the (m-k+i)-th row must contain the vector which */ -/* defines the elementary reflector H(i), for i = 1,2,...,k, as */ -/* returned by DGERQF in the last k rows of its array argument */ -/* A. */ -/* On exit, the M-by-N matrix Q. */ - -/* LDA (input) INTEGER */ -/* The first dimension of the array A. LDA >= max(1,M). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGERQF. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,M). */ -/* For optimum performance LWORK >= M*NB, where NB is the */ -/* optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument has an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } - - if (*info == 0) { - if (*m <= 0) { - lwkopt = 1; - } else { - nb = ilaenv_(&c__1, "DORGRQ", " ", m, n, k, &c_n1); - lwkopt = *m * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < std::max(1_integer,*m) && ! lquery) { - *info = -8; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGRQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - return 0; - } - - nbmin = 2; - nx = 0; - iws = *m; - if (nb > 1 && nb < *k) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DORGRQ", " ", m, n, k, &c_n1); - nx = std::max(i__1,i__2); - if (nx < *k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DORGRQ", " ", m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the first block. */ -/* The last kk rows are handled by the block method. */ - -/* Computing MIN */ - i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb; - kk = std::min(i__1,i__2); - -/* Set A(1:m-kk,n-kk+1:n) to zero. */ - - i__1 = *n; - for (j = *n - kk + 1; j <= i__1; ++j) { - i__2 = *m - kk; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the first or only block. */ - - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorgr2_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo) - ; - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = *k; - i__2 = nb; - for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *k - i__ + 1; - ib = std::min(i__3,i__4); - ii = *m - *k + i__; - if (ii > 1) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__3 = *n - *k + i__ + ib - 1; - dlarft_("Backward", "Rowwise", &i__3, &ib, &a[ii + a_dim1], - lda, &tau[i__], &work[1], &ldwork); - -/* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */ - - i__3 = ii - 1; - i__4 = *n - *k + i__ + ib - 1; - dlarfb_("Right", "Transpose", "Backward", "Rowwise", &i__3, & - i__4, &ib, &a[ii + a_dim1], lda, &work[1], &ldwork, & - a[a_offset], lda, &work[ib + 1], &ldwork); - } - -/* Apply H' to columns 1:n-k+i+ib-1 of current block */ - - i__3 = *n - *k + i__ + ib - 1; - dorgr2_(&ib, &i__3, &ib, &a[ii + a_dim1], lda, &tau[i__], &work[1] -, &iinfo); - -/* Set columns n-k+i+ib:n of current block to zero */ - - i__3 = *n; - for (l = *n - *k + i__ + ib; l <= i__3; ++l) { - i__4 = ii + ib - 1; - for (j = ii; j <= i__4; ++j) { - a[j + l * a_dim1] = 0.; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (double) iws; - return 0; - -/* End of DORGRQ */ - -} /* dorgrq_ */ diff --git a/external/clapack/lapack/dorgtr.cpp b/external/clapack/lapack/dorgtr.cpp deleted file mode 100644 index 9546bb19..00000000 --- a/external/clapack/lapack/dorgtr.cpp +++ /dev/null @@ -1,230 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dorgtr_(const char *uplo, integer *n, double *a, integer * - lda, double *tau, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, nb; - integer iinfo; - bool upper; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORGTR generates a real orthogonal matrix Q which is defined as the */ -/* product of n-1 elementary reflectors of order N, as returned by */ -/* DSYTRD: */ - -/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */ - -/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A contains elementary reflectors */ -/* from DSYTRD; */ -/* = 'L': Lower triangle of A contains elementary reflectors */ -/* from DSYTRD. */ - -/* N (input) INTEGER */ -/* The order of the matrix Q. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the vectors which define the elementary reflectors, */ -/* as returned by DSYTRD. */ -/* On exit, the N-by-N orthogonal matrix Q. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DSYTRD. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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-1). */ -/* For optimum performance LWORK >= (N-1)*NB, where NB is */ -/* the optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = 1, i__2 = *n - 1; - if (*lwork < std::max(i__1,i__2) && ! lquery) { - *info = -7; - } - } - - if (*info == 0) { - if (upper) { - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, "DORGQL", " ", &i__1, &i__2, &i__3, &c_n1); - } else { - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, "DORGQR", " ", &i__1, &i__2, &i__3, &c_n1); - } -/* Computing MAX */ - i__1 = 1, i__2 = *n - 1; - lwkopt = std::max(i__1,i__2) * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGTR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - work[1] = 1.; - return 0; - } - - if (upper) { - -/* Q was determined by a call to DSYTRD with UPLO = 'U' */ - -/* Shift the vectors which define the elementary reflectors one */ -/* column to the left, and set the last row and column of Q to */ -/* those of the unit matrix */ - - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1]; -/* L10: */ - } - a[*n + j * a_dim1] = 0.; -/* L20: */ - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - a[i__ + *n * a_dim1] = 0.; -/* L30: */ - } - a[*n + *n * a_dim1] = 1.; - -/* Generate Q(1:n-1,1:n-1) */ - - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], - lwork, &iinfo); - - } else { - -/* Q was determined by a call to DSYTRD with UPLO = 'L'. */ - -/* Shift the vectors which define the elementary reflectors one */ -/* column to the right, and set the first row and column of Q to */ -/* those of the unit matrix */ - - for (j = *n; j >= 2; --j) { - a[j * a_dim1 + 1] = 0.; - i__1 = *n; - for (i__ = j + 1; i__ <= i__1; ++i__) { - a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1]; -/* L40: */ - } -/* L50: */ - } - a[a_dim1 + 1] = 1.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - a[i__ + a_dim1] = 0.; -/* L60: */ - } - if (*n > 1) { - -/* Generate Q(2:n,2:n) */ - - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1], - &work[1], lwork, &iinfo); - } - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORGTR */ - -} /* dorgtr_ */ diff --git a/external/clapack/lapack/dorm2l.cpp b/external/clapack/lapack/dorm2l.cpp deleted file mode 100644 index 8aa9017a..00000000 --- a/external/clapack/lapack/dorm2l.cpp +++ /dev/null @@ -1,214 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dorm2l_(const char *side, const char *trans, integer *m, integer *n, - integer *k, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, mi, ni, nq; - double aii; - bool left; - bool notran; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORM2L 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(k) . . . H(2) H(1) */ - -/* as returned by DGEQLF. 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 */ -/* DGEQLF in the last 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 DGEQLF. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < std::max(1_integer,nq)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORM2L", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(1:m-k+i,1:n) */ - - mi = *m - *k + i__; - } else { - -/* H(i) is applied to C(1:m,1:n-k+i) */ - - ni = *n - *k + i__; - } - -/* Apply H(i) */ - - aii = a[nq - *k + i__ + i__ * a_dim1]; - a[nq - *k + i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[ - c_offset], ldc, &work[1]); - a[nq - *k + i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DORM2L */ - -} /* dorm2l_ */ diff --git a/external/clapack/lapack/dorm2r.cpp b/external/clapack/lapack/dorm2r.cpp deleted file mode 100644 index 053348f1..00000000 --- a/external/clapack/lapack/dorm2r.cpp +++ /dev/null @@ -1,218 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dorm2r_(const char *side, const char *trans, integer *m, integer *n, - integer *k, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, ic, jc, mi, ni, nq; - double aii; - bool left; - bool notran; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < std::max(1_integer,nq)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORM2R", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* 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__; - } - -/* Apply H(i) */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1]); - a[i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DORM2R */ - -} /* dorm2r_ */ diff --git a/external/clapack/lapack/dormbr.cpp b/external/clapack/lapack/dormbr.cpp deleted file mode 100644 index eae3fa0c..00000000 --- a/external/clapack/lapack/dormbr.cpp +++ /dev/null @@ -1,339 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; - -/* Subroutine */ int dormbr_(const char *vect, const char *side, const char *trans, integer *m, - integer *n, integer *k, double *a, integer *lda, double *tau, - double *c__, integer *ldc, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; - char ch__1[3]; - - /* Local variables */ - integer i1, i2, nb, mi, ni, nq, nw; - bool left; - integer iinfo; - bool notran; - bool applyq; - char transt[1]; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* If VECT = 'Q', DORMBR 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 */ - -/* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C */ -/* with */ -/* SIDE = 'L' SIDE = 'R' */ -/* TRANS = 'N': P * C C * P */ -/* TRANS = 'T': P**T * C C * P**T */ - -/* Here Q and P**T are the orthogonal matrices determined by DGEBRD when */ -/* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and */ -/* P**T are defined as products of elementary reflectors H(i) and G(i) */ -/* respectively. */ - -/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */ -/* order of the orthogonal matrix Q or P**T that is applied. */ - -/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */ -/* if nq >= k, Q = H(1) H(2) . . . H(k); */ -/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */ - -/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */ -/* if k < nq, P = G(1) G(2) . . . G(k); */ -/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* = 'Q': apply Q or Q**T; */ -/* = 'P': apply P or P**T. */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q, Q**T, P or P**T from the Left; */ -/* = 'R': apply Q, Q**T, P or P**T from the Right. */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N': No transpose, apply Q or P; */ -/* = 'T': Transpose, apply Q**T or P**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 */ -/* If VECT = 'Q', the number of columns in the original */ -/* matrix reduced by DGEBRD. */ -/* If VECT = 'P', the number of rows in the original */ -/* matrix reduced by DGEBRD. */ -/* K >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,min(nq,K)) if VECT = 'Q' */ -/* (LDA,nq) if VECT = 'P' */ -/* The vectors which define the elementary reflectors H(i) and */ -/* G(i), whose products determine the matrices Q and P, as */ -/* returned by DGEBRD. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* If VECT = 'Q', LDA >= max(1,nq); */ -/* if VECT = 'P', LDA >= max(1,min(nq,K)). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i) or G(i) which determines Q or P, as returned */ -/* by DGEBRD in the array argument TAUQ or TAUP. */ - -/* 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 */ -/* or P*C or P**T*C or C*P or C*P**T. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - applyq = lsame_(vect, "Q"); - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q or P and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! applyq && ! lsame_(vect, "P")) { - *info = -1; - } else if (! left && ! lsame_(side, "R")) { - *info = -2; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*k < 0) { - *info = -6; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = 1, i__2 = std::min(nq,*k); - if (applyq && *lda < std::max(1_integer,nq) || ! applyq && *lda < std::max(i__1,i__2)) { - *info = -8; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -11; - } else if (*lwork < std::max(1_integer,nw) && ! lquery) { - *info = -13; - } - } - - if (*info == 0) { - if (applyq) { - if (left) { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__1, n, &i__2, &c_n1); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__1, &i__2, &c_n1); - } - } else { - if (left) { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, "DORMLQ", ch__1, &i__1, n, &i__2, &c_n1); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, "DORMLQ", ch__1, m, &i__1, &i__2, &c_n1); - } - } - lwkopt = std::max(1_integer,nw) * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMBR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - work[1] = 1.; - if (*m == 0 || *n == 0) { - return 0; - } - - if (applyq) { - -/* Apply Q */ - - if (nq >= *k) { - -/* Q was determined by a call to DGEBRD with nq >= k */ - - dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo); - } else if (nq > 1) { - -/* Q was determined by a call to DGEBRD with nq < k */ - - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1] -, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); - } - } else { - -/* Apply P */ - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - if (nq > *k) { - -/* P was determined by a call to DGEBRD with nq > k */ - - dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo); - } else if (nq > 1) { - -/* P was determined by a call to DGEBRD with nq <= k */ - - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda, - &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, & - iinfo); - } - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORMBR */ - -} /* dormbr_ */ diff --git a/external/clapack/lapack/dormhr.cpp b/external/clapack/lapack/dormhr.cpp deleted file mode 100644 index 3f5a0595..00000000 --- a/external/clapack/lapack/dormhr.cpp +++ /dev/null @@ -1,237 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; - -/* Subroutine */ int dormhr_(const char *side, const char *trans, integer *m, integer *n, - integer *ilo, integer *ihi, double *a, integer *lda, double * - tau, double *c__, integer *ldc, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2; - char ch__1[3]; - - /* Local variables */ - integer i1, i2, nb, mi, nh, ni, nq, nw; - bool left; - integer iinfo; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORMHR 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 of order nq, with nq = m if */ -/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ -/* IHI-ILO elementary reflectors, as returned by DGEHRD: */ - -/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ - -/* 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. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* ILO and IHI must have the same values as in the previous call */ -/* of DGEHRD. Q is equal to the unit matrix except in the */ -/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */ -/* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and */ -/* ILO = 1 and IHI = 0, if M = 0; */ -/* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and */ -/* ILO = 1 and IHI = 0, if N = 0. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,M) if SIDE = 'L' */ -/* (LDA,N) if SIDE = 'R' */ -/* The vectors which define the elementary reflectors, as */ -/* returned by DGEHRD. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */ - -/* TAU (input) DOUBLE PRECISION array, dimension */ -/* (M-1) if SIDE = 'L' */ -/* (N-1) if SIDE = 'R' */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGEHRD. */ - -/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - nh = *ihi - *ilo; - left = lsame_(side, "L"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*ilo < 1 || *ilo > std::max(1_integer,nq)) { - *info = -5; - } else if (*ihi < std::min(*ilo,nq) || *ihi > nq) { - *info = -6; - } else if (*lda < std::max(1_integer,nq)) { - *info = -8; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -11; - } else if (*lwork < std::max(1_integer,nw) && ! lquery) { - *info = -13; - } - - if (*info == 0) { - if (left) { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = const_cast (side); - i__1[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__1, &c__2, 2_integer); - ch__1 [2] = '\0'; - nb = ilaenv_(&c__1, "DORMQR", ch__1, &nh, n, &nh, &c_n1); - } else { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = const_cast (side); - i__1[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__1, &c__2, 2_integer); - ch__1 [2] = '\0'; - nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &nh, &nh, &c_n1); - } - lwkopt = std::max(1_integer,nw) * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__2 = -(*info); - xerbla_("DORMHR", &i__2); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || nh == 0) { - work[1] = 1.; - return 0; - } - - if (left) { - mi = nh; - ni = *n; - i1 = *ilo + 1; - i2 = 1; - } else { - mi = *m; - ni = nh; - i1 = 1; - i2 = *ilo + 1; - } - - dormqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, & - tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); - - work[1] = (double) lwkopt; - return 0; - -/* End of DORMHR */ - -} /* dormhr_ */ diff --git a/external/clapack/lapack/dorml2.cpp b/external/clapack/lapack/dorml2.cpp deleted file mode 100644 index 6acad46f..00000000 --- a/external/clapack/lapack/dorml2.cpp +++ /dev/null @@ -1,214 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dorml2_(const char *side, const char *trans, integer *m, integer *n, - integer *k, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, ic, jc, mi, ni, nq; - double aii; - bool left; - bool notran; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORML2 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(k) . . . H(2) H(1) */ - -/* as returned by DGELQF. 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,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGELQF in the first k rows 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. LDA >= max(1,K). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGELQF. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < std::max(1_integer,*k)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORML2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* 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__; - } - -/* Apply H(i) */ - - aii = a[i__ + i__ * a_dim1]; - a[i__ + i__ * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1]); - a[i__ + i__ * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DORML2 */ - -} /* dorml2_ */ diff --git a/external/clapack/lapack/dormlq.cpp b/external/clapack/lapack/dormlq.cpp deleted file mode 100644 index cb0419a1..00000000 --- a/external/clapack/lapack/dormlq.cpp +++ /dev/null @@ -1,311 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; -static integer c__65 = 65; - -/* Subroutine */ int dormlq_(const char *side, const char *trans, integer *m, integer *n, - integer *k, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[3]; - - /* Local variables */ - integer i__; - double t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; - bool left; - integer nbmin, iinfo; - bool notran; - integer ldwork; - char transt[1]; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORMLQ 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(k) . . . H(2) H(1) */ - -/* as returned by DGELQF. 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,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGELQF in the first k rows 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. LDA >= max(1,K). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGELQF. */ - -/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < std::max(1_integer,*k)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } else if (*lwork < std::max(1_integer,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - -/* Determine the block size. NB may be at most NBMAX, where NBMAX */ -/* is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1); - nb = std::min(i__1,i__2); - lwkopt = std::max(1_integer,nw) * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMLQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = std::min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__4 = nq - i__ + 1; - dlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], - lda, &tau[i__], t, &c__65); - if (left) { - -/* 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__; - } - -/* Apply H or H' */ - - dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ - + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], - ldc, &work[1], &ldwork); -/* L10: */ - } - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORMLQ */ - -} /* dormlq_ */ diff --git a/external/clapack/lapack/dormql.cpp b/external/clapack/lapack/dormql.cpp deleted file mode 100644 index f92aa9ff..00000000 --- a/external/clapack/lapack/dormql.cpp +++ /dev/null @@ -1,304 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; -static integer c__65 = 65; - -/* Subroutine */ int dormql_(const char *side, const char *trans, integer *m, integer *n, - integer *k, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[3]; - - /* Local variables */ - integer i__; - double t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws; - bool left; - integer nbmin, iinfo; - bool notran; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORMQL 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(k) . . . H(2) H(1) */ - -/* as returned by DGEQLF. 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 */ -/* DGEQLF in the last 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 DGEQLF. */ - -/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = std::max(1_integer,*n); - } else { - nq = *n; - nw = std::max(1_integer,*m); - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < std::max(1_integer,nq)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } - - if (*info == 0) { - if (*m == 0 || *n == 0) { - lwkopt = 1; - } else { - -/* Determine the block size. NB may be at most NBMAX, where */ -/* NBMAX is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQL", ch__1, m, n, k, &c_n1); - nb = std::min(i__1,i__2); - lwkopt = nw * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < nw && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMQL", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQL", ch__1, m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = std::min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__4 = nq - *k + i__ + ib - 1; - dlarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1] -, lda, &tau[i__], t, &c__65); - if (left) { - -/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */ - - mi = *m - *k + i__ + ib - 1; - } else { - -/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */ - - ni = *n - *k + i__ + ib - 1; - } - -/* Apply H or H' */ - - dlarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[ - i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, & - work[1], &ldwork); -/* L10: */ - } - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORMQL */ - -} /* dormql_ */ diff --git a/external/clapack/lapack/dormqr.cpp b/external/clapack/lapack/dormqr.cpp deleted file mode 100644 index 38dab3a8..00000000 --- a/external/clapack/lapack/dormqr.cpp +++ /dev/null @@ -1,304 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; -static integer c__65 = 65; - -/* Subroutine */ int dormqr_(const char *side, const char *trans, integer *m, integer *n, - integer *k, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[3]; - - /* Local variables */ - integer i__; - double t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws; - bool left; - integer nbmin, iinfo; - bool notran; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < std::max(1_integer,nq)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } else if (*lwork < std::max(1_integer,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - -/* Determine the block size. NB may be at most NBMAX, where NBMAX */ -/* is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1); - nb = std::min(i__1,i__2); - lwkopt = std::max(1_integer,nw) * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMQR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = std::min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__4 = nq - i__ + 1; - dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * - a_dim1], lda, &tau[i__], t, &c__65) - ; - if (left) { - -/* 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__; - } - -/* Apply H or H' */ - - dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[ - i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * - c_dim1], ldc, &work[1], &ldwork); -/* L10: */ - } - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORMQR */ - -} /* dormqr_ */ diff --git a/external/clapack/lapack/dormr2.cpp b/external/clapack/lapack/dormr2.cpp deleted file mode 100644 index 0077e6f7..00000000 --- a/external/clapack/lapack/dormr2.cpp +++ /dev/null @@ -1,210 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dormr2_(const char *side, const char *trans, integer *m, integer *n, - integer *k, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, mi, ni, nq; - double aii; - bool left; - bool notran; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORMR2 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 DGERQF. 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,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGERQF in the last k rows 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. LDA >= max(1,K). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGERQF. */ - -/* 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < std::max(1_integer,*k)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMR2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(1:m-k+i,1:n) */ - - mi = *m - *k + i__; - } else { - -/* H(i) is applied to C(1:m,1:n-k+i) */ - - ni = *n - *k + i__; - } - -/* Apply H(i) */ - - aii = a[i__ + (nq - *k + i__) * a_dim1]; - a[i__ + (nq - *k + i__) * a_dim1] = 1.; - dlarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &tau[i__], &c__[ - c_offset], ldc, &work[1]); - a[i__ + (nq - *k + i__) * a_dim1] = aii; -/* L10: */ - } - return 0; - -/* End of DORMR2 */ - -} /* dormr2_ */ diff --git a/external/clapack/lapack/dormr3.cpp b/external/clapack/lapack/dormr3.cpp deleted file mode 100644 index 5b413720..00000000 --- a/external/clapack/lapack/dormr3.cpp +++ /dev/null @@ -1,225 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dormr3_(const char *side, const char *trans, integer *m, integer *n, - integer *k, integer *l, double *a, integer *lda, double *tau, - double *c__, integer *ldc, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - - /* Local variables */ - integer i__, i1, i2, i3, ja, ic, jc, mi, ni, nq; - bool left; - bool notran; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORMR3 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 DTZRZF. 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. */ - -/* L (input) INTEGER */ -/* The number of columns of the matrix A containing */ -/* the meaningful part of the Householder reflectors. */ -/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DTZRZF in the last k rows 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. LDA >= max(1,K). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DTZRZF. */ - -/* 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 */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*l < 0 || left && *l > *m || ! left && *l > *n) { - *info = -6; - } else if (*lda < std::max(1_integer,*k)) { - *info = -8; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -11; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMR3", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - ja = *m - *l + 1; - jc = 1; - } else { - mi = *m; - ja = *n - *l + 1; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) or H(i)' is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H(i) or H(i)' is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H(i) or H(i)' */ - - dlarz_(side, &mi, &ni, l, &a[i__ + ja * a_dim1], lda, &tau[i__], &c__[ - ic + jc * c_dim1], ldc, &work[1]); - -/* L10: */ - } - - return 0; - -/* End of DORMR3 */ - -} /* dormr3_ */ diff --git a/external/clapack/lapack/dormrq.cpp b/external/clapack/lapack/dormrq.cpp deleted file mode 100644 index 5aa03f72..00000000 --- a/external/clapack/lapack/dormrq.cpp +++ /dev/null @@ -1,312 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; -static integer c__65 = 65; - -/* Subroutine */ int dormrq_(const char *side, const char *trans, integer *m, integer *n, - integer *k, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[3]; - - /* Local variables */ - integer i__; - double t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws; - bool left; - integer nbmin, iinfo; - bool notran; - integer ldwork; - char transt[1]; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORMRQ 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 DGERQF. 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,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DGERQF in the last k rows 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. LDA >= max(1,K). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DGERQF. */ - -/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = std::max(1_integer,*n); - } else { - nq = *n; - nw = std::max(1_integer,*m); - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < std::max(1_integer,*k)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } - - if (*info == 0) { - if (*m == 0 || *n == 0) { - lwkopt = 1; - } else { - -/* Determine the block size. NB may be at most NBMAX, where */ -/* NBMAX is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMRQ", ch__1, m, n, k, &c_n1); - nb = std::min(i__1,i__2); - lwkopt = nw * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < nw && ! lquery) { - *info = -12; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMRQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMRQ", ch__1, m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dormr2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - } else { - mi = *m; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = std::min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__4 = nq - *k + i__ + ib - 1; - dlarft_("Backward", "Rowwise", &i__4, &ib, &a[i__ + a_dim1], lda, - &tau[i__], t, &c__65); - if (left) { - -/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */ - - mi = *m - *k + i__ + ib - 1; - } else { - -/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */ - - ni = *n - *k + i__ + ib - 1; - } - -/* Apply H or H' */ - - dlarfb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, &a[ - i__ + a_dim1], lda, t, &c__65, &c__[c_offset], ldc, &work[ - 1], &ldwork); -/* L10: */ - } - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORMRQ */ - -} /* dormrq_ */ diff --git a/external/clapack/lapack/dormrz.cpp b/external/clapack/lapack/dormrz.cpp deleted file mode 100644 index 5dfded82..00000000 --- a/external/clapack/lapack/dormrz.cpp +++ /dev/null @@ -1,336 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; -static integer c__65 = 65; - -/* Subroutine */ int dormrz_(const char *side, const char *trans, integer *m, integer *n, - integer *k, integer *l, double *a, integer *lda, double *tau, - double *c__, integer *ldc, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[3]; - - /* Local variables */ - integer i__; - double t[4160] /* was [65][64] */; - integer i1, i2, i3, ib, ic, ja, jc, nb, mi, ni, nq, nw, iws; - bool left; - integer nbmin, iinfo; - bool notran; - integer ldwork; - char transt[1]; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* January 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORMRZ 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 DTZRZF. 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. */ - -/* L (input) INTEGER */ -/* The number of columns of the matrix A containing */ -/* the meaningful part of the Householder reflectors. */ -/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,M) if SIDE = 'L', */ -/* (LDA,N) if SIDE = 'R' */ -/* The i-th row must contain the vector which defines the */ -/* elementary reflector H(i), for i = 1,2,...,k, as returned by */ -/* DTZRZF in the last k rows 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. LDA >= max(1,K). */ - -/* TAU (input) DOUBLE PRECISION array, dimension (K) */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DTZRZF. */ - -/* 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**H*C or C*Q**H or C*Q. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = std::max(1_integer,*n); - } else { - nq = *n; - nw = std::max(1_integer,*m); - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*l < 0 || left && *l > *m || ! left && *l > *n) { - *info = -6; - } else if (*lda < std::max(1_integer,*k)) { - *info = -8; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -11; - } - - if (*info == 0) { - if (*m == 0 || *n == 0) { - lwkopt = 1; - } else { - -/* Determine the block size. NB may be at most NBMAX, where */ -/* NBMAX is used to define the local array T. */ - -/* Computing MIN */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMRQ", ch__1, m, n, k, &c_n1); - nb = std::min(i__1,i__2); - lwkopt = nw * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < std::max(1_integer,nw) && ! lquery) { - *info = -13; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMRZ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = const_cast (side); - i__3[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__3, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMRQ", ch__1, m, n, k, &c_n1); - nbmin = std::max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dormr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - ja = *m - *l + 1; - } else { - mi = *m; - ic = 1; - ja = *n - *l + 1; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = std::min(i__4,i__5); - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - dlarzt_("Backward", "Rowwise", l, &ib, &a[i__ + ja * a_dim1], lda, - &tau[i__], t, &c__65); - - if (left) { - -/* 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__; - } - -/* Apply H or H' */ - - dlarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, &a[ - i__ + ja * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1] -, ldc, &work[1], &ldwork); -/* L10: */ - } - - } - - work[1] = (double) lwkopt; - - return 0; - -/* End of DORMRZ */ - -} /* dormrz_ */ diff --git a/external/clapack/lapack/dormtr.cpp b/external/clapack/lapack/dormtr.cpp deleted file mode 100644 index 1c3cb3cf..00000000 --- a/external/clapack/lapack/dormtr.cpp +++ /dev/null @@ -1,274 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; - -/* Subroutine */ int dormtr_(const char *side, const char *uplo, const char *trans, integer *m, - integer *n, double *a, integer *lda, double *tau, double * - c__, integer *ldc, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3; - char ch__1[3]; - - /* Local variables */ - integer i1, i2, nb, mi, ni, nq, nw; - bool left; - integer iinfo; - bool upper; - integer lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DORMTR 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 of order nq, with nq = m if */ -/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ -/* nq-1 elementary reflectors, as returned by DSYTRD: */ - -/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ - -/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'L': apply Q or Q**T from the Left; */ -/* = 'R': apply Q or Q**T from the Right. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A contains elementary reflectors */ -/* from DSYTRD; */ -/* = 'L': Lower triangle of A contains elementary reflectors */ -/* from DSYTRD. */ - -/* 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. */ - -/* A (input) DOUBLE PRECISION array, dimension */ -/* (LDA,M) if SIDE = 'L' */ -/* (LDA,N) if SIDE = 'R' */ -/* The vectors which define the elementary reflectors, as */ -/* returned by DSYTRD. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. */ -/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */ - -/* TAU (input) DOUBLE PRECISION array, dimension */ -/* (M-1) if SIDE = 'L' */ -/* (N-1) if SIDE = 'R' */ -/* TAU(i) must contain the scalar factor of the elementary */ -/* reflector H(i), as returned by DSYTRD. */ - -/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T")) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,nq)) { - *info = -7; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } else if (*lwork < std::max(1_integer,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - if (upper) { - if (left) { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = const_cast (side); - i__1[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__1, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, "DORMQL", ch__1, &i__2, n, &i__3, &c_n1); - } else { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = const_cast (side); - i__1[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__1, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, "DORMQL", ch__1, m, &i__2, &i__3, &c_n1); - } - } else { - if (left) { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = const_cast (side); - i__1[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__1, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__2 = *m - 1; - i__3 = *m - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__2, n, &i__3, &c_n1); - } else { -/* Writing concatenation */ - i__1[0] = 1, a__1[0] = const_cast (side); - i__1[1] = 1, a__1[1] = const_cast (trans); - s_cat(ch__1, a__1, i__1, &c__2, 2_integer); - ch__1 [2] = '\0'; - i__2 = *n - 1; - i__3 = *n - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__2, &i__3, &c_n1); - } - } - lwkopt = std::max(1_integer,nw) * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__2 = -(*info); - xerbla_("DORMTR", &i__2); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || nq == 1) { - work[1] = 1.; - return 0; - } - - if (left) { - mi = *m - 1; - ni = *n; - } else { - mi = *m; - ni = *n - 1; - } - - if (upper) { - -/* Q was determined by a call to DSYTRD with UPLO = 'U' */ - - i__2 = nq - 1; - dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & - tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo); - } else { - -/* Q was determined by a call to DSYTRD with UPLO = 'L' */ - - if (left) { - i1 = 2; - i2 = 1; - } else { - i1 = 1; - i2 = 2; - } - i__2 = nq - 1; - dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & - c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); - } - work[1] = (double) lwkopt; - return 0; - -/* End of DORMTR */ - -} /* dormtr_ */ diff --git a/external/clapack/lapack/dpbcon.cpp b/external/clapack/lapack/dpbcon.cpp deleted file mode 100644 index 26f3071e..00000000 --- a/external/clapack/lapack/dpbcon.cpp +++ /dev/null @@ -1,210 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dpbcon_(const char *uplo, integer *n, integer *kd, double * - ab, integer *ldab, double *anorm, double *rcond, double * - work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1; - double d__1; - - /* Local variables */ - integer ix, kase; - double scale; - integer isave[3]; - bool upper; - double scalel; - double scaleu; - double ainvnm; - char normin[1]; - double smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBCON estimates the reciprocal of the condition number (in the */ -/* 1-norm) of a real symmetric positive definite band matrix using the */ -/* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangular factor stored in AB; */ -/* = 'L': Lower triangular factor stored in AB. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T of the band matrix A, stored in the */ -/* first KD+1 rows of the array. The j-th column of U or L is */ -/* stored in the j-th column of the array AB as follows: */ -/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* ANORM (input) DOUBLE PRECISION */ -/* The 1-norm (or infinity-norm) of the symmetric band matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ -/* estimate of the 1-norm of inv(A) computed in this routine. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kd < 0) { - *info = -3; - } else if (*ldab < *kd + 1) { - *info = -5; - } else if (*anorm < 0.) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - - smlnum = dlamch_("Safe minimum"); - -/* Estimate the 1-norm of the inverse. */ - - kase = 0; - *(unsigned char *)normin = 'N'; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (upper) { - -/* Multiply by inv(U'). */ - - dlatbs_("Upper", "Transpose", "Non-unit", normin, n, kd, &ab[ - ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1], - info); - *(unsigned char *)normin = 'Y'; - -/* Multiply by inv(U). */ - - dlatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[ - ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1], - info); - } else { - -/* Multiply by inv(L). */ - - dlatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[ - ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1], - info); - *(unsigned char *)normin = 'Y'; - -/* Multiply by inv(L'). */ - - dlatbs_("Lower", "Transpose", "Non-unit", normin, n, kd, &ab[ - ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1], - info); - } - -/* Multiply by 1/SCALE if doing so will not cause overflow. */ - - scale = scalel * scaleu; - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) - { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - -L20: - - return 0; - -/* End of DPBCON */ - -} /* dpbcon_ */ diff --git a/external/clapack/lapack/dpbequ.cpp b/external/clapack/lapack/dpbequ.cpp deleted file mode 100644 index d2709634..00000000 --- a/external/clapack/lapack/dpbequ.cpp +++ /dev/null @@ -1,186 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dpbequ_(const char *uplo, integer *n, integer *kd, double * - ab, integer *ldab, double *s, double *scond, double *amax, - integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double smin; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBEQU computes row and column scalings intended to equilibrate a */ -/* symmetric positive definite band matrix A and reduce its condition */ -/* number (with respect to the two-norm). S contains the scale factors, */ -/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ -/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ -/* choice of S puts the condition number of B within a factor N of the */ -/* smallest possible condition number over all possible diagonal */ -/* scalings. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangular of A is stored; */ -/* = 'L': Lower triangular of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangle of the symmetric band matrix A, */ -/* stored in the first KD+1 rows of the array. The j-th column */ -/* of A is stored in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array A. LDAB >= KD+1. */ - -/* S (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, S contains the scale factors for A. */ - -/* SCOND (output) DOUBLE PRECISION */ -/* If INFO = 0, S contains the ratio of the smallest S(i) to */ -/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ -/* large nor too small, it is not worth scaling by S. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --s; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kd < 0) { - *info = -3; - } else if (*ldab < *kd + 1) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBEQU", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *scond = 1.; - *amax = 0.; - return 0; - } - - if (upper) { - j = *kd + 1; - } else { - j = 1; - } - -/* Initialize SMIN and AMAX. */ - - s[1] = ab[j + ab_dim1]; - smin = s[1]; - *amax = s[1]; - -/* Find the minimum and maximum diagonal elements. */ - - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - s[i__] = ab[j + i__ * ab_dim1]; -/* Computing MIN */ - d__1 = smin, d__2 = s[i__]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = *amax, d__2 = s[i__]; - *amax = std::max(d__1,d__2); -/* L10: */ - } - - if (smin <= 0.) { - -/* Find the first non-positive diagonal element and return. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] <= 0.) { - *info = i__; - return 0; - } -/* L20: */ - } - } else { - -/* Set the scale factors to the reciprocals */ -/* of the diagonal elements. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - s[i__] = 1. / sqrt(s[i__]); -/* L30: */ - } - -/* Compute SCOND = min(S(I)) / max(S(I)) */ - - *scond = sqrt(smin) / sqrt(*amax); - } - return 0; - -/* End of DPBEQU */ - -} /* dpbequ_ */ diff --git a/external/clapack/lapack/dpbrfs.cpp b/external/clapack/lapack/dpbrfs.cpp deleted file mode 100644 index bb0e9904..00000000 --- a/external/clapack/lapack/dpbrfs.cpp +++ /dev/null @@ -1,413 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b12 = -1.; -static double c_b14 = 1.; - -/* Subroutine */ int dpbrfs_(const char *uplo, integer *n, integer *kd, integer * - nrhs, double *ab, integer *ldab, double *afb, integer *ldafb, - double *b, integer *ldb, double *x, integer *ldx, double * - ferr, double *berr, double *work, integer *iwork, integer * - info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, - x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k, l; - double s, xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - integer count; - bool upper; - double safmin; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBRFS improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is symmetric positive definite */ -/* and banded, and provides error bounds and backward error estimates */ -/* for the solution. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangle of the symmetric band matrix A, */ -/* stored in the first KD+1 rows of the array. The j-th column */ -/* of A is stored in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T of the band matrix A as computed by */ -/* DPBTRF, in the same storage format as A (see AB). */ - -/* LDAFB (input) INTEGER */ -/* The leading dimension of the array AFB. LDAFB >= KD+1. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DPBTRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kd < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*ldab < *kd + 1) { - *info = -6; - } else if (*ldafb < *kd + 1) { - *info = -8; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -10; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - -/* Computing MIN */ - i__1 = *n + 1, i__2 = (*kd << 1) + 2; - nz = std::min(i__1,i__2); - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - A * X */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dsbmv_(uplo, n, kd, &c_b12, &ab[ab_offset], ldab, &x[j * x_dim1 + 1], - &c__1, &c_b14, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L30: */ - } - -/* Compute abs(A)*abs(X) + abs(B). */ - - if (upper) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - l = *kd + 1 - k; -/* Computing MAX */ - i__3 = 1, i__4 = k - *kd; - i__5 = k - 1; - for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) { - work[i__] += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) - * xk; - s += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) * ( - d__2 = x[i__ + j * x_dim1], abs(d__2)); -/* L40: */ - } - work[k] = work[k] + (d__1 = ab[*kd + 1 + k * ab_dim1], abs( - d__1)) * xk + s; -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - work[k] += (d__1 = ab[k * ab_dim1 + 1], abs(d__1)) * xk; - l = 1 - k; -/* Computing MIN */ - i__3 = *n, i__4 = k + *kd; - i__5 = std::min(i__3,i__4); - for (i__ = k + 1; i__ <= i__5; ++i__) { - work[i__] += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) - * xk; - s += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) * ( - d__2 = x[i__ + j * x_dim1], abs(d__2)); -/* L60: */ - } - work[k] += s; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + 1] -, n, info); - daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(A))* */ -/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(A) is the inverse of A */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(A) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(A'). */ - - dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n - + 1], n, info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] *= work[i__]; -/* L110: */ - } - } else if (kase == 2) { - -/* Multiply by inv(A)*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] *= work[i__]; -/* L120: */ - } - dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n - + 1], n, info); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DPBRFS */ - -} /* dpbrfs_ */ diff --git a/external/clapack/lapack/dpbstf.cpp b/external/clapack/lapack/dpbstf.cpp deleted file mode 100644 index 7f4976bf..00000000 --- a/external/clapack/lapack/dpbstf.cpp +++ /dev/null @@ -1,292 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b9 = -1.; - -/* Subroutine */ int dpbstf_(const char *uplo, integer *n, integer *kd, double * - ab, integer *ldab, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer j, m, km; - double ajj; - integer kld; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBSTF computes a split Cholesky factorization of a real */ -/* symmetric positive definite band matrix A. */ - -/* This routine is designed to be used in conjunction with DSBGST. */ - -/* The factorization has the form A = S**T*S where S is a band matrix */ -/* of the same bandwidth as A and the following structure: */ - -/* S = ( U ) */ -/* ( M L ) */ - -/* where U is upper triangular of order m = (n+kd)/2, and L is lower */ -/* triangular of order n-m. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first kd+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* On exit, if INFO = 0, the factor S from the split Cholesky */ -/* factorization A = S**T*S. See Further Details. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the factorization could not be completed, */ -/* because the updated element a(i,i) was negative; the */ -/* matrix A is not positive definite. */ - -/* Further Details */ -/* =============== */ - -/* The band storage scheme is illustrated by the following example, when */ -/* N = 7, KD = 2: */ - -/* S = ( s11 s12 s13 ) */ -/* ( s22 s23 s24 ) */ -/* ( s33 s34 ) */ -/* ( s44 ) */ -/* ( s53 s54 s55 ) */ -/* ( s64 s65 s66 ) */ -/* ( s75 s76 s77 ) */ - -/* If UPLO = 'U', the array AB holds: */ - -/* on entry: on exit: */ - -/* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 */ -/* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 */ -/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */ - -/* If UPLO = 'L', the array AB holds: */ - -/* on entry: on exit: */ - -/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */ -/* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * */ -/* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * */ - -/* Array elements marked * are not used by the routine. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kd < 0) { - *info = -3; - } else if (*ldab < *kd + 1) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBSTF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Computing MAX */ - i__1 = 1, i__2 = *ldab - 1; - kld = std::max(i__1,i__2); - -/* Set the splitting point m. */ - - m = (*n + *kd) / 2; - - if (upper) { - -/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */ - - i__1 = m + 1; - for (j = *n; j >= i__1; --j) { - -/* Compute s(j,j) and test for non-positive-definiteness. */ - - ajj = ab[*kd + 1 + j * ab_dim1]; - if (ajj <= 0.) { - goto L50; - } - ajj = sqrt(ajj); - ab[*kd + 1 + j * ab_dim1] = ajj; -/* Computing MIN */ - i__2 = j - 1; - km = std::min(i__2,*kd); - -/* Compute elements j-km:j-1 of the j-th column and update the */ -/* the leading submatrix within the band. */ - - d__1 = 1. / ajj; - dscal_(&km, &d__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1); - dsyr_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1, - &ab[*kd + 1 + (j - km) * ab_dim1], &kld); -/* L10: */ - } - -/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */ - - i__1 = m; - for (j = 1; j <= i__1; ++j) { - -/* Compute s(j,j) and test for non-positive-definiteness. */ - - ajj = ab[*kd + 1 + j * ab_dim1]; - if (ajj <= 0.) { - goto L50; - } - ajj = sqrt(ajj); - ab[*kd + 1 + j * ab_dim1] = ajj; -/* Computing MIN */ - i__2 = *kd, i__3 = m - j; - km = std::min(i__2,i__3); - -/* Compute elements j+1:j+km of the j-th row and update the */ -/* trailing submatrix within the band. */ - - if (km > 0) { - d__1 = 1. / ajj; - dscal_(&km, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld); - dsyr_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld, - &ab[*kd + 1 + (j + 1) * ab_dim1], &kld); - } -/* L20: */ - } - } else { - -/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */ - - i__1 = m + 1; - for (j = *n; j >= i__1; --j) { - -/* Compute s(j,j) and test for non-positive-definiteness. */ - - ajj = ab[j * ab_dim1 + 1]; - if (ajj <= 0.) { - goto L50; - } - ajj = sqrt(ajj); - ab[j * ab_dim1 + 1] = ajj; -/* Computing MIN */ - i__2 = j - 1; - km = std::min(i__2,*kd); - -/* Compute elements j-km:j-1 of the j-th row and update the */ -/* trailing submatrix within the band. */ - - d__1 = 1. / ajj; - dscal_(&km, &d__1, &ab[km + 1 + (j - km) * ab_dim1], &kld); - dsyr_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld, - &ab[(j - km) * ab_dim1 + 1], &kld); -/* L30: */ - } - -/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */ - - i__1 = m; - for (j = 1; j <= i__1; ++j) { - -/* Compute s(j,j) and test for non-positive-definiteness. */ - - ajj = ab[j * ab_dim1 + 1]; - if (ajj <= 0.) { - goto L50; - } - ajj = sqrt(ajj); - ab[j * ab_dim1 + 1] = ajj; -/* Computing MIN */ - i__2 = *kd, i__3 = m - j; - km = std::min(i__2,i__3); - -/* Compute elements j+1:j+km of the j-th column and update the */ -/* trailing submatrix within the band. */ - - if (km > 0) { - d__1 = 1. / ajj; - dscal_(&km, &d__1, &ab[j * ab_dim1 + 2], &c__1); - dsyr_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[( - j + 1) * ab_dim1 + 1], &kld); - } -/* L40: */ - } - } - return 0; - -L50: - *info = j; - return 0; - -/* End of DPBSTF */ - -} /* dpbstf_ */ diff --git a/external/clapack/lapack/dpbsv.cpp b/external/clapack/lapack/dpbsv.cpp deleted file mode 100644 index c3c8a4c3..00000000 --- a/external/clapack/lapack/dpbsv.cpp +++ /dev/null @@ -1,163 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dpbsv_(const char *uplo, integer *n, integer *kd, integer * - nrhs, double *ab, integer *ldab, double *b, integer *ldb, - integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBSV computes the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric positive definite band matrix and X */ -/* and B are N-by-NRHS matrices. */ - -/* The Cholesky decomposition is used to factor A as */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular band matrix, and L is a lower */ -/* triangular band matrix, with the same number of superdiagonals or */ -/* subdiagonals as A. The factored form of A is then used to solve the */ -/* system of equations A * X = B. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */ -/* See below for further details. */ - -/* On exit, if INFO = 0, the triangular factor U or L from the */ -/* Cholesky factorization A = U**T*U or A = L*L**T of the band */ -/* matrix A, in the same storage format as A. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i of A is not */ -/* positive definite, so the factorization could not be */ -/* completed, and the solution has not been computed. */ - -/* Further Details */ -/* =============== */ - -/* The band storage scheme is illustrated by the following example, when */ -/* N = 6, KD = 2, and UPLO = 'U': */ - -/* On entry: On exit: */ - -/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ -/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ -/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ - -/* Similarly, if UPLO = 'L' the format of A is as follows: */ - -/* On entry: On exit: */ - -/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ -/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ -/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ - -/* Array elements marked * are not used by the routine. */ - -/* ===================================================================== */ - -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kd < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*ldab < *kd + 1) { - *info = -6; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBSV ", &i__1); - return 0; - } - -/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ - - dpbtrf_(uplo, n, kd, &ab[ab_offset], ldab, info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dpbtrs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &b[b_offset], ldb, - info); - - } - return 0; - -/* End of DPBSV */ - -} /* dpbsv_ */ diff --git a/external/clapack/lapack/dpbsvx.cpp b/external/clapack/lapack/dpbsvx.cpp deleted file mode 100644 index 7be232f5..00000000 --- a/external/clapack/lapack/dpbsvx.cpp +++ /dev/null @@ -1,481 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dpbsvx_(const char *fact, const char *uplo, integer *n, integer *kd, - integer *nrhs, double *ab, integer *ldab, double *afb, - integer *ldafb, char *equed, double *s, double *b, integer * - ldb, double *x, integer *ldx, double *rcond, double *ferr, - double *berr, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, - x_dim1, x_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, j1, j2; - double amax, smin, smax; - double scond, anorm; - bool equil, rcequ, upper; - bool nofact; - double bignum; - integer infequ; - double smlnum; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */ -/* compute the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric positive definite band matrix and X */ -/* and B are N-by-NRHS matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ -/* the system: */ -/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ -/* Whether or not the system will be equilibrated depends on the */ -/* scaling of the matrix A, but if equilibration is used, A is */ -/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ - -/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ -/* factor the matrix A (after equilibration if FACT = 'E') as */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular band matrix, and L is a lower */ -/* triangular band matrix. */ - -/* 3. If the leading i-by-i principal minor is not positive definite, */ -/* then the routine returns with INFO = i. Otherwise, the factored */ -/* form of A is used to estimate the condition number of the matrix */ -/* A. If the reciprocal of the condition number is less than machine */ -/* precision, INFO = N+1 is returned as a warning, but the routine */ -/* still goes on to solve for X and compute error bounds as */ -/* described below. */ - -/* 4. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 5. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* 6. If equilibration was used, the matrix X is premultiplied by */ -/* diag(S) so that it solves the original system before */ -/* equilibration. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of the matrix A is */ -/* supplied on entry, and if not, whether the matrix A should be */ -/* equilibrated before it is factored. */ -/* = 'F': On entry, AFB contains the factored form of A. */ -/* If EQUED = 'Y', the matrix A has been equilibrated */ -/* with scaling factors given by S. AB and AFB will not */ -/* be modified. */ -/* = 'N': The matrix A will be copied to AFB and factored. */ -/* = 'E': The matrix A will be equilibrated if necessary, then */ -/* copied to AFB and factored. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right-hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array, except */ -/* if FACT = 'F' and EQUED = 'Y', then A must contain the */ -/* equilibrated matrix diag(S)*A*diag(S). The j-th column of A */ -/* is stored in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */ -/* See below for further details. */ - -/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ -/* diag(S)*A*diag(S). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array A. LDAB >= KD+1. */ - -/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */ -/* If FACT = 'F', then AFB is an input argument and on entry */ -/* contains the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T of the band matrix */ -/* A, in the same storage format as A (see AB). If EQUED = 'Y', */ -/* then AFB is the factored form of the equilibrated matrix A. */ - -/* If FACT = 'N', then AFB is an output argument and on exit */ -/* returns the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T. */ - -/* If FACT = 'E', then AFB is an output argument and on exit */ -/* returns the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T of the equilibrated */ -/* matrix A (see the description of A for the form of the */ -/* equilibrated matrix). */ - -/* LDAFB (input) INTEGER */ -/* The leading dimension of the array AFB. LDAFB >= KD+1. */ - -/* EQUED (input or output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration (always true if FACT = 'N'). */ -/* = 'Y': Equilibration was done, i.e., A has been replaced by */ -/* diag(S) * A * diag(S). */ -/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ -/* output argument. */ - -/* S (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The scale factors for A; not accessed if EQUED = 'N'. S is */ -/* an input argument if FACT = 'F'; otherwise, S is an output */ -/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */ -/* must be positive. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ -/* B is overwritten by diag(S) * B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ -/* the original system of equations. Note that if EQUED = 'Y', */ -/* A and B are modified on exit, and the solution to the */ -/* equilibrated system is inv(diag(S))*X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The estimate of the reciprocal condition number of the matrix */ -/* A after equilibration (if done). If RCOND is less than the */ -/* machine precision (in particular, if RCOND = 0), the matrix */ -/* is singular to working precision. This condition is */ -/* indicated by a return code of INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= N: the leading minor of order i of A is */ -/* not positive definite, so the factorization */ -/* could not be completed, and the solution has not */ -/* been computed. RCOND = 0 is returned. */ -/* = N+1: U is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* Further Details */ -/* =============== */ - -/* The band storage scheme is illustrated by the following example, when */ -/* N = 6, KD = 2, and UPLO = 'U': */ - -/* Two-dimensional storage of the symmetric matrix A: */ - -/* a11 a12 a13 */ -/* a22 a23 a24 */ -/* a33 a34 a35 */ -/* a44 a45 a46 */ -/* a55 a56 */ -/* (aij=conjg(aji)) a66 */ - -/* Band storage of the upper triangle of A: */ - -/* * * a13 a24 a35 a46 */ -/* * a12 a23 a34 a45 a56 */ -/* a11 a22 a33 a44 a55 a66 */ - -/* Similarly, if UPLO = 'L' the format of A is as follows: */ - -/* a11 a22 a33 a44 a55 a66 */ -/* a21 a32 a43 a54 a65 * */ -/* a31 a42 a53 a64 * * */ - -/* Array elements marked * are not used by the routine. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1; - afb -= afb_offset; - --s; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - equil = lsame_(fact, "E"); - upper = lsame_(uplo, "U"); - if (nofact || equil) { - *(unsigned char *)equed = 'N'; - rcequ = false; - } else { - rcequ = lsame_(equed, "Y"); - smlnum = dlamch_("Safe minimum"); - bignum = 1. / smlnum; - } - -/* Test the input parameters. */ - - if (! nofact && ! equil && ! lsame_(fact, "F")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*kd < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*ldab < *kd + 1) { - *info = -7; - } else if (*ldafb < *kd + 1) { - *info = -9; - } else if (lsame_(fact, "F") && ! (rcequ || lsame_( - equed, "N"))) { - *info = -10; - } else { - if (rcequ) { - smin = bignum; - smax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = smin, d__2 = s[j]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = smax, d__2 = s[j]; - smax = std::max(d__1,d__2); -/* L10: */ - } - if (smin <= 0.) { - *info = -11; - } else if (*n > 0) { - scond = std::max(smin,smlnum) / std::min(smax,bignum); - } else { - scond = 1.; - } - } - if (*info == 0) { - if (*ldb < std::max(1_integer,*n)) { - *info = -13; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -15; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBSVX", &i__1); - return 0; - } - - if (equil) { - -/* Compute row and column scalings to equilibrate the matrix A. */ - - dpbequ_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, & - infequ); - if (infequ == 0) { - -/* Equilibrate the matrix. */ - - dlaqsb_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, - equed); - rcequ = lsame_(equed, "Y"); - } - } - -/* Scale the right-hand side. */ - - if (rcequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1]; -/* L20: */ - } -/* L30: */ - } - } - - if (nofact || equil) { - -/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ - - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = j - *kd; - j1 = std::max(i__2,1_integer); - i__2 = j - j1 + 1; - dcopy_(&i__2, &ab[*kd + 1 - j + j1 + j * ab_dim1], &c__1, & - afb[*kd + 1 - j + j1 + j * afb_dim1], &c__1); -/* L40: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = j + *kd; - j2 = std::min(i__2,*n); - i__2 = j2 - j + 1; - dcopy_(&i__2, &ab[j * ab_dim1 + 1], &c__1, &afb[j * afb_dim1 - + 1], &c__1); -/* L50: */ - } - } - - dpbtrf_(uplo, n, kd, &afb[afb_offset], ldafb, info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A. */ - - anorm = dlansb_("1", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); - -/* Compute the reciprocal of the condition number of A. */ - - dpbcon_(uplo, n, kd, &afb[afb_offset], ldafb, &anorm, rcond, &work[1], & - iwork[1], info); - -/* Compute the solution matrix X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dpbtrs_(uplo, n, kd, nrhs, &afb[afb_offset], ldafb, &x[x_offset], ldx, - info); - -/* Use iterative refinement to improve the computed solution and */ -/* compute error bounds and backward error estimates for it. */ - - dpbrfs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, - &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] -, &iwork[1], info); - -/* Transform the solution matrix X to a solution of the original */ -/* system. */ - - if (rcequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1]; -/* L60: */ - } -/* L70: */ - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] /= scond; -/* L80: */ - } - } - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - - return 0; - -/* End of DPBSVX */ - -} /* dpbsvx_ */ diff --git a/external/clapack/lapack/dpbtf2.cpp b/external/clapack/lapack/dpbtf2.cpp deleted file mode 100644 index 84b5bf69..00000000 --- a/external/clapack/lapack/dpbtf2.cpp +++ /dev/null @@ -1,224 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b8 = -1.; -static integer c__1 = 1; - -/* Subroutine */ int dpbtf2_(const char *uplo, integer *n, integer *kd, double * - ab, integer *ldab, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer j, kn; - double ajj; - integer kld; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBTF2 computes the Cholesky factorization of a real symmetric */ -/* positive definite band matrix A. */ - -/* The factorization has the form */ -/* A = U' * U , if UPLO = 'U', or */ -/* A = L * L', if UPLO = 'L', */ -/* where U is an upper triangular matrix, U' is the transpose of U, and */ -/* L is lower triangular. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of super-diagonals of the matrix A if UPLO = 'U', */ -/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* On exit, if INFO = 0, the triangular factor U or L from the */ -/* Cholesky factorization A = U'*U or A = L*L' of the band */ -/* matrix A, in the same storage format as A. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, the leading minor of order k is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* Further Details */ -/* =============== */ - -/* The band storage scheme is illustrated by the following example, when */ -/* N = 6, KD = 2, and UPLO = 'U': */ - -/* On entry: On exit: */ - -/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ -/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ -/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ - -/* Similarly, if UPLO = 'L' the format of A is as follows: */ - -/* On entry: On exit: */ - -/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ -/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ -/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ - -/* Array elements marked * are not used by the routine. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kd < 0) { - *info = -3; - } else if (*ldab < *kd + 1) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBTF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Computing MAX */ - i__1 = 1, i__2 = *ldab - 1; - kld = std::max(i__1,i__2); - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute U(J,J) and test for non-positive-definiteness. */ - - ajj = ab[*kd + 1 + j * ab_dim1]; - if (ajj <= 0.) { - goto L30; - } - ajj = sqrt(ajj); - ab[*kd + 1 + j * ab_dim1] = ajj; - -/* Compute elements J+1:J+KN of row J and update the */ -/* trailing submatrix within the band. */ - -/* Computing MIN */ - i__2 = *kd, i__3 = *n - j; - kn = std::min(i__2,i__3); - if (kn > 0) { - d__1 = 1. / ajj; - dscal_(&kn, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld); - dsyr_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld, - &ab[*kd + 1 + (j + 1) * ab_dim1], &kld); - } -/* L10: */ - } - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute L(J,J) and test for non-positive-definiteness. */ - - ajj = ab[j * ab_dim1 + 1]; - if (ajj <= 0.) { - goto L30; - } - ajj = sqrt(ajj); - ab[j * ab_dim1 + 1] = ajj; - -/* Compute elements J+1:J+KN of column J and update the */ -/* trailing submatrix within the band. */ - -/* Computing MIN */ - i__2 = *kd, i__3 = *n - j; - kn = std::min(i__2,i__3); - if (kn > 0) { - d__1 = 1. / ajj; - dscal_(&kn, &d__1, &ab[j * ab_dim1 + 2], &c__1); - dsyr_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[( - j + 1) * ab_dim1 + 1], &kld); - } -/* L20: */ - } - } - return 0; - -L30: - *info = j; - return 0; - -/* End of DPBTF2 */ - -} /* dpbtf2_ */ diff --git a/external/clapack/lapack/dpbtrf.cpp b/external/clapack/lapack/dpbtrf.cpp deleted file mode 100644 index 735e9392..00000000 --- a/external/clapack/lapack/dpbtrf.cpp +++ /dev/null @@ -1,444 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b18 = 1.; -static double c_b21 = -1.; -static integer c__33 = 33; - -/* Subroutine */ int dpbtrf_(const char *uplo, integer *n, integer *kd, double * - ab, integer *ldab, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, i2, i3, ib, nb, ii, jj; - double work[1056] /* was [33][32] */; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBTRF computes the Cholesky factorization of a real symmetric */ -/* positive definite band matrix A. */ - -/* The factorization has the form */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* On exit, if INFO = 0, the triangular factor U or L from the */ -/* Cholesky factorization A = U**T*U or A = L*L**T of the band */ -/* matrix A, in the same storage format as A. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* Further Details */ -/* =============== */ - -/* The band storage scheme is illustrated by the following example, when */ -/* N = 6, KD = 2, and UPLO = 'U': */ - -/* On entry: On exit: */ - -/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */ -/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ -/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ - -/* Similarly, if UPLO = 'L' the format of A is as follows: */ - -/* On entry: On exit: */ - -/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */ -/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */ -/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */ - -/* Array elements marked * are not used by the routine. */ - -/* Contributed by */ -/* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - - /* Function Body */ - *info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kd < 0) { - *info = -3; - } else if (*ldab < *kd + 1) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment */ - - nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1); - -/* The block size must not exceed the semi-bandwidth KD, and must not */ -/* exceed the limit set by the size of the local array WORK. */ - - nb = std::min(nb,32_integer); - - if (nb <= 1 || nb > *kd) { - -/* Use unblocked code */ - - dpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info); - } else { - -/* Use blocked code */ - - if (lsame_(uplo, "U")) { - -/* Compute the Cholesky factorization of a symmetric band */ -/* matrix, given the upper triangle of the matrix in band */ -/* storage. */ - -/* Zero the upper triangle of the work array. */ - - i__1 = nb; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__ + j * 33 - 34] = 0.; -/* L10: */ - } -/* L20: */ - } - -/* Process the band matrix one diagonal block at a time. */ - - i__1 = *n; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = std::min(i__3,i__4); - -/* Factorize the diagonal block */ - - i__3 = *ldab - 1; - dpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii); - if (ii != 0) { - *info = i__ + ii - 1; - goto L150; - } - if (i__ + ib <= *n) { - -/* Update the relevant part of the trailing submatrix. */ -/* If A11 denotes the diagonal block which has just been */ -/* factorized, then we need to update the remaining */ -/* blocks in the diagram: */ - -/* A11 A12 A13 */ -/* A22 A23 */ -/* A33 */ - -/* The numbers of rows and columns in the partitioning */ -/* are IB, I2, I3 respectively. The blocks A12, A22 and */ -/* A23 are empty if IB = KD. The upper triangle of A13 */ -/* lies outside the band. */ - -/* Computing MIN */ - i__3 = *kd - ib, i__4 = *n - i__ - ib + 1; - i2 = std::min(i__3,i__4); -/* Computing MIN */ - i__3 = ib, i__4 = *n - i__ - *kd + 1; - i3 = std::min(i__3,i__4); - - if (i2 > 0) { - -/* Update A12 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, - &i2, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], & - i__3, &ab[*kd + 1 - ib + (i__ + ib) * ab_dim1] -, &i__4); - -/* Update A22 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &ab[* - kd + 1 - ib + (i__ + ib) * ab_dim1], &i__3, & - c_b18, &ab[*kd + 1 + (i__ + ib) * ab_dim1], & - i__4); - } - - if (i3 > 0) { - -/* Copy the lower triangle of A13 into the work array. */ - - i__3 = i3; - for (jj = 1; jj <= i__3; ++jj) { - i__4 = ib; - for (ii = jj; ii <= i__4; ++ii) { - work[ii + jj * 33 - 34] = ab[ii - jj + 1 + ( - jj + i__ + *kd - 1) * ab_dim1]; -/* L30: */ - } -/* L40: */ - } - -/* Update A13 (in the work array). */ - - i__3 = *ldab - 1; - dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib, - &i3, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], & - i__3, work, &c__33); - -/* Update A23 */ - - if (i2 > 0) { - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dgemm_("Transpose", "No Transpose", &i2, &i3, &ib, - &c_b21, &ab[*kd + 1 - ib + (i__ + ib) * - ab_dim1], &i__3, work, &c__33, &c_b18, & - ab[ib + 1 + (i__ + *kd) * ab_dim1], &i__4); - } - -/* Update A33 */ - - i__3 = *ldab - 1; - dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, & - c__33, &c_b18, &ab[*kd + 1 + (i__ + *kd) * - ab_dim1], &i__3); - -/* Copy the lower triangle of A13 back into place. */ - - i__3 = i3; - for (jj = 1; jj <= i__3; ++jj) { - i__4 = ib; - for (ii = jj; ii <= i__4; ++ii) { - ab[ii - jj + 1 + (jj + i__ + *kd - 1) * - ab_dim1] = work[ii + jj * 33 - 34]; -/* L50: */ - } -/* L60: */ - } - } - } -/* L70: */ - } - } else { - -/* Compute the Cholesky factorization of a symmetric band */ -/* matrix, given the lower triangle of the matrix in band */ -/* storage. */ - -/* Zero the lower triangle of the work array. */ - - i__2 = nb; - for (j = 1; j <= i__2; ++j) { - i__1 = nb; - for (i__ = j + 1; i__ <= i__1; ++i__) { - work[i__ + j * 33 - 34] = 0.; -/* L80: */ - } -/* L90: */ - } - -/* Process the band matrix one diagonal block at a time. */ - - i__2 = *n; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = std::min(i__3,i__4); - -/* Factorize the diagonal block */ - - i__3 = *ldab - 1; - dpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii); - if (ii != 0) { - *info = i__ + ii - 1; - goto L150; - } - if (i__ + ib <= *n) { - -/* Update the relevant part of the trailing submatrix. */ -/* If A11 denotes the diagonal block which has just been */ -/* factorized, then we need to update the remaining */ -/* blocks in the diagram: */ - -/* A11 */ -/* A21 A22 */ -/* A31 A32 A33 */ - -/* The numbers of rows and columns in the partitioning */ -/* are IB, I2, I3 respectively. The blocks A21, A22 and */ -/* A32 are empty if IB = KD. The lower triangle of A31 */ -/* lies outside the band. */ - -/* Computing MIN */ - i__3 = *kd - ib, i__4 = *n - i__ - ib + 1; - i2 = std::min(i__3,i__4); -/* Computing MIN */ - i__3 = ib, i__4 = *n - i__ - *kd + 1; - i3 = std::min(i__3,i__4); - - if (i2 > 0) { - -/* Update A21 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i2, - &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, & - ab[ib + 1 + i__ * ab_dim1], &i__4); - -/* Update A22 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dsyrk_("Lower", "No Transpose", &i2, &ib, &c_b21, &ab[ - ib + 1 + i__ * ab_dim1], &i__3, &c_b18, &ab[( - i__ + ib) * ab_dim1 + 1], &i__4); - } - - if (i3 > 0) { - -/* Copy the upper triangle of A31 into the work array. */ - - i__3 = ib; - for (jj = 1; jj <= i__3; ++jj) { - i__4 = std::min(jj,i3); - for (ii = 1; ii <= i__4; ++ii) { - work[ii + jj * 33 - 34] = ab[*kd + 1 - jj + - ii + (jj + i__ - 1) * ab_dim1]; -/* L100: */ - } -/* L110: */ - } - -/* Update A31 (in the work array). */ - - i__3 = *ldab - 1; - dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i3, - &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, - work, &c__33); - -/* Update A32 */ - - if (i2 > 0) { - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dgemm_("No transpose", "Transpose", &i3, &i2, &ib, - &c_b21, work, &c__33, &ab[ib + 1 + i__ * - ab_dim1], &i__3, &c_b18, &ab[*kd + 1 - ib - + (i__ + ib) * ab_dim1], &i__4); - } - -/* Update A33 */ - - i__3 = *ldab - 1; - dsyrk_("Lower", "No Transpose", &i3, &ib, &c_b21, - work, &c__33, &c_b18, &ab[(i__ + *kd) * - ab_dim1 + 1], &i__3); - -/* Copy the upper triangle of A31 back into place. */ - - i__3 = ib; - for (jj = 1; jj <= i__3; ++jj) { - i__4 = std::min(jj,i3); - for (ii = 1; ii <= i__4; ++ii) { - ab[*kd + 1 - jj + ii + (jj + i__ - 1) * - ab_dim1] = work[ii + jj * 33 - 34]; -/* L120: */ - } -/* L130: */ - } - } - } -/* L140: */ - } - } - } - return 0; - -L150: - return 0; - -/* End of DPBTRF */ - -} /* dpbtrf_ */ diff --git a/external/clapack/lapack/dpbtrs.cpp b/external/clapack/lapack/dpbtrs.cpp deleted file mode 100644 index 95c11a80..00000000 --- a/external/clapack/lapack/dpbtrs.cpp +++ /dev/null @@ -1,168 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dpbtrs_(const char *uplo, integer *n, integer *kd, integer * - nrhs, double *ab, integer *ldab, double *b, integer *ldb, - integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - integer j; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPBTRS solves a system of linear equations A*X = B with a symmetric */ -/* positive definite band matrix A using the Cholesky factorization */ -/* A = U**T*U or A = L*L**T computed by DPBTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangular factor stored in AB; */ -/* = 'L': Lower triangular factor stored in AB. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T of the band matrix A, stored in the */ -/* first KD+1 rows of the array. The j-th column of U or L is */ -/* stored in the j-th column of the array AB as follows: */ -/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kd < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*ldab < *kd + 1) { - *info = -6; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPBTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B where A = U'*U. */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Solve U'*X = B, overwriting B with X. */ - - dtbsv_("Upper", "Transpose", "Non-unit", n, kd, &ab[ab_offset], - ldab, &b[j * b_dim1 + 1], &c__1); - -/* Solve U*X = B, overwriting B with X. */ - - dtbsv_("Upper", "No transpose", "Non-unit", n, kd, &ab[ab_offset], - ldab, &b[j * b_dim1 + 1], &c__1); -/* L10: */ - } - } else { - -/* Solve A*X = B where A = L*L'. */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Solve L*X = B, overwriting B with X. */ - - dtbsv_("Lower", "No transpose", "Non-unit", n, kd, &ab[ab_offset], - ldab, &b[j * b_dim1 + 1], &c__1); - -/* Solve L'*X = B, overwriting B with X. */ - - dtbsv_("Lower", "Transpose", "Non-unit", n, kd, &ab[ab_offset], - ldab, &b[j * b_dim1 + 1], &c__1); -/* L20: */ - } - } - - return 0; - -/* End of DPBTRS */ - -} /* dpbtrs_ */ diff --git a/external/clapack/lapack/dpftrf.cpp b/external/clapack/lapack/dpftrf.cpp deleted file mode 100644 index 7f1c76b6..00000000 --- a/external/clapack/lapack/dpftrf.cpp +++ /dev/null @@ -1,430 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b12 = 1.; -static double c_b15 = -1.; - -int dpftrf_(const char *transr, const char *uplo, integer *n, double *a, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer k, n1, n2; - bool normaltransr; - bool lower; - bool nisodd; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ - -/* Purpose */ -/* ======= */ - -/* DPFTRF computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the block version of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': The Normal TRANSR of RFP A is stored; */ -/* = 'T': The Transpose TRANSR of RFP A is stored. */ - -/* UPLO (input) CHARACTER */ -/* = 'U': Upper triangle of RFP A is stored; */ -/* = 'L': Lower triangle of RFP A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); */ -/* On entry, the symmetric matrix A in RFP format. RFP format is */ -/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ -/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ -/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */ -/* the transpose of RFP A as defined when */ -/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ -/* follows: If UPLO = 'U' the RFP A contains the NT elements of */ -/* upper packed A. If UPLO = 'L' the RFP A contains the elements */ -/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */ -/* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N */ -/* is odd. See the Note below for more details. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization RFP A = U**T*U or RFP A = L*L**T. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - *info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - if (! normaltransr && ! lsame_(transr, "T")) { - *info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPFTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* If N is odd, set NISODD = .TRUE. */ -/* If N is even, set K = N/2 and NISODD = .FALSE. */ - - if (*n % 2 == 0) { - k = *n / 2; - nisodd = false; - } else { - nisodd = true; - } - -/* Set N1 and N2 depending on LOWER */ - - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - -/* start execution: there are eight cases */ - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ -/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ -/* T1 -> a(0), T2 -> a(n), S -> a(n1) */ - - dpotrf_("L", &n1, a, n, info); - if (*info > 0) { - return 0; - } - dtrsm_("R", "L", "T", "N", &n2, &n1, &c_b12, a, n, &a[n1], n); - dsyrk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b12, &a[*n], - n); - dpotrf_("U", &n2, &a[*n], n, info); - if (*info > 0) { - *info += n1; - } - - } else { - -/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ -/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ -/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ - - dpotrf_("L", &n1, &a[n2], n, info); - if (*info > 0) { - return 0; - } - dtrsm_("L", "L", "N", "N", &n1, &n2, &c_b12, &a[n2], n, a, n); - dsyrk_("U", "T", &n2, &n1, &c_b15, a, n, &c_b12, &a[n1], n); - dpotrf_("U", &n2, &a[n1], n, info); - if (*info > 0) { - *info += n1; - } - - } - - } else { - -/* N is odd and TRANSR = 'T' */ - - if (lower) { - -/* SRPA for LOWER, TRANSPOSE and N is odd */ -/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */ -/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */ - - dpotrf_("U", &n1, a, &n1, info); - if (*info > 0) { - return 0; - } - dtrsm_("L", "U", "T", "N", &n1, &n2, &c_b12, a, &n1, &a[n1 * - n1], &n1); - dsyrk_("L", "T", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b12, & - a[1], &n1); - dpotrf_("L", &n2, &a[1], &n1, info); - if (*info > 0) { - *info += n1; - } - - } else { - -/* SRPA for UPPER, TRANSPOSE and N is odd */ -/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */ -/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */ - - dpotrf_("U", &n1, &a[n2 * n2], &n2, info); - if (*info > 0) { - return 0; - } - dtrsm_("R", "U", "N", "N", &n2, &n1, &c_b12, &a[n2 * n2], &n2, - a, &n2); - dsyrk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b12, &a[n1 * n2] -, &n2); - dpotrf_("L", &n2, &a[n1 * n2], &n2, info); - if (*info > 0) { - *info += n1; - } - - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ -/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ -/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ - - i__1 = *n + 1; - dpotrf_("L", &k, &a[1], &i__1, info); - if (*info > 0) { - return 0; - } - i__1 = *n + 1; - i__2 = *n + 1; - dtrsm_("R", "L", "T", "N", &k, &k, &c_b12, &a[1], &i__1, &a[k - + 1], &i__2); - i__1 = *n + 1; - i__2 = *n + 1; - dsyrk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b12, a, - &i__2); - i__1 = *n + 1; - dpotrf_("U", &k, a, &i__1, info); - if (*info > 0) { - *info += k; - } - - } else { - -/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ -/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ -/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ - - i__1 = *n + 1; - dpotrf_("L", &k, &a[k + 1], &i__1, info); - if (*info > 0) { - return 0; - } - i__1 = *n + 1; - i__2 = *n + 1; - dtrsm_("L", "L", "N", "N", &k, &k, &c_b12, &a[k + 1], &i__1, - a, &i__2); - i__1 = *n + 1; - i__2 = *n + 1; - dsyrk_("U", "T", &k, &k, &c_b15, a, &i__1, &c_b12, &a[k], & - i__2); - i__1 = *n + 1; - dpotrf_("U", &k, &a[k], &i__1, info); - if (*info > 0) { - *info += k; - } - - } - - } else { - -/* N is even and TRANSR = 'T' */ - - if (lower) { - -/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ -/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ -/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ - - dpotrf_("U", &k, &a[k], &k, info); - if (*info > 0) { - return 0; - } - dtrsm_("L", "U", "T", "N", &k, &k, &c_b12, &a[k], &n1, &a[k * - (k + 1)], &k); - dsyrk_("L", "T", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b12, - a, &k); - dpotrf_("L", &k, a, &k, info); - if (*info > 0) { - *info += k; - } - - } else { - -/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ -/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ -/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ - - dpotrf_("U", &k, &a[k * (k + 1)], &k, info); - if (*info > 0) { - return 0; - } - dtrsm_("R", "U", "N", "N", &k, &k, &c_b12, &a[k * (k + 1)], & - k, a, &k); - dsyrk_("L", "N", &k, &k, &c_b15, a, &k, &c_b12, &a[k * k], &k); - dpotrf_("L", &k, &a[k * k], &k, info); - if (*info > 0) { - *info += k; - } - - } - - } - - } - - return 0; - -/* End of DPFTRF */ - -} /* dpftrf_ */ diff --git a/external/clapack/lapack/dpftri.cpp b/external/clapack/lapack/dpftri.cpp deleted file mode 100644 index e4af9929..00000000 --- a/external/clapack/lapack/dpftri.cpp +++ /dev/null @@ -1,378 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b11 = 1.; - -int dpftri_(const char *transr, const char *uplo, integer *n, double *a, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer k, n1, n2; - bool normaltransr, lower, nisodd; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPFTRI computes the inverse of a (real) symmetric positive definite */ -/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ -/* computed by DPFTRF. */ - -/* Arguments */ -/* ========= */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': The Normal TRANSR of RFP A is stored; */ -/* = 'T': The Transpose TRANSR of RFP A is stored. */ - -/* UPLO (input) CHARACTER */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ) */ -/* On entry, the symmetric matrix A in RFP format. RFP format is */ -/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ -/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ -/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */ -/* the transpose of RFP A as defined when */ -/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ -/* follows: If UPLO = 'U' the RFP A contains the nt elements of */ -/* upper packed A. If UPLO = 'L' the RFP A contains the elements */ -/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */ -/* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N */ -/* is odd. See the Note below for more details. */ - -/* On exit, the symmetric inverse of the original matrix, in the */ -/* same storage format. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the (i,i) element of the factor U or L is */ -/* zero, and the inverse could not be computed. */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - *info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - if (! normaltransr && ! lsame_(transr, "T")) { - *info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPFTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Invert the triangular Cholesky factor U or L. */ - - dtftri_(transr, uplo, "N", n, a, info); - if (*info > 0) { - return 0; - } - -/* If N is odd, set NISODD = .TRUE. */ -/* If N is even, set K = N/2 and NISODD = .FALSE. */ - - if (*n % 2 == 0) { - k = *n / 2; - nisodd = false; - } else { - nisodd = true; - } - -/* Set N1 and N2 depending on LOWER */ - - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - -/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */ -/* inv(L)^C*inv(L). There are eight cases. */ - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */ -/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */ -/* T1 -> a(0), T2 -> a(n), S -> a(N1) */ - - dlauum_("L", &n1, a, n, info); - dsyrk_("L", "T", &n1, &n2, &c_b11, &a[n1], n, &c_b11, a, n); - dtrmm_("L", "U", "N", "N", &n2, &n1, &c_b11, &a[*n], n, &a[n1] -, n); - dlauum_("U", &n2, &a[*n], n, info); - - } else { - -/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */ -/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */ -/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */ - - dlauum_("L", &n1, &a[n2], n, info); - dsyrk_("L", "N", &n1, &n2, &c_b11, a, n, &c_b11, &a[n2], n); - dtrmm_("R", "U", "T", "N", &n1, &n2, &c_b11, &a[n1], n, a, n); - dlauum_("U", &n2, &a[n1], n, info); - - } - - } else { - -/* N is odd and TRANSR = 'T' */ - - if (lower) { - -/* SRPA for LOWER, TRANSPOSE, and N is odd */ -/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */ - - dlauum_("U", &n1, a, &n1, info); - dsyrk_("U", "N", &n1, &n2, &c_b11, &a[n1 * n1], &n1, &c_b11, - a, &n1); - dtrmm_("R", "L", "N", "N", &n1, &n2, &c_b11, &a[1], &n1, &a[ - n1 * n1], &n1); - dlauum_("L", &n2, &a[1], &n1, info); - - } else { - -/* SRPA for UPPER, TRANSPOSE, and N is odd */ -/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */ - - dlauum_("U", &n1, &a[n2 * n2], &n2, info); - dsyrk_("U", "T", &n1, &n2, &c_b11, a, &n2, &c_b11, &a[n2 * n2] -, &n2); - dtrmm_("L", "L", "T", "N", &n2, &n1, &c_b11, &a[n1 * n2], &n2, - a, &n2); - dlauum_("L", &n2, &a[n1 * n2], &n2, info); - - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ -/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ -/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ - - i__1 = *n + 1; - dlauum_("L", &k, &a[1], &i__1, info); - i__1 = *n + 1; - i__2 = *n + 1; - dsyrk_("L", "T", &k, &k, &c_b11, &a[k + 1], &i__1, &c_b11, &a[ - 1], &i__2); - i__1 = *n + 1; - i__2 = *n + 1; - dtrmm_("L", "U", "N", "N", &k, &k, &c_b11, a, &i__1, &a[k + 1] -, &i__2); - i__1 = *n + 1; - dlauum_("U", &k, a, &i__1, info); - - } else { - -/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ -/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ -/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ - - i__1 = *n + 1; - dlauum_("L", &k, &a[k + 1], &i__1, info); - i__1 = *n + 1; - i__2 = *n + 1; - dsyrk_("L", "N", &k, &k, &c_b11, a, &i__1, &c_b11, &a[k + 1], - &i__2); - i__1 = *n + 1; - i__2 = *n + 1; - dtrmm_("R", "U", "T", "N", &k, &k, &c_b11, &a[k], &i__1, a, & - i__2); - i__1 = *n + 1; - dlauum_("U", &k, &a[k], &i__1, info); - - } - - } else { - -/* N is even and TRANSR = 'T' */ - - if (lower) { - -/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */ -/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */ -/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ - - dlauum_("U", &k, &a[k], &k, info); - dsyrk_("U", "N", &k, &k, &c_b11, &a[k * (k + 1)], &k, &c_b11, - &a[k], &k); - dtrmm_("R", "L", "N", "N", &k, &k, &c_b11, a, &k, &a[k * (k + - 1)], &k); - dlauum_("L", &k, a, &k, info); - - } else { - -/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */ -/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */ -/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ - - dlauum_("U", &k, &a[k * (k + 1)], &k, info); - dsyrk_("U", "T", &k, &k, &c_b11, a, &k, &c_b11, &a[k * (k + 1) - ], &k); - dtrmm_("L", "L", "T", "N", &k, &k, &c_b11, &a[k * k], &k, a, & - k); - dlauum_("L", &k, &a[k * k], &k, info); - - } - - } - - } - - return 0; - -/* End of DPFTRI */ - -} /* dpftri_ */ diff --git a/external/clapack/lapack/dpftrs.cpp b/external/clapack/lapack/dpftrs.cpp deleted file mode 100644 index 101d23a9..00000000 --- a/external/clapack/lapack/dpftrs.cpp +++ /dev/null @@ -1,222 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - - -/* Table of constant values */ - -static double c_b10 = 1.; - -int dpftrs_(char *transr, char *uplo, integer *n, integer *nrhs, double *a, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1; - - /* Local variables */ - bool normaltransr, lower; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPFTRS solves a system of linear equations A*X = B with a symmetric */ -/* positive definite matrix A using the Cholesky factorization */ -/* A = U**T*U or A = L*L**T computed by DPFTRF. */ - -/* Arguments */ -/* ========= */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': The Normal TRANSR of RFP A is stored; */ -/* = 'T': The Transpose TRANSR of RFP A is stored. */ - -/* UPLO (input) CHARACTER */ -/* = 'U': Upper triangle of RFP A is stored; */ -/* = 'L': Lower triangle of RFP A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ). */ -/* The triangular factor U or L from the Cholesky factorization */ -/* of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF. */ -/* See note below for more details about RFP A. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - if (! normaltransr && ! lsame_(transr, "T")) { - *info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPFTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - -/* start execution: there are two triangular solves */ - - if (lower) { - dtfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b10, a, &b[b_offset], - ldb); - dtfsm_(transr, "L", uplo, "T", "N", n, nrhs, &c_b10, a, &b[b_offset], - ldb); - } else { - dtfsm_(transr, "L", uplo, "T", "N", n, nrhs, &c_b10, a, &b[b_offset], - ldb); - dtfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b10, a, &b[b_offset], - ldb); - } - - return 0; - -/* End of DPFTRS */ - -} /* dpftrs_ */ diff --git a/external/clapack/lapack/dpocon.cpp b/external/clapack/lapack/dpocon.cpp deleted file mode 100644 index 9e0c9062..00000000 --- a/external/clapack/lapack/dpocon.cpp +++ /dev/null @@ -1,197 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dpocon_(const char *uplo, integer *n, double *a, integer * - lda, double *anorm, double *rcond, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - double d__1; - - /* Local variables */ - integer ix, kase; - double scale; - integer isave[3]; - bool upper; - double scalel; - double scaleu; - double ainvnm; - char normin[1]; - double smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOCON estimates the reciprocal of the condition number (in the */ -/* 1-norm) of a real symmetric positive definite matrix using the */ -/* Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* ANORM (input) DOUBLE PRECISION */ -/* The 1-norm (or infinity-norm) of the symmetric matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ -/* estimate of the 1-norm of inv(A) computed in this routine. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else if (*anorm < 0.) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - - smlnum = dlamch_("Safe minimum"); - -/* Estimate the 1-norm of inv(A). */ - - kase = 0; - *(unsigned char *)normin = 'N'; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (upper) { - -/* Multiply by inv(U'). */ - - dlatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset], - lda, &work[1], &scalel, &work[(*n << 1) + 1], info); - *(unsigned char *)normin = 'Y'; - -/* Multiply by inv(U). */ - - dlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ - a_offset], lda, &work[1], &scaleu, &work[(*n << 1) + 1], - info); - } else { - -/* Multiply by inv(L). */ - - dlatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[ - a_offset], lda, &work[1], &scalel, &work[(*n << 1) + 1], - info); - *(unsigned char *)normin = 'Y'; - -/* Multiply by inv(L'). */ - - dlatrs_("Lower", "Transpose", "Non-unit", normin, n, &a[a_offset], - lda, &work[1], &scaleu, &work[(*n << 1) + 1], info); - } - -/* Multiply by 1/SCALE if doing so will not cause overflow. */ - - scale = scalel * scaleu; - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) - { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - -L20: - return 0; - -/* End of DPOCON */ - -} /* dpocon_ */ diff --git a/external/clapack/lapack/dpoequ.cpp b/external/clapack/lapack/dpoequ.cpp deleted file mode 100644 index a121d805..00000000 --- a/external/clapack/lapack/dpoequ.cpp +++ /dev/null @@ -1,159 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dpoequ_(integer *n, double *a, integer *lda, - double *s, double *scond, double *amax, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer i__; - double smin; - - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOEQU computes row and column scalings intended to equilibrate a */ -/* symmetric positive definite matrix A and reduce its condition number */ -/* (with respect to the two-norm). S contains the scale factors, */ -/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ -/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ -/* choice of S puts the condition number of B within a factor N of the */ -/* smallest possible condition number over all possible diagonal */ -/* scalings. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The N-by-N symmetric positive definite matrix whose scaling */ -/* factors are to be computed. Only the diagonal elements of A */ -/* are referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* S (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, S contains the scale factors for A. */ - -/* SCOND (output) DOUBLE PRECISION */ -/* If INFO = 0, S contains the ratio of the smallest S(i) to */ -/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ -/* large nor too small, it is not worth scaling by S. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --s; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*lda < std::max(1_integer,*n)) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOEQU", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *scond = 1.; - *amax = 0.; - return 0; - } - -/* Find the minimum and maximum diagonal elements. */ - - s[1] = a[a_dim1 + 1]; - smin = s[1]; - *amax = s[1]; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - s[i__] = a[i__ + i__ * a_dim1]; -/* Computing MIN */ - d__1 = smin, d__2 = s[i__]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = *amax, d__2 = s[i__]; - *amax = std::max(d__1,d__2); -/* L10: */ - } - - if (smin <= 0.) { - -/* Find the first non-positive diagonal element and return. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] <= 0.) { - *info = i__; - return 0; - } -/* L20: */ - } - } else { - -/* Set the scale factors to the reciprocals */ -/* of the diagonal elements. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - s[i__] = 1. / sqrt(s[i__]); -/* L30: */ - } - -/* Compute SCOND = min(S(I)) / max(S(I)) */ - - *scond = sqrt(smin) / sqrt(*amax); - } - return 0; - -/* End of DPOEQU */ - -} /* dpoequ_ */ diff --git a/external/clapack/lapack/dpoequb.cpp b/external/clapack/lapack/dpoequb.cpp deleted file mode 100644 index d92a8805..00000000 --- a/external/clapack/lapack/dpoequb.cpp +++ /dev/null @@ -1,169 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dpoequb_(integer *n, double *a, integer *lda, double *s, double *scond, double *amax, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__; - double tmp, base, smin; - -/* -- LAPACK routine (version 3.2) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOEQU computes row and column scalings intended to equilibrate a */ -/* symmetric positive definite matrix A and reduce its condition number */ -/* (with respect to the two-norm). S contains the scale factors, */ -/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ -/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ -/* choice of S puts the condition number of B within a factor N of the */ -/* smallest possible condition number over all possible diagonal */ -/* scalings. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The N-by-N symmetric positive definite matrix whose scaling */ -/* factors are to be computed. Only the diagonal elements of A */ -/* are referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* S (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, S contains the scale factors for A. */ - -/* SCOND (output) DOUBLE PRECISION */ -/* If INFO = 0, S contains the ratio of the smallest S(i) to */ -/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ -/* large nor too small, it is not worth scaling by S. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - -/* Positive definite only performs 1 pass of equilibration. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --s; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*lda < std::max(1_integer,*n)) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOEQUB", &i__1); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - *scond = 1.; - *amax = 0.; - return 0; - } - base = dlamch_("B"); - tmp = -.5 / log(base); - -/* Find the minimum and maximum diagonal elements. */ - - s[1] = a[a_dim1 + 1]; - smin = s[1]; - *amax = s[1]; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - s[i__] = a[i__ + i__ * a_dim1]; -/* Computing MIN */ - d__1 = smin, d__2 = s[i__]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = *amax, d__2 = s[i__]; - *amax = std::max(d__1,d__2); -/* L10: */ - } - - if (smin <= 0.) { - -/* Find the first non-positive diagonal element and return. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] <= 0.) { - *info = i__; - return 0; - } -/* L20: */ - } - } else { - -/* Set the scale factors to the reciprocals */ -/* of the diagonal elements. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = (integer) (tmp * log(s[i__])); - s[i__] = pow_di(&base, &i__2); -/* L30: */ - } - -/* Compute SCOND = min(S(I)) / max(S(I)). */ - - *scond = sqrt(smin) / sqrt(*amax); - } - - return 0; - -/* End of DPOEQUB */ - -} /* dpoequb_ */ diff --git a/external/clapack/lapack/dporfs.cpp b/external/clapack/lapack/dporfs.cpp deleted file mode 100644 index 96ba8570..00000000 --- a/external/clapack/lapack/dporfs.cpp +++ /dev/null @@ -1,398 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b12 = -1.; -static double c_b14 = 1.; - -/* Subroutine */ int dporfs_(const char *uplo, integer *n, integer *nrhs, - double *a, integer *lda, double *af, integer *ldaf, - double *b, integer *ldb, double *x, integer *ldx, double * - ferr, double *berr, double *work, integer *iwork, integer * - info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s, xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - integer count; - bool upper; - double safmin; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPORFS improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is symmetric positive definite, */ -/* and provides error bounds and backward error estimates for the */ -/* solution. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of A contains the upper triangular part */ -/* of the matrix A, and the strictly lower triangular part of A */ -/* is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of A contains the lower triangular part of */ -/* the matrix A, and the strictly upper triangular part of A is */ -/* not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DPOTRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -11; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPORFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *n + 1; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - A * X */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, - &c_b14, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L30: */ - } - -/* Compute abs(A)*abs(X) + abs(B). */ - - if (upper) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ - i__ + j * x_dim1], abs(d__2)); -/* L40: */ - } - work[k] = work[k] + (d__1 = a[k + k * a_dim1], abs(d__1)) * - xk + s; -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - work[k] += (d__1 = a[k + k * a_dim1], abs(d__1)) * xk; - i__3 = *n; - for (i__ = k + 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ - i__ + j * x_dim1], abs(d__2)); -/* L60: */ - } - work[k] += s; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1], n, - info); - daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(A))* */ -/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(A) is the inverse of A */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(A) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(A'). */ - - dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1], - n, info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L110: */ - } - } else if (kase == 2) { - -/* Multiply by inv(A)*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L120: */ - } - dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1], - n, info); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DPORFS */ - -} /* dporfs_ */ diff --git a/external/clapack/lapack/dporfsx.cpp b/external/clapack/lapack/dporfsx.cpp deleted file mode 100644 index 8de84aae..00000000 --- a/external/clapack/lapack/dporfsx.cpp +++ /dev/null @@ -1,587 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c_n1 = -1; -static integer c__0 = 0; -static integer c__1 = 1; - -int dporfsx_(const char *uplo, const char *equed, integer *n, integer *nrhs, double *a, integer *lda, - double *af, integer *ldaf, double *s, double *b, integer *ldb, double *x, integer * - ldx, double *rcond, double *berr, integer *n_err_bnds__, double *err_bnds_norm__, double *err_bnds_comp__, - integer *nparams, double *params, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, - err_bnds_comp_dim1, err_bnds_comp_offset, i__1; - double d__1, d__2; - - /* Builtin functions */ - double sqrt(double); - - /* Local variables */ - double illrcond_thresh__, unstable_thresh__, err_lbnd__; - integer ref_type__, j; - double rcond_tmp__; - integer prec_type__; - double cwise_wrong__; - char norm[1]; - bool ignore_cwise__; - double anorm; - bool rcequ; - integer ithresh, n_norms__; - double rthresh; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPORFSX improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is symmetric positive */ -/* definite, and provides error bounds and backward error estimates */ -/* for the solution. In addition to normwise error bound, the code */ -/* provides maximum componentwise error bound if possible. See */ -/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */ -/* error bounds. */ - -/* The original system of linear equations may have been equilibrated */ -/* before calling this routine, as described by arguments EQUED and S */ -/* below. In this case, the solution and error bounds returned are */ -/* for the original unequilibrated system. */ - -/* Arguments */ -/* ========= */ - -/* Some optional parameters are bundled in the PARAMS array. These */ -/* settings determine how refinement is performed, but often the */ -/* defaults are acceptable. If the defaults are acceptable, users */ -/* can pass NPARAMS = 0 which prevents the source code from accessing */ -/* the PARAMS argument. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* EQUED (input) CHARACTER*1 */ -/* Specifies the form of equilibration that was done to A */ -/* before calling this routine. This is needed to compute */ -/* the solution and error bounds correctly. */ -/* = 'N': No equilibration */ -/* = 'Y': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(S) * A * diag(S). */ -/* The right hand side B has been changed accordingly. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of A contains the upper triangular part */ -/* of the matrix A, and the strictly lower triangular part of A */ -/* is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of A contains the lower triangular part of */ -/* the matrix A, and the strictly upper triangular part of A is */ -/* not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* S (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */ -/* the left and right by diag(S). S is an input argument if FACT = */ -/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ -/* = 'Y', each element of S must be positive. If S is output, each */ -/* element of S is a power of the radix. If S is input, each element */ -/* of S should be a power of the radix to ensure a reliable solution */ -/* and error estimates. Scaling by powers of the radix does not cause */ -/* rounding errors unless the result underflows or overflows. */ -/* Rounding errors during scaling lead to refining with a matrix that */ -/* is not equivalent to the input matrix, producing error estimates */ -/* that may not be reliable. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DGETRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* Reciprocal scaled condition number. This is an estimate of the */ -/* reciprocal Skeel condition number of the matrix A after */ -/* equilibration (if done). If this is less than the machine */ -/* precision (in particular, if it is zero), the matrix is singular */ -/* to working precision. Note that the error may still be small even */ -/* if this number is very small and the matrix appears ill- */ -/* conditioned. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* Componentwise relative backward error. This is the */ -/* componentwise relative backward error of each solution vector X(j) */ -/* (i.e., the smallest relative change in any element of A or B that */ -/* makes X(j) an exact solution). */ - -/* N_ERR_BNDS (input) INTEGER */ -/* Number of error bounds to return for each right hand side */ -/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */ -/* ERR_BNDS_COMP below. */ - -/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ -/* For each right-hand side, this array contains information about */ -/* various error bounds and condition numbers corresponding to the */ -/* normwise relative error, which is defined as follows: */ - -/* Normwise relative error in the ith solution vector: */ -/* max_j (abs(XTRUE(j,i) - X(j,i))) */ -/* ------------------------------ */ -/* max_j abs(X(j,i)) */ - -/* The array is indexed by the type of error information as described */ -/* below. There currently are up to three pieces of information */ -/* returned. */ - -/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ -/* right-hand side. */ - -/* The second index in ERR_BNDS_NORM(:,err) contains the following */ -/* three fields: */ -/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ -/* reciprocal condition number is less than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). */ - -/* err = 2 "Guaranteed" error bound: The estimated forward error, */ -/* almost certainly within a factor of 10 of the true error */ -/* so long as the next entry is greater than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ -/* be trusted if the previous boolean is true. */ - -/* err = 3 Reciprocal condition number: Estimated normwise */ -/* reciprocal condition number. Compared with the threshold */ -/* sqrt(n) * dlamch('Epsilon') to determine if the error */ -/* estimate is "guaranteed". These reciprocal condition */ -/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ -/* appropriately scaled matrix Z. */ -/* Let Z = S*A, where S scales each row by a power of the */ -/* radix so all absolute row sums of Z are approximately 1. */ - -/* See Lapack Working Note 165 for further details and extra */ -/* cautions. */ - -/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ -/* For each right-hand side, this array contains information about */ -/* various error bounds and condition numbers corresponding to the */ -/* componentwise relative error, which is defined as follows: */ - -/* Componentwise relative error in the ith solution vector: */ -/* abs(XTRUE(j,i) - X(j,i)) */ -/* max_j ---------------------- */ -/* abs(X(j,i)) */ - -/* The array is indexed by the right-hand side i (on which the */ -/* componentwise relative error depends), and the type of error */ -/* information as described below. There currently are up to three */ -/* pieces of information returned for each right-hand side. If */ -/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ -/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ -/* the first (:,N_ERR_BNDS) entries are returned. */ - -/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ -/* right-hand side. */ - -/* The second index in ERR_BNDS_COMP(:,err) contains the following */ -/* three fields: */ -/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ -/* reciprocal condition number is less than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). */ - -/* err = 2 "Guaranteed" error bound: The estimated forward error, */ -/* almost certainly within a factor of 10 of the true error */ -/* so long as the next entry is greater than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ -/* be trusted if the previous boolean is true. */ - -/* err = 3 Reciprocal condition number: Estimated componentwise */ -/* reciprocal condition number. Compared with the threshold */ -/* sqrt(n) * dlamch('Epsilon') to determine if the error */ -/* estimate is "guaranteed". These reciprocal condition */ -/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ -/* appropriately scaled matrix Z. */ -/* Let Z = S*(A*diag(x)), where x is the solution for the */ -/* current right-hand side and S scales each row of */ -/* A*diag(x) by a power of the radix so all absolute row */ -/* sums of Z are approximately 1. */ - -/* See Lapack Working Note 165 for further details and extra */ -/* cautions. */ - -/* NPARAMS (input) INTEGER */ -/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */ -/* PARAMS array is never referenced and default values are used. */ - -/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */ -/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */ -/* that entry will be filled with default value used for that */ -/* parameter. Only positions up to NPARAMS are accessed; defaults */ -/* are used for higher-numbered parameters. */ - -/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ -/* refinement or not. */ -/* Default: 1.0D+0 */ -/* = 0.0 : No refinement is performed, and no error bounds are */ -/* computed. */ -/* = 1.0 : Use the double-precision refinement algorithm, */ -/* possibly with doubled-single computations if the */ -/* compilation environment does not support DOUBLE */ -/* PRECISION. */ -/* (other values are reserved for future use) */ - -/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ -/* computations allowed for refinement. */ -/* Default: 10 */ -/* Aggressive: Set to 100 to permit convergence using approximate */ -/* factorizations or factorizations other than LU. If */ -/* the factorization uses a technique other than */ -/* Gaussian elimination, the guarantees in */ -/* err_bnds_norm and err_bnds_comp may no longer be */ -/* trustworthy. */ - -/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ -/* will attempt to find a solution with small componentwise */ -/* relative error in the double-precision algorithm. Positive */ -/* is true, 0.0 is false. */ -/* Default: 1.0 (attempt componentwise convergence) */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: Successful exit. The solution to every right-hand side is */ -/* guaranteed. */ -/* < 0: If INFO = -i, the i-th argument had an illegal value */ -/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly singular, so */ -/* the solution and error bounds could not be computed. RCOND = 0 */ -/* is returned. */ -/* = N+J: The solution corresponding to the Jth right-hand side is */ -/* not guaranteed. The solutions corresponding to other right- */ -/* hand sides K with K > J may not be guaranteed as well, but */ -/* only the first such right-hand side is reported. If a small */ -/* componentwise error is not requested (PARAMS(3) = 0.0) then */ -/* the Jth right-hand side is the first with a normwise error */ -/* bound that is not guaranteed (the smallest J such */ -/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ -/* the Jth right-hand side is the first with either a normwise or */ -/* componentwise error bound that is not guaranteed (the smallest */ -/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ -/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ -/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ -/* about all of the right-hand sides check ERR_BNDS_NORM or */ -/* ERR_BNDS_COMP. */ - -/* ================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Check the input parameters. */ - - /* Parameter adjustments */ - err_bnds_comp_dim1 = *nrhs; - err_bnds_comp_offset = 1 + err_bnds_comp_dim1; - err_bnds_comp__ -= err_bnds_comp_offset; - err_bnds_norm_dim1 = *nrhs; - err_bnds_norm_offset = 1 + err_bnds_norm_dim1; - err_bnds_norm__ -= err_bnds_norm_offset; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --s; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --berr; - --params; - --work; - --iwork; - - /* Function Body */ - *info = 0; - ref_type__ = 1; - if (*nparams >= 1) { - if (params[1] < 0.) { - params[1] = 1.; - } else { - ref_type__ = (integer) params[1]; - } - } - -/* Set default parameters. */ - - illrcond_thresh__ = (double) (*n) * dlamch_("Epsilon"); - ithresh = 10; - rthresh = .5; - unstable_thresh__ = .25; - ignore_cwise__ = FALSE_; - - if (*nparams >= 2) { - if (params[2] < 0.) { - params[2] = (double) ithresh; - } else { - ithresh = (integer) params[2]; - } - } - if (*nparams >= 3) { - if (params[3] < 0.) { - if (ignore_cwise__) { - params[3] = 0.; - } else { - params[3] = 1.; - } - } else { - ignore_cwise__ = params[3] == 0.; - } - } - if (ref_type__ == 0 || *n_err_bnds__ == 0) { - n_norms__ = 0; - } else if (ignore_cwise__) { - n_norms__ = 1; - } else { - n_norms__ = 2; - } - - rcequ = lsame_(equed, "Y"); - -/* Test input parameters. */ - - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! rcequ && ! lsame_(equed, "N")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < max(1,*n)) { - *info = -6; - } else if (*ldaf < max(1,*n)) { - *info = -8; - } else if (*ldb < max(1,*n)) { - *info = -11; - } else if (*ldx < max(1,*n)) { - *info = -13; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPORFSX", &i__1); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *nrhs == 0) { - *rcond = 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - berr[j] = 0.; - if (*n_err_bnds__ >= 1) { - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } else if (*n_err_bnds__ >= 2) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.; - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.; - } else if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.; - } - } - return 0; - } - -/* Default to failure. */ - - *rcond = 0.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - berr[j] = 1.; - if (*n_err_bnds__ >= 1) { - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } else if (*n_err_bnds__ >= 2) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - } else if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.; - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.; - } - } - -/* Compute the norm of A and the reciprocal of the condition */ -/* number of A. */ - - *(unsigned char *)norm = 'I'; - anorm = dlansy_(norm, uplo, n, &a[a_offset], lda, &work[1]); - dpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1], - info); - -/* Perform refinement on each right-hand side */ - - if (ref_type__ != 0) { - prec_type__ = ilaprec_("E"); - dla_porfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda, - &af[af_offset], ldaf, &rcequ, &s[1], &b[b_offset], ldb, &x[ - x_offset], ldx, &berr[1], &n_norms__, &err_bnds_norm__[ - err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset], - &work[*n + 1], &work[1], &work[(*n << 1) + 1], &work[1], - rcond, &ithresh, &rthresh, &unstable_thresh__, & - ignore_cwise__, info, 1_integer); - } -/* Computing MAX */ - d__1 = 10., d__2 = sqrt((double) (*n)); - err_lbnd__ = std::max(d__1,d__2) * dlamch_("Epsilon"); - if (*n_err_bnds__ >= 1 && n_norms__ >= 1) { - -/* Compute scaled normwise condition number cond(A*C). */ - - if (rcequ) { - rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[ - af_offset], ldaf, &c_n1, &s[1], info, &work[1], &iwork[1], 1_integer); - } else { - rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[ - af_offset], ldaf, &c__0, &s[1], info, &work[1], &iwork[1], 1_integer); - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Cap the error at 1.0. */ - - if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 - << 1)] > 1.) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - } - -/* Threshold the error (see LAWN). */ - - if (rcond_tmp__ < illrcond_thresh__) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - err_bnds_norm__[j + err_bnds_norm_dim1] = 0.; - if (*info <= *n) { - *info = *n + j; - } - } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < - err_lbnd__) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__; - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - } - -/* Save the condition number. */ - - if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__; - } - } - } - if (*n_err_bnds__ >= 1 && n_norms__ >= 2) { - -/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */ -/* each right-hand side using the current solution as an estimate of */ -/* the true solution. If the componentwise error estimate is too */ -/* large, then the solution is a lousy estimate of truth and the */ -/* estimated RCOND may be too optimistic. To avoid misleading users, */ -/* the inverse condition number is set to 0.0 when the estimated */ -/* cwise error is at least CWISE_WRONG. */ - - cwise_wrong__ = sqrt(dlamch_("Epsilon")); - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < - cwise_wrong__) { - rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[ - af_offset], ldaf, &c__1, &x[j * x_dim1 + 1], info, & - work[1], &iwork[1], 1_integer); - } else { - rcond_tmp__ = 0.; - } - -/* Cap the error at 1.0. */ - - if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 - << 1)] > 1.) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - } - -/* Threshold the error (see LAWN). */ - - if (rcond_tmp__ < illrcond_thresh__) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 0.; - if (params[3] == 1. && *info < *n + j) { - *info = *n + j; - } - } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < - err_lbnd__) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } - -/* Save the condition number. */ - - if (*n_err_bnds__ >= 3) { - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__; - } - } - } - - return 0; - -/* End of DPORFSX */ - -} /* dporfsx_ */ diff --git a/external/clapack/lapack/dposv.cpp b/external/clapack/lapack/dposv.cpp deleted file mode 100644 index dbe50ac0..00000000 --- a/external/clapack/lapack/dposv.cpp +++ /dev/null @@ -1,131 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dposv_(const char *uplo, integer *n, integer *nrhs, double - *a, integer *lda, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOSV computes the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric positive definite matrix and X and B */ -/* are N-by-NRHS matrices. */ - -/* The Cholesky decomposition is used to factor A as */ -/* A = U**T* U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is a lower triangular */ -/* matrix. The factored form of A is then used to solve the system of */ -/* equations A * X = B. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i of A is not */ -/* positive definite, so the factorization could not be */ -/* completed, and the solution has not been computed. */ - -/* ===================================================================== */ - -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOSV ", &i__1); - return 0; - } - -/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ - - dpotrf_(uplo, n, &a[a_offset], lda, info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info); - - } - return 0; - -/* End of DPOSV */ - -} /* dposv_ */ diff --git a/external/clapack/lapack/dposvx.cpp b/external/clapack/lapack/dposvx.cpp deleted file mode 100644 index 3074536d..00000000 --- a/external/clapack/lapack/dposvx.cpp +++ /dev/null @@ -1,418 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dposvx_(const char *fact, const char *uplo, integer *n, integer * - nrhs, double *a, integer *lda, double *af, integer *ldaf, - char *equed, double *s, double *b, integer *ldb, double * - x, integer *ldx, double *rcond, double *ferr, double * - berr, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double amax, smin, smax; - double scond, anorm; - bool equil, rcequ; - bool nofact; - double bignum; - integer infequ; - double smlnum; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */ -/* compute the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric positive definite matrix and X and B */ -/* are N-by-NRHS matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ -/* the system: */ -/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ -/* Whether or not the system will be equilibrated depends on the */ -/* scaling of the matrix A, but if equilibration is used, A is */ -/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ - -/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ -/* factor the matrix A (after equilibration if FACT = 'E') as */ -/* A = U**T* U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is a lower triangular */ -/* matrix. */ - -/* 3. If the leading i-by-i principal minor is not positive definite, */ -/* then the routine returns with INFO = i. Otherwise, the factored */ -/* form of A is used to estimate the condition number of the matrix */ -/* A. If the reciprocal of the condition number is less than machine */ -/* precision, INFO = N+1 is returned as a warning, but the routine */ -/* still goes on to solve for X and compute error bounds as */ -/* described below. */ - -/* 4. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 5. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* 6. If equilibration was used, the matrix X is premultiplied by */ -/* diag(S) so that it solves the original system before */ -/* equilibration. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of the matrix A is */ -/* supplied on entry, and if not, whether the matrix A should be */ -/* equilibrated before it is factored. */ -/* = 'F': On entry, AF contains the factored form of A. */ -/* If EQUED = 'Y', the matrix A has been equilibrated */ -/* with scaling factors given by S. A and AF will not */ -/* be modified. */ -/* = 'N': The matrix A will be copied to AF and factored. */ -/* = 'E': The matrix A will be equilibrated if necessary, then */ -/* copied to AF and factored. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A, except if FACT = 'F' and */ -/* EQUED = 'Y', then A must contain the equilibrated matrix */ -/* diag(S)*A*diag(S). If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. A is not modified if */ -/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ - -/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ -/* diag(S)*A*diag(S). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* If FACT = 'F', then AF is an input argument and on entry */ -/* contains the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T, in the same storage */ -/* format as A. If EQUED .ne. 'N', then AF is the factored form */ -/* of the equilibrated matrix diag(S)*A*diag(S). */ - -/* If FACT = 'N', then AF is an output argument and on exit */ -/* returns the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T of the original */ -/* matrix A. */ - -/* If FACT = 'E', then AF is an output argument and on exit */ -/* returns the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T of the equilibrated */ -/* matrix A (see the description of A for the form of the */ -/* equilibrated matrix). */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* EQUED (input or output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration (always true if FACT = 'N'). */ -/* = 'Y': Equilibration was done, i.e., A has been replaced by */ -/* diag(S) * A * diag(S). */ -/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ -/* output argument. */ - -/* S (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The scale factors for A; not accessed if EQUED = 'N'. S is */ -/* an input argument if FACT = 'F'; otherwise, S is an output */ -/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */ -/* must be positive. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ -/* B is overwritten by diag(S) * B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ -/* the original system of equations. Note that if EQUED = 'Y', */ -/* A and B are modified on exit, and the solution to the */ -/* equilibrated system is inv(diag(S))*X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The estimate of the reciprocal condition number of the matrix */ -/* A after equilibration (if done). If RCOND is less than the */ -/* machine precision (in particular, if RCOND = 0), the matrix */ -/* is singular to working precision. This condition is */ -/* indicated by a return code of INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= N: the leading minor of order i of A is */ -/* not positive definite, so the factorization */ -/* could not be completed, and the solution has not */ -/* been computed. RCOND = 0 is returned. */ -/* = N+1: U is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --s; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - equil = lsame_(fact, "E"); - if (nofact || equil) { - *(unsigned char *)equed = 'N'; - rcequ = false; - } else { - rcequ = lsame_(equed, "Y"); - smlnum = dlamch_("Safe minimum"); - bignum = 1. / smlnum; - } - -/* Test the input parameters. */ - - if (! nofact && ! equil && ! lsame_(fact, "F")) { - *info = -1; - } else if (! lsame_(uplo, "U") && ! lsame_(uplo, - "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -8; - } else if (lsame_(fact, "F") && ! (rcequ || lsame_( - equed, "N"))) { - *info = -9; - } else { - if (rcequ) { - smin = bignum; - smax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = smin, d__2 = s[j]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = smax, d__2 = s[j]; - smax = std::max(d__1,d__2); -/* L10: */ - } - if (smin <= 0.) { - *info = -10; - } else if (*n > 0) { - scond = std::max(smin,smlnum) / std::min(smax,bignum); - } else { - scond = 1.; - } - } - if (*info == 0) { - if (*ldb < std::max(1_integer,*n)) { - *info = -12; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -14; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOSVX", &i__1); - return 0; - } - - if (equil) { - -/* Compute row and column scalings to equilibrate the matrix A. */ - - dpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ); - if (infequ == 0) { - -/* Equilibrate the matrix. */ - - dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); - rcequ = lsame_(equed, "Y"); - } - } - -/* Scale the right hand side. */ - - if (rcequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1]; -/* L20: */ - } -/* L30: */ - } - } - - if (nofact || equil) { - -/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ - - dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); - dpotrf_(uplo, n, &af[af_offset], ldaf, info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A. */ - - anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &work[1]); - -/* Compute the reciprocal of the condition number of A. */ - - dpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1], - info); - -/* Compute the solution matrix X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solution and */ -/* compute error bounds and backward error estimates for it. */ - - dporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &b[ - b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], & - iwork[1], info); - -/* Transform the solution matrix X to a solution of the original */ -/* system. */ - - if (rcequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1]; -/* L40: */ - } -/* L50: */ - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] /= scond; -/* L60: */ - } - } - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - - return 0; - -/* End of DPOSVX */ - -} /* dposvx_ */ diff --git a/external/clapack/lapack/dposvxx.cpp b/external/clapack/lapack/dposvxx.cpp deleted file mode 100644 index f39ba1dd..00000000 --- a/external/clapack/lapack/dposvxx.cpp +++ /dev/null @@ -1,576 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dposvxx_(const char *fact, const char *uplo, integer *n, integer *nrhs, double *a, - integer *lda, double *af, integer *ldaf, char *equed, double *s, double *b, - integer *ldb, double *x, integer *ldx, double *rcond, double *rpvgrw, double *berr, - integer *n_err_bnds__, double *err_bnds_norm__, double *err_bnds_comp__, - integer *nparams, double *params, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, - err_bnds_comp_dim1, err_bnds_comp_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer j; - double amax, smin, smax; - double scond; - bool equil, rcequ, nofact; - double bignum; - integer infequ; - double smlnum; - -/* -- LAPACK driver routine (version 3.2) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */ -/* to compute the solution to a double precision system of linear equations */ -/* A * X = B, where A is an N-by-N symmetric positive definite matrix */ -/* and X and B are N-by-NRHS matrices. */ - -/* If requested, both normwise and maximum componentwise error bounds */ -/* are returned. DPOSVXX will return a solution with a tiny */ -/* guaranteed error (O(eps) where eps is the working machine */ -/* precision) unless the matrix is very ill-conditioned, in which */ -/* case a warning is returned. Relevant condition numbers also are */ -/* calculated and returned. */ - -/* DPOSVXX accepts user-provided factorizations and equilibration */ -/* factors; see the definitions of the FACT and EQUED options. */ -/* Solving with refinement and using a factorization from a previous */ -/* DPOSVXX call will also produce a solution with either O(eps) */ -/* errors or warnings, but we cannot make that claim for general */ -/* user-provided factorizations and equilibration factors if they */ -/* differ from what DPOSVXX would itself produce. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */ -/* the system: */ - -/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */ - -/* Whether or not the system will be equilibrated depends on the */ -/* scaling of the matrix A, but if equilibration is used, A is */ -/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ - -/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ -/* factor the matrix A (after equilibration if FACT = 'E') as */ -/* A = U**T* U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is a lower triangular */ -/* matrix. */ - -/* 3. If the leading i-by-i principal minor is not positive definite, */ -/* then the routine returns with INFO = i. Otherwise, the factored */ -/* form of A is used to estimate the condition number of the matrix */ -/* A (see argument RCOND). If the reciprocal of the condition number */ -/* is less than machine precision, the routine still goes on to solve */ -/* for X and compute error bounds as described below. */ - -/* 4. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ -/* the routine will use iterative refinement to try to get a small */ -/* error and error bounds. Refinement calculates the residual to at */ -/* least twice the working precision. */ - -/* 6. If equilibration was used, the matrix X is premultiplied by */ -/* diag(S) so that it solves the original system before */ -/* equilibration. */ - -/* Arguments */ -/* ========= */ - -/* Some optional parameters are bundled in the PARAMS array. These */ -/* settings determine how refinement is performed, but often the */ -/* defaults are acceptable. If the defaults are acceptable, users */ -/* can pass NPARAMS = 0 which prevents the source code from accessing */ -/* the PARAMS argument. */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of the matrix A is */ -/* supplied on entry, and if not, whether the matrix A should be */ -/* equilibrated before it is factored. */ -/* = 'F': On entry, AF contains the factored form of A. */ -/* If EQUED is not 'N', the matrix A has been */ -/* equilibrated with scaling factors given by S. */ -/* A and AF are not modified. */ -/* = 'N': The matrix A will be copied to AF and factored. */ -/* = 'E': The matrix A will be equilibrated if necessary, then */ -/* copied to AF and factored. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = */ -/* 'Y', then A must contain the equilibrated matrix */ -/* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper */ -/* triangular part of A contains the upper triangular part of the */ -/* matrix A, and the strictly lower triangular part of A is not */ -/* referenced. If UPLO = 'L', the leading N-by-N lower triangular */ -/* part of A contains the lower triangular part of the matrix A, and */ -/* the strictly upper triangular part of A is not referenced. A is */ -/* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = */ -/* 'N' on exit. */ - -/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ -/* diag(S)*A*diag(S). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* If FACT = 'F', then AF is an input argument and on entry */ -/* contains the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T, in the same storage */ -/* format as A. If EQUED .ne. 'N', then AF is the factored */ -/* form of the equilibrated matrix diag(S)*A*diag(S). */ - -/* If FACT = 'N', then AF is an output argument and on exit */ -/* returns the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T of the original */ -/* matrix A. */ - -/* If FACT = 'E', then AF is an output argument and on exit */ -/* returns the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T of the equilibrated */ -/* matrix A (see the description of A for the form of the */ -/* equilibrated matrix). */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* EQUED (input or output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration (always true if FACT = 'N'). */ -/* = 'Y': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(S) * A * diag(S). */ -/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ -/* output argument. */ - -/* S (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */ -/* the left and right by diag(S). S is an input argument if FACT = */ -/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ -/* = 'Y', each element of S must be positive. If S is output, each */ -/* element of S is a power of the radix. If S is input, each element */ -/* of S should be a power of the radix to ensure a reliable solution */ -/* and error estimates. Scaling by powers of the radix does not cause */ -/* rounding errors unless the result underflows or overflows. */ -/* Rounding errors during scaling lead to refining with a matrix that */ -/* is not equivalent to the input matrix, producing error estimates */ -/* that may not be reliable. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, */ -/* if EQUED = 'N', B is not modified; */ -/* if EQUED = 'Y', B is overwritten by diag(S)*B; */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0, the N-by-NRHS solution matrix X to the original */ -/* system of equations. Note that A and B are modified on exit if */ -/* EQUED .ne. 'N', and the solution to the equilibrated system is */ -/* inv(diag(S))*X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* Reciprocal scaled condition number. This is an estimate of the */ -/* reciprocal Skeel condition number of the matrix A after */ -/* equilibration (if done). If this is less than the machine */ -/* precision (in particular, if it is zero), the matrix is singular */ -/* to working precision. Note that the error may still be small even */ -/* if this number is very small and the matrix appears ill- */ -/* conditioned. */ - -/* RPVGRW (output) DOUBLE PRECISION */ -/* Reciprocal pivot growth. On exit, this contains the reciprocal */ -/* pivot growth factor norm(A)/norm(U). The "max absolute element" */ -/* norm is used. If this is much less than 1, then the stability of */ -/* the LU factorization of the (equilibrated) matrix A could be poor. */ -/* This also means that the solution X, estimated condition numbers, */ -/* and error bounds could be unreliable. If factorization fails with */ -/* 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly singular, so */ -/* the solution and error bounds could not be computed. RCOND = 0 */ -/* is returned. */ -/* = N+J: The solution corresponding to the Jth right-hand side is */ -/* not guaranteed. The solutions corresponding to other right- */ -/* hand sides K with K > J may not be guaranteed as well, but */ -/* only the first such right-hand side is reported. If a small */ -/* componentwise error is not requested (PARAMS(3) = 0.0) then */ -/* the Jth right-hand side is the first with a normwise error */ -/* bound that is not guaranteed (the smallest J such */ -/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ -/* the Jth right-hand side is the first with either a normwise or */ -/* componentwise error bound that is not guaranteed (the smallest */ -/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ -/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ -/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ -/* about all of the right-hand sides check ERR_BNDS_NORM or */ -/* ERR_BNDS_COMP. */ - -/* ================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - err_bnds_comp_dim1 = *nrhs; - err_bnds_comp_offset = 1 + err_bnds_comp_dim1; - err_bnds_comp__ -= err_bnds_comp_offset; - err_bnds_norm_dim1 = *nrhs; - err_bnds_norm_offset = 1 + err_bnds_norm_dim1; - err_bnds_norm__ -= err_bnds_norm_offset; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --s; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --berr; - --params; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - equil = lsame_(fact, "E"); - smlnum = dlamch_("Safe minimum"); - bignum = 1. / smlnum; - if (nofact || equil) { - *(unsigned char *)equed = 'N'; - rcequ = false; - } else { - rcequ = lsame_(equed, "Y"); - } - -/* Default is failure. If an input parameter is wrong or */ -/* factorization fails, make everything look horrible. Only the */ -/* pivot growth is set here, the rest is initialized in DPORFSX. */ - - *rpvgrw = 0.; - -/* Test the input parameters. PARAMS is not tested until DPORFSX. */ - - if (! nofact && ! equil && ! lsame_(fact, "F")) { - *info = -1; - } else if (! lsame_(uplo, "U") && ! lsame_(uplo, - "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -8; - } else if (lsame_(fact, "F") && ! (rcequ || lsame_( - equed, "N"))) { - *info = -9; - } else { - if (rcequ) { - smin = bignum; - smax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = smin, d__2 = s[j]; - smin = min(d__1,d__2); -/* Computing MAX */ - d__1 = smax, d__2 = s[j]; - smax = std::max(d__1,d__2); -/* L10: */ - } - if (smin <= 0.) { - *info = -10; - } else if (*n > 0) { - scond = std::max(smin,smlnum) / std::min(smax,bignum); - } else { - scond = 1.; - } - } - if (*info == 0) { - if (*ldb < std::max(1_integer,*n)) { - *info = -12; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -14; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOSVXX", &i__1); - return 0; - } - - if (equil) { - -/* Compute row and column scalings to equilibrate the matrix A. */ - - dpoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ); - if (infequ == 0) { - -/* Equilibrate the matrix. */ - - dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); - rcequ = lsame_(equed, "Y"); - } - } - -/* Scale the right-hand side. */ - - if (rcequ) { - dlascl2_(n, nrhs, &s[1], &b[b_offset], ldb); - } - - if (nofact || equil) { - -/* Compute the LU factorization of A. */ - - dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); - dpotrf_(uplo, n, &af[af_offset], ldaf, info); - -/* Return if INFO is non-zero. */ - - if (*info != 0) { - -/* Pivot in column INFO is exactly 0 */ -/* Compute the reciprocal pivot growth factor of the */ -/* leading rank-deficient INFO columns of A. */ - - *rpvgrw = dla_porpvgrw__(uplo, info, &a[a_offset], lda, &af[ - af_offset], ldaf, &work[1], 1_integer); - return 0; - } - } - -/* Compute the reciprocal growth factor RPVGRW. */ - - *rpvgrw = dla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf, - &work[1], 1_integer); - -/* Compute the solution matrix X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solution and */ -/* compute error bounds and backward error estimates for it. */ - - dporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, & - s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1], - n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], & - err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[ - 1], &iwork[1], info); - -/* Scale solutions. */ - - if (rcequ) { - dlascl2_(n, nrhs, &s[1], &x[x_offset], ldx); - } - - return 0; - -/* End of DPOSVXX */ - -} /* dposvxx_ */ diff --git a/external/clapack/lapack/dpotf2.cpp b/external/clapack/lapack/dpotf2.cpp deleted file mode 100644 index 64904332..00000000 --- a/external/clapack/lapack/dpotf2.cpp +++ /dev/null @@ -1,198 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b10 = -1.; -static double c_b12 = 1.; - -int dpotf2_(const char *uplo, integer *n, double *a, integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer j; - double ajj; - bool upper; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOTF2 computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U' * U , if UPLO = 'U', or */ -/* A = L * L', if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n by n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U'*U or A = L*L'. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, the leading minor of order k is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute U(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1, - &a[j * a_dim1 + 1], &c__1); - if (ajj <= 0. || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of row J. */ - - if (j < *n) { - i__2 = j - 1; - i__3 = *n - j; - dgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 - + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( - j + 1) * a_dim1], lda); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute L(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j - + a_dim1], lda); - if (ajj <= 0. || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of column J. */ - - if (j < *n) { - i__2 = *n - j; - i__3 = j - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + - a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + - j * a_dim1], &c__1); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); - } -/* L20: */ - } - } - goto L40; - -L30: - *info = j; - -L40: - return 0; - -/* End of DPOTF2 */ - -} /* dpotf2_ */ diff --git a/external/clapack/lapack/dpotrf.cpp b/external/clapack/lapack/dpotrf.cpp deleted file mode 100644 index 4227debf..00000000 --- a/external/clapack/lapack/dpotrf.cpp +++ /dev/null @@ -1,219 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b13 = -1.; -static double c_b14 = 1.; - -/* Subroutine */ int dpotrf_(const char *uplo, integer *n, double *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer j, jb, nb; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOTRF computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the block version of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code. */ - - dpotf2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code. */ - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = std::min(i__3,i__4); - i__3 = j - 1; - dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j * - a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda); - dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block row. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, & - c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) * - a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) * - a_dim1], lda); - i__3 = *n - j - jb + 1; - dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, & - i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j - + jb) * a_dim1], lda); - } -/* L10: */ - } - - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__2 = *n; - i__1 = nb; - for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = std::min(i__3,i__4); - i__3 = j - 1; - dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j + - a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda); - dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block column. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, & - c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1], - lda, &c_b14, &a[j + jb + j * a_dim1], lda); - i__3 = *n - j - jb + 1; - dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, & - jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb + - j * a_dim1], lda); - } -/* L20: */ - } - } - } - goto L40; - -L30: - *info = *info + j - 1; - -L40: - return 0; - -/* End of DPOTRF */ - -} /* dpotrf_ */ diff --git a/external/clapack/lapack/dpotri.cpp b/external/clapack/lapack/dpotri.cpp deleted file mode 100644 index 162299c5..00000000 --- a/external/clapack/lapack/dpotri.cpp +++ /dev/null @@ -1,105 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dpotri_(const char *uplo, integer *n, double *a, integer * - lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOTRI computes the inverse of a real symmetric positive definite */ -/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ -/* computed by DPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T, as computed by */ -/* DPOTRF. */ -/* On exit, the upper or lower triangle of the (symmetric) */ -/* inverse of A, overwriting the input factor U or L. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the (i,i) element of the factor U or L is */ -/* zero, and the inverse could not be computed. */ - -/* ===================================================================== */ - -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Invert the triangular Cholesky factor U or L. */ - - dtrtri_(uplo, "Non-unit", n, &a[a_offset], lda, info); - if (*info > 0) { - return 0; - } - -/* Form inv(U)*inv(U)' or inv(L)'*inv(L). */ - - dlauum_(uplo, n, &a[a_offset], lda, info); - - return 0; - -/* End of DPOTRI */ - -} /* dpotri_ */ diff --git a/external/clapack/lapack/dpotrs.cpp b/external/clapack/lapack/dpotrs.cpp deleted file mode 100644 index e8753b24..00000000 --- a/external/clapack/lapack/dpotrs.cpp +++ /dev/null @@ -1,148 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b9 = 1.; - -/* Subroutine */ int dpotrs_(const char *uplo, integer *n, integer *nrhs, - double *a, integer *lda, double *b, integer *ldb, integer * - info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - bool upper; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOTRS solves a system of linear equations A*X = B with a symmetric */ -/* positive definite matrix A using the Cholesky factorization */ -/* A = U**T*U or A = L*L**T computed by DPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B where A = U'*U. */ - -/* Solve U'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Solve U*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb); - } else { - -/* Solve A*X = B where A = L*L'. */ - -/* Solve L*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb); - -/* Solve L'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb); - } - - return 0; - -/* End of DPOTRS */ - -} /* dpotrs_ */ diff --git a/external/clapack/lapack/dppcon.cpp b/external/clapack/lapack/dppcon.cpp deleted file mode 100644 index 25cb7863..00000000 --- a/external/clapack/lapack/dppcon.cpp +++ /dev/null @@ -1,193 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dppcon_(const char *uplo, integer *n, double *ap, - double *anorm, double *rcond, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer ix, kase; - double scale; - integer isave[3]; - bool upper; - double scalel; - double scaleu; - double ainvnm; - char normin[1]; - double smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPPCON estimates the reciprocal of the condition number (in the */ -/* 1-norm) of a real symmetric positive definite packed matrix using */ -/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */ -/* DPPTRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, packed columnwise in a linear */ -/* array. The j-th column of U or L is stored in the array AP */ -/* as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ - -/* ANORM (input) DOUBLE PRECISION */ -/* The 1-norm (or infinity-norm) of the symmetric matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ -/* estimate of the 1-norm of inv(A) computed in this routine. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --iwork; - --work; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*anorm < 0.) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPPCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - - smlnum = dlamch_("Safe minimum"); - -/* Estimate the 1-norm of the inverse. */ - - kase = 0; - *(unsigned char *)normin = 'N'; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (upper) { - -/* Multiply by inv(U'). */ - - dlatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], & - work[1], &scalel, &work[(*n << 1) + 1], info); - *(unsigned char *)normin = 'Y'; - -/* Multiply by inv(U). */ - - dlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], & - work[1], &scaleu, &work[(*n << 1) + 1], info); - } else { - -/* Multiply by inv(L). */ - - dlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], & - work[1], &scalel, &work[(*n << 1) + 1], info); - *(unsigned char *)normin = 'Y'; - -/* Multiply by inv(L'). */ - - dlatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], & - work[1], &scaleu, &work[(*n << 1) + 1], info); - } - -/* Multiply by 1/SCALE if doing so will not cause overflow. */ - - scale = scalel * scaleu; - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) - { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - -L20: - return 0; - -/* End of DPPCON */ - -} /* dppcon_ */ diff --git a/external/clapack/lapack/dppequ.cpp b/external/clapack/lapack/dppequ.cpp deleted file mode 100644 index 144f1ba7..00000000 --- a/external/clapack/lapack/dppequ.cpp +++ /dev/null @@ -1,193 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dppequ_(const char *uplo, integer *n, double *ap, - double *s, double *scond, double *amax, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2; - - /* Local variables */ - integer i__, jj; - double smin; - - bool upper; - - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPPEQU computes row and column scalings intended to equilibrate a */ -/* symmetric positive definite matrix A in packed storage and reduce */ -/* its condition number (with respect to the two-norm). S contains the */ -/* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix */ -/* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. */ -/* This choice of S puts the condition number of B within a factor N of */ -/* the smallest possible condition number over all possible diagonal */ -/* scalings. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangle of the symmetric matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* S (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, S contains the scale factors for A. */ - -/* SCOND (output) DOUBLE PRECISION */ -/* If INFO = 0, S contains the ratio of the smallest S(i) to */ -/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ -/* large nor too small, it is not worth scaling by S. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --s; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPPEQU", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *scond = 1.; - *amax = 0.; - return 0; - } - -/* Initialize SMIN and AMAX. */ - - s[1] = ap[1]; - smin = s[1]; - *amax = s[1]; - - if (upper) { - -/* UPLO = 'U': Upper triangle of A is stored. */ -/* Find the minimum and maximum diagonal elements. */ - - jj = 1; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - jj += i__; - s[i__] = ap[jj]; -/* Computing MIN */ - d__1 = smin, d__2 = s[i__]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = *amax, d__2 = s[i__]; - *amax = std::max(d__1,d__2); -/* L10: */ - } - - } else { - -/* UPLO = 'L': Lower triangle of A is stored. */ -/* Find the minimum and maximum diagonal elements. */ - - jj = 1; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - jj = jj + *n - i__ + 2; - s[i__] = ap[jj]; -/* Computing MIN */ - d__1 = smin, d__2 = s[i__]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = *amax, d__2 = s[i__]; - *amax = std::max(d__1,d__2); -/* L20: */ - } - } - - if (smin <= 0.) { - -/* Find the first non-positive diagonal element and return. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] <= 0.) { - *info = i__; - return 0; - } -/* L30: */ - } - } else { - -/* Set the scale factors to the reciprocals */ -/* of the diagonal elements. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - s[i__] = 1. / sqrt(s[i__]); -/* L40: */ - } - -/* Compute SCOND = min(S(I)) / max(S(I)) */ - - *scond = sqrt(smin) / sqrt(*amax); - } - return 0; - -/* End of DPPEQU */ - -} /* dppequ_ */ diff --git a/external/clapack/lapack/dpprfs.cpp b/external/clapack/lapack/dpprfs.cpp deleted file mode 100644 index 72b7efc6..00000000 --- a/external/clapack/lapack/dpprfs.cpp +++ /dev/null @@ -1,388 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b12 = -1.; -static double c_b14 = 1.; - -/* Subroutine */ int dpprfs_(const char *uplo, integer *n, integer *nrhs, - double *ap, double *afp, double *b, integer *ldb, - double *x, integer *ldx, double *ferr, double *berr, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s; - integer ik, kk; - double xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - integer count; - bool upper; - double safmin; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPPRFS improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is symmetric positive definite */ -/* and packed, and provides error bounds and backward error estimates */ -/* for the solution. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangle of the symmetric matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF, */ -/* packed columnwise in a linear array in the same format as A */ -/* (see AP). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DPPTRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --afp; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPPRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *n + 1; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - A * X */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, & - work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L30: */ - } - -/* Compute abs(A)*abs(X) + abs(B). */ - - kk = 1; - if (upper) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - ik = kk; - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; - s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * - x_dim1], abs(d__2)); - ++ik; -/* L40: */ - } - work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk + - s; - kk += k; -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - work[k] += (d__1 = ap[kk], abs(d__1)) * xk; - ik = kk + 1; - i__3 = *n; - for (i__ = k + 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; - s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * - x_dim1], abs(d__2)); - ++ik; -/* L60: */ - } - work[k] += s; - kk += *n - k + 1; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); - daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(A))* */ -/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(A) is the inverse of A */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(A) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(A'). */ - - dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L110: */ - } - } else if (kase == 2) { - -/* Multiply by inv(A)*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L120: */ - } - dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DPPRFS */ - -} /* dpprfs_ */ diff --git a/external/clapack/lapack/dppsv.cpp b/external/clapack/lapack/dppsv.cpp deleted file mode 100644 index c5a113b1..00000000 --- a/external/clapack/lapack/dppsv.cpp +++ /dev/null @@ -1,141 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dppsv_(const char *uplo, integer *n, integer *nrhs, double - *ap, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPPSV computes the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric positive definite matrix stored in */ -/* packed format and X and B are N-by-NRHS matrices. */ - -/* The Cholesky decomposition is used to factor A as */ -/* A = U**T* U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is a lower triangular */ -/* matrix. The factored form of A is then used to solve the system of */ -/* equations A * X = B. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ -/* See below for further details. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T, in the same storage */ -/* format as A. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i of A is not */ -/* positive definite, so the factorization could not be */ -/* completed, and the solution has not been computed. */ - -/* Further Details */ -/* =============== */ - -/* The packed storage scheme is illustrated by the following example */ -/* when N = 4, UPLO = 'U': */ - -/* Two-dimensional storage of the symmetric matrix A: */ - -/* a11 a12 a13 a14 */ -/* a22 a23 a24 */ -/* a33 a34 (aij = conjg(aji)) */ -/* a44 */ - -/* Packed storage of the upper triangle of A: */ - -/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ - -/* ===================================================================== */ - -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPPSV ", &i__1); - return 0; - } - -/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ - - dpptrf_(uplo, n, &ap[1], info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dpptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info); - - } - return 0; - -/* End of DPPSV */ - -} /* dppsv_ */ diff --git a/external/clapack/lapack/dppsvx.cpp b/external/clapack/lapack/dppsvx.cpp deleted file mode 100644 index dff98901..00000000 --- a/external/clapack/lapack/dppsvx.cpp +++ /dev/null @@ -1,422 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dppsvx_(const char *fact, const char *uplo, integer *n, integer * - nrhs, double *ap, double *afp, char *equed, double *s, - double *b, integer *ldb, double *x, integer *ldx, double * - rcond, double *ferr, double *berr, double *work, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double amax, smin, smax; - double scond, anorm; - bool equil, rcequ; - bool nofact; - double bignum; - integer infequ; - double smlnum; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */ -/* compute the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric positive definite matrix stored in */ -/* packed format and X and B are N-by-NRHS matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ -/* the system: */ -/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */ -/* Whether or not the system will be equilibrated depends on the */ -/* scaling of the matrix A, but if equilibration is used, A is */ -/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ - -/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */ -/* factor the matrix A (after equilibration if FACT = 'E') as */ -/* A = U**T* U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is a lower triangular */ -/* matrix. */ - -/* 3. If the leading i-by-i principal minor is not positive definite, */ -/* then the routine returns with INFO = i. Otherwise, the factored */ -/* form of A is used to estimate the condition number of the matrix */ -/* A. If the reciprocal of the condition number is less than machine */ -/* precision, INFO = N+1 is returned as a warning, but the routine */ -/* still goes on to solve for X and compute error bounds as */ -/* described below. */ - -/* 4. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 5. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* 6. If equilibration was used, the matrix X is premultiplied by */ -/* diag(S) so that it solves the original system before */ -/* equilibration. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of the matrix A is */ -/* supplied on entry, and if not, whether the matrix A should be */ -/* equilibrated before it is factored. */ -/* = 'F': On entry, AFP contains the factored form of A. */ -/* If EQUED = 'Y', the matrix A has been equilibrated */ -/* with scaling factors given by S. AP and AFP will not */ -/* be modified. */ -/* = 'N': The matrix A will be copied to AFP and factored. */ -/* = 'E': The matrix A will be equilibrated if necessary, then */ -/* copied to AFP and factored. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array, except if FACT = 'F' */ -/* and EQUED = 'Y', then A must contain the equilibrated matrix */ -/* diag(S)*A*diag(S). The j-th column of A is stored in the */ -/* array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ -/* See below for further details. A is not modified if */ -/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ - -/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ -/* diag(S)*A*diag(S). */ - -/* AFP (input or output) DOUBLE PRECISION array, dimension */ -/* (N*(N+1)/2) */ -/* If FACT = 'F', then AFP is an input argument and on entry */ -/* contains the triangular factor U or L from the Cholesky */ -/* factorization A = U'*U or A = L*L', in the same storage */ -/* format as A. If EQUED .ne. 'N', then AFP is the factored */ -/* form of the equilibrated matrix A. */ - -/* If FACT = 'N', then AFP is an output argument and on exit */ -/* returns the triangular factor U or L from the Cholesky */ -/* factorization A = U'*U or A = L*L' of the original matrix A. */ - -/* If FACT = 'E', then AFP is an output argument and on exit */ -/* returns the triangular factor U or L from the Cholesky */ -/* factorization A = U'*U or A = L*L' of the equilibrated */ -/* matrix A (see the description of AP for the form of the */ -/* equilibrated matrix). */ - -/* EQUED (input or output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration (always true if FACT = 'N'). */ -/* = 'Y': Equilibration was done, i.e., A has been replaced by */ -/* diag(S) * A * diag(S). */ -/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ -/* output argument. */ - -/* S (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The scale factors for A; not accessed if EQUED = 'N'. S is */ -/* an input argument if FACT = 'F'; otherwise, S is an output */ -/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */ -/* must be positive. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */ -/* B is overwritten by diag(S) * B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */ -/* the original system of equations. Note that if EQUED = 'Y', */ -/* A and B are modified on exit, and the solution to the */ -/* equilibrated system is inv(diag(S))*X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The estimate of the reciprocal condition number of the matrix */ -/* A after equilibration (if done). If RCOND is less than the */ -/* machine precision (in particular, if RCOND = 0), the matrix */ -/* is singular to working precision. This condition is */ -/* indicated by a return code of INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= N: the leading minor of order i of A is */ -/* not positive definite, so the factorization */ -/* could not be completed, and the solution has not */ -/* been computed. RCOND = 0 is returned. */ -/* = N+1: U is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* Further Details */ -/* =============== */ - -/* The packed storage scheme is illustrated by the following example */ -/* when N = 4, UPLO = 'U': */ - -/* Two-dimensional storage of the symmetric matrix A: */ - -/* a11 a12 a13 a14 */ -/* a22 a23 a24 */ -/* a33 a34 (aij = conjg(aji)) */ -/* a44 */ - -/* Packed storage of the upper triangle of A: */ - -/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --ap; - --afp; - --s; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - equil = lsame_(fact, "E"); - if (nofact || equil) { - *(unsigned char *)equed = 'N'; - rcequ = false; - } else { - rcequ = lsame_(equed, "Y"); - smlnum = dlamch_("Safe minimum"); - bignum = 1. / smlnum; - } - -/* Test the input parameters. */ - - if (! nofact && ! equil && ! lsame_(fact, "F")) { - *info = -1; - } else if (! lsame_(uplo, "U") && ! lsame_(uplo, - "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (lsame_(fact, "F") && ! (rcequ || lsame_( - equed, "N"))) { - *info = -7; - } else { - if (rcequ) { - smin = bignum; - smax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = smin, d__2 = s[j]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = smax, d__2 = s[j]; - smax = std::max(d__1,d__2); -/* L10: */ - } - if (smin <= 0.) { - *info = -8; - } else if (*n > 0) { - scond = std::max(smin,smlnum) / std::min(smax,bignum); - } else { - scond = 1.; - } - } - if (*info == 0) { - if (*ldb < std::max(1_integer,*n)) { - *info = -10; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -12; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPPSVX", &i__1); - return 0; - } - - if (equil) { - -/* Compute row and column scalings to equilibrate the matrix A. */ - - dppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ); - if (infequ == 0) { - -/* Equilibrate the matrix. */ - - dlaqsp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed); - rcequ = lsame_(equed, "Y"); - } - } - -/* Scale the right-hand side. */ - - if (rcequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1]; -/* L20: */ - } -/* L30: */ - } - } - - if (nofact || equil) { - -/* Compute the Cholesky factorization A = U'*U or A = L*L'. */ - - i__1 = *n * (*n + 1) / 2; - dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); - dpptrf_(uplo, n, &afp[1], info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A. */ - - anorm = dlansp_("I", uplo, n, &ap[1], &work[1]); - -/* Compute the reciprocal of the condition number of A. */ - - dppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info); - -/* Compute the solution matrix X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solution and */ -/* compute error bounds and backward error estimates for it. */ - - dpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset], - ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info); - -/* Transform the solution matrix X to a solution of the original */ -/* system. */ - - if (rcequ) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1]; -/* L40: */ - } -/* L50: */ - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] /= scond; -/* L60: */ - } - } - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - - return 0; - -/* End of DPPSVX */ - -} /* dppsvx_ */ diff --git a/external/clapack/lapack/dpptrf.cpp b/external/clapack/lapack/dpptrf.cpp deleted file mode 100644 index d5a20f2a..00000000 --- a/external/clapack/lapack/dpptrf.cpp +++ /dev/null @@ -1,199 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b16 = -1.; - -/* Subroutine */ int dpptrf_(const char *uplo, integer *n, double *ap, integer * - info) -{ - /* System generated locals */ - integer i__1, i__2; - double d__1; - - /* Local variables */ - integer j, jc, jj; - double ajj; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPPTRF computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A stored in packed format. */ - -/* The factorization has the form */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ -/* See below for further details. */ - -/* On exit, if INFO = 0, the triangular factor U or L from the */ -/* Cholesky factorization A = U**T*U or A = L*L**T, in the same */ -/* storage format as A. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* Further Details */ -/* ======= ======= */ - -/* The packed storage scheme is illustrated by the following example */ -/* when N = 4, UPLO = 'U': */ - -/* Two-dimensional storage of the symmetric matrix A: */ - -/* a11 a12 a13 a14 */ -/* a22 a23 a24 */ -/* a33 a34 (aij = aji) */ -/* a44 */ - -/* Packed storage of the upper triangle of A: */ - -/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPPTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - jj = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jc = jj + 1; - jj += j; - -/* Compute elements 1:J-1 of column J. */ - - if (j > 1) { - i__2 = j - 1; - dtpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[ - jc], &c__1); - } - -/* Compute U(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = ap[jj] - ddot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1); - if (ajj <= 0.) { - ap[jj] = ajj; - goto L30; - } - ap[jj] = sqrt(ajj); -/* L10: */ - } - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - jj = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute L(J,J) and test for non-positive-definiteness. */ - - ajj = ap[jj]; - if (ajj <= 0.) { - ap[jj] = ajj; - goto L30; - } - ajj = sqrt(ajj); - ap[jj] = ajj; - -/* Compute elements J+1:N of column J and update the trailing */ -/* submatrix. */ - - if (j < *n) { - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &ap[jj + 1], &c__1); - i__2 = *n - j; - dspr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n - - j + 1]); - jj = jj + *n - j + 1; - } -/* L20: */ - } - } - goto L40; - -L30: - *info = j; - -L40: - return 0; - -/* End of DPPTRF */ - -} /* dpptrf_ */ diff --git a/external/clapack/lapack/dpptri.cpp b/external/clapack/lapack/dpptri.cpp deleted file mode 100644 index e9d4b617..00000000 --- a/external/clapack/lapack/dpptri.cpp +++ /dev/null @@ -1,151 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b8 = 1.; -static integer c__1 = 1; - -/* Subroutine */ int dpptri_(const char *uplo, integer *n, double *ap, integer * - info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer j, jc, jj; - double ajj; - integer jjn; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPPTRI computes the inverse of a real symmetric positive definite */ -/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */ -/* computed by DPPTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangular factor is stored in AP; */ -/* = 'L': Lower triangular factor is stored in AP. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the triangular factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T, packed columnwise as */ -/* a linear array. The j-th column of U or L is stored in the */ -/* array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ - -/* On exit, the upper or lower triangle of the (symmetric) */ -/* inverse of A, overwriting the input factor U or L. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the (i,i) element of the factor U or L is */ -/* zero, and the inverse could not be computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPPTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Invert the triangular Cholesky factor U or L. */ - - dtptri_(uplo, "Non-unit", n, &ap[1], info); - if (*info > 0) { - return 0; - } - - if (upper) { - -/* Compute the product inv(U) * inv(U)'. */ - - jj = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jc = jj + 1; - jj += j; - if (j > 1) { - i__2 = j - 1; - dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]); - } - ajj = ap[jj]; - dscal_(&j, &ajj, &ap[jc], &c__1); -/* L10: */ - } - - } else { - -/* Compute the product inv(L)' * inv(L). */ - - jj = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - jjn = jj + *n - j + 1; - i__2 = *n - j + 1; - ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1); - if (j < *n) { - i__2 = *n - j; - dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ - jj + 1], &c__1); - } - jj = jjn; -/* L20: */ - } - } - - return 0; - -/* End of DPPTRI */ - -} /* dpptri_ */ diff --git a/external/clapack/lapack/dpptrs.cpp b/external/clapack/lapack/dpptrs.cpp deleted file mode 100644 index b5cbbd93..00000000 --- a/external/clapack/lapack/dpptrs.cpp +++ /dev/null @@ -1,154 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dpptrs_(const char *uplo, integer *n, integer *nrhs, - double *ap, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1; - - /* Local variables */ - integer i__; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPPTRS solves a system of linear equations A*X = B with a symmetric */ -/* positive definite matrix A in packed storage using the Cholesky */ -/* factorization A = U**T*U or A = L*L**T computed by DPPTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, packed columnwise in a linear */ -/* array. The j-th column of U or L is stored in the array AP */ -/* as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPPTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B where A = U'*U. */ - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Solve U'*X = B, overwriting B with X. */ - - dtpsv_("Upper", "Transpose", "Non-unit", n, &ap[1], &b[i__ * - b_dim1 + 1], &c__1); - -/* Solve U*X = B, overwriting B with X. */ - - dtpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ * - b_dim1 + 1], &c__1); -/* L10: */ - } - } else { - -/* Solve A*X = B where A = L*L'. */ - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Solve L*Y = B, overwriting B with X. */ - - dtpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ * - b_dim1 + 1], &c__1); - -/* Solve L'*X = Y, overwriting B with X. */ - - dtpsv_("Lower", "Transpose", "Non-unit", n, &ap[1], &b[i__ * - b_dim1 + 1], &c__1); -/* L20: */ - } - } - - return 0; - -/* End of DPPTRS */ - -} /* dpptrs_ */ diff --git a/external/clapack/lapack/dpstf2.cpp b/external/clapack/lapack/dpstf2.cpp deleted file mode 100644 index 59683f40..00000000 --- a/external/clapack/lapack/dpstf2.cpp +++ /dev/null @@ -1,367 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b16 = -1.; -static double c_b18 = 1.; - -int dpstf2_(const char *uplo, integer *n, double *a, integer *lda, integer *piv, integer *rank, - double *tol, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - integer i__, j, maxlocval; - double ajj; - integer pvt; - double dtemp; - integer itemp; - double dstop; - bool upper; - - -/* -- LAPACK PROTOTYPE routine (version 3.2) -- */ -/* Craig Lucas, University of Manchester / NAG Ltd. */ -/* October, 2008 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPSTF2 computes the Cholesky factorization with complete */ -/* pivoting of a real symmetric positive semidefinite matrix A. */ - -/* The factorization has the form */ -/* P' * A * P = U' * U , if UPLO = 'U', */ -/* P' * A * P = L * L', if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular, and */ -/* P is stored as vector PIV. */ - -/* This algorithm does not attempt to check that A is positive */ -/* semidefinite. This version of the algorithm calls level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n by n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization as above. */ - -/* PIV (output) INTEGER array, dimension (N) */ -/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ - -/* RANK (output) INTEGER */ -/* The rank of A given by the number of steps the algorithm */ -/* completed. */ - -/* TOL (input) DOUBLE PRECISION */ -/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */ -/* will be used. The algorithm terminates at the (K-1)st step */ -/* if the pivot <= TOL. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* WORK DOUBLE PRECISION array, dimension (2*N) */ -/* Work space. */ - -/* INFO (output) INTEGER */ -/* < 0: If INFO = -K, the K-th argument had an illegal value, */ -/* = 0: algorithm completed successfully, and */ -/* > 0: the matrix A is either rank deficient with computed rank */ -/* as returned in RANK, or is indefinite. See Section 7 of */ -/* LAPACK Working Note #161 for further information. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - --work; - --piv; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPSTF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Initialize PIV */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - piv[i__] = i__; -/* L100: */ - } - -/* Compute stopping value */ - - pvt = 1; - ajj = a[pvt + pvt * a_dim1]; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if (a[i__ + i__ * a_dim1] > ajj) { - pvt = i__; - ajj = a[pvt + pvt * a_dim1]; - } - } - if (ajj == 0. || disnan_(&ajj)) { - *rank = 0; - *info = 1; - goto L170; - } - -/* Compute stopping value if not supplied */ - - if (*tol < 0.) { - dstop = *n * dlamch_("Epsilon") * ajj; - } else { - dstop = *tol; - } - -/* Set first half of WORK to zero, holds dot products */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L110: */ - } - - if (upper) { - -/* Compute the Cholesky factorization P' * A * P = U' * U */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Find pivot, test for exit, else swap rows and columns */ -/* Update dot products, compute possible pivots which are */ -/* stored in the second half of WORK */ - - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - - if (j > 1) { -/* Computing 2nd power */ - d__1 = a[j - 1 + i__ * a_dim1]; - work[i__] += d__1 * d__1; - } - work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; - -/* L120: */ - } - - if (j > 1) { - maxlocval = (*n << 1) - (*n + j) + 1; - itemp = dmaxloc_(&work[*n + j], &maxlocval); - pvt = itemp + j - 1; - ajj = work[*n + pvt]; - if (ajj <= dstop || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L160; - } - } - - if (j != pvt) { - -/* Pivot OK, so can now swap pivot rows and columns */ - - a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; - i__2 = j - 1; - dswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1], - &c__1); - if (pvt < *n) { - i__2 = *n - pvt; - dswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + ( - pvt + 1) * a_dim1], lda); - } - i__2 = pvt - j - 1; - dswap_(&i__2, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + pvt * - a_dim1], &c__1); - -/* Swap dot products and PIV */ - - dtemp = work[j]; - work[j] = work[pvt]; - work[pvt] = dtemp; - itemp = piv[pvt]; - piv[pvt] = piv[j]; - piv[j] = itemp; - } - - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of row J */ - - if (j < *n) { - i__2 = j - 1; - i__3 = *n - j; - dgemv_("Trans", &i__2, &i__3, &c_b16, &a[(j + 1) * a_dim1 + 1] -, lda, &a[j * a_dim1 + 1], &c__1, &c_b18, &a[j + (j + - 1) * a_dim1], lda); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); - } - -/* L130: */ - } - - } else { - -/* Compute the Cholesky factorization P' * A * P = L * L' */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Find pivot, test for exit, else swap rows and columns */ -/* Update dot products, compute possible pivots which are */ -/* stored in the second half of WORK */ - - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - - if (j > 1) { -/* Computing 2nd power */ - d__1 = a[i__ + (j - 1) * a_dim1]; - work[i__] += d__1 * d__1; - } - work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; - -/* L140: */ - } - - if (j > 1) { - maxlocval = (*n << 1) - (*n + j) + 1; - itemp = dmaxloc_(&work[*n + j], &maxlocval); - pvt = itemp + j - 1; - ajj = work[*n + pvt]; - if (ajj <= dstop || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L160; - } - } - - if (j != pvt) { - -/* Pivot OK, so can now swap pivot rows and columns */ - - a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; - i__2 = j - 1; - dswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda); - if (pvt < *n) { - i__2 = *n - pvt; - dswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1 - + pvt * a_dim1], &c__1); - } - i__2 = pvt - j - 1; - dswap_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + (j + 1) - * a_dim1], lda); - -/* Swap dot products and PIV */ - - dtemp = work[j]; - work[j] = work[pvt]; - work[pvt] = dtemp; - itemp = piv[pvt]; - piv[pvt] = piv[j]; - piv[j] = itemp; - } - - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of column J */ - - if (j < *n) { - i__2 = *n - j; - i__3 = j - 1; - dgemv_("No Trans", &i__2, &i__3, &c_b16, &a[j + 1 + a_dim1], - lda, &a[j + a_dim1], lda, &c_b18, &a[j + 1 + j * - a_dim1], &c__1); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); - } - -/* L150: */ - } - - } - -/* Ran to completion, A has full rank */ - - *rank = *n; - - goto L170; -L160: - -/* Rank is number of steps completed. Set INFO = 1 to signal */ -/* that the factorization cannot be used to solve a system. */ - - *rank = j - 1; - *info = 1; - -L170: - return 0; - -/* End of DPSTF2 */ - -} /* dpstf2_ */ diff --git a/external/clapack/lapack/dpstrf.cpp b/external/clapack/lapack/dpstrf.cpp deleted file mode 100644 index aa5233d9..00000000 --- a/external/clapack/lapack/dpstrf.cpp +++ /dev/null @@ -1,436 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b22 = -1.; -static double c_b24 = 1.; - -int dpstrf_(const char *uplo, integer *n, double *a, integer *lda, integer *piv, integer *rank, - double *tol, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - double d__1; - - /* Local variables */ - integer i__, j, k, maxlocvar, jb, nb; - double ajj; - integer pvt; - double dtemp; - integer itemp; - double dstop; - bool upper; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Craig Lucas, University of Manchester / NAG Ltd. */ -/* October, 2008 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPSTRF computes the Cholesky factorization with complete */ -/* pivoting of a real symmetric positive semidefinite matrix A. */ - -/* The factorization has the form */ -/* P' * A * P = U' * U , if UPLO = 'U', */ -/* P' * A * P = L * L', if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular, and */ -/* P is stored as vector PIV. */ - -/* This algorithm does not attempt to check that A is positive */ -/* semidefinite. This version of the algorithm calls level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n by n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization as above. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* PIV (output) INTEGER array, dimension (N) */ -/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */ - -/* RANK (output) INTEGER */ -/* The rank of A given by the number of steps the algorithm */ -/* completed. */ - -/* TOL (input) DOUBLE PRECISION */ -/* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */ -/* will be used. The algorithm terminates at the (K-1)st step */ -/* if the pivot <= TOL. */ - -/* WORK DOUBLE PRECISION array, dimension (2*N) */ -/* Work space. */ - -/* INFO (output) INTEGER */ -/* < 0: If INFO = -K, the K-th argument had an illegal value, */ -/* = 0: algorithm completed successfully, and */ -/* > 0: the matrix A is either rank deficient with computed rank */ -/* as returned in RANK, or is indefinite. See Section 7 of */ -/* LAPACK Working Note #161 for further information. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --work; - --piv; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPSTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Get block size */ - - nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - dpstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1], - info); - goto L200; - - } else { - -/* Initialize PIV */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - piv[i__] = i__; -/* L100: */ - } - -/* Compute stopping value */ - - pvt = 1; - ajj = a[pvt + pvt * a_dim1]; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if (a[i__ + i__ * a_dim1] > ajj) { - pvt = i__; - ajj = a[pvt + pvt * a_dim1]; - } - } - if (ajj == 0. || disnan_(&ajj)) { - *rank = 0; - *info = 1; - goto L200; - } - -/* Compute stopping value if not supplied */ - - if (*tol < 0.) { - dstop = *n * dlamch_("Epsilon") * ajj; - } else { - dstop = *tol; - } - - - if (upper) { - -/* Compute the Cholesky factorization P' * A * P = U' * U */ - - i__1 = *n; - i__2 = nb; - for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { - -/* Account for last block not being NB wide */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - k + 1; - jb = std::min(i__3,i__4); - -/* Set relevant part of first half of WORK to zero, */ -/* holds dot products */ - - i__3 = *n; - for (i__ = k; i__ <= i__3; ++i__) { - work[i__] = 0.; -/* L110: */ - } - - i__3 = k + jb - 1; - for (j = k; j <= i__3; ++j) { - -/* Find pivot, test for exit, else swap rows and columns */ -/* Update dot products, compute possible pivots which are */ -/* stored in the second half of WORK */ - - i__4 = *n; - for (i__ = j; i__ <= i__4; ++i__) { - - if (j > k) { -/* Computing 2nd power */ - d__1 = a[j - 1 + i__ * a_dim1]; - work[i__] += d__1 * d__1; - } - work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; - -/* L120: */ - } - - if (j > 1) { - maxlocvar = (*n << 1) - (*n + j) + 1; - itemp = dmaxloc_(&work[*n + j], &maxlocvar); - pvt = itemp + j - 1; - ajj = work[*n + pvt]; - if (ajj <= dstop || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L190; - } - } - - if (j != pvt) { - -/* Pivot OK, so can now swap pivot rows and columns */ - - a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; - i__4 = j - 1; - dswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt * - a_dim1 + 1], &c__1); - if (pvt < *n) { - i__4 = *n - pvt; - dswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[ - pvt + (pvt + 1) * a_dim1], lda); - } - i__4 = pvt - j - 1; - dswap_(&i__4, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 - + pvt * a_dim1], &c__1); - -/* Swap dot products and PIV */ - - dtemp = work[j]; - work[j] = work[pvt]; - work[pvt] = dtemp; - itemp = piv[pvt]; - piv[pvt] = piv[j]; - piv[j] = itemp; - } - - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of row J. */ - - if (j < *n) { - i__4 = j - k; - i__5 = *n - j; - dgemv_("Trans", &i__4, &i__5, &c_b22, &a[k + (j + 1) * - a_dim1], lda, &a[k + j * a_dim1], &c__1, & - c_b24, &a[j + (j + 1) * a_dim1], lda); - i__4 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__4, &d__1, &a[j + (j + 1) * a_dim1], lda); - } - -/* L130: */ - } - -/* Update trailing matrix, J already incremented */ - - if (k + jb <= *n) { - i__3 = *n - j + 1; - dsyrk_("Upper", "Trans", &i__3, &jb, &c_b22, &a[k + j * - a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda); - } - -/* L140: */ - } - - } else { - -/* Compute the Cholesky factorization P' * A * P = L * L' */ - - i__2 = *n; - i__1 = nb; - for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { - -/* Account for last block not being NB wide */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - k + 1; - jb = std::min(i__3,i__4); - -/* Set relevant part of first half of WORK to zero, */ -/* holds dot products */ - - i__3 = *n; - for (i__ = k; i__ <= i__3; ++i__) { - work[i__] = 0.; -/* L150: */ - } - - i__3 = k + jb - 1; - for (j = k; j <= i__3; ++j) { - -/* Find pivot, test for exit, else swap rows and columns */ -/* Update dot products, compute possible pivots which are */ -/* stored in the second half of WORK */ - - i__4 = *n; - for (i__ = j; i__ <= i__4; ++i__) { - - if (j > k) { -/* Computing 2nd power */ - d__1 = a[i__ + (j - 1) * a_dim1]; - work[i__] += d__1 * d__1; - } - work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__]; - -/* L160: */ - } - - if (j > 1) { - maxlocvar = (*n << 1) - (*n + j) + 1; - itemp = dmaxloc_(&work[*n + j], &maxlocvar); - pvt = itemp + j - 1; - ajj = work[*n + pvt]; - if (ajj <= dstop || disnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L190; - } - } - - if (j != pvt) { - -/* Pivot OK, so can now swap pivot rows and columns */ - - a[pvt + pvt * a_dim1] = a[j + j * a_dim1]; - i__4 = j - 1; - dswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1], - lda); - if (pvt < *n) { - i__4 = *n - pvt; - dswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[ - pvt + 1 + pvt * a_dim1], &c__1); - } - i__4 = pvt - j - 1; - dswap_(&i__4, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + - (j + 1) * a_dim1], lda); - -/* Swap dot products and PIV */ - - dtemp = work[j]; - work[j] = work[pvt]; - work[pvt] = dtemp; - itemp = piv[pvt]; - piv[pvt] = piv[j]; - piv[j] = itemp; - } - - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of column J. */ - - if (j < *n) { - i__4 = *n - j; - i__5 = j - k; - dgemv_("No Trans", &i__4, &i__5, &c_b22, &a[j + 1 + k - * a_dim1], lda, &a[j + k * a_dim1], lda, & - c_b24, &a[j + 1 + j * a_dim1], &c__1); - i__4 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__4, &d__1, &a[j + 1 + j * a_dim1], &c__1); - } - -/* L170: */ - } - -/* Update trailing matrix, J already incremented */ - - if (k + jb <= *n) { - i__3 = *n - j + 1; - dsyrk_("Lower", "No Trans", &i__3, &jb, &c_b22, &a[j + k * - a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda); - } - -/* L180: */ - } - - } - } - -/* Ran to completion, A has full rank */ - - *rank = *n; - - goto L200; -L190: - -/* Rank is the number of steps completed. Set INFO = 1 to signal */ -/* that the factorization cannot be used to solve a system. */ - - *rank = j - 1; - *info = 1; - -L200: - return 0; - -/* End of DPSTRF */ - -} /* dpstrf_ */ diff --git a/external/clapack/lapack/dptcon.cpp b/external/clapack/lapack/dptcon.cpp deleted file mode 100644 index b7f94bf6..00000000 --- a/external/clapack/lapack/dptcon.cpp +++ /dev/null @@ -1,172 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dptcon_(integer *n, double *d__, double *e, - double *anorm, double *rcond, double *work, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer i__, ix; - - - double ainvnm; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPTCON computes the reciprocal of the condition number (in the */ -/* 1-norm) of a real symmetric positive definite tridiagonal matrix */ -/* using the factorization A = L*D*L**T or A = U**T*D*U computed by */ -/* DPTTRF. */ - -/* Norm(inv(A)) is computed by a direct method, and the reciprocal of */ -/* the condition number is computed as */ -/* RCOND = 1 / (ANORM * norm(inv(A))). */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the diagonal matrix D from the */ -/* factorization of A, as computed by DPTTRF. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) off-diagonal elements of the unit bidiagonal factor */ -/* U or L from the factorization of A, as computed by DPTTRF. */ - -/* ANORM (input) DOUBLE PRECISION */ -/* The 1-norm of the original matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the */ -/* 1-norm of inv(A) computed in this routine. */ - -/* 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 method used is described in Nicholas J. Higham, "Efficient */ -/* Algorithms for Computing the Condition Number of a Tridiagonal */ -/* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments. */ - - /* Parameter adjustments */ - --work; - --e; - --d__; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*anorm < 0.) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPTCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - -/* Check that D(1:N) is positive. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] <= 0.) { - return 0; - } -/* L10: */ - } - -/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */ - -/* m(i,j) = abs(A(i,j)), i = j, */ -/* m(i,j) = -abs(A(i,j)), i .ne. j, */ - -/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */ - -/* Solve M(L) * x = e. */ - - work[1] = 1.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - work[i__] = work[i__ - 1] * (d__1 = e[i__ - 1], abs(d__1)) + 1.; -/* L20: */ - } - -/* Solve D * M(L)' * x = b. */ - - work[*n] /= d__[*n]; - for (i__ = *n - 1; i__ >= 1; --i__) { - work[i__] = work[i__] / d__[i__] + work[i__ + 1] * (d__1 = e[i__], - abs(d__1)); -/* L30: */ - } - -/* Compute AINVNM = max(x(i)), 1<=i<=n. */ - - ix = idamax_(n, &work[1], &c__1); - ainvnm = (d__1 = work[ix], abs(d__1)); - -/* Compute the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - - return 0; - -/* End of DPTCON */ - -} /* dptcon_ */ diff --git a/external/clapack/lapack/dpteqr.cpp b/external/clapack/lapack/dpteqr.cpp deleted file mode 100644 index e569c09c..00000000 --- a/external/clapack/lapack/dpteqr.cpp +++ /dev/null @@ -1,219 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b7 = 0.; -static double c_b8 = 1.; -static integer c__0 = 0; -static integer c__1 = 1; - -/* Subroutine */ int dpteqr_(const char *compz, integer *n, double *d__, - double *e, double *z__, integer *ldz, double *work, - integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1; - - /* Local variables */ - double c__[1] /* was [1][1] */; - integer i__; - double vt[1] /* was [1][1] */; - integer nru; - integer icompz; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a */ -/* symmetric positive definite tridiagonal matrix by first factoring the */ -/* matrix using DPTTRF, and then calling DBDSQR to compute the singular */ -/* values of the bidiagonal factor. */ - -/* This routine computes the eigenvalues of the positive definite */ -/* tridiagonal matrix to high relative accuracy. This means that if the */ -/* eigenvalues range over many orders of magnitude in size, then the */ -/* small eigenvalues and corresponding eigenvectors will be computed */ -/* more accurately than, for example, with the standard QR method. */ - -/* The eigenvectors of a full or band symmetric positive definite matrix */ -/* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to */ -/* reduce this matrix to tridiagonal form. (The reduction to tridiagonal */ -/* form, however, may preclude the possibility of obtaining high */ -/* relative accuracy in the small eigenvalues of the original matrix, if */ -/* these eigenvalues range over many orders of magnitude.) */ - -/* Arguments */ -/* ========= */ - -/* COMPZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only. */ -/* = 'V': Compute eigenvectors of original symmetric */ -/* matrix also. Array Z contains the orthogonal */ -/* matrix used to reduce the original matrix to */ -/* tridiagonal form. */ -/* = 'I': Compute eigenvectors of tridiagonal matrix also. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal */ -/* matrix. */ -/* On normal exit, D contains the eigenvalues, in descending */ -/* order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix. */ -/* On exit, E has been destroyed. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* On entry, if COMPZ = 'V', the orthogonal matrix used in the */ -/* reduction to tridiagonal form. */ -/* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */ -/* original symmetric matrix; */ -/* if COMPZ = 'I', the orthonormal eigenvectors of the */ -/* tridiagonal matrix. */ -/* If INFO > 0 on exit, Z contains the eigenvectors associated */ -/* with only the stored eigenvalues. */ -/* If COMPZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* COMPZ = 'V' or 'I', LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = i, and i is: */ -/* <= N the Cholesky factorization of the matrix could */ -/* not be performed because the i-th principal minor */ -/* was not positive definite. */ -/* > N the SVD algorithm failed to converge; */ -/* if INFO = N+i, i off-diagonal elements of the */ -/* bidiagonal factor did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - *info = 0; - - if (lsame_(compz, "N")) { - icompz = 0; - } else if (lsame_(compz, "V")) { - icompz = 1; - } else if (lsame_(compz, "I")) { - icompz = 2; - } else { - icompz = -1; - } - if (icompz < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldz < 1 || icompz > 0 && *ldz < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPTEQR", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (icompz > 0) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - if (icompz == 2) { - dlaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz); - } - -/* Call DPTTRF to factor the matrix. */ - - dpttrf_(n, &d__[1], &e[1], info); - if (*info != 0) { - return 0; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = sqrt(d__[i__]); -/* L10: */ - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - e[i__] *= d__[i__]; -/* L20: */ - } - -/* Call DBDSQR to compute the singular values/vectors of the */ -/* bidiagonal factor. */ - - if (icompz > 0) { - nru = *n; - } else { - nru = 0; - } - dbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[ - z_offset], ldz, c__, &c__1, &work[1], info); - -/* Square the singular values. */ - - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] *= d__[i__]; -/* L30: */ - } - } else { - *info = *n + *info; - } - - return 0; - -/* End of DPTEQR */ - -} /* dpteqr_ */ diff --git a/external/clapack/lapack/dptrfs.cpp b/external/clapack/lapack/dptrfs.cpp deleted file mode 100644 index 93d7cb56..00000000 --- a/external/clapack/lapack/dptrfs.cpp +++ /dev/null @@ -1,345 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b11 = 1.; - -/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, double *d__, - double *e, double *df, double *ef, double *b, integer - *ldb, double *x, integer *ldx, double *ferr, double *berr, - double *work, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j; - double s, bi, cx, dx, ex; - integer ix, nz; - double eps, safe1, safe2; - integer count; - double safmin; - double lstres; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPTRFS improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is symmetric positive definite */ -/* and tridiagonal, and provides error bounds and backward error */ -/* estimates for the solution. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix A. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */ - -/* DF (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the diagonal matrix D from the */ -/* factorization computed by DPTTRF. */ - -/* EF (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the unit bidiagonal factor */ -/* L from the factorization computed by DPTTRF. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DPTTRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --df; - --ef; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*nrhs < 0) { - *info = -2; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPTRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = 4; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - A * X. Also compute */ -/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */ - - if (*n == 1) { - bi = b[j * b_dim1 + 1]; - dx = d__[1] * x[j * x_dim1 + 1]; - work[*n + 1] = bi - dx; - work[1] = abs(bi) + abs(dx); - } else { - bi = b[j * b_dim1 + 1]; - dx = d__[1] * x[j * x_dim1 + 1]; - ex = e[1] * x[j * x_dim1 + 2]; - work[*n + 1] = bi - dx - ex; - work[1] = abs(bi) + abs(dx) + abs(ex); - i__2 = *n - 1; - for (i__ = 2; i__ <= i__2; ++i__) { - bi = b[i__ + j * b_dim1]; - cx = e[i__ - 1] * x[i__ - 1 + j * x_dim1]; - dx = d__[i__] * x[i__ + j * x_dim1]; - ex = e[i__] * x[i__ + 1 + j * x_dim1]; - work[*n + i__] = bi - cx - dx - ex; - work[i__] = abs(bi) + abs(cx) + abs(dx) + abs(ex); -/* L30: */ - } - bi = b[*n + j * b_dim1]; - cx = e[*n - 1] * x[*n - 1 + j * x_dim1]; - dx = d__[*n] * x[*n + j * x_dim1]; - work[*n + *n] = bi - cx - dx; - work[*n] = abs(bi) + abs(cx) + abs(dx); - } - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L40: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dpttrs_(n, &c__1, &df[1], &ef[1], &work[*n + 1], n, info); - daxpy_(n, &c_b11, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(A))* */ -/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(A) is the inverse of A */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L50: */ - } - ix = idamax_(n, &work[1], &c__1); - ferr[j] = work[ix]; - -/* Estimate the norm of inv(A). */ - -/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */ - -/* m(i,j) = abs(A(i,j)), i = j, */ -/* m(i,j) = -abs(A(i,j)), i .ne. j, */ - -/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */ - -/* Solve M(L) * x = e. */ - - work[1] = 1.; - i__2 = *n; - for (i__ = 2; i__ <= i__2; ++i__) { - work[i__] = work[i__ - 1] * (d__1 = ef[i__ - 1], abs(d__1)) + 1.; -/* L60: */ - } - -/* Solve D * M(L)' * x = b. */ - - work[*n] /= df[*n]; - for (i__ = *n - 1; i__ >= 1; --i__) { - work[i__] = work[i__] / df[i__] + work[i__ + 1] * (d__1 = ef[i__], - abs(d__1)); -/* L70: */ - } - -/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */ - - ix = idamax_(n, &work[1], &c__1); - ferr[j] *= (d__1 = work[ix], abs(d__1)); - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L80: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L90: */ - } - - return 0; - -/* End of DPTRFS */ - -} /* dptrfs_ */ diff --git a/external/clapack/lapack/dptsv.cpp b/external/clapack/lapack/dptsv.cpp deleted file mode 100644 index 5822e203..00000000 --- a/external/clapack/lapack/dptsv.cpp +++ /dev/null @@ -1,111 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dptsv_(integer *n, integer *nrhs, double *d__, - double *e, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPTSV computes the solution to a real system of linear equations */ -/* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal */ -/* matrix, and X and B are N-by-NRHS matrices. */ - -/* A is factored as A = L*D*L**T, and the factored form of A is then */ -/* used to solve the system of equations. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix */ -/* A. On exit, the n diagonal elements of the diagonal matrix */ -/* D from the factorization A = L*D*L**T. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix A. On exit, the (n-1) subdiagonal elements of the */ -/* unit bidiagonal factor L from the L*D*L**T factorization of */ -/* A. (E can also be regarded as the superdiagonal of the unit */ -/* bidiagonal factor U from the U**T*D*U factorization of A.) */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i is not */ -/* positive definite, and the solution has not been */ -/* computed. The factorization has not been completed */ -/* unless i = N. */ - -/* ===================================================================== */ - -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*nrhs < 0) { - *info = -2; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPTSV ", &i__1); - return 0; - } - -/* Compute the L*D*L' (or U'*D*U) factorization of A. */ - - dpttrf_(n, &d__[1], &e[1], info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dpttrs_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info); - } - return 0; - -/* End of DPTSV */ - -} /* dptsv_ */ diff --git a/external/clapack/lapack/dptsvx.cpp b/external/clapack/lapack/dptsvx.cpp deleted file mode 100644 index e6a583d3..00000000 --- a/external/clapack/lapack/dptsvx.cpp +++ /dev/null @@ -1,254 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dptsvx_(const char *fact, integer *n, integer *nrhs, - double *d__, double *e, double *df, double *ef, - double *b, integer *ldb, double *x, integer *ldx, double * - rcond, double *ferr, double *berr, double *work, integer * - info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1; - - /* Local variables */ - double anorm; - bool nofact; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPTSVX uses the factorization A = L*D*L**T to compute the solution */ -/* to a real system of linear equations A*X = B, where A is an N-by-N */ -/* symmetric positive definite tridiagonal matrix and X and B are */ -/* N-by-NRHS matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L */ -/* is a unit lower bidiagonal matrix and D is diagonal. The */ -/* factorization can also be regarded as having the form */ -/* A = U**T*D*U. */ - -/* 2. If the leading i-by-i principal minor is not positive definite, */ -/* then the routine returns with INFO = i. Otherwise, the factored */ -/* form of A is used to estimate the condition number of the matrix */ -/* A. If the reciprocal of the condition number is less than machine */ -/* precision, INFO = N+1 is returned as a warning, but the routine */ -/* still goes on to solve for X and compute error bounds as */ -/* described below. */ - -/* 3. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 4. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of A has been */ -/* supplied on entry. */ -/* = 'F': On entry, DF and EF contain the factored form of A. */ -/* D, E, DF, and EF will not be modified. */ -/* = 'N': The matrix A will be copied to DF and EF and */ -/* factored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix A. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */ - -/* DF (input or output) DOUBLE PRECISION array, dimension (N) */ -/* If FACT = 'F', then DF is an input argument and on entry */ -/* contains the n diagonal elements of the diagonal matrix D */ -/* from the L*D*L**T factorization of A. */ -/* If FACT = 'N', then DF is an output argument and on exit */ -/* contains the n diagonal elements of the diagonal matrix D */ -/* from the L*D*L**T factorization of A. */ - -/* EF (input or output) DOUBLE PRECISION array, dimension (N-1) */ -/* If FACT = 'F', then EF is an input argument and on entry */ -/* contains the (n-1) subdiagonal elements of the unit */ -/* bidiagonal factor L from the L*D*L**T factorization of A. */ -/* If FACT = 'N', then EF is an output argument and on exit */ -/* contains the (n-1) subdiagonal elements of the unit */ -/* bidiagonal factor L from the L*D*L**T factorization of A. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The N-by-NRHS right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal condition number of the matrix A. If RCOND */ -/* is less than the machine precision (in particular, if */ -/* RCOND = 0), the matrix is singular to working precision. */ -/* This condition is indicated by a return code of INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in any */ -/* element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= N: the leading minor of order i of A is */ -/* not positive definite, so the factorization */ -/* could not be completed, and the solution has not */ -/* been computed. RCOND = 0 is returned. */ -/* = N+1: U is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --df; - --ef; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - if (! nofact && ! lsame_(fact, "F")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -11; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPTSVX", &i__1); - return 0; - } - - if (nofact) { - -/* Compute the L*D*L' (or U'*D*U) factorization of A. */ - - dcopy_(n, &d__[1], &c__1, &df[1], &c__1); - if (*n > 1) { - i__1 = *n - 1; - dcopy_(&i__1, &e[1], &c__1, &ef[1], &c__1); - } - dpttrf_(n, &df[1], &ef[1], info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A. */ - - anorm = dlanst_("1", n, &d__[1], &e[1]); - -/* Compute the reciprocal of the condition number of A. */ - - dptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info); - -/* Compute the solution vectors X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dpttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solutions and */ -/* compute error bounds and backward error estimates for them. */ - - dptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[ - x_offset], ldx, &ferr[1], &berr[1], &work[1], info); - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - - return 0; - -/* End of DPTSVX */ - -} /* dptsvx_ */ diff --git a/external/clapack/lapack/dpttrf.cpp b/external/clapack/lapack/dpttrf.cpp deleted file mode 100644 index f7bdf3e9..00000000 --- a/external/clapack/lapack/dpttrf.cpp +++ /dev/null @@ -1,169 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dpttrf_(integer *n, double *d__, double *e, - integer *info) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, i4; - double ei; - - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPTTRF computes the L*D*L' factorization of a real symmetric */ -/* positive definite tridiagonal matrix A. The factorization may also */ -/* be regarded as having the form A = U'*D*U. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix */ -/* A. On exit, the n diagonal elements of the diagonal matrix */ -/* D from the L*D*L' factorization of A. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix A. On exit, the (n-1) subdiagonal elements of the */ -/* unit bidiagonal factor L from the L*D*L' factorization of A. */ -/* E can also be regarded as the superdiagonal of the unit */ -/* bidiagonal factor U from the U'*D*U factorization of A. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, the leading minor of order k is not */ -/* positive definite; if k < N, the factorization could not */ -/* be completed, while if k = N, the factorization was */ -/* completed, but D(N) <= 0. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --e; - --d__; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - i__1 = -(*info); - xerbla_("DPTTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Compute the L*D*L' (or U'*D*U) factorization of A. */ - - i4 = (*n - 1) % 4; - i__1 = i4; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] <= 0.) { - *info = i__; - goto L30; - } - ei = e[i__]; - e[i__] = ei / d__[i__]; - d__[i__ + 1] -= e[i__] * ei; -/* L10: */ - } - - i__1 = *n - 4; - for (i__ = i4 + 1; i__ <= i__1; i__ += 4) { - -/* Drop out of the loop if d(i) <= 0: the matrix is not positive */ -/* definite. */ - - if (d__[i__] <= 0.) { - *info = i__; - goto L30; - } - -/* Solve for e(i) and d(i+1). */ - - ei = e[i__]; - e[i__] = ei / d__[i__]; - d__[i__ + 1] -= e[i__] * ei; - - if (d__[i__ + 1] <= 0.) { - *info = i__ + 1; - goto L30; - } - -/* Solve for e(i+1) and d(i+2). */ - - ei = e[i__ + 1]; - e[i__ + 1] = ei / d__[i__ + 1]; - d__[i__ + 2] -= e[i__ + 1] * ei; - - if (d__[i__ + 2] <= 0.) { - *info = i__ + 2; - goto L30; - } - -/* Solve for e(i+2) and d(i+3). */ - - ei = e[i__ + 2]; - e[i__ + 2] = ei / d__[i__ + 2]; - d__[i__ + 3] -= e[i__ + 2] * ei; - - if (d__[i__ + 3] <= 0.) { - *info = i__ + 3; - goto L30; - } - -/* Solve for e(i+3) and d(i+4). */ - - ei = e[i__ + 3]; - e[i__ + 3] = ei / d__[i__ + 3]; - d__[i__ + 4] -= e[i__ + 3] * ei; -/* L20: */ - } - -/* Check d(n) for positive definiteness. */ - - if (d__[*n] <= 0.) { - *info = *n; - } - -L30: - return 0; - -/* End of DPTTRF */ - -} /* dpttrf_ */ diff --git a/external/clapack/lapack/dpttrs.cpp b/external/clapack/lapack/dpttrs.cpp deleted file mode 100644 index 739ddba1..00000000 --- a/external/clapack/lapack/dpttrs.cpp +++ /dev/null @@ -1,140 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dpttrs_(integer *n, integer *nrhs, double *d__, - double *e, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer j, jb, nb; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPTTRS solves a tridiagonal system of the form */ -/* A * X = B */ -/* using the L*D*L' factorization of A computed by DPTTRF. D is a */ -/* diagonal matrix specified in the vector D, L is a unit bidiagonal */ -/* matrix whose subdiagonal is specified in the vector E, and X and B */ -/* are N by NRHS matrices. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the tridiagonal matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the diagonal matrix D from the */ -/* L*D*L' factorization of A. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the unit bidiagonal factor */ -/* L from the L*D*L' factorization of A. E can also be regarded */ -/* as the superdiagonal of the unit bidiagonal factor U from the */ -/* factorization A = U'*D*U. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side vectors B for the system of */ -/* linear equations. */ -/* On exit, the solution vectors, X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments. */ - - /* Parameter adjustments */ - --d__; - --e; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*nrhs < 0) { - *info = -2; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPTTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - -/* Determine the number of right-hand sides to solve at a time. */ - - if (*nrhs == 1) { - nb = 1; - } else { -/* Computing MAX */ - i__1 = 1, i__2 = ilaenv_(&c__1, "DPTTRS", " ", n, nrhs, &c_n1, &c_n1); - nb = std::max(i__1,i__2); - } - - if (nb >= *nrhs) { - dptts2_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb); - } else { - i__1 = *nrhs; - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nrhs - j + 1; - jb = std::min(i__3,nb); - dptts2_(n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb); -/* L10: */ - } - } - - return 0; - -/* End of DPTTRS */ - -} /* dpttrs_ */ diff --git a/external/clapack/lapack/dptts2.cpp b/external/clapack/lapack/dptts2.cpp deleted file mode 100644 index 4d9b7ca6..00000000 --- a/external/clapack/lapack/dptts2.cpp +++ /dev/null @@ -1,116 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dptts2_(integer *n, integer *nrhs, double *d__, - double *e, double *b, integer *ldb) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, j; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPTTS2 solves a tridiagonal system of the form */ -/* A * X = B */ -/* using the L*D*L' factorization of A computed by DPTTRF. D is a */ -/* diagonal matrix specified in the vector D, L is a unit bidiagonal */ -/* matrix whose subdiagonal is specified in the vector E, and X and B */ -/* are N by NRHS matrices. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the tridiagonal matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the diagonal matrix D from the */ -/* L*D*L' factorization of A. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the unit bidiagonal factor */ -/* L from the L*D*L' factorization of A. E can also be regarded */ -/* as the superdiagonal of the unit bidiagonal factor U from the */ -/* factorization A = U'*D*U. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side vectors B for the system of */ -/* linear equations. */ -/* On exit, the solution vectors, X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - --d__; - --e; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - if (*n <= 1) { - if (*n == 1) { - d__1 = 1. / d__[1]; - dscal_(nrhs, &d__1, &b[b_offset], ldb); - } - return 0; - } - -/* Solve A * X = B using the factorization A = L*D*L', */ -/* overwriting each right hand side vector with its solution. */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Solve L * x = b. */ - - i__2 = *n; - for (i__ = 2; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] -= b[i__ - 1 + j * b_dim1] * e[i__ - 1]; -/* L10: */ - } - -/* Solve D * L' * x = b. */ - - b[*n + j * b_dim1] /= d__[*n]; - for (i__ = *n - 1; i__ >= 1; --i__) { - b[i__ + j * b_dim1] = b[i__ + j * b_dim1] / d__[i__] - b[i__ + 1 - + j * b_dim1] * e[i__]; -/* L20: */ - } -/* L30: */ - } - - return 0; - -/* End of DPTTS2 */ - -} /* dptts2_ */ diff --git a/external/clapack/lapack/drscl.cpp b/external/clapack/lapack/drscl.cpp deleted file mode 100644 index e8e05898..00000000 --- a/external/clapack/lapack/drscl.cpp +++ /dev/null @@ -1,119 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int drscl_(integer *n, double *sa, double *sx, - integer *incx) -{ - double mul, cden; - bool done; - double cnum, cden1, cnum1; - double bignum, smlnum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DRSCL multiplies an n-element real vector x by the real scalar 1/a. */ -/* This is done without overflow or underflow as long as */ -/* the final result x/a does not overflow or underflow. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of components of the vector x. */ - -/* SA (input) DOUBLE PRECISION */ -/* The scalar a which is used to divide each component of x. */ -/* SA must be >= 0, or the subroutine will divide by zero. */ - -/* SX (input/output) DOUBLE PRECISION array, dimension */ -/* (1+(N-1)*abs(INCX)) */ -/* The n-element vector x. */ - -/* INCX (input) INTEGER */ -/* The increment between successive values of the vector SX. */ -/* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick return if possible */ - - /* Parameter adjustments */ - --sx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - -/* Get machine parameters */ - - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Initialize the denominator to SA and the numerator to 1. */ - - cden = *sa; - cnum = 1.; - -L10: - cden1 = cden * smlnum; - cnum1 = cnum / bignum; - if (abs(cden1) > abs(cnum) && cnum != 0.) { - -/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ - - mul = smlnum; - done = false; - cden = cden1; - } else if (abs(cnum1) > abs(cden)) { - -/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ - - mul = bignum; - done = false; - cnum = cnum1; - } else { - -/* Multiply X by CNUM / CDEN and return. */ - - mul = cnum / cden; - done = true; - } - -/* Scale the vector X by MUL */ - - dscal_(n, &mul, &sx[1], incx); - - if (! done) { - goto L10; - } - - return 0; - -/* End of DRSCL */ - -} /* drscl_ */ diff --git a/external/clapack/lapack/dsbev.cpp b/external/clapack/lapack/dsbev.cpp deleted file mode 100644 index 98d95da0..00000000 --- a/external/clapack/lapack/dsbev.cpp +++ /dev/null @@ -1,237 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b11 = 1.; -static integer c__1 = 1; - -/* Subroutine */ int dsbev_(const char *jobz, const char *uplo, integer *n, integer *kd, - double *ab, integer *ldab, double *w, double *z__, - integer *ldz, double *work, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, z_dim1, z_offset, i__1; - double d__1; - - /* Local variables */ - double eps; - integer inde; - double anrm; - integer imax; - double rmin, rmax; - double sigma; - integer iinfo; - bool lower, wantz; - integer iscale; - double safmin; - double bignum; - integer indwrk; - double smlnum; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBEV computes all the eigenvalues and, optionally, eigenvectors of */ -/* a real symmetric band matrix A. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* On exit, AB is overwritten by values generated during the */ -/* reduction to tridiagonal form. If UPLO = 'U', the first */ -/* superdiagonal and the diagonal of the tridiagonal matrix T */ -/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ -/* the diagonal and first subdiagonal of T are returned in the */ -/* first two rows of AB. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD + 1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ -/* eigenvectors of the matrix A, with the i-th column of Z */ -/* holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2)) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the algorithm failed to converge; i */ -/* off-diagonal elements of an intermediate tridiagonal */ -/* form did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - lower = lsame_(uplo, "L"); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*kd < 0) { - *info = -4; - } else if (*ldab < *kd + 1) { - *info = -6; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -9; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSBEV ", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (lower) { - w[1] = ab[ab_dim1 + 1]; - } else { - w[1] = ab[*kd + 1 + ab_dim1]; - } - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); - rmax = sqrt(bignum); - -/* Scale matrix to allowable range, if necessary. */ - - anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); - iscale = 0; - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - if (lower) { - dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, - info); - } else { - dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, - info); - } - } - -/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ - - inde = 1; - indwrk = inde + *n; - dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ - z_offset], ldz, &work[indwrk], &iinfo); - -/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */ - - if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); - } else { - dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ - indwrk], info); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (iscale == 1) { - if (*info == 0) { - imax = *n; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - - return 0; - -/* End of DSBEV */ - -} /* dsbev_ */ diff --git a/external/clapack/lapack/dsbevd.cpp b/external/clapack/lapack/dsbevd.cpp deleted file mode 100644 index 45045084..00000000 --- a/external/clapack/lapack/dsbevd.cpp +++ /dev/null @@ -1,303 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b11 = 1.; -static double c_b18 = 0.; -static integer c__1 = 1; - -/* Subroutine */ int dsbevd_(const char *jobz, const char *uplo, integer *n, integer *kd, - double *ab, integer *ldab, double *w, double *z__, - integer *ldz, double *work, integer *lwork, integer *iwork, - integer *liwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, z_dim1, z_offset, i__1; - double d__1; - - /* Local variables */ - double eps; - integer inde; - double anrm, rmin, rmax; - double sigma; - integer iinfo, lwmin; - bool lower, wantz; - integer indwk2, llwrk2; - integer iscale; - double safmin; - double bignum; - integer indwrk, liwmin; - double smlnum; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of */ -/* a real symmetric band matrix A. If eigenvectors are desired, it uses */ -/* a divide and conquer algorithm. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* On exit, AB is overwritten by values generated during the */ -/* reduction to tridiagonal form. If UPLO = 'U', the first */ -/* superdiagonal and the diagonal of the tridiagonal matrix T */ -/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ -/* the diagonal and first subdiagonal of T are returned in the */ -/* first two rows of AB. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD + 1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ -/* eigenvectors of the matrix A, with the i-th column of Z */ -/* holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace/output) 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 N <= 1, LWORK must be at least 1. */ -/* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. */ -/* If JOBZ = 'V' and N > 2, LWORK must be at least */ -/* ( 1 + 5*N + 2*N**2 ). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array LIWORK. */ -/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ -/* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the algorithm failed to converge; i */ -/* off-diagonal elements of an intermediate tridiagonal */ -/* form did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - lower = lsame_(uplo, "L"); - lquery = *lwork == -1 || *liwork == -1; - - *info = 0; - if (*n <= 1) { - liwmin = 1; - lwmin = 1; - } else { - if (wantz) { - liwmin = *n * 5 + 3; -/* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 5 + 1 + (i__1 * i__1 << 1); - } else { - liwmin = 1; - lwmin = *n << 1; - } - } - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*kd < 0) { - *info = -4; - } else if (*ldab < *kd + 1) { - *info = -6; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -9; - } - - if (*info == 0) { - work[1] = (double) lwmin; - iwork[1] = liwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -11; - } else if (*liwork < liwmin && ! lquery) { - *info = -13; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSBEVD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - w[1] = ab[ab_dim1 + 1]; - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); - rmax = sqrt(bignum); - -/* Scale matrix to allowable range, if necessary. */ - - anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); - iscale = 0; - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - if (lower) { - dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, - info); - } else { - dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, - info); - } - } - -/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ - - inde = 1; - indwrk = inde + *n; - indwk2 = indwrk + *n * *n; - llwrk2 = *lwork - indwk2 + 1; - dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ - z_offset], ldz, &work[indwrk], &iinfo); - -/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */ - - if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); - } else { - dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & - llwrk2, &iwork[1], liwork, info); - dgemm_("N", "N", n, n, n, &c_b11, &z__[z_offset], ldz, &work[indwrk], - n, &c_b18, &work[indwk2], n); - dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (iscale == 1) { - d__1 = 1. / sigma; - dscal_(n, &d__1, &w[1], &c__1); - } - - work[1] = (double) lwmin; - iwork[1] = liwmin; - return 0; - -/* End of DSBEVD */ - -} /* dsbevd_ */ diff --git a/external/clapack/lapack/dsbevx.cpp b/external/clapack/lapack/dsbevx.cpp deleted file mode 100644 index 0d42704e..00000000 --- a/external/clapack/lapack/dsbevx.cpp +++ /dev/null @@ -1,474 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b14 = 1.; -static integer c__1 = 1; -static double c_b34 = 0.; - -/* Subroutine */ int dsbevx_(const char *jobz, const char *range, const char *uplo, integer *n, - integer *kd, double *ab, integer *ldab, double *q, integer * - ldq, double *vl, double *vu, integer *il, integer *iu, - double *abstol, integer *m, double *w, double *z__, - integer *ldz, double *work, integer *iwork, integer *ifail, - integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, - i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, jj; - double eps, vll, vuu, tmp1; - integer indd, inde; - double anrm; - integer imax; - double rmin, rmax; - bool test; - integer itmp1, indee; - double sigma; - integer iinfo; - char order[1]; - bool lower, wantz; - bool alleig, indeig; - integer iscale, indibl; - bool valeig; - double safmin; - double abstll, bignum; - integer indisp; - integer indiwo; - integer indwrk; - integer nsplit; - double smlnum; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBEVX computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric band matrix A. Eigenvalues and eigenvectors can */ -/* be selected by specifying either a range of values or a range of */ -/* indices for the desired eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found; */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found; */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* On exit, AB is overwritten by values generated during the */ -/* reduction to tridiagonal form. If UPLO = 'U', the first */ -/* superdiagonal and the diagonal of the tridiagonal matrix T */ -/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ -/* the diagonal and first subdiagonal of T are returned in the */ -/* first two rows of AB. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD + 1. */ - -/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */ -/* If JOBZ = 'V', the N-by-N orthogonal matrix used in the */ -/* reduction to tridiagonal form. */ -/* If JOBZ = 'N', the array Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. If JOBZ = 'V', then */ -/* LDQ >= max(1,N). */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing AB to tridiagonal form. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ -/* If this routine returns with INFO>0, indicating that some */ -/* eigenvectors did not converge, try setting ABSTOL to */ -/* 2*DLAMCH('S'). */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices */ -/* with Guaranteed High Relative Accuracy," by Demmel and */ -/* Kahan, LAPACK Working Note #3. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If an eigenvector fails to converge, then that column of Z */ -/* contains the latest approximation to the eigenvector, and the */ -/* index of the eigenvector is returned in IFAIL. */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (7*N) */ - -/* IWORK (workspace) INTEGER array, dimension (5*N) */ - -/* IFAIL (output) INTEGER array, dimension (N) */ -/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ -/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ -/* indices of the eigenvectors that failed to converge. */ -/* If JOBZ = 'N', then IFAIL is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* Their indices are stored in array IFAIL. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - lower = lsame_(uplo, "L"); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*kd < 0) { - *info = -5; - } else if (*ldab < *kd + 1) { - *info = -7; - } else if (wantz && *ldq < std::max(1_integer,*n)) { - *info = -9; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -11; - } - } else if (indeig) { - if (*il < 1 || *il > std::max(1_integer,*n)) { - *info = -12; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -13; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -18; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSBEVX", &i__1); - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - - if (*n == 1) { - *m = 1; - if (lower) { - tmp1 = ab[ab_dim1 + 1]; - } else { - tmp1 = ab[*kd + 1 + ab_dim1]; - } - if (valeig) { - if (! (*vl < tmp1 && *vu >= tmp1)) { - *m = 0; - } - } - if (*m == 1) { - w[1] = tmp1; - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = std::min(d__1,d__2); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - abstll = *abstol; - if (valeig) { - vll = *vl; - vuu = *vu; - } else { - vll = 0.; - vuu = 0.; - } - anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - if (lower) { - dlascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab, - info); - } else { - dlascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab, - info); - } - if (*abstol > 0.) { - abstll = *abstol * sigma; - } - if (valeig) { - vll = *vl * sigma; - vuu = *vu * sigma; - } - } - -/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ - - indd = 1; - inde = indd + *n; - indwrk = inde + *n; - dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde], - &q[q_offset], ldq, &work[indwrk], &iinfo); - -/* If all eigenvalues are desired and ABSTOL is less than or equal */ -/* to zero, then call DSTERF or SSTEQR. If this fails for some */ -/* eigenvalue, then try DSTEBZ. */ - - test = false; - if (indeig) { - if (*il == 1 && *iu == *n) { - test = true; - } - } - if ((alleig || test) && *abstol <= 0.) { - dcopy_(n, &work[indd], &c__1, &w[1], &c__1); - indee = indwrk + (*n << 1); - if (! wantz) { - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dsterf_(n, &w[1], &work[indee], info); - } else { - dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz); - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ - indwrk], info); - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - ifail[i__] = 0; -/* L10: */ - } - } - } - if (*info == 0) { - *m = *n; - goto L30; - } - *info = 0; - } - -/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - indibl = 1; - indisp = indibl + *n; - indiwo = indisp + *n; - dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ - inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); - - if (wantz) { - dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ - indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by DSTEIN. */ - - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1); - dgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, & - c_b34, &z__[j * z_dim1 + 1], &c__1); -/* L20: */ - } - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - -L30: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L40: */ - } - - if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; - w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; - w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - if (*info != 0) { - itmp1 = ifail[i__]; - ifail[i__] = ifail[j]; - ifail[j] = itmp1; - } - } -/* L50: */ - } - } - - return 0; - -/* End of DSBEVX */ - -} /* dsbevx_ */ diff --git a/external/clapack/lapack/dsbgst.cpp b/external/clapack/lapack/dsbgst.cpp deleted file mode 100644 index 999bdab9..00000000 --- a/external/clapack/lapack/dsbgst.cpp +++ /dev/null @@ -1,1728 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b8 = 0.; -static double c_b9 = 1.; -static integer c__1 = 1; -static double c_b20 = -1.; - -/* Subroutine */ int dsbgst_(const char *vect, const char *uplo, integer *n, integer *ka, - integer *kb, double *ab, integer *ldab, double *bb, integer * - ldbb, double *x, integer *ldx, double *work, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, bb_dim1, bb_offset, x_dim1, x_offset, i__1, - i__2, i__3, i__4; - double d__1; - - /* Local variables */ - integer i__, j, k, l, m; - double t; - integer i0, i1, i2, j1, j2; - double ra; - integer nr, nx, ka1, kb1; - double ra1; - integer j1t, j2t; - double bii; - integer kbt, nrt, inca; - bool upper, wantx; - bool update; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBGST reduces a real symmetric-definite banded generalized */ -/* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, */ -/* such that C has the same bandwidth as A. */ - -/* B must have been previously factorized as S**T*S by DPBSTF, using a */ -/* split Cholesky factorization. A is overwritten by C = X**T*A*X, where */ -/* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the */ -/* bandwidth of A. */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* = 'N': do not form the transformation matrix X; */ -/* = 'V': form X. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* KA (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ - -/* KB (input) INTEGER */ -/* The number of superdiagonals of the matrix B if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first ka+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ - -/* On exit, the transformed matrix X**T*A*X, stored in the same */ -/* format as A. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KA+1. */ - -/* BB (input) DOUBLE PRECISION array, dimension (LDBB,N) */ -/* The banded factor S from the split Cholesky factorization of */ -/* B, as returned by DPBSTF, stored in the first KB+1 rows of */ -/* the array. */ - -/* LDBB (input) INTEGER */ -/* The leading dimension of the array BB. LDBB >= KB+1. */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,N) */ -/* If VECT = 'V', the n-by-n matrix X. */ -/* If VECT = 'N', the array X is not referenced. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. */ -/* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - bb_dim1 = *ldbb; - bb_offset = 1 + bb_dim1; - bb -= bb_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --work; - - /* Function Body */ - wantx = lsame_(vect, "V"); - upper = lsame_(uplo, "U"); - ka1 = *ka + 1; - kb1 = *kb + 1; - *info = 0; - if (! wantx && ! lsame_(vect, "N")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ka < 0) { - *info = -4; - } else if (*kb < 0 || *kb > *ka) { - *info = -5; - } else if (*ldab < *ka + 1) { - *info = -7; - } else if (*ldbb < *kb + 1) { - *info = -9; - } else if (*ldx < 1 || wantx && *ldx < std::max(1_integer,*n)) { - *info = -11; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSBGST", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - inca = *ldab * ka1; - -/* Initialize X to the unit matrix, if needed */ - - if (wantx) { - dlaset_("Full", n, n, &c_b8, &c_b9, &x[x_offset], ldx); - } - -/* Set M to the splitting point m. It must be the same value as is */ -/* used in DPBSTF. The chosen value allows the arrays WORK and RWORK */ -/* to be of dimension (N). */ - - m = (*n + *kb) / 2; - -/* The routine works in two phases, corresponding to the two halves */ -/* of the split Cholesky factorization of B as S**T*S where */ - -/* S = ( U ) */ -/* ( M L ) */ - -/* with U upper triangular of order m, and L lower triangular of */ -/* order n-m. S has the same bandwidth as B. */ - -/* S is treated as a product of elementary matrices: */ - -/* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) */ - -/* where S(i) is determined by the i-th row of S. */ - -/* In phase 1, the index i takes the values n, n-1, ... , m+1; */ -/* in phase 2, it takes the values 1, 2, ... , m. */ - -/* For each value of i, the current matrix A is updated by forming */ -/* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside */ -/* the band of A. The bulge is then pushed down toward the bottom of */ -/* A in phase 1, and up toward the top of A in phase 2, by applying */ -/* plane rotations. */ - -/* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 */ -/* of them are linearly independent, so annihilating a bulge requires */ -/* only 2*kb-1 plane rotations. The rotations are divided into a 1st */ -/* set of kb-1 rotations, and a 2nd set of kb rotations. */ - -/* Wherever possible, rotations are generated and applied in vector */ -/* operations of length NR between the indices J1 and J2 (sometimes */ -/* replaced by modified values NRT, J1T or J2T). */ - -/* The cosines and sines of the rotations are stored in the array */ -/* WORK. The cosines of the 1st set of rotations are stored in */ -/* elements n+2:n+m-kb-1 and the sines of the 1st set in elements */ -/* 2:m-kb-1; the cosines of the 2nd set are stored in elements */ -/* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. */ - -/* The bulges are not formed explicitly; nonzero elements outside the */ -/* band are created only when they are required for generating new */ -/* rotations; they are stored in the array WORK, in positions where */ -/* they are later overwritten by the sines of the rotations which */ -/* annihilate them. */ - -/* **************************** Phase 1 ***************************** */ - -/* The logical structure of this phase is: */ - -/* UPDATE = .TRUE. */ -/* DO I = N, M + 1, -1 */ -/* use S(i) to update A and create a new bulge */ -/* apply rotations to push all bulges KA positions downward */ -/* END DO */ -/* UPDATE = .FALSE. */ -/* DO I = M + KA + 1, N - 1 */ -/* apply rotations to push all bulges KA positions downward */ -/* END DO */ - -/* To avoid duplicating code, the two loops are merged. */ - - update = true; - i__ = *n + 1; -L10: - if (update) { - --i__; -/* Computing MIN */ - i__1 = *kb, i__2 = i__ - 1; - kbt = std::min(i__1,i__2); - i0 = i__ - 1; -/* Computing MIN */ - i__1 = *n, i__2 = i__ + *ka; - i1 = std::min(i__1,i__2); - i2 = i__ - kbt + ka1; - if (i__ < m + 1) { - update = false; - ++i__; - i0 = m; - if (*ka == 0) { - goto L480; - } - goto L10; - } - } else { - i__ += *ka; - if (i__ > *n - 1) { - goto L480; - } - } - - if (upper) { - -/* Transform A, working with the upper triangle */ - - if (update) { - -/* Form inv(S(i))**T * A * inv(S(i)) */ - - bii = bb[kb1 + i__ * bb_dim1]; - i__1 = i1; - for (j = i__; j <= i__1; ++j) { - ab[i__ - j + ka1 + j * ab_dim1] /= bii; -/* L20: */ - } -/* Computing MAX */ - i__1 = 1, i__2 = i__ - *ka; - i__3 = i__; - for (j = std::max(i__1,i__2); j <= i__3; ++j) { - ab[j - i__ + ka1 + i__ * ab_dim1] /= bii; -/* L30: */ - } - i__3 = i__ - 1; - for (k = i__ - kbt; k <= i__3; ++k) { - i__1 = k; - for (j = i__ - kbt; j <= i__1; ++j) { - ab[j - k + ka1 + k * ab_dim1] = ab[j - k + ka1 + k * - ab_dim1] - bb[j - i__ + kb1 + i__ * bb_dim1] * ab[ - k - i__ + ka1 + i__ * ab_dim1] - bb[k - i__ + kb1 - + i__ * bb_dim1] * ab[j - i__ + ka1 + i__ * - ab_dim1] + ab[ka1 + i__ * ab_dim1] * bb[j - i__ + - kb1 + i__ * bb_dim1] * bb[k - i__ + kb1 + i__ * - bb_dim1]; -/* L40: */ - } -/* Computing MAX */ - i__1 = 1, i__2 = i__ - *ka; - i__4 = i__ - kbt - 1; - for (j = std::max(i__1,i__2); j <= i__4; ++j) { - ab[j - k + ka1 + k * ab_dim1] -= bb[k - i__ + kb1 + i__ * - bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1]; -/* L50: */ - } -/* L60: */ - } - i__3 = i1; - for (j = i__; j <= i__3; ++j) { -/* Computing MAX */ - i__4 = j - *ka, i__1 = i__ - kbt; - i__2 = i__ - 1; - for (k = std::max(i__4,i__1); k <= i__2; ++k) { - ab[k - j + ka1 + j * ab_dim1] -= bb[k - i__ + kb1 + i__ * - bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1]; -/* L70: */ - } -/* L80: */ - } - - if (wantx) { - -/* post-multiply X by inv(S(i)) */ - - i__3 = *n - m; - d__1 = 1. / bii; - dscal_(&i__3, &d__1, &x[m + 1 + i__ * x_dim1], &c__1); - if (kbt > 0) { - i__3 = *n - m; - dger_(&i__3, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], & - c__1, &bb[kb1 - kbt + i__ * bb_dim1], &c__1, &x[m - + 1 + (i__ - kbt) * x_dim1], ldx); - } - } - -/* store a(i,i1) in RA1 for use in next loop over K */ - - ra1 = ab[i__ - i1 + ka1 + i1 * ab_dim1]; - } - -/* Generate and apply vectors of rotations to chase all the */ -/* existing bulges KA positions down toward the bottom of the */ -/* band */ - - i__3 = *kb - 1; - for (k = 1; k <= i__3; ++k) { - if (update) { - -/* Determine the rotations which would annihilate the bulge */ -/* which has in theory just been created */ - - if (i__ - k + *ka < *n && i__ - k > 1) { - -/* generate rotation to annihilate a(i,i-k+ka+1) */ - - dlartg_(&ab[k + 1 + (i__ - k + *ka) * ab_dim1], &ra1, & - work[*n + i__ - k + *ka - m], &work[i__ - k + *ka - - m], &ra); - -/* create nonzero element a(i-k,i-k+ka+1) outside the */ -/* band and store it in WORK(i-k) */ - - t = -bb[kb1 - k + i__ * bb_dim1] * ra1; - work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[ - i__ - k + *ka - m] * ab[(i__ - k + *ka) * ab_dim1 - + 1]; - ab[(i__ - k + *ka) * ab_dim1 + 1] = work[i__ - k + *ka - - m] * t + work[*n + i__ - k + *ka - m] * ab[(i__ - - k + *ka) * ab_dim1 + 1]; - ra1 = ra; - } - } -/* Computing MAX */ - i__2 = 1, i__4 = k - i0 + 2; - j2 = i__ - k - 1 + std::max(i__2,i__4) * ka1; - nr = (*n - j2 + *ka) / ka1; - j1 = j2 + (nr - 1) * ka1; - if (update) { -/* Computing MAX */ - i__2 = j2, i__4 = i__ + (*ka << 1) - k + 1; - j2t = std::max(i__2,i__4); - } else { - j2t = j2; - } - nrt = (*n - j2t + *ka) / ka1; - i__2 = j1; - i__4 = ka1; - for (j = j2t; i__4 < 0 ? j >= i__2 : j <= i__2; j += i__4) { - -/* create nonzero element a(j-ka,j+1) outside the band */ -/* and store it in WORK(j-m) */ - - work[j - m] *= ab[(j + 1) * ab_dim1 + 1]; - ab[(j + 1) * ab_dim1 + 1] = work[*n + j - m] * ab[(j + 1) * - ab_dim1 + 1]; -/* L90: */ - } - -/* generate rotations in 1st set to annihilate elements which */ -/* have been created outside the band */ - - if (nrt > 0) { - dlargv_(&nrt, &ab[j2t * ab_dim1 + 1], &inca, &work[j2t - m], & - ka1, &work[*n + j2t - m], &ka1); - } - if (nr > 0) { - -/* apply rotations in 1st set from the right */ - - i__4 = *ka - 1; - for (l = 1; l <= i__4; ++l) { - dlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka - - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2 - - m], &work[j2 - m], &ka1); -/* L100: */ - } - -/* apply rotations in 1st set from both sides to diagonal */ -/* blocks */ - - dlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) * - ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[ - *n + j2 - m], &work[j2 - m], &ka1); - - } - -/* start applying rotations in 1st set from the left */ - - i__4 = *kb - k + 1; - for (l = *ka - 1; l >= i__4; --l) { - nrt = (*n - j2 + l) / ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & - ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & - work[*n + j2 - m], &work[j2 - m], &ka1); - } -/* L110: */ - } - - if (wantx) { - -/* post-multiply X by product of rotations in 1st set */ - - i__4 = j1; - i__2 = ka1; - for (j = j2; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) { - i__1 = *n - m; - drot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j - + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j - - m]); -/* L120: */ - } - } -/* L130: */ - } - - if (update) { - if (i2 <= *n && kbt > 0) { - -/* create nonzero element a(i-kbt,i-kbt+ka+1) outside the */ -/* band and store it in WORK(i-kbt) */ - - work[i__ - kbt] = -bb[kb1 - kbt + i__ * bb_dim1] * ra1; - } - } - - for (k = *kb; k >= 1; --k) { - if (update) { -/* Computing MAX */ - i__3 = 2, i__2 = k - i0 + 1; - j2 = i__ - k - 1 + std::max(i__3,i__2) * ka1; - } else { -/* Computing MAX */ - i__3 = 1, i__2 = k - i0 + 1; - j2 = i__ - k - 1 + std::max(i__3,i__2) * ka1; - } - -/* finish applying rotations in 2nd set from the left */ - - for (l = *kb - k; l >= 1; --l) { - nrt = (*n - j2 + *ka + l) / ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[l + (j2 - l + 1) * ab_dim1], &inca, &ab[ - l + 1 + (j2 - l + 1) * ab_dim1], &inca, &work[*n - + j2 - *ka], &work[j2 - *ka], &ka1); - } -/* L140: */ - } - nr = (*n - j2 + *ka) / ka1; - j1 = j2 + (nr - 1) * ka1; - i__3 = j2; - i__2 = -ka1; - for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) { - work[j] = work[j - *ka]; - work[*n + j] = work[*n + j - *ka]; -/* L150: */ - } - i__2 = j1; - i__3 = ka1; - for (j = j2; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) { - -/* create nonzero element a(j-ka,j+1) outside the band */ -/* and store it in WORK(j) */ - - work[j] *= ab[(j + 1) * ab_dim1 + 1]; - ab[(j + 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + 1) * - ab_dim1 + 1]; -/* L160: */ - } - if (update) { - if (i__ - k < *n - *ka && k <= kbt) { - work[i__ - k + *ka] = work[i__ - k]; - } - } -/* L170: */ - } - - for (k = *kb; k >= 1; --k) { -/* Computing MAX */ - i__3 = 1, i__2 = k - i0 + 1; - j2 = i__ - k - 1 + std::max(i__3,i__2) * ka1; - nr = (*n - j2 + *ka) / ka1; - j1 = j2 + (nr - 1) * ka1; - if (nr > 0) { - -/* generate rotations in 2nd set to annihilate elements */ -/* which have been created outside the band */ - - dlargv_(&nr, &ab[j2 * ab_dim1 + 1], &inca, &work[j2], &ka1, & - work[*n + j2], &ka1); - -/* apply rotations in 2nd set from the right */ - - i__3 = *ka - 1; - for (l = 1; l <= i__3; ++l) { - dlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka - - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2], - &work[j2], &ka1); -/* L180: */ - } - -/* apply rotations in 2nd set from both sides to diagonal */ -/* blocks */ - - dlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) * - ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[ - *n + j2], &work[j2], &ka1); - - } - -/* start applying rotations in 2nd set from the left */ - - i__3 = *kb - k + 1; - for (l = *ka - 1; l >= i__3; --l) { - nrt = (*n - j2 + l) / ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & - ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & - work[*n + j2], &work[j2], &ka1); - } -/* L190: */ - } - - if (wantx) { - -/* post-multiply X by product of rotations in 2nd set */ - - i__3 = j1; - i__2 = ka1; - for (j = j2; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) { - i__4 = *n - m; - drot_(&i__4, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j - + 1) * x_dim1], &c__1, &work[*n + j], &work[j]); -/* L200: */ - } - } -/* L210: */ - } - - i__2 = *kb - 1; - for (k = 1; k <= i__2; ++k) { -/* Computing MAX */ - i__3 = 1, i__4 = k - i0 + 2; - j2 = i__ - k - 1 + std::max(i__3,i__4) * ka1; - -/* finish applying rotations in 1st set from the left */ - - for (l = *kb - k; l >= 1; --l) { - nrt = (*n - j2 + l) / ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & - ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & - work[*n + j2 - m], &work[j2 - m], &ka1); - } -/* L220: */ - } -/* L230: */ - } - - if (*kb > 1) { - i__2 = i__ - *kb + (*ka << 1) + 1; - for (j = *n - 1; j >= i__2; --j) { - work[*n + j - m] = work[*n + j - *ka - m]; - work[j - m] = work[j - *ka - m]; -/* L240: */ - } - } - - } else { - -/* Transform A, working with the lower triangle */ - - if (update) { - -/* Form inv(S(i))**T * A * inv(S(i)) */ - - bii = bb[i__ * bb_dim1 + 1]; - i__2 = i1; - for (j = i__; j <= i__2; ++j) { - ab[j - i__ + 1 + i__ * ab_dim1] /= bii; -/* L250: */ - } -/* Computing MAX */ - i__2 = 1, i__3 = i__ - *ka; - i__4 = i__; - for (j = std::max(i__2,i__3); j <= i__4; ++j) { - ab[i__ - j + 1 + j * ab_dim1] /= bii; -/* L260: */ - } - i__4 = i__ - 1; - for (k = i__ - kbt; k <= i__4; ++k) { - i__2 = k; - for (j = i__ - kbt; j <= i__2; ++j) { - ab[k - j + 1 + j * ab_dim1] = ab[k - j + 1 + j * ab_dim1] - - bb[i__ - j + 1 + j * bb_dim1] * ab[i__ - k + 1 - + k * ab_dim1] - bb[i__ - k + 1 + k * bb_dim1] * - ab[i__ - j + 1 + j * ab_dim1] + ab[i__ * ab_dim1 - + 1] * bb[i__ - j + 1 + j * bb_dim1] * bb[i__ - k - + 1 + k * bb_dim1]; -/* L270: */ - } -/* Computing MAX */ - i__2 = 1, i__3 = i__ - *ka; - i__1 = i__ - kbt - 1; - for (j = std::max(i__2,i__3); j <= i__1; ++j) { - ab[k - j + 1 + j * ab_dim1] -= bb[i__ - k + 1 + k * - bb_dim1] * ab[i__ - j + 1 + j * ab_dim1]; -/* L280: */ - } -/* L290: */ - } - i__4 = i1; - for (j = i__; j <= i__4; ++j) { -/* Computing MAX */ - i__1 = j - *ka, i__2 = i__ - kbt; - i__3 = i__ - 1; - for (k = std::max(i__1,i__2); k <= i__3; ++k) { - ab[j - k + 1 + k * ab_dim1] -= bb[i__ - k + 1 + k * - bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1]; -/* L300: */ - } -/* L310: */ - } - - if (wantx) { - -/* post-multiply X by inv(S(i)) */ - - i__4 = *n - m; - d__1 = 1. / bii; - dscal_(&i__4, &d__1, &x[m + 1 + i__ * x_dim1], &c__1); - if (kbt > 0) { - i__4 = *n - m; - i__3 = *ldbb - 1; - dger_(&i__4, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], & - c__1, &bb[kbt + 1 + (i__ - kbt) * bb_dim1], &i__3, - &x[m + 1 + (i__ - kbt) * x_dim1], ldx); - } - } - -/* store a(i1,i) in RA1 for use in next loop over K */ - - ra1 = ab[i1 - i__ + 1 + i__ * ab_dim1]; - } - -/* Generate and apply vectors of rotations to chase all the */ -/* existing bulges KA positions down toward the bottom of the */ -/* band */ - - i__4 = *kb - 1; - for (k = 1; k <= i__4; ++k) { - if (update) { - -/* Determine the rotations which would annihilate the bulge */ -/* which has in theory just been created */ - - if (i__ - k + *ka < *n && i__ - k > 1) { - -/* generate rotation to annihilate a(i-k+ka+1,i) */ - - dlartg_(&ab[ka1 - k + i__ * ab_dim1], &ra1, &work[*n + - i__ - k + *ka - m], &work[i__ - k + *ka - m], &ra) - ; - -/* create nonzero element a(i-k+ka+1,i-k) outside the */ -/* band and store it in WORK(i-k) */ - - t = -bb[k + 1 + (i__ - k) * bb_dim1] * ra1; - work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[ - i__ - k + *ka - m] * ab[ka1 + (i__ - k) * ab_dim1] - ; - ab[ka1 + (i__ - k) * ab_dim1] = work[i__ - k + *ka - m] * - t + work[*n + i__ - k + *ka - m] * ab[ka1 + (i__ - - k) * ab_dim1]; - ra1 = ra; - } - } -/* Computing MAX */ - i__3 = 1, i__1 = k - i0 + 2; - j2 = i__ - k - 1 + std::max(i__3,i__1) * ka1; - nr = (*n - j2 + *ka) / ka1; - j1 = j2 + (nr - 1) * ka1; - if (update) { -/* Computing MAX */ - i__3 = j2, i__1 = i__ + (*ka << 1) - k + 1; - j2t = std::max(i__3,i__1); - } else { - j2t = j2; - } - nrt = (*n - j2t + *ka) / ka1; - i__3 = j1; - i__1 = ka1; - for (j = j2t; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) { - -/* create nonzero element a(j+1,j-ka) outside the band */ -/* and store it in WORK(j-m) */ - - work[j - m] *= ab[ka1 + (j - *ka + 1) * ab_dim1]; - ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j - m] * ab[ka1 - + (j - *ka + 1) * ab_dim1]; -/* L320: */ - } - -/* generate rotations in 1st set to annihilate elements which */ -/* have been created outside the band */ - - if (nrt > 0) { - dlargv_(&nrt, &ab[ka1 + (j2t - *ka) * ab_dim1], &inca, &work[ - j2t - m], &ka1, &work[*n + j2t - m], &ka1); - } - if (nr > 0) { - -/* apply rotations in 1st set from the left */ - - i__1 = *ka - 1; - for (l = 1; l <= i__1; ++l) { - dlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[ - l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2 - - m], &work[j2 - m], &ka1); -/* L330: */ - } - -/* apply rotations in 1st set from both sides to diagonal */ -/* blocks */ - - dlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 + - 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2 - m], - &work[j2 - m], &ka1); - - } - -/* start applying rotations in 1st set from the right */ - - i__1 = *kb - k + 1; - for (l = *ka - 1; l >= i__1; --l) { - nrt = (*n - j2 + l) / ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ - ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + - j2 - m], &work[j2 - m], &ka1); - } -/* L340: */ - } - - if (wantx) { - -/* post-multiply X by product of rotations in 1st set */ - - i__1 = j1; - i__3 = ka1; - for (j = j2; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { - i__2 = *n - m; - drot_(&i__2, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j - + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j - - m]); -/* L350: */ - } - } -/* L360: */ - } - - if (update) { - if (i2 <= *n && kbt > 0) { - -/* create nonzero element a(i-kbt+ka+1,i-kbt) outside the */ -/* band and store it in WORK(i-kbt) */ - - work[i__ - kbt] = -bb[kbt + 1 + (i__ - kbt) * bb_dim1] * ra1; - } - } - - for (k = *kb; k >= 1; --k) { - if (update) { -/* Computing MAX */ - i__4 = 2, i__3 = k - i0 + 1; - j2 = i__ - k - 1 + std::max(i__4,i__3) * ka1; - } else { -/* Computing MAX */ - i__4 = 1, i__3 = k - i0 + 1; - j2 = i__ - k - 1 + std::max(i__4,i__3) * ka1; - } - -/* finish applying rotations in 2nd set from the right */ - - for (l = *kb - k; l >= 1; --l) { - nrt = (*n - j2 + *ka + l) / ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[ka1 - l + 1 + (j2 - *ka) * ab_dim1], & - inca, &ab[ka1 - l + (j2 - *ka + 1) * ab_dim1], & - inca, &work[*n + j2 - *ka], &work[j2 - *ka], &ka1) - ; - } -/* L370: */ - } - nr = (*n - j2 + *ka) / ka1; - j1 = j2 + (nr - 1) * ka1; - i__4 = j2; - i__3 = -ka1; - for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { - work[j] = work[j - *ka]; - work[*n + j] = work[*n + j - *ka]; -/* L380: */ - } - i__3 = j1; - i__4 = ka1; - for (j = j2; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { - -/* create nonzero element a(j+1,j-ka) outside the band */ -/* and store it in WORK(j) */ - - work[j] *= ab[ka1 + (j - *ka + 1) * ab_dim1]; - ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j] * ab[ka1 + ( - j - *ka + 1) * ab_dim1]; -/* L390: */ - } - if (update) { - if (i__ - k < *n - *ka && k <= kbt) { - work[i__ - k + *ka] = work[i__ - k]; - } - } -/* L400: */ - } - - for (k = *kb; k >= 1; --k) { -/* Computing MAX */ - i__4 = 1, i__3 = k - i0 + 1; - j2 = i__ - k - 1 + std::max(i__4,i__3) * ka1; - nr = (*n - j2 + *ka) / ka1; - j1 = j2 + (nr - 1) * ka1; - if (nr > 0) { - -/* generate rotations in 2nd set to annihilate elements */ -/* which have been created outside the band */ - - dlargv_(&nr, &ab[ka1 + (j2 - *ka) * ab_dim1], &inca, &work[j2] -, &ka1, &work[*n + j2], &ka1); - -/* apply rotations in 2nd set from the left */ - - i__4 = *ka - 1; - for (l = 1; l <= i__4; ++l) { - dlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[ - l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2] -, &work[j2], &ka1); -/* L410: */ - } - -/* apply rotations in 2nd set from both sides to diagonal */ -/* blocks */ - - dlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 + - 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2], & - work[j2], &ka1); - - } - -/* start applying rotations in 2nd set from the right */ - - i__4 = *kb - k + 1; - for (l = *ka - 1; l >= i__4; --l) { - nrt = (*n - j2 + l) / ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ - ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + - j2], &work[j2], &ka1); - } -/* L420: */ - } - - if (wantx) { - -/* post-multiply X by product of rotations in 2nd set */ - - i__4 = j1; - i__3 = ka1; - for (j = j2; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { - i__1 = *n - m; - drot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j - + 1) * x_dim1], &c__1, &work[*n + j], &work[j]); -/* L430: */ - } - } -/* L440: */ - } - - i__3 = *kb - 1; - for (k = 1; k <= i__3; ++k) { -/* Computing MAX */ - i__4 = 1, i__1 = k - i0 + 2; - j2 = i__ - k - 1 + std::max(i__4,i__1) * ka1; - -/* finish applying rotations in 1st set from the right */ - - for (l = *kb - k; l >= 1; --l) { - nrt = (*n - j2 + l) / ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ - ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + - j2 - m], &work[j2 - m], &ka1); - } -/* L450: */ - } -/* L460: */ - } - - if (*kb > 1) { - i__3 = i__ - *kb + (*ka << 1) + 1; - for (j = *n - 1; j >= i__3; --j) { - work[*n + j - m] = work[*n + j - *ka - m]; - work[j - m] = work[j - *ka - m]; -/* L470: */ - } - } - - } - - goto L10; - -L480: - -/* **************************** Phase 2 ***************************** */ - -/* The logical structure of this phase is: */ - -/* UPDATE = .TRUE. */ -/* DO I = 1, M */ -/* use S(i) to update A and create a new bulge */ -/* apply rotations to push all bulges KA positions upward */ -/* END DO */ -/* UPDATE = .FALSE. */ -/* DO I = M - KA - 1, 2, -1 */ -/* apply rotations to push all bulges KA positions upward */ -/* END DO */ - -/* To avoid duplicating code, the two loops are merged. */ - - update = true; - i__ = 0; -L490: - if (update) { - ++i__; -/* Computing MIN */ - i__3 = *kb, i__4 = m - i__; - kbt = std::min(i__3,i__4); - i0 = i__ + 1; -/* Computing MAX */ - i__3 = 1, i__4 = i__ - *ka; - i1 = std::max(i__3,i__4); - i2 = i__ + kbt - ka1; - if (i__ > m) { - update = false; - --i__; - i0 = m + 1; - if (*ka == 0) { - return 0; - } - goto L490; - } - } else { - i__ -= *ka; - if (i__ < 2) { - return 0; - } - } - - if (i__ < m - kbt) { - nx = m; - } else { - nx = *n; - } - - if (upper) { - -/* Transform A, working with the upper triangle */ - - if (update) { - -/* Form inv(S(i))**T * A * inv(S(i)) */ - - bii = bb[kb1 + i__ * bb_dim1]; - i__3 = i__; - for (j = i1; j <= i__3; ++j) { - ab[j - i__ + ka1 + i__ * ab_dim1] /= bii; -/* L500: */ - } -/* Computing MIN */ - i__4 = *n, i__1 = i__ + *ka; - i__3 = std::min(i__4,i__1); - for (j = i__; j <= i__3; ++j) { - ab[i__ - j + ka1 + j * ab_dim1] /= bii; -/* L510: */ - } - i__3 = i__ + kbt; - for (k = i__ + 1; k <= i__3; ++k) { - i__4 = i__ + kbt; - for (j = k; j <= i__4; ++j) { - ab[k - j + ka1 + j * ab_dim1] = ab[k - j + ka1 + j * - ab_dim1] - bb[i__ - j + kb1 + j * bb_dim1] * ab[ - i__ - k + ka1 + k * ab_dim1] - bb[i__ - k + kb1 + - k * bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1] + - ab[ka1 + i__ * ab_dim1] * bb[i__ - j + kb1 + j * - bb_dim1] * bb[i__ - k + kb1 + k * bb_dim1]; -/* L520: */ - } -/* Computing MIN */ - i__1 = *n, i__2 = i__ + *ka; - i__4 = std::min(i__1,i__2); - for (j = i__ + kbt + 1; j <= i__4; ++j) { - ab[k - j + ka1 + j * ab_dim1] -= bb[i__ - k + kb1 + k * - bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1]; -/* L530: */ - } -/* L540: */ - } - i__3 = i__; - for (j = i1; j <= i__3; ++j) { -/* Computing MIN */ - i__1 = j + *ka, i__2 = i__ + kbt; - i__4 = std::min(i__1,i__2); - for (k = i__ + 1; k <= i__4; ++k) { - ab[j - k + ka1 + k * ab_dim1] -= bb[i__ - k + kb1 + k * - bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1]; -/* L550: */ - } -/* L560: */ - } - - if (wantx) { - -/* post-multiply X by inv(S(i)) */ - - d__1 = 1. / bii; - dscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1); - if (kbt > 0) { - i__3 = *ldbb - 1; - dger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[ - *kb + (i__ + 1) * bb_dim1], &i__3, &x[(i__ + 1) * - x_dim1 + 1], ldx); - } - } - -/* store a(i1,i) in RA1 for use in next loop over K */ - - ra1 = ab[i1 - i__ + ka1 + i__ * ab_dim1]; - } - -/* Generate and apply vectors of rotations to chase all the */ -/* existing bulges KA positions up toward the top of the band */ - - i__3 = *kb - 1; - for (k = 1; k <= i__3; ++k) { - if (update) { - -/* Determine the rotations which would annihilate the bulge */ -/* which has in theory just been created */ - - if (i__ + k - ka1 > 0 && i__ + k < m) { - -/* generate rotation to annihilate a(i+k-ka-1,i) */ - - dlartg_(&ab[k + 1 + i__ * ab_dim1], &ra1, &work[*n + i__ - + k - *ka], &work[i__ + k - *ka], &ra); - -/* create nonzero element a(i+k-ka-1,i+k) outside the */ -/* band and store it in WORK(m-kb+i+k) */ - - t = -bb[kb1 - k + (i__ + k) * bb_dim1] * ra1; - work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t - - work[i__ + k - *ka] * ab[(i__ + k) * ab_dim1 + 1]; - ab[(i__ + k) * ab_dim1 + 1] = work[i__ + k - *ka] * t + - work[*n + i__ + k - *ka] * ab[(i__ + k) * ab_dim1 - + 1]; - ra1 = ra; - } - } -/* Computing MAX */ - i__4 = 1, i__1 = k + i0 - m + 1; - j2 = i__ + k + 1 - std::max(i__4,i__1) * ka1; - nr = (j2 + *ka - 1) / ka1; - j1 = j2 - (nr - 1) * ka1; - if (update) { -/* Computing MIN */ - i__4 = j2, i__1 = i__ - (*ka << 1) + k - 1; - j2t = std::min(i__4,i__1); - } else { - j2t = j2; - } - nrt = (j2t + *ka - 1) / ka1; - i__4 = j2t; - i__1 = ka1; - for (j = j1; i__1 < 0 ? j >= i__4 : j <= i__4; j += i__1) { - -/* create nonzero element a(j-1,j+ka) outside the band */ -/* and store it in WORK(j) */ - - work[j] *= ab[(j + *ka - 1) * ab_dim1 + 1]; - ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + *ka - - 1) * ab_dim1 + 1]; -/* L570: */ - } - -/* generate rotations in 1st set to annihilate elements which */ -/* have been created outside the band */ - - if (nrt > 0) { - dlargv_(&nrt, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[j1], - &ka1, &work[*n + j1], &ka1); - } - if (nr > 0) { - -/* apply rotations in 1st set from the left */ - - i__1 = *ka - 1; - for (l = 1; l <= i__1; ++l) { - dlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, & - ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n - + j1], &work[j1], &ka1); -/* L580: */ - } - -/* apply rotations in 1st set from both sides to diagonal */ -/* blocks */ - - dlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) * - ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n + - j1], &work[j1], &ka1); - - } - -/* start applying rotations in 1st set from the right */ - - i__1 = *kb - k + 1; - for (l = *ka - 1; l >= i__1; --l) { - nrt = (j2 + l - 1) / ka1; - j1t = j2 - (nrt - 1) * ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( - j1t - 1) * ab_dim1], &inca, &work[*n + j1t], & - work[j1t], &ka1); - } -/* L590: */ - } - - if (wantx) { - -/* post-multiply X by product of rotations in 1st set */ - - i__1 = j2; - i__4 = ka1; - for (j = j1; i__4 < 0 ? j >= i__1 : j <= i__1; j += i__4) { - drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 - + 1], &c__1, &work[*n + j], &work[j]); -/* L600: */ - } - } -/* L610: */ - } - - if (update) { - if (i2 > 0 && kbt > 0) { - -/* create nonzero element a(i+kbt-ka-1,i+kbt) outside the */ -/* band and store it in WORK(m-kb+i+kbt) */ - - work[m - *kb + i__ + kbt] = -bb[kb1 - kbt + (i__ + kbt) * - bb_dim1] * ra1; - } - } - - for (k = *kb; k >= 1; --k) { - if (update) { -/* Computing MAX */ - i__3 = 2, i__4 = k + i0 - m; - j2 = i__ + k + 1 - std::max(i__3,i__4) * ka1; - } else { -/* Computing MAX */ - i__3 = 1, i__4 = k + i0 - m; - j2 = i__ + k + 1 - std::max(i__3,i__4) * ka1; - } - -/* finish applying rotations in 2nd set from the right */ - - for (l = *kb - k; l >= 1; --l) { - nrt = (j2 + *ka + l - 1) / ka1; - j1t = j2 - (nrt - 1) * ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[l + (j1t + *ka) * ab_dim1], &inca, &ab[ - l + 1 + (j1t + *ka - 1) * ab_dim1], &inca, &work[* - n + m - *kb + j1t + *ka], &work[m - *kb + j1t + * - ka], &ka1); - } -/* L620: */ - } - nr = (j2 + *ka - 1) / ka1; - j1 = j2 - (nr - 1) * ka1; - i__3 = j2; - i__4 = ka1; - for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { - work[m - *kb + j] = work[m - *kb + j + *ka]; - work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka]; -/* L630: */ - } - i__4 = j2; - i__3 = ka1; - for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { - -/* create nonzero element a(j-1,j+ka) outside the band */ -/* and store it in WORK(m-kb+j) */ - - work[m - *kb + j] *= ab[(j + *ka - 1) * ab_dim1 + 1]; - ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + m - *kb + j] * ab[ - (j + *ka - 1) * ab_dim1 + 1]; -/* L640: */ - } - if (update) { - if (i__ + k > ka1 && k <= kbt) { - work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k]; - } - } -/* L650: */ - } - - for (k = *kb; k >= 1; --k) { -/* Computing MAX */ - i__3 = 1, i__4 = k + i0 - m; - j2 = i__ + k + 1 - std::max(i__3,i__4) * ka1; - nr = (j2 + *ka - 1) / ka1; - j1 = j2 - (nr - 1) * ka1; - if (nr > 0) { - -/* generate rotations in 2nd set to annihilate elements */ -/* which have been created outside the band */ - - dlargv_(&nr, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[m - * - kb + j1], &ka1, &work[*n + m - *kb + j1], &ka1); - -/* apply rotations in 2nd set from the left */ - - i__3 = *ka - 1; - for (l = 1; l <= i__3; ++l) { - dlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, & - ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n - + m - *kb + j1], &work[m - *kb + j1], &ka1); -/* L660: */ - } - -/* apply rotations in 2nd set from both sides to diagonal */ -/* blocks */ - - dlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) * - ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n + - m - *kb + j1], &work[m - *kb + j1], &ka1); - - } - -/* start applying rotations in 2nd set from the right */ - - i__3 = *kb - k + 1; - for (l = *ka - 1; l >= i__3; --l) { - nrt = (j2 + l - 1) / ka1; - j1t = j2 - (nrt - 1) * ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( - j1t - 1) * ab_dim1], &inca, &work[*n + m - *kb + - j1t], &work[m - *kb + j1t], &ka1); - } -/* L670: */ - } - - if (wantx) { - -/* post-multiply X by product of rotations in 2nd set */ - - i__3 = j2; - i__4 = ka1; - for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { - drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 - + 1], &c__1, &work[*n + m - *kb + j], &work[m - * - kb + j]); -/* L680: */ - } - } -/* L690: */ - } - - i__4 = *kb - 1; - for (k = 1; k <= i__4; ++k) { -/* Computing MAX */ - i__3 = 1, i__1 = k + i0 - m + 1; - j2 = i__ + k + 1 - std::max(i__3,i__1) * ka1; - -/* finish applying rotations in 1st set from the right */ - - for (l = *kb - k; l >= 1; --l) { - nrt = (j2 + l - 1) / ka1; - j1t = j2 - (nrt - 1) * ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( - j1t - 1) * ab_dim1], &inca, &work[*n + j1t], & - work[j1t], &ka1); - } -/* L700: */ - } -/* L710: */ - } - - if (*kb > 1) { -/* Computing MIN */ - i__3 = i__ + *kb; - i__4 = std::min(i__3,m) - (*ka << 1) - 1; - for (j = 2; j <= i__4; ++j) { - work[*n + j] = work[*n + j + *ka]; - work[j] = work[j + *ka]; -/* L720: */ - } - } - - } else { - -/* Transform A, working with the lower triangle */ - - if (update) { - -/* Form inv(S(i))**T * A * inv(S(i)) */ - - bii = bb[i__ * bb_dim1 + 1]; - i__4 = i__; - for (j = i1; j <= i__4; ++j) { - ab[i__ - j + 1 + j * ab_dim1] /= bii; -/* L730: */ - } -/* Computing MIN */ - i__3 = *n, i__1 = i__ + *ka; - i__4 = std::min(i__3,i__1); - for (j = i__; j <= i__4; ++j) { - ab[j - i__ + 1 + i__ * ab_dim1] /= bii; -/* L740: */ - } - i__4 = i__ + kbt; - for (k = i__ + 1; k <= i__4; ++k) { - i__3 = i__ + kbt; - for (j = k; j <= i__3; ++j) { - ab[j - k + 1 + k * ab_dim1] = ab[j - k + 1 + k * ab_dim1] - - bb[j - i__ + 1 + i__ * bb_dim1] * ab[k - i__ + - 1 + i__ * ab_dim1] - bb[k - i__ + 1 + i__ * - bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1] + ab[ - i__ * ab_dim1 + 1] * bb[j - i__ + 1 + i__ * - bb_dim1] * bb[k - i__ + 1 + i__ * bb_dim1]; -/* L750: */ - } -/* Computing MIN */ - i__1 = *n, i__2 = i__ + *ka; - i__3 = std::min(i__1,i__2); - for (j = i__ + kbt + 1; j <= i__3; ++j) { - ab[j - k + 1 + k * ab_dim1] -= bb[k - i__ + 1 + i__ * - bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1]; -/* L760: */ - } -/* L770: */ - } - i__4 = i__; - for (j = i1; j <= i__4; ++j) { -/* Computing MIN */ - i__1 = j + *ka, i__2 = i__ + kbt; - i__3 = std::min(i__1,i__2); - for (k = i__ + 1; k <= i__3; ++k) { - ab[k - j + 1 + j * ab_dim1] -= bb[k - i__ + 1 + i__ * - bb_dim1] * ab[i__ - j + 1 + j * ab_dim1]; -/* L780: */ - } -/* L790: */ - } - - if (wantx) { - -/* post-multiply X by inv(S(i)) */ - - d__1 = 1. / bii; - dscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1); - if (kbt > 0) { - dger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[ - i__ * bb_dim1 + 2], &c__1, &x[(i__ + 1) * x_dim1 - + 1], ldx); - } - } - -/* store a(i,i1) in RA1 for use in next loop over K */ - - ra1 = ab[i__ - i1 + 1 + i1 * ab_dim1]; - } - -/* Generate and apply vectors of rotations to chase all the */ -/* existing bulges KA positions up toward the top of the band */ - - i__4 = *kb - 1; - for (k = 1; k <= i__4; ++k) { - if (update) { - -/* Determine the rotations which would annihilate the bulge */ -/* which has in theory just been created */ - - if (i__ + k - ka1 > 0 && i__ + k < m) { - -/* generate rotation to annihilate a(i,i+k-ka-1) */ - - dlartg_(&ab[ka1 - k + (i__ + k - *ka) * ab_dim1], &ra1, & - work[*n + i__ + k - *ka], &work[i__ + k - *ka], & - ra); - -/* create nonzero element a(i+k,i+k-ka-1) outside the */ -/* band and store it in WORK(m-kb+i+k) */ - - t = -bb[k + 1 + i__ * bb_dim1] * ra1; - work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t - - work[i__ + k - *ka] * ab[ka1 + (i__ + k - *ka) * - ab_dim1]; - ab[ka1 + (i__ + k - *ka) * ab_dim1] = work[i__ + k - *ka] - * t + work[*n + i__ + k - *ka] * ab[ka1 + (i__ + - k - *ka) * ab_dim1]; - ra1 = ra; - } - } -/* Computing MAX */ - i__3 = 1, i__1 = k + i0 - m + 1; - j2 = i__ + k + 1 - std::max(i__3,i__1) * ka1; - nr = (j2 + *ka - 1) / ka1; - j1 = j2 - (nr - 1) * ka1; - if (update) { -/* Computing MIN */ - i__3 = j2, i__1 = i__ - (*ka << 1) + k - 1; - j2t = std::min(i__3,i__1); - } else { - j2t = j2; - } - nrt = (j2t + *ka - 1) / ka1; - i__3 = j2t; - i__1 = ka1; - for (j = j1; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) { - -/* create nonzero element a(j+ka,j-1) outside the band */ -/* and store it in WORK(j) */ - - work[j] *= ab[ka1 + (j - 1) * ab_dim1]; - ab[ka1 + (j - 1) * ab_dim1] = work[*n + j] * ab[ka1 + (j - 1) - * ab_dim1]; -/* L800: */ - } - -/* generate rotations in 1st set to annihilate elements which */ -/* have been created outside the band */ - - if (nrt > 0) { - dlargv_(&nrt, &ab[ka1 + j1 * ab_dim1], &inca, &work[j1], &ka1, - &work[*n + j1], &ka1); - } - if (nr > 0) { - -/* apply rotations in 1st set from the right */ - - i__1 = *ka - 1; - for (l = 1; l <= i__1; ++l) { - dlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2 - + (j1 - 1) * ab_dim1], &inca, &work[*n + j1], & - work[j1], &ka1); -/* L810: */ - } - -/* apply rotations in 1st set from both sides to diagonal */ -/* blocks */ - - dlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + - 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + j1] -, &work[j1], &ka1); - - } - -/* start applying rotations in 1st set from the left */ - - i__1 = *kb - k + 1; - for (l = *ka - 1; l >= i__1; --l) { - nrt = (j2 + l - 1) / ka1; - j1t = j2 - (nrt - 1) * ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] -, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], - &inca, &work[*n + j1t], &work[j1t], &ka1); - } -/* L820: */ - } - - if (wantx) { - -/* post-multiply X by product of rotations in 1st set */ - - i__1 = j2; - i__3 = ka1; - for (j = j1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { - drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 - + 1], &c__1, &work[*n + j], &work[j]); -/* L830: */ - } - } -/* L840: */ - } - - if (update) { - if (i2 > 0 && kbt > 0) { - -/* create nonzero element a(i+kbt,i+kbt-ka-1) outside the */ -/* band and store it in WORK(m-kb+i+kbt) */ - - work[m - *kb + i__ + kbt] = -bb[kbt + 1 + i__ * bb_dim1] * - ra1; - } - } - - for (k = *kb; k >= 1; --k) { - if (update) { -/* Computing MAX */ - i__4 = 2, i__3 = k + i0 - m; - j2 = i__ + k + 1 - std::max(i__4,i__3) * ka1; - } else { -/* Computing MAX */ - i__4 = 1, i__3 = k + i0 - m; - j2 = i__ + k + 1 - std::max(i__4,i__3) * ka1; - } - -/* finish applying rotations in 2nd set from the left */ - - for (l = *kb - k; l >= 1; --l) { - nrt = (j2 + *ka + l - 1) / ka1; - j1t = j2 - (nrt - 1) * ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t + l - 1) * ab_dim1], - &inca, &ab[ka1 - l + (j1t + l - 1) * ab_dim1], & - inca, &work[*n + m - *kb + j1t + *ka], &work[m - * - kb + j1t + *ka], &ka1); - } -/* L850: */ - } - nr = (j2 + *ka - 1) / ka1; - j1 = j2 - (nr - 1) * ka1; - i__4 = j2; - i__3 = ka1; - for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { - work[m - *kb + j] = work[m - *kb + j + *ka]; - work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka]; -/* L860: */ - } - i__3 = j2; - i__4 = ka1; - for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { - -/* create nonzero element a(j+ka,j-1) outside the band */ -/* and store it in WORK(m-kb+j) */ - - work[m - *kb + j] *= ab[ka1 + (j - 1) * ab_dim1]; - ab[ka1 + (j - 1) * ab_dim1] = work[*n + m - *kb + j] * ab[ka1 - + (j - 1) * ab_dim1]; -/* L870: */ - } - if (update) { - if (i__ + k > ka1 && k <= kbt) { - work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k]; - } - } -/* L880: */ - } - - for (k = *kb; k >= 1; --k) { -/* Computing MAX */ - i__4 = 1, i__3 = k + i0 - m; - j2 = i__ + k + 1 - std::max(i__4,i__3) * ka1; - nr = (j2 + *ka - 1) / ka1; - j1 = j2 - (nr - 1) * ka1; - if (nr > 0) { - -/* generate rotations in 2nd set to annihilate elements */ -/* which have been created outside the band */ - - dlargv_(&nr, &ab[ka1 + j1 * ab_dim1], &inca, &work[m - *kb + - j1], &ka1, &work[*n + m - *kb + j1], &ka1); - -/* apply rotations in 2nd set from the right */ - - i__4 = *ka - 1; - for (l = 1; l <= i__4; ++l) { - dlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2 - + (j1 - 1) * ab_dim1], &inca, &work[*n + m - *kb - + j1], &work[m - *kb + j1], &ka1); -/* L890: */ - } - -/* apply rotations in 2nd set from both sides to diagonal */ -/* blocks */ - - dlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + - 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + m - - *kb + j1], &work[m - *kb + j1], &ka1); - - } - -/* start applying rotations in 2nd set from the left */ - - i__4 = *kb - k + 1; - for (l = *ka - 1; l >= i__4; --l) { - nrt = (j2 + l - 1) / ka1; - j1t = j2 - (nrt - 1) * ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] -, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], - &inca, &work[*n + m - *kb + j1t], &work[m - *kb - + j1t], &ka1); - } -/* L900: */ - } - - if (wantx) { - -/* post-multiply X by product of rotations in 2nd set */ - - i__4 = j2; - i__3 = ka1; - for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { - drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 - + 1], &c__1, &work[*n + m - *kb + j], &work[m - * - kb + j]); -/* L910: */ - } - } -/* L920: */ - } - - i__3 = *kb - 1; - for (k = 1; k <= i__3; ++k) { -/* Computing MAX */ - i__4 = 1, i__1 = k + i0 - m + 1; - j2 = i__ + k + 1 - std::max(i__4,i__1) * ka1; - -/* finish applying rotations in 1st set from the left */ - - for (l = *kb - k; l >= 1; --l) { - nrt = (j2 + l - 1) / ka1; - j1t = j2 - (nrt - 1) * ka1; - if (nrt > 0) { - dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] -, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], - &inca, &work[*n + j1t], &work[j1t], &ka1); - } -/* L930: */ - } -/* L940: */ - } - - if (*kb > 1) { -/* Computing MIN */ - i__4 = i__ + *kb; - i__3 = std::min(i__4,m) - (*ka << 1) - 1; - for (j = 2; j <= i__3; ++j) { - work[*n + j] = work[*n + j + *ka]; - work[j] = work[j + *ka]; -/* L950: */ - } - } - - } - - goto L490; - -/* End of DSBGST */ - -} /* dsbgst_ */ diff --git a/external/clapack/lapack/dsbgv.cpp b/external/clapack/lapack/dsbgv.cpp deleted file mode 100644 index b783e134..00000000 --- a/external/clapack/lapack/dsbgv.cpp +++ /dev/null @@ -1,211 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dsbgv_(const char *jobz, const char *uplo, integer *n, integer *ka, - integer *kb, double *ab, integer *ldab, double *bb, integer * - ldbb, double *w, double *z__, integer *ldz, double *work, - integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1; - - /* Local variables */ - integer inde; - char vect[1]; - integer iinfo; - bool upper, wantz; - integer indwrk; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBGV computes all the eigenvalues, and optionally, the eigenvectors */ -/* of a real generalized symmetric-definite banded eigenproblem, of */ -/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */ -/* and banded, and B is also positive definite. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangles of A and B are stored; */ -/* = 'L': Lower triangles of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* KA (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ - -/* KB (input) INTEGER */ -/* The number of superdiagonals of the matrix B if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first ka+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ - -/* On exit, the contents of AB are destroyed. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KA+1. */ - -/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix B, stored in the first kb+1 rows of the array. The */ -/* j-th column of B is stored in the j-th column of the array BB */ -/* as follows: */ -/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */ -/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */ - -/* On exit, the factor S from the split Cholesky factorization */ -/* B = S**T*S, as returned by DPBSTF. */ - -/* LDBB (input) INTEGER */ -/* The leading dimension of the array BB. LDBB >= KB+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ -/* eigenvectors, with the i-th column of Z holding the */ -/* eigenvector associated with W(i). The eigenvectors are */ -/* normalized so that Z**T*B*Z = I. */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= N. */ - -/* 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 */ -/* > 0: if INFO = i, and i is: */ -/* <= N: the algorithm failed to converge: */ -/* i off-diagonal elements of an intermediate */ -/* tridiagonal form did not converge to zero; */ -/* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF */ -/* returned INFO = i: B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - bb_dim1 = *ldbb; - bb_offset = 1 + bb_dim1; - bb -= bb_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - upper = lsame_(uplo, "U"); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ka < 0) { - *info = -4; - } else if (*kb < 0 || *kb > *ka) { - *info = -5; - } else if (*ldab < *ka + 1) { - *info = -7; - } else if (*ldbb < *kb + 1) { - *info = -9; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSBGV ", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Form a split Cholesky factorization of B. */ - - dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem. */ - - inde = 1; - indwrk = inde + *n; - dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, - &z__[z_offset], ldz, &work[indwrk], &iinfo) - ; - -/* Reduce to tridiagonal form. */ - - if (wantz) { - *(unsigned char *)vect = 'U'; - } else { - *(unsigned char *)vect = 'N'; - } - dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ - z_offset], ldz, &work[indwrk], &iinfo); - -/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */ - - if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); - } else { - dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ - indwrk], info); - } - return 0; - -/* End of DSBGV */ - -} /* dsbgv_ */ diff --git a/external/clapack/lapack/dsbgvd.cpp b/external/clapack/lapack/dsbgvd.cpp deleted file mode 100644 index e0f845fc..00000000 --- a/external/clapack/lapack/dsbgvd.cpp +++ /dev/null @@ -1,299 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b12 = 1.; -static double c_b13 = 0.; - -/* Subroutine */ int dsbgvd_(const char *jobz, const char *uplo, integer *n, integer *ka, - integer *kb, double *ab, integer *ldab, double *bb, integer * - ldbb, double *w, double *z__, integer *ldz, double *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1; - - /* Local variables */ - integer inde; - char vect[1]; - integer iinfo, lwmin; - bool upper, wantz; - integer indwk2, llwrk2; - integer indwrk, liwmin; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors */ -/* of a real generalized symmetric-definite banded eigenproblem, of the */ -/* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and */ -/* banded, and B is also positive definite. If eigenvectors are */ -/* desired, it uses a divide and conquer algorithm. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangles of A and B are stored; */ -/* = 'L': Lower triangles of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* KA (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ - -/* KB (input) INTEGER */ -/* The number of superdiagonals of the matrix B if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first ka+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ - -/* On exit, the contents of AB are destroyed. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KA+1. */ - -/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix B, stored in the first kb+1 rows of the array. The */ -/* j-th column of B is stored in the j-th column of the array BB */ -/* as follows: */ -/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */ -/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */ - -/* On exit, the factor S from the split Cholesky factorization */ -/* B = S**T*S, as returned by DPBSTF. */ - -/* LDBB (input) INTEGER */ -/* The leading dimension of the array BB. LDBB >= KB+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ -/* eigenvectors, with the i-th column of Z holding the */ -/* eigenvector associated with W(i). The eigenvectors are */ -/* normalized so Z**T*B*Z = I. */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* If N <= 1, LWORK >= 1. */ -/* If JOBZ = 'N' and N > 1, LWORK >= 3*N. */ -/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */ -/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is: */ -/* <= N: the algorithm failed to converge: */ -/* i off-diagonal elements of an intermediate */ -/* tridiagonal form did not converge to zero; */ -/* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF */ -/* returned INFO = i: B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - bb_dim1 = *ldbb; - bb_offset = 1 + bb_dim1; - bb -= bb_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - upper = lsame_(uplo, "U"); - lquery = *lwork == -1 || *liwork == -1; - - *info = 0; - if (*n <= 1) { - liwmin = 1; - lwmin = 1; - } else if (wantz) { - liwmin = *n * 5 + 3; -/* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 5 + 1 + (i__1 * i__1 << 1); - } else { - liwmin = 1; - lwmin = *n << 1; - } - - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ka < 0) { - *info = -4; - } else if (*kb < 0 || *kb > *ka) { - *info = -5; - } else if (*ldab < *ka + 1) { - *info = -7; - } else if (*ldbb < *kb + 1) { - *info = -9; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -12; - } - - if (*info == 0) { - work[1] = (double) lwmin; - iwork[1] = liwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -14; - } else if (*liwork < liwmin && ! lquery) { - *info = -16; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSBGVD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Form a split Cholesky factorization of B. */ - - dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem. */ - - inde = 1; - indwrk = inde + *n; - indwk2 = indwrk + *n * *n; - llwrk2 = *lwork - indwk2 + 1; - dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, - &z__[z_offset], ldz, &work[indwrk], &iinfo) - ; - -/* Reduce to tridiagonal form. */ - - if (wantz) { - *(unsigned char *)vect = 'U'; - } else { - *(unsigned char *)vect = 'N'; - } - dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ - z_offset], ldz, &work[indwrk], &iinfo); - -/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */ - - if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); - } else { - dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & - llwrk2, &iwork[1], liwork, info); - dgemm_("N", "N", n, n, n, &c_b12, &z__[z_offset], ldz, &work[indwrk], - n, &c_b13, &work[indwk2], n); - dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); - } - - work[1] = (double) lwmin; - iwork[1] = liwmin; - - return 0; - -/* End of DSBGVD */ - -} /* dsbgvd_ */ diff --git a/external/clapack/lapack/dsbgvx.cpp b/external/clapack/lapack/dsbgvx.cpp deleted file mode 100644 index 718956ec..00000000 --- a/external/clapack/lapack/dsbgvx.cpp +++ /dev/null @@ -1,427 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b25 = 1.; -static double c_b27 = 0.; - -/* Subroutine */ int dsbgvx_(const char *jobz, const char *range, const char *uplo, integer *n, - integer *ka, integer *kb, double *ab, integer *ldab, double * - bb, integer *ldbb, double *q, integer *ldq, double *vl, - double *vu, integer *il, integer *iu, double *abstol, integer - *m, double *w, double *z__, integer *ldz, double *work, - integer *iwork, integer *ifail, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1, - z_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, jj; - double tmp1; - integer indd, inde; - char vect[1]; - bool test; - integer itmp1, indee; - integer iinfo; - char order[1]; - bool upper, wantz, alleig, indeig; - integer indibl; - bool valeig; - integer indisp; - integer indiwo; - integer indwrk; - integer nsplit; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBGVX computes selected eigenvalues, and optionally, eigenvectors */ -/* of a real generalized symmetric-definite banded eigenproblem, of */ -/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */ -/* and banded, and B is also positive definite. Eigenvalues and */ -/* eigenvectors can be selected by specifying either all eigenvalues, */ -/* a range of values or a range of indices for the desired eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangles of A and B are stored; */ -/* = 'L': Lower triangles of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* KA (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ - -/* KB (input) INTEGER */ -/* The number of superdiagonals of the matrix B if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first ka+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ - -/* On exit, the contents of AB are destroyed. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KA+1. */ - -/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix B, stored in the first kb+1 rows of the array. The */ -/* j-th column of B is stored in the j-th column of the array BB */ -/* as follows: */ -/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */ -/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */ - -/* On exit, the factor S from the split Cholesky factorization */ -/* B = S**T*S, as returned by DPBSTF. */ - -/* LDBB (input) INTEGER */ -/* The leading dimension of the array BB. LDBB >= KB+1. */ - -/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */ -/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */ -/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */ -/* and consequently C to tridiagonal form. */ -/* If JOBZ = 'N', the array Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. If JOBZ = 'N', */ -/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing A to tridiagonal form. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ -/* If this routine returns with INFO>0, indicating that some */ -/* eigenvectors did not converge, try setting ABSTOL to */ -/* 2*DLAMCH('S'). */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ -/* eigenvectors, with the i-th column of Z holding the */ -/* eigenvector associated with W(i). The eigenvectors are */ -/* normalized so Z**T*B*Z = I. */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N) */ - -/* IWORK (workspace/output) INTEGER array, dimension (5*N) */ - -/* IFAIL (output) INTEGER array, dimension (M) */ -/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ -/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ -/* indices of the eigenvalues that failed to converge. */ -/* If JOBZ = 'N', then IFAIL is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0 : successful exit */ -/* < 0 : if INFO = -i, the i-th argument had an illegal value */ -/* <= N: if INFO = i, then i eigenvectors failed to converge. */ -/* Their indices are stored in IFAIL. */ -/* > N : DPBSTF returned an error code; i.e., */ -/* if INFO = N + i, for 1 <= i <= N, then the leading */ -/* minor of order i of B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - bb_dim1 = *ldbb; - bb_offset = 1 + bb_dim1; - bb -= bb_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - upper = lsame_(uplo, "U"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*ka < 0) { - *info = -5; - } else if (*kb < 0 || *kb > *ka) { - *info = -6; - } else if (*ldab < *ka + 1) { - *info = -8; - } else if (*ldbb < *kb + 1) { - *info = -10; - } else if (*ldq < 1 || wantz && *ldq < *n) { - *info = -12; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -14; - } - } else if (indeig) { - if (*il < 1 || *il > std::max(1_integer,*n)) { - *info = -15; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -16; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -21; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSBGVX", &i__1); - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - -/* Form a split Cholesky factorization of B. */ - - dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem. */ - - dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, - &q[q_offset], ldq, &work[1], &iinfo); - -/* Reduce symmetric band matrix to tridiagonal form. */ - - indd = 1; - inde = indd + *n; - indwrk = inde + *n; - if (wantz) { - *(unsigned char *)vect = 'U'; - } else { - *(unsigned char *)vect = 'N'; - } - dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &work[indd], &work[inde], - &q[q_offset], ldq, &work[indwrk], &iinfo); - -/* If all eigenvalues are desired and ABSTOL is less than or equal */ -/* to zero, then call DSTERF or SSTEQR. If this fails for some */ -/* eigenvalue, then try DSTEBZ. */ - - test = false; - if (indeig) { - if (*il == 1 && *iu == *n) { - test = true; - } - } - if ((alleig || test) && *abstol <= 0.) { - dcopy_(n, &work[indd], &c__1, &w[1], &c__1); - indee = indwrk + (*n << 1); - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - if (! wantz) { - dsterf_(n, &w[1], &work[indee], info); - } else { - dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz); - dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ - indwrk], info); - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - ifail[i__] = 0; -/* L10: */ - } - } - } - if (*info == 0) { - *m = *n; - goto L30; - } - *info = 0; - } - -/* Otherwise, call DSTEBZ and, if eigenvectors are desired, */ -/* call DSTEIN. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - indibl = 1; - indisp = indibl + *n; - indiwo = indisp + *n; - dstebz_(range, order, n, vl, vu, il, iu, abstol, &work[indd], &work[inde], - m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], - &iwork[indiwo], info); - - if (wantz) { - dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ - indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); - -/* Apply transformation matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by DSTEIN. */ - - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1); - dgemv_("N", n, n, &c_b25, &q[q_offset], ldq, &work[1], &c__1, & - c_b27, &z__[j * z_dim1 + 1], &c__1); -/* L20: */ - } - } - -L30: - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L40: */ - } - - if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; - w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; - w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - if (*info != 0) { - itmp1 = ifail[i__]; - ifail[i__] = ifail[j]; - ifail[j] = itmp1; - } - } -/* L50: */ - } - } - - return 0; - -/* End of DSBGVX */ - -} /* dsbgvx_ */ diff --git a/external/clapack/lapack/dsbtrd.cpp b/external/clapack/lapack/dsbtrd.cpp deleted file mode 100644 index 43fc5055..00000000 --- a/external/clapack/lapack/dsbtrd.cpp +++ /dev/null @@ -1,687 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b9 = 0.; -static double c_b10 = 1.; -static integer c__1 = 1; - -/* Subroutine */ int dsbtrd_(const char *vect, const char *uplo, integer *n, integer *kd, - double *ab, integer *ldab, double *d__, double *e, - double *q, integer *ldq, double *work, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4, - i__5; - - /* Local variables */ - integer i__, j, k, l, i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt, - kdm1, inca, jend, lend, jinc, incx, last; - double temp; - integer j1end, j1inc, iqend; - bool initq, wantq, upper; - integer iqaend; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSBTRD reduces a real symmetric band matrix A to symmetric */ -/* tridiagonal form T by an orthogonal similarity transformation: */ -/* Q**T * A * Q = T. */ - -/* Arguments */ -/* ========= */ - -/* VECT (input) CHARACTER*1 */ -/* = 'N': do not form Q; */ -/* = 'V': form Q; */ -/* = 'U': update a matrix X, by forming X*Q. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ - -/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* On entry, the upper or lower triangle of the symmetric band */ -/* matrix A, stored in the first KD+1 rows of the array. The */ -/* j-th column of A is stored in the j-th column of the array AB */ -/* as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ -/* On exit, the diagonal elements of AB are overwritten by the */ -/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */ -/* elements on the first superdiagonal (if UPLO = 'U') or the */ -/* first subdiagonal (if UPLO = 'L') are overwritten by the */ -/* off-diagonal elements of T; the rest of AB is overwritten by */ -/* values generated during the reduction. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* D (output) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T. */ - -/* E (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix T: */ -/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* On entry, if VECT = 'U', then Q must contain an N-by-N */ -/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */ - -/* On exit: */ -/* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; */ -/* if VECT = 'U', Q contains the product X*Q; */ -/* if VECT = 'N', the array Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. */ -/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */ - -/* 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 */ -/* =============== */ - -/* Modified by Linda Kaufman, Bell Labs. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --d__; - --e; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --work; - - /* Function Body */ - initq = lsame_(vect, "V"); - wantq = initq || lsame_(vect, "U"); - upper = lsame_(uplo, "U"); - kd1 = *kd + 1; - kdm1 = *kd - 1; - incx = *ldab - 1; - iqend = 1; - - *info = 0; - if (! wantq && ! lsame_(vect, "N")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*kd < 0) { - *info = -4; - } else if (*ldab < kd1) { - *info = -6; - } else if (*ldq < std::max(1_integer,*n) && wantq) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSBTRD", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Initialize Q to the unit matrix, if needed */ - - if (initq) { - dlaset_("Full", n, n, &c_b9, &c_b10, &q[q_offset], ldq); - } - -/* Wherever possible, plane rotations are generated and applied in */ -/* vector operations of length NR over the index set J1:J2:KD1. */ - -/* The cosines and sines of the plane rotations are stored in the */ -/* arrays D and WORK. */ - - inca = kd1 * *ldab; -/* Computing MIN */ - i__1 = *n - 1; - kdn = std::min(i__1,*kd); - if (upper) { - - if (*kd > 1) { - -/* Reduce to tridiagonal form, working with upper triangle */ - - nr = 0; - j1 = kdn + 2; - j2 = 1; - - i__1 = *n - 2; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Reduce i-th row of matrix to tridiagonal form */ - - for (k = kdn + 1; k >= 2; --k) { - j1 += kdn; - j2 += kdn; - - if (nr > 0) { - -/* generate plane rotations to annihilate nonzero */ -/* elements which have been created outside the band */ - - dlargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, & - work[j1], &kd1, &d__[j1], &kd1); - -/* apply rotations from the right */ - - -/* Dependent on the the number of diagonals either */ -/* DLARTV or DROT is used */ - - if (nr >= (*kd << 1) - 1) { - i__2 = *kd - 1; - for (l = 1; l <= i__2; ++l) { - dlartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1], - &inca, &ab[l + j1 * ab_dim1], &inca, & - d__[j1], &work[j1], &kd1); -/* L10: */ - } - - } else { - jend = j1 + (nr - 1) * kd1; - i__2 = jend; - i__3 = kd1; - for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <= - i__2; jinc += i__3) { - drot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], & - c__1, &ab[jinc * ab_dim1 + 1], &c__1, - &d__[jinc], &work[jinc]); -/* L20: */ - } - } - } - - - if (k > 2) { - if (k <= *n - i__ + 1) { - -/* generate plane rotation to annihilate a(i,i+k-1) */ -/* within the band */ - - dlartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1] -, &ab[*kd - k + 2 + (i__ + k - 1) * - ab_dim1], &d__[i__ + k - 1], &work[i__ + - k - 1], &temp); - ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1] = temp; - -/* apply rotation from the right */ - - i__3 = k - 3; - drot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) * - ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ + - k - 1) * ab_dim1], &c__1, &d__[i__ + k - - 1], &work[i__ + k - 1]); - } - ++nr; - j1 = j1 - kdn - 1; - } - -/* apply plane rotations from both sides to diagonal */ -/* blocks */ - - if (nr > 0) { - dlar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 + - j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca, - &d__[j1], &work[j1], &kd1); - } - -/* apply plane rotations from the left */ - - if (nr > 0) { - if ((*kd << 1) - 1 < nr) { - -/* Dependent on the the number of diagonals either */ -/* DLARTV or DROT is used */ - - i__3 = *kd - 1; - for (l = 1; l <= i__3; ++l) { - if (j2 + l > *n) { - nrt = nr - 1; - } else { - nrt = nr; - } - if (nrt > 0) { - dlartv_(&nrt, &ab[*kd - l + (j1 + l) * - ab_dim1], &inca, &ab[*kd - l + 1 - + (j1 + l) * ab_dim1], &inca, & - d__[j1], &work[j1], &kd1); - } -/* L30: */ - } - } else { - j1end = j1 + kd1 * (nr - 2); - if (j1end >= j1) { - i__3 = j1end; - i__2 = kd1; - for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <= - i__3; jin += i__2) { - i__4 = *kd - 1; - drot_(&i__4, &ab[*kd - 1 + (jin + 1) * - ab_dim1], &incx, &ab[*kd + (jin + - 1) * ab_dim1], &incx, &d__[jin], & - work[jin]); -/* L40: */ - } - } -/* Computing MIN */ - i__2 = kdm1, i__3 = *n - j2; - lend = std::min(i__2,i__3); - last = j1end + kd1; - if (lend > 0) { - drot_(&lend, &ab[*kd - 1 + (last + 1) * - ab_dim1], &incx, &ab[*kd + (last + 1) - * ab_dim1], &incx, &d__[last], &work[ - last]); - } - } - } - - if (wantq) { - -/* accumulate product of plane rotations in Q */ - - if (initq) { - -/* take advantage of the fact that Q was */ -/* initially the Identity matrix */ - - iqend = std::max(iqend,j2); -/* Computing MAX */ - i__2 = 0, i__3 = k - 3; - i2 = std::max(i__2,i__3); - iqaend = i__ * *kd + 1; - if (k == 2) { - iqaend += *kd; - } - iqaend = std::min(iqaend,iqend); - i__2 = j2; - i__3 = kd1; - for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j - += i__3) { - ibl = i__ - i2 / kdm1; - ++i2; -/* Computing MAX */ - i__4 = 1, i__5 = j - ibl; - iqb = std::max(i__4,i__5); - nq = iqaend + 1 - iqb; -/* Computing MIN */ - i__4 = iqaend + *kd; - iqaend = std::min(i__4,iqend); - drot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1, - &q[iqb + j * q_dim1], &c__1, &d__[j], - &work[j]); -/* L50: */ - } - } else { - - i__3 = j2; - i__2 = kd1; - for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j - += i__2) { - drot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[ - j * q_dim1 + 1], &c__1, &d__[j], & - work[j]); -/* L60: */ - } - } - - } - - if (j2 + kdn > *n) { - -/* adjust J2 to keep within the bounds of the matrix */ - - --nr; - j2 = j2 - kdn - 1; - } - - i__2 = j2; - i__3 = kd1; - for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) - { - -/* create nonzero element a(j-1,j+kd) outside the band */ -/* and store it in WORK */ - - work[j + *kd] = work[j] * ab[(j + *kd) * ab_dim1 + 1]; - ab[(j + *kd) * ab_dim1 + 1] = d__[j] * ab[(j + *kd) * - ab_dim1 + 1]; -/* L70: */ - } -/* L80: */ - } -/* L90: */ - } - } - - if (*kd > 0) { - -/* copy off-diagonal elements to E */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - e[i__] = ab[*kd + (i__ + 1) * ab_dim1]; -/* L100: */ - } - } else { - -/* set E to zero if original matrix was diagonal */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - e[i__] = 0.; -/* L110: */ - } - } - -/* copy diagonal elements to D */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = ab[kd1 + i__ * ab_dim1]; -/* L120: */ - } - - } else { - - if (*kd > 1) { - -/* Reduce to tridiagonal form, working with lower triangle */ - - nr = 0; - j1 = kdn + 2; - j2 = 1; - - i__1 = *n - 2; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Reduce i-th column of matrix to tridiagonal form */ - - for (k = kdn + 1; k >= 2; --k) { - j1 += kdn; - j2 += kdn; - - if (nr > 0) { - -/* generate plane rotations to annihilate nonzero */ -/* elements which have been created outside the band */ - - dlargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, & - work[j1], &kd1, &d__[j1], &kd1); - -/* apply plane rotations from one side */ - - -/* Dependent on the the number of diagonals either */ -/* DLARTV or DROT is used */ - - if (nr > (*kd << 1) - 1) { - i__3 = *kd - 1; - for (l = 1; l <= i__3; ++l) { - dlartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) * - ab_dim1], &inca, &ab[kd1 - l + 1 + ( - j1 - kd1 + l) * ab_dim1], &inca, &d__[ - j1], &work[j1], &kd1); -/* L130: */ - } - } else { - jend = j1 + kd1 * (nr - 1); - i__3 = jend; - i__2 = kd1; - for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <= - i__3; jinc += i__2) { - drot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1] -, &incx, &ab[kd1 + (jinc - *kd) * - ab_dim1], &incx, &d__[jinc], &work[ - jinc]); -/* L140: */ - } - } - - } - - if (k > 2) { - if (k <= *n - i__ + 1) { - -/* generate plane rotation to annihilate a(i+k-1,i) */ -/* within the band */ - - dlartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ * - ab_dim1], &d__[i__ + k - 1], &work[i__ + - k - 1], &temp); - ab[k - 1 + i__ * ab_dim1] = temp; - -/* apply rotation from the left */ - - i__2 = k - 3; - i__3 = *ldab - 1; - i__4 = *ldab - 1; - drot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], & - i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], & - i__4, &d__[i__ + k - 1], &work[i__ + k - - 1]); - } - ++nr; - j1 = j1 - kdn - 1; - } - -/* apply plane rotations from both sides to diagonal */ -/* blocks */ - - if (nr > 0) { - dlar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 * - ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], & - inca, &d__[j1], &work[j1], &kd1); - } - -/* apply plane rotations from the right */ - - -/* Dependent on the the number of diagonals either */ -/* DLARTV or DROT is used */ - - if (nr > 0) { - if (nr > (*kd << 1) - 1) { - i__2 = *kd - 1; - for (l = 1; l <= i__2; ++l) { - if (j2 + l > *n) { - nrt = nr - 1; - } else { - nrt = nr; - } - if (nrt > 0) { - dlartv_(&nrt, &ab[l + 2 + (j1 - 1) * - ab_dim1], &inca, &ab[l + 1 + j1 * - ab_dim1], &inca, &d__[j1], &work[ - j1], &kd1); - } -/* L150: */ - } - } else { - j1end = j1 + kd1 * (nr - 2); - if (j1end >= j1) { - i__2 = j1end; - i__3 = kd1; - for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 : - j1inc <= i__2; j1inc += i__3) { - drot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 + - 3], &c__1, &ab[j1inc * ab_dim1 + - 2], &c__1, &d__[j1inc], &work[ - j1inc]); -/* L160: */ - } - } -/* Computing MIN */ - i__3 = kdm1, i__2 = *n - j2; - lend = std::min(i__3,i__2); - last = j1end + kd1; - if (lend > 0) { - drot_(&lend, &ab[(last - 1) * ab_dim1 + 3], & - c__1, &ab[last * ab_dim1 + 2], &c__1, - &d__[last], &work[last]); - } - } - } - - - - if (wantq) { - -/* accumulate product of plane rotations in Q */ - - if (initq) { - -/* take advantage of the fact that Q was */ -/* initially the Identity matrix */ - - iqend = std::max(iqend,j2); -/* Computing MAX */ - i__3 = 0, i__2 = k - 3; - i2 = std::max(i__3,i__2); - iqaend = i__ * *kd + 1; - if (k == 2) { - iqaend += *kd; - } - iqaend = std::min(iqaend,iqend); - i__3 = j2; - i__2 = kd1; - for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j - += i__2) { - ibl = i__ - i2 / kdm1; - ++i2; -/* Computing MAX */ - i__4 = 1, i__5 = j - ibl; - iqb = std::max(i__4,i__5); - nq = iqaend + 1 - iqb; -/* Computing MIN */ - i__4 = iqaend + *kd; - iqaend = std::min(i__4,iqend); - drot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1, - &q[iqb + j * q_dim1], &c__1, &d__[j], - &work[j]); -/* L170: */ - } - } else { - - i__2 = j2; - i__3 = kd1; - for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j - += i__3) { - drot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[ - j * q_dim1 + 1], &c__1, &d__[j], & - work[j]); -/* L180: */ - } - } - } - - if (j2 + kdn > *n) { - -/* adjust J2 to keep within the bounds of the matrix */ - - --nr; - j2 = j2 - kdn - 1; - } - - i__3 = j2; - i__2 = kd1; - for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) - { - -/* create nonzero element a(j+kd,j-1) outside the */ -/* band and store it in WORK */ - - work[j + *kd] = work[j] * ab[kd1 + j * ab_dim1]; - ab[kd1 + j * ab_dim1] = d__[j] * ab[kd1 + j * ab_dim1] - ; -/* L190: */ - } -/* L200: */ - } -/* L210: */ - } - } - - if (*kd > 0) { - -/* copy off-diagonal elements to E */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - e[i__] = ab[i__ * ab_dim1 + 2]; -/* L220: */ - } - } else { - -/* set E to zero if original matrix was diagonal */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - e[i__] = 0.; -/* L230: */ - } - } - -/* copy diagonal elements to D */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = ab[i__ * ab_dim1 + 1]; -/* L240: */ - } - } - - return 0; - -/* End of DSBTRD */ - -} /* dsbtrd_ */ diff --git a/external/clapack/lapack/dsfrk.cpp b/external/clapack/lapack/dsfrk.cpp deleted file mode 100644 index b3566943..00000000 --- a/external/clapack/lapack/dsfrk.cpp +++ /dev/null @@ -1,493 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dsfrk_(const char *transr, const char *uplo, const char *trans, integer *n, - integer *k, double *alpha, double *a, integer *lda, - double *beta, double *c__) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - - /* Local variables */ - integer j, n1, n2, nk, info; - bool normaltransr; - integer nrowa; - bool lower, nisodd, notrans; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Level 3 BLAS like routine for C in RFP Format. */ - -/* DSFRK performs one of the symmetric rank--k operations */ - -/* C := alpha*A*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*A + beta*C, */ - -/* where alpha and beta are real scalars, C is an n--by--n symmetric */ -/* matrix and A is an n--by--k matrix in the first case and a k--by--n */ -/* matrix in the second case. */ - -/* Arguments */ -/* ========== */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': The Normal Form of RFP A is stored; */ -/* = 'T': The Transpose Form of RFP A is stored. */ - -/* UPLO - (input) CHARACTER */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - (input) CHARACTER */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ - -/* Unchanged on exit. */ - -/* N - (input) INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - (input) INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrix A, and on entry with TRANS = 'T' */ -/* or 't', K specifies the number of rows of the matrix A. K */ -/* must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - (input) DOUBLE PRECISION. */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - (input) DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where KA */ -/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */ -/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */ -/* the array A must contain the matrix A, otherwise the leading */ -/* K--by--N part of the array A must contain the matrix A. */ -/* Unchanged on exit. */ - -/* LDA - (input) INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. When TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - (input) DOUBLE PRECISION. */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - - -/* C - (input/output) DOUBLE PRECISION array, dimension ( NT ); */ -/* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP */ -/* Format. RFP Format is described by TRANSR, UPLO and N. */ - -/* Arguments */ -/* ========== */ - -/* .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --c__; - - /* Function Body */ - info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - notrans = lsame_(trans, "N"); - - if (notrans) { - nrowa = *n; - } else { - nrowa = *k; - } - - if (! normaltransr && ! lsame_(transr, "T")) { - info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - info = -2; - } else if (! notrans && ! lsame_(trans, "T")) { - info = -3; - } else if (*n < 0) { - info = -4; - } else if (*k < 0) { - info = -5; - } else if (*lda < std::max(1_integer,nrowa)) { - info = -8; - } - if (info != 0) { - i__1 = -info; - xerbla_("DSFRK ", &i__1); - return 0; - } - -/* Quick return if possible. */ - -/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */ -/* done (it is in DSYRK for example) and left in the general case. */ - - if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } - - if (*alpha == 0. && *beta == 0.) { - i__1 = *n * (*n + 1) / 2; - for (j = 1; j <= i__1; ++j) { - c__[j] = 0.; - } - return 0; - } - -/* C is N-by-N. */ -/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ -/* If N is even, NISODD = .FALSE., and NK. */ - - if (*n % 2 == 0) { - nisodd = false; - nk = *n / 2; - } else { - nisodd = true; - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - } - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* N is odd, TRANSR = 'N', and UPLO = 'L' */ - - if (notrans) { - -/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */ - - dsyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[1], n); - dsyrk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, - beta, &c__[*n + 1], n); - dgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1], - lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1], n); - - } else { - -/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */ - - dsyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[1], n); - dsyrk_("U", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], - lda, beta, &c__[*n + 1], n) - ; - dgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1 - + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1], n); - - } - - } else { - -/* N is odd, TRANSR = 'N', and UPLO = 'U' */ - - if (notrans) { - -/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */ - - dsyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[n2 + 1], n); - dsyrk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda, - beta, &c__[n1 + 1], n); - dgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, - &a[n2 + a_dim1], lda, beta, &c__[1], n); - - } else { - -/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */ - - dsyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[n2 + 1], n); - dsyrk_("U", "T", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda, - beta, &c__[n1 + 1], n); - dgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, - &a[n2 * a_dim1 + 1], lda, beta, &c__[1], n); - - } - - } - - } else { - -/* N is odd, and TRANSR = 'T' */ - - if (lower) { - -/* N is odd, TRANSR = 'T', and UPLO = 'L' */ - - if (notrans) { - -/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */ - - dsyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[1], &n1); - dsyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, - beta, &c__[2], &n1); - dgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, - &a[n1 + 1 + a_dim1], lda, beta, &c__[n1 * n1 + 1], - &n1); - - } else { - -/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */ - - dsyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[1], &n1); - dsyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], - lda, beta, &c__[2], &n1); - dgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, - &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[n1 * - n1 + 1], &n1); - - } - - } else { - -/* N is odd, TRANSR = 'T', and UPLO = 'U' */ - - if (notrans) { - -/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */ - - dsyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[n2 * n2 + 1], &n2); - dsyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, - beta, &c__[n1 * n2 + 1], &n2); - dgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1], - lda, &a[a_dim1 + 1], lda, beta, &c__[1], &n2); - - } else { - -/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */ - - dsyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[n2 * n2 + 1], &n2); - dsyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], - lda, beta, &c__[n1 * n2 + 1], &n2); - dgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1 - + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], & - n2); - - } - - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* N is even, TRANSR = 'N', and UPLO = 'L' */ - - if (notrans) { - -/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */ - - i__1 = *n + 1; - dsyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[2], &i__1); - i__1 = *n + 1; - dsyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, - beta, &c__[1], &i__1); - i__1 = *n + 1; - dgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1], - lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], & - i__1); - - } else { - -/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */ - - i__1 = *n + 1; - dsyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[2], &i__1); - i__1 = *n + 1; - dsyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], - lda, beta, &c__[1], &i__1); - i__1 = *n + 1; - dgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1 - + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], &i__1); - - } - - } else { - -/* N is even, TRANSR = 'N', and UPLO = 'U' */ - - if (notrans) { - -/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */ - - i__1 = *n + 1; - dsyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk + 2], &i__1); - i__1 = *n + 1; - dsyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, - beta, &c__[nk + 1], &i__1); - i__1 = *n + 1; - dgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, - &a[nk + 1 + a_dim1], lda, beta, &c__[1], &i__1); - - } else { - -/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */ - - i__1 = *n + 1; - dsyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk + 2], &i__1); - i__1 = *n + 1; - dsyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], - lda, beta, &c__[nk + 1], &i__1); - i__1 = *n + 1; - dgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, - &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[1], &i__1); - - } - - } - - } else { - -/* N is even, and TRANSR = 'T' */ - - if (lower) { - -/* N is even, TRANSR = 'T', and UPLO = 'L' */ - - if (notrans) { - -/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */ - - dsyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk + 1], &nk); - dsyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, - beta, &c__[1], &nk); - dgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, - &a[nk + 1 + a_dim1], lda, beta, &c__[(nk + 1) * - nk + 1], &nk); - - } else { - -/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */ - - dsyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk + 1], &nk); - dsyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], - lda, beta, &c__[1], &nk); - dgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, - &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[(nk + 1) * nk + 1], &nk); - - } - - } else { - -/* N is even, TRANSR = 'T', and UPLO = 'U' */ - - if (notrans) { - -/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */ - - dsyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk * (nk + 1) + 1], &nk); - dsyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, - beta, &c__[nk * nk + 1], &nk); - dgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1], - lda, &a[a_dim1 + 1], lda, beta, &c__[1], &nk); - - } else { - -/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */ - - dsyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk * (nk + 1) + 1], &nk); - dsyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], - lda, beta, &c__[nk * nk + 1], &nk); - dgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1 - + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], & - nk); - - } - - } - - } - - } - - return 0; - -/* End of DSFRK */ - -} /* dsfrk_ */ diff --git a/external/clapack/lapack/dsgesv.cpp b/external/clapack/lapack/dsgesv.cpp deleted file mode 100644 index e47dab52..00000000 --- a/external/clapack/lapack/dsgesv.cpp +++ /dev/null @@ -1,375 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - - -/* Table of constant values */ - -static double c_b10 = -1.; -static double c_b11 = 1.; -static integer c__1 = 1; - -int dsgesv_(integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer *ldb, - double *x, integer *ldx, double *work, float *swork, integer *iter, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, x_dim1, x_offset, i__1; - double d__1; - - - /* Local variables */ - double cte, eps, anrm, rnrm, xnrm; - integer i__, ptsa, ptsx, iiter; - -/* -- LAPACK PROTOTYPE driver routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* February 2007 */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSGESV computes the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ - -/* DSGESV first attempts to factorize the matrix in SINGLE PRECISION */ -/* and use this factorization within an iterative refinement procedure */ -/* to produce a solution with DOUBLE PRECISION normwise backward error */ -/* quality (see below). If the approach fails the method switches to a */ -/* DOUBLE PRECISION factorization and solve. */ - -/* The iterative refinement is not going to be a winning strategy if */ -/* the ratio SINGLE PRECISION performance over DOUBLE PRECISION */ -/* performance is too small. A reasonable strategy should take the */ -/* number of right-hand sides and the size of the matrix into account. */ -/* This might be done with a call to ILAENV in the future. Up to now, we */ -/* always try iterative refinement. */ - -/* The iterative refinement process is stopped if */ -/* ITER > ITERMAX */ -/* or for all the RHS we have: */ -/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */ -/* where */ -/* o ITER is the number of the current iteration in the iterative */ -/* refinement process */ -/* o RNRM is the infinity-norm of the residual */ -/* o XNRM is the infinity-norm of the solution */ -/* o ANRM is the infinity-operator-norm of the matrix A */ -/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */ -/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */ -/* respectively. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input or input/ouptut) DOUBLE PRECISION array, */ -/* dimension (LDA,N) */ -/* On entry, the N-by-N coefficient matrix A. */ -/* On exit, if iterative refinement has been successfully used */ -/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */ -/* unchanged, if double precision factorization has been used */ -/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */ -/* array A contains the factors L and U from the factorization */ -/* A = P*L*U; the unit diagonal elements of L are not stored. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* The pivot indices that define the permutation matrix P; */ -/* row i of the matrix was interchanged with row IPIV(i). */ -/* Corresponds either to the single precision factorization */ -/* (if INFO.EQ.0 and ITER.GE.0) or the double precision */ -/* factorization (if INFO.EQ.0 and ITER.LT.0). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The N-by-NRHS right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS) */ -/* This array is used to hold the residual vectors. */ - -/* SWORK (workspace) REAL array, dimension (N*(N+NRHS)) */ -/* This array is used to use the single precision matrix and the */ -/* right-hand sides or solutions in single precision. */ - -/* ITER (output) INTEGER */ -/* < 0: iterative refinement has failed, double precision */ -/* factorization has been performed */ -/* -1 : the routine fell back to full precision for */ -/* implementation- or machine-specific reasons */ -/* -2 : narrowing the precision induced an overflow, */ -/* the routine fell back to full precision */ -/* -3 : failure of SGETRF */ -/* -31: stop the iterative refinement after the 30th */ -/* iterations */ -/* > 0: iterative refinement has been sucessfully used. */ -/* Returns the number of iterations */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is */ -/* exactly zero. The factorization has been completed, */ -/* but the factor U is exactly singular, so the solution */ -/* could not be computed. */ - -/* ========= */ - -/* .. Parameters .. */ - - - - -/* .. Local Scalars .. */ - -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - work_dim1 = *n; - work_offset = 1 + work_dim1; - work -= work_offset; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --swork; - - /* Function Body */ - *info = 0; - *iter = 0; - -/* Test the input parameters. */ - - if (*n < 0) { - *info = -1; - } else if (*nrhs < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSGESV", &i__1); - return 0; - } - -/* Quick return if (N.EQ.0). */ - - if (*n == 0) { - return 0; - } - -/* Skip single precision iterative refinement if a priori slower */ -/* than double precision factorization. */ - - if (false) { - *iter = -1; - goto L40; - } - -/* Compute some constants. */ - - anrm = dlange_("I", n, n, &a[a_offset], lda, &work[work_offset]); - eps = dlamch_("Epsilon"); - cte = anrm * eps * sqrt((double) (*n)) * 1.; - -/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */ - - ptsa = 1; - ptsx = ptsa + *n * *n; - -/* Convert B from double precision to single precision and store the */ -/* result in SX. */ - - dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info); - - if (*info != 0) { - *iter = -2; - goto L40; - } - -/* Convert A from double precision to single precision and store the */ -/* result in SA. */ - - dlag2s_(n, n, &a[a_offset], lda, &swork[ptsa], n, info); - - if (*info != 0) { - *iter = -2; - goto L40; - } - -/* Compute the LU factorization of SA. */ - - sgetrf_(n, n, &swork[ptsa], n, &ipiv[1], info); - - if (*info != 0) { - *iter = -3; - goto L40; - } - -/* Solve the system SA*SX = SB. */ - - sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ptsx], - n, info); - -/* Convert SX back to double precision */ - - slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info); - -/* Compute R = B - AX (R is WORK). */ - - dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); - - dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[a_offset], - lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n); - -/* Check whether the NRHS normwise backward errors satisfy the */ -/* stopping criterion. If yes, set ITER=0 and return. */ - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * - x_dim1], abs(d__1)); - rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + - i__ * work_dim1], abs(d__1)); - if (rnrm > xnrm * cte) { - goto L10; - } - } - -/* If we are here, the NRHS normwise backward errors satisfy the */ -/* stopping criterion. We are good to exit. */ - - *iter = 0; - return 0; - -L10: - - for (iiter = 1; iiter <= 30; ++iiter) { - -/* Convert R (in WORK) from double precision to single precision */ -/* and store the result in SX. */ - - dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info); - - if (*info != 0) { - *iter = -2; - goto L40; - } - -/* Solve the system SA*SX = SR. */ - - sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ - ptsx], n, info); - -/* Convert SX back to double precision and update the current */ -/* iterate. */ - - slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info); - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * - x_dim1 + 1], &c__1); - } - -/* Compute R = B - AX (R is WORK). */ - - dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); - - dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[ - a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset], - n); - -/* Check whether the NRHS normwise backward errors satisfy the */ -/* stopping criterion. If yes, set ITER=IITER>0 and return. */ - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * - x_dim1], abs(d__1)); - rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) - + i__ * work_dim1], abs(d__1)); - if (rnrm > xnrm * cte) { - goto L20; - } - } - -/* If we are here, the NRHS normwise backward errors satisfy the */ -/* stopping criterion, we are good to exit. */ - - *iter = iiter; - - return 0; - -L20: - -/* L30: */ - ; - } - -/* If we are at this place of the code, this is because we have */ -/* performed ITER=ITERMAX iterations and never satisified the */ -/* stopping criterion, set up the ITER flag accordingly and follow up */ -/* on double precision routine. */ - - *iter = -31; - -L40: - -/* Single-precision iterative refinement failed to converge to a */ -/* satisfactory solution, so we resort to double precision. */ - - dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); - - if (*info != 0) { - return 0; - } - - dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &x[x_offset] -, ldx, info); - - return 0; - -/* End of DSGESV. */ - -} /* dsgesv_ */ diff --git a/external/clapack/lapack/dspcon.cpp b/external/clapack/lapack/dspcon.cpp deleted file mode 100644 index cc64e4b6..00000000 --- a/external/clapack/lapack/dspcon.cpp +++ /dev/null @@ -1,179 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dspcon_(const char *uplo, integer *n, double *ap, integer * - ipiv, double *anorm, double *rcond, double *work, integer - *iwork, integer *info) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, ip, kase; - integer isave[3]; - bool upper; - double ainvnm; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPCON estimates the reciprocal of the condition number (in the */ -/* 1-norm) of a real symmetric packed matrix A using the factorization */ -/* A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the details of the factorization are stored */ -/* as an upper or lower triangular matrix. */ -/* = 'U': Upper triangular, form is A = U*D*U**T; */ -/* = 'L': Lower triangular, form is A = L*D*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The block diagonal matrix D and the multipliers used to */ -/* obtain the factor U or L as computed by DSPTRF, stored as a */ -/* packed triangular matrix. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSPTRF. */ - -/* ANORM (input) DOUBLE PRECISION */ -/* The 1-norm of the original matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ -/* estimate of the 1-norm of inv(A) computed in this routine. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --iwork; - --work; - --ipiv; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*anorm < 0.) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm <= 0.) { - return 0; - } - -/* Check that the diagonal matrix D is nonsingular. */ - - if (upper) { - -/* Upper triangular storage: examine D from bottom to top */ - - ip = *n * (*n + 1) / 2; - for (i__ = *n; i__ >= 1; --i__) { - if (ipiv[i__] > 0 && ap[ip] == 0.) { - return 0; - } - ip -= i__; -/* L10: */ - } - } else { - -/* Lower triangular storage: examine D from top to bottom. */ - - ip = 1; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (ipiv[i__] > 0 && ap[ip] == 0.) { - return 0; - } - ip = ip + *n - i__ + 1; -/* L20: */ - } - } - -/* Estimate the 1-norm of the inverse. */ - - kase = 0; -L30: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - -/* Multiply by inv(L*D*L') or inv(U*D*U'). */ - - dsptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info); - goto L30; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - - return 0; - -/* End of DSPCON */ - -} /* dspcon_ */ diff --git a/external/clapack/lapack/dspev.cpp b/external/clapack/lapack/dspev.cpp deleted file mode 100644 index d7f54493..00000000 --- a/external/clapack/lapack/dspev.cpp +++ /dev/null @@ -1,217 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dspev_(const char *jobz, const char *uplo, integer *n, double * - ap, double *w, double *z__, integer *ldz, double *work, - integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1; - double d__1; - - /* Local variables */ - double eps; - integer inde; - double anrm; - integer imax; - double rmin, rmax; - double sigma; - integer iinfo; - bool wantz; - integer iscale; - double safmin; - double bignum; - integer indtau; - integer indwrk; - double smlnum; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPEV computes all the eigenvalues and, optionally, eigenvectors of a */ -/* real symmetric matrix A in packed storage. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, AP is overwritten by values generated during the */ -/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */ -/* and first superdiagonal of the tridiagonal matrix T overwrite */ -/* the corresponding elements of A, and if UPLO = 'L', the */ -/* diagonal and first subdiagonal of T overwrite the */ -/* corresponding elements of A. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ -/* eigenvectors of the matrix A, with the i-th column of Z */ -/* holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* 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. */ -/* > 0: if INFO = i, the algorithm failed to converge; i */ -/* off-diagonal elements of an intermediate tridiagonal */ -/* form did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (lsame_(uplo, "U") || lsame_(uplo, - "L"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -7; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPEV ", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - w[1] = ap[1]; - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); - rmax = sqrt(bignum); - -/* Scale matrix to allowable range, if necessary. */ - - anrm = dlansp_("M", uplo, n, &ap[1], &work[1]); - iscale = 0; - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - i__1 = *n * (*n + 1) / 2; - dscal_(&i__1, &sigma, &ap[1], &c__1); - } - -/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ - - inde = 1; - indtau = inde + *n; - dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo); - -/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ -/* DOPGTR to generate the orthogonal matrix, then call DSTEQR. */ - - if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); - } else { - indwrk = indtau + *n; - dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[ - indwrk], &iinfo); - dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ - indtau], info); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (iscale == 1) { - if (*info == 0) { - imax = *n; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - - return 0; - -/* End of DSPEV */ - -} /* dspev_ */ diff --git a/external/clapack/lapack/dspevd.cpp b/external/clapack/lapack/dspevd.cpp deleted file mode 100644 index 3255c53a..00000000 --- a/external/clapack/lapack/dspevd.cpp +++ /dev/null @@ -1,283 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dspevd_(const char *jobz, const char *uplo, integer *n, double * - ap, double *w, double *z__, integer *ldz, double *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1; - double d__1; - - /* Local variables */ - double eps; - integer inde; - double anrm, rmin, rmax; - double sigma; - integer iinfo, lwmin; - bool wantz; - integer iscale; - double safmin; - double bignum; - integer indtau; - integer indwrk, liwmin; - integer llwork; - double smlnum; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPEVD computes all the eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric matrix A in packed storage. If eigenvectors are */ -/* desired, it uses a divide and conquer algorithm. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, AP is overwritten by values generated during the */ -/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */ -/* and first superdiagonal of the tridiagonal matrix T overwrite */ -/* the corresponding elements of A, and if UPLO = 'L', the */ -/* diagonal and first subdiagonal of T overwrite the */ -/* corresponding elements of A. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ -/* eigenvectors of the matrix A, with the i-th column of Z */ -/* holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, */ -/* dimension (LWORK) */ -/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* If N <= 1, LWORK must be at least 1. */ -/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. */ -/* If JOBZ = 'V' and N > 1, LWORK must be at least */ -/* 1 + 6*N + N**2. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the required sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ -/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the required sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: if INFO = i, the algorithm failed to converge; i */ -/* off-diagonal elements of an intermediate tridiagonal */ -/* form did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - lquery = *lwork == -1 || *liwork == -1; - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (lsame_(uplo, "U") || lsame_(uplo, - "L"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -7; - } - - if (*info == 0) { - if (*n <= 1) { - liwmin = 1; - lwmin = 1; - } else { - if (wantz) { - liwmin = *n * 5 + 3; -/* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 6 + 1 + i__1 * i__1; - } else { - liwmin = 1; - lwmin = *n << 1; - } - } - iwork[1] = liwmin; - work[1] = (double) lwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -9; - } else if (*liwork < liwmin && ! lquery) { - *info = -11; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPEVD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - w[1] = ap[1]; - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); - rmax = sqrt(bignum); - -/* Scale matrix to allowable range, if necessary. */ - - anrm = dlansp_("M", uplo, n, &ap[1], &work[1]); - iscale = 0; - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - i__1 = *n * (*n + 1) / 2; - dscal_(&i__1, &sigma, &ap[1], &c__1); - } - -/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ - - inde = 1; - indtau = inde + *n; - dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo); - -/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ -/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ -/* tridiagonal matrix, then call DOPMTR to multiply it by the */ -/* Householder transformations represented in AP. */ - - if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); - } else { - indwrk = indtau + *n; - llwork = *lwork - indwrk + 1; - dstedc_("I", n, &w[1], &work[inde], &z__[z_offset], ldz, &work[indwrk] -, &llwork, &iwork[1], liwork, info); - dopmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset], - ldz, &work[indwrk], &iinfo); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (iscale == 1) { - d__1 = 1. / sigma; - dscal_(n, &d__1, &w[1], &c__1); - } - - work[1] = (double) lwmin; - iwork[1] = liwmin; - return 0; - -/* End of DSPEVD */ - -} /* dspevd_ */ diff --git a/external/clapack/lapack/dspevx.cpp b/external/clapack/lapack/dspevx.cpp deleted file mode 100644 index 1315433a..00000000 --- a/external/clapack/lapack/dspevx.cpp +++ /dev/null @@ -1,427 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dspevx_(const char *jobz, const char *range, const char *uplo, integer *n, - double *ap, double *vl, double *vu, integer *il, integer * - iu, double *abstol, integer *m, double *w, double *z__, - integer *ldz, double *work, integer *iwork, integer *ifail, - integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, jj; - double eps, vll, vuu, tmp1; - integer indd, inde; - double anrm; - integer imax; - double rmin, rmax; - bool test; - integer itmp1, indee; - double sigma; - integer iinfo; - char order[1]; - bool wantz; - bool alleig, indeig; - integer iscale, indibl; - bool valeig; - double safmin; - double abstll, bignum; - integer indtau, indisp; - integer indiwo; - integer indwrk; - integer nsplit; - double smlnum; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPEVX computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric matrix A in packed storage. Eigenvalues/vectors */ -/* can be selected by specifying either a range of values or a range of */ -/* indices for the desired eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found; */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found; */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, AP is overwritten by values generated during the */ -/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */ -/* and first superdiagonal of the tridiagonal matrix T overwrite */ -/* the corresponding elements of A, and if UPLO = 'L', the */ -/* diagonal and first subdiagonal of T overwrite the */ -/* corresponding elements of A. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing AP to tridiagonal form. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ -/* If this routine returns with INFO>0, indicating that some */ -/* eigenvectors did not converge, try setting ABSTOL to */ -/* 2*DLAMCH('S'). */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices */ -/* with Guaranteed High Relative Accuracy," by Demmel and */ -/* Kahan, LAPACK Working Note #3. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the selected eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If an eigenvector fails to converge, then that column of Z */ -/* contains the latest approximation to the eigenvector, and the */ -/* index of the eigenvector is returned in IFAIL. */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) */ - -/* IWORK (workspace) INTEGER array, dimension (5*N) */ - -/* IFAIL (output) INTEGER array, dimension (N) */ -/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ -/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ -/* indices of the eigenvectors that failed to converge. */ -/* If JOBZ = 'N', then IFAIL is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* Their indices are stored in array IFAIL. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (! (lsame_(uplo, "L") || lsame_(uplo, - "U"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -7; - } - } else if (indeig) { - if (*il < 1 || *il > std::max(1_integer,*n)) { - *info = -8; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -9; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -14; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPEVX", &i__1); - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (alleig || indeig) { - *m = 1; - w[1] = ap[1]; - } else { - if (*vl < ap[1] && *vu >= ap[1]) { - *m = 1; - w[1] = ap[1]; - } - } - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = std::min(d__1,d__2); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - abstll = *abstol; - if (valeig) { - vll = *vl; - vuu = *vu; - } else { - vll = 0.; - vuu = 0.; - } - anrm = dlansp_("M", uplo, n, &ap[1], &work[1]); - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - i__1 = *n * (*n + 1) / 2; - dscal_(&i__1, &sigma, &ap[1], &c__1); - if (*abstol > 0.) { - abstll = *abstol * sigma; - } - if (valeig) { - vll = *vl * sigma; - vuu = *vu * sigma; - } - } - -/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ - - indtau = 1; - inde = indtau + *n; - indd = inde + *n; - indwrk = indd + *n; - dsptrd_(uplo, n, &ap[1], &work[indd], &work[inde], &work[indtau], &iinfo); - -/* If all eigenvalues are desired and ABSTOL is less than or equal */ -/* to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails */ -/* for some eigenvalue, then try DSTEBZ. */ - - test = false; - if (indeig) { - if (*il == 1 && *iu == *n) { - test = true; - } - } - if ((alleig || test) && *abstol <= 0.) { - dcopy_(n, &work[indd], &c__1, &w[1], &c__1); - indee = indwrk + (*n << 1); - if (! wantz) { - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dsterf_(n, &w[1], &work[indee], info); - } else { - dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, & - work[indwrk], &iinfo); - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ - indwrk], info); - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - ifail[i__] = 0; -/* L10: */ - } - } - } - if (*info == 0) { - *m = *n; - goto L20; - } - *info = 0; - } - -/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - indibl = 1; - indisp = indibl + *n; - indiwo = indisp + *n; - dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ - inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); - - if (wantz) { - dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ - indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by DSTEIN. */ - - dopmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset], - ldz, &work[indwrk], info); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - -L20: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L30: */ - } - - if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; - w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; - w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - if (*info != 0) { - itmp1 = ifail[i__]; - ifail[i__] = ifail[j]; - ifail[j] = itmp1; - } - } -/* L40: */ - } - } - - return 0; - -/* End of DSPEVX */ - -} /* dspevx_ */ diff --git a/external/clapack/lapack/dspgst.cpp b/external/clapack/lapack/dspgst.cpp deleted file mode 100644 index f50a73c6..00000000 --- a/external/clapack/lapack/dspgst.cpp +++ /dev/null @@ -1,258 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b9 = -1.; -static double c_b11 = 1.; - -/* Subroutine */ int dspgst_(integer *itype, const char *uplo, integer *n, - double *ap, double *bp, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - double d__1; - - /* Local variables */ - integer j, k, j1, k1, jj, kk; - double ct, ajj; - integer j1j1; - double akk; - integer k1k1; - double bjj, bkk; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPGST reduces a real symmetric-definite generalized eigenproblem */ -/* to standard form, using packed storage. */ - -/* If ITYPE = 1, the problem is A*x = lambda*B*x, */ -/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */ - -/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ -/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */ - -/* B must have been previously factorized as U**T*U or L*L**T by DPPTRF. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */ -/* = 2 or 3: compute U*A*U**T or L**T*A*L. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored and B is factored as */ -/* U**T*U; */ -/* = 'L': Lower triangle of A is stored and B is factored as */ -/* L*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, if INFO = 0, the transformed matrix, stored in the */ -/* same format as A. */ - -/* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The triangular factor from the Cholesky factorization of B, */ -/* stored in the same format as A, as returned by DPPTRF. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --bp; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPGST", &i__1); - return 0; - } - - if (*itype == 1) { - if (upper) { - -/* Compute inv(U')*A*inv(U) */ - -/* J1 and JJ are the indices of A(1,j) and A(j,j) */ - - jj = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - j1 = jj + 1; - jj += j; - -/* Compute the j-th column of the upper triangle of A */ - - bjj = bp[jj]; - dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], & - c__1); - i__2 = j - 1; - dspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, & - ap[j1], &c__1); - i__2 = j - 1; - d__1 = 1. / bjj; - dscal_(&i__2, &d__1, &ap[j1], &c__1); - i__2 = j - 1; - ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], & - c__1)) / bjj; -/* L10: */ - } - } else { - -/* Compute inv(L)*A*inv(L') */ - -/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ - - kk = 1; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - k1k1 = kk + *n - k + 1; - -/* Update the lower triangle of A(k:n,k:n) */ - - akk = ap[kk]; - bkk = bp[kk]; -/* Computing 2nd power */ - d__1 = bkk; - akk /= d__1 * d__1; - ap[kk] = akk; - if (k < *n) { - i__2 = *n - k; - d__1 = 1. / bkk; - dscal_(&i__2, &d__1, &ap[kk + 1], &c__1); - ct = akk * -.5; - i__2 = *n - k; - daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) - ; - i__2 = *n - k; - dspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1] -, &c__1, &ap[k1k1]); - i__2 = *n - k; - daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) - ; - i__2 = *n - k; - dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], - &ap[kk + 1], &c__1); - } - kk = k1k1; -/* L20: */ - } - } - } else { - if (upper) { - -/* Compute U*A*U' */ - -/* K1 and KK are the indices of A(1,k) and A(k,k) */ - - kk = 0; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - k1 = kk + 1; - kk += k; - -/* Update the upper triangle of A(1:k,1:k) */ - - akk = ap[kk]; - bkk = bp[kk]; - i__2 = k - 1; - dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ - k1], &c__1); - ct = akk * .5; - i__2 = k - 1; - daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); - i__2 = k - 1; - dspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, & - ap[1]); - i__2 = k - 1; - daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); - i__2 = k - 1; - dscal_(&i__2, &bkk, &ap[k1], &c__1); -/* Computing 2nd power */ - d__1 = bkk; - ap[kk] = akk * (d__1 * d__1); -/* L30: */ - } - } else { - -/* Compute L'*A*L */ - -/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ - - jj = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - j1j1 = jj + *n - j + 1; - -/* Compute the j-th column of the lower triangle of A */ - - ajj = ap[jj]; - bjj = bp[jj]; - i__2 = *n - j; - ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj - + 1], &c__1); - i__2 = *n - j; - dscal_(&i__2, &bjj, &ap[jj + 1], &c__1); - i__2 = *n - j; - dspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, & - c_b11, &ap[jj + 1], &c__1); - i__2 = *n - j + 1; - dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj], - &c__1); - jj = j1j1; -/* L40: */ - } - } - } - return 0; - -/* End of DSPGST */ - -} /* dspgst_ */ diff --git a/external/clapack/lapack/dspgv.cpp b/external/clapack/lapack/dspgv.cpp deleted file mode 100644 index ce534117..00000000 --- a/external/clapack/lapack/dspgv.cpp +++ /dev/null @@ -1,219 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dspgv_(integer *itype, const char *jobz, const char *uplo, integer * - n, double *ap, double *bp, double *w, double *z__, - integer *ldz, double *work, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1; - - /* Local variables */ - integer j, neig; - char trans[1]; - bool upper; - bool wantz; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPGV computes all the eigenvalues and, optionally, the eigenvectors */ -/* of a real generalized symmetric-definite eigenproblem, of the form */ -/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */ -/* Here A and B are assumed to be symmetric, stored in packed format, */ -/* and B is also positive definite. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* Specifies the problem type to be solved: */ -/* = 1: A*x = (lambda)*B*x */ -/* = 2: A*B*x = (lambda)*x */ -/* = 3: B*A*x = (lambda)*x */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangles of A and B are stored; */ -/* = 'L': Lower triangles of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension */ -/* (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, the contents of AP are destroyed. */ - -/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* B, packed columnwise in a linear array. The j-th column of B */ -/* is stored in the array BP as follows: */ -/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ - -/* On exit, the triangular factor U or L from the Cholesky */ -/* factorization B = U**T*U or B = L*L**T, in the same storage */ -/* format as B. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ -/* eigenvectors. The eigenvectors are normalized as follows: */ -/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ -/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* 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 */ -/* > 0: DPPTRF or DSPEV returned an error code: */ -/* <= N: if INFO = i, DSPEV failed to converge; */ -/* i off-diagonal elements of an intermediate */ -/* tridiagonal form did not converge to zero. */ -/* > N: if INFO = n + i, for 1 <= i <= n, then the leading */ -/* minor of order i of B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --bp; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - upper = lsame_(uplo, "U"); - - *info = 0; - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! (wantz || lsame_(jobz, "N"))) { - *info = -2; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPGV ", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Form a Cholesky factorization of B. */ - - dpptrf_(uplo, n, &bp[1], info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem and solve. */ - - dspgst_(itype, uplo, n, &ap[1], &bp[1], info); - dspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info); - - if (wantz) { - -/* Backtransform eigenvectors to the original problem. */ - - neig = *n; - if (*info > 0) { - neig = *info - 1; - } - if (*itype == 1 || *itype == 2) { - -/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ -/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ - - if (upper) { - *(unsigned char *)trans = 'N'; - } else { - *(unsigned char *)trans = 'T'; - } - - i__1 = neig; - for (j = 1; j <= i__1; ++j) { - dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + - 1], &c__1); -/* L10: */ - } - - } else if (*itype == 3) { - -/* For B*A*x=(lambda)*x; */ -/* backtransform eigenvectors: x = L*y or U'*y */ - - if (upper) { - *(unsigned char *)trans = 'T'; - } else { - *(unsigned char *)trans = 'N'; - } - - i__1 = neig; - for (j = 1; j <= i__1; ++j) { - dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + - 1], &c__1); -/* L20: */ - } - } - } - return 0; - -/* End of DSPGV */ - -} /* dspgv_ */ diff --git a/external/clapack/lapack/dspgvd.cpp b/external/clapack/lapack/dspgvd.cpp deleted file mode 100644 index ec6797fb..00000000 --- a/external/clapack/lapack/dspgvd.cpp +++ /dev/null @@ -1,310 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dspgvd_(integer *itype, const char *jobz, const char *uplo, integer * - n, double *ap, double *bp, double *w, double *z__, - integer *ldz, double *work, integer *lwork, integer *iwork, - integer *liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer j, neig; - integer lwmin; - char trans[1]; - bool upper; - bool wantz; - integer liwmin; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors */ -/* of a real generalized symmetric-definite eigenproblem, of the form */ -/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ -/* B are assumed to be symmetric, stored in packed format, and B is also */ -/* positive definite. */ -/* If eigenvectors are desired, it uses a divide and conquer algorithm. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* Specifies the problem type to be solved: */ -/* = 1: A*x = (lambda)*B*x */ -/* = 2: A*B*x = (lambda)*x */ -/* = 3: B*A*x = (lambda)*x */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangles of A and B are stored; */ -/* = 'L': Lower triangles of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, the contents of AP are destroyed. */ - -/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* B, packed columnwise in a linear array. The j-th column of B */ -/* is stored in the array BP as follows: */ -/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ - -/* On exit, the triangular factor U or L from the Cholesky */ -/* factorization B = U**T*U or B = L*L**T, in the same storage */ -/* format as B. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ -/* eigenvectors. The eigenvectors are normalized as follows: */ -/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ -/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* If N <= 1, LWORK >= 1. */ -/* If JOBZ = 'N' and N > 1, LWORK >= 2*N. */ -/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the required sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */ -/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the required sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: DPPTRF or DSPEVD returned an error code: */ -/* <= N: if INFO = i, DSPEVD failed to converge; */ -/* i off-diagonal elements of an intermediate */ -/* tridiagonal form did not converge to zero; */ -/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ -/* minor of order i of B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --bp; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - upper = lsame_(uplo, "U"); - lquery = *lwork == -1 || *liwork == -1; - - *info = 0; - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! (wantz || lsame_(jobz, "N"))) { - *info = -2; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -9; - } - - if (*info == 0) { - if (*n <= 1) { - liwmin = 1; - lwmin = 1; - } else { - if (wantz) { - liwmin = *n * 5 + 3; -/* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); - } else { - liwmin = 1; - lwmin = *n << 1; - } - } - work[1] = (double) lwmin; - iwork[1] = liwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -11; - } else if (*liwork < liwmin && ! lquery) { - *info = -13; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPGVD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Form a Cholesky factorization of BP. */ - - dpptrf_(uplo, n, &bp[1], info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem and solve. */ - - dspgst_(itype, uplo, n, &ap[1], &bp[1], info); - dspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], - lwork, &iwork[1], liwork, info); -/* Computing MAX */ - d__1 = (double) lwmin; - lwmin = (integer) std::max(d__1,work[1]); -/* Computing MAX */ - d__1 = (double) liwmin, d__2 = (double) iwork[1]; - liwmin = (integer) std::max(d__1,d__2); - - if (wantz) { - -/* Backtransform eigenvectors to the original problem. */ - - neig = *n; - if (*info > 0) { - neig = *info - 1; - } - if (*itype == 1 || *itype == 2) { - -/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ -/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ - - if (upper) { - *(unsigned char *)trans = 'N'; - } else { - *(unsigned char *)trans = 'T'; - } - - i__1 = neig; - for (j = 1; j <= i__1; ++j) { - dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + - 1], &c__1); -/* L10: */ - } - - } else if (*itype == 3) { - -/* For B*A*x=(lambda)*x; */ -/* backtransform eigenvectors: x = L*y or U'*y */ - - if (upper) { - *(unsigned char *)trans = 'T'; - } else { - *(unsigned char *)trans = 'N'; - } - - i__1 = neig; - for (j = 1; j <= i__1; ++j) { - dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + - 1], &c__1); -/* L20: */ - } - } - } - - work[1] = (double) lwmin; - iwork[1] = liwmin; - - return 0; - -/* End of DSPGVD */ - -} /* dspgvd_ */ diff --git a/external/clapack/lapack/dspgvx.cpp b/external/clapack/lapack/dspgvx.cpp deleted file mode 100644 index 3ef1c3c7..00000000 --- a/external/clapack/lapack/dspgvx.cpp +++ /dev/null @@ -1,316 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dspgvx_(integer *itype, const char *jobz, const char *range, const char * - uplo, integer *n, double *ap, double *bp, double *vl, - double *vu, integer *il, integer *iu, double *abstol, integer - *m, double *w, double *z__, integer *ldz, double *work, - integer *iwork, integer *ifail, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1; - - /* Local variables */ - integer j; - char trans[1]; - bool upper; - bool wantz, alleig, indeig, valeig; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPGVX computes selected eigenvalues, and optionally, eigenvectors */ -/* of a real generalized symmetric-definite eigenproblem, of the form */ -/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */ -/* and B are assumed to be symmetric, stored in packed storage, and B */ -/* is also positive definite. Eigenvalues and eigenvectors can be */ -/* selected by specifying either a range of values or a range of indices */ -/* for the desired eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* Specifies the problem type to be solved: */ -/* = 1: A*x = (lambda)*B*x */ -/* = 2: A*B*x = (lambda)*x */ -/* = 3: B*A*x = (lambda)*x */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A and B are stored; */ -/* = 'L': Lower triangle of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix pencil (A,B). N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, the contents of AP are destroyed. */ - -/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* B, packed columnwise in a linear array. The j-th column of B */ -/* is stored in the array BP as follows: */ -/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ - -/* On exit, the triangular factor U or L from the Cholesky */ -/* factorization B = U**T*U or B = L*L**T, in the same storage */ -/* format as B. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing A to tridiagonal form. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ -/* If this routine returns with INFO>0, indicating that some */ -/* eigenvectors did not converge, try setting ABSTOL to */ -/* 2*DLAMCH('S'). */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* On normal exit, the first M elements contain the selected */ -/* eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* The eigenvectors are normalized as follows: */ -/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ -/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ - -/* If an eigenvector fails to converge, then that column of Z */ -/* contains the latest approximation to the eigenvector, and the */ -/* index of the eigenvector is returned in IFAIL. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) */ - -/* IWORK (workspace) INTEGER array, dimension (5*N) */ - -/* IFAIL (output) INTEGER array, dimension (N) */ -/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ -/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ -/* indices of the eigenvectors that failed to converge. */ -/* If JOBZ = 'N', then IFAIL is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: DPPTRF or DSPEVX returned an error code: */ -/* <= N: if INFO = i, DSPEVX failed to converge; */ -/* i eigenvectors failed to converge. Their indices */ -/* are stored in array IFAIL. */ -/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ -/* minor of order i of B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --bp; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - upper = lsame_(uplo, "U"); - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - *info = 0; - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! (wantz || lsame_(jobz, "N"))) { - *info = -2; - } else if (! (alleig || valeig || indeig)) { - *info = -3; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -9; - } - } else if (indeig) { - if (*il < 1) { - *info = -10; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -11; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -16; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPGVX", &i__1); - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - -/* Form a Cholesky factorization of B. */ - - dpptrf_(uplo, n, &bp[1], info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem and solve. */ - - dspgst_(itype, uplo, n, &ap[1], &bp[1], info); - dspevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], & - z__[z_offset], ldz, &work[1], &iwork[1], &ifail[1], info); - - if (wantz) { - -/* Backtransform eigenvectors to the original problem. */ - - if (*info > 0) { - *m = *info - 1; - } - if (*itype == 1 || *itype == 2) { - -/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ -/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ - - if (upper) { - *(unsigned char *)trans = 'N'; - } else { - *(unsigned char *)trans = 'T'; - } - - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + - 1], &c__1); -/* L10: */ - } - - } else if (*itype == 3) { - -/* For B*A*x=(lambda)*x; */ -/* backtransform eigenvectors: x = L*y or U'*y */ - - if (upper) { - *(unsigned char *)trans = 'T'; - } else { - *(unsigned char *)trans = 'N'; - } - - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + - 1], &c__1); -/* L20: */ - } - } - } - - return 0; - -/* End of DSPGVX */ - -} /* dspgvx_ */ diff --git a/external/clapack/lapack/dsposv.cpp b/external/clapack/lapack/dsposv.cpp deleted file mode 100644 index e0b162f5..00000000 --- a/external/clapack/lapack/dsposv.cpp +++ /dev/null @@ -1,381 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b10 = -1.; -static double c_b11 = 1.; -static integer c__1 = 1; - -int dsposv_(const char *uplo, integer *n, integer *nrhs, double *a, integer *lda, double *b, integer *ldb, - double *x, integer *ldx, double *work, float *swork, integer *iter, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, - x_dim1, x_offset, i__1; - double d__1; - - /* Local variables */ - integer i__; - double cte, eps, anrm; - integer ptsa; - double rnrm, xnrm; - integer ptsx; - integer iiter; - - -/* -- LAPACK PROTOTYPE driver routine (version 3.1.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ -/* May 2007 */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPOSV computes the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric positive definite matrix and X and B */ -/* are N-by-NRHS matrices. */ - -/* DSPOSV first attempts to factorize the matrix in SINGLE PRECISION */ -/* and use this factorization within an iterative refinement procedure */ -/* to produce a solution with DOUBLE PRECISION normwise backward error */ -/* quality (see below). If the approach fails the method switches to a */ -/* DOUBLE PRECISION factorization and solve. */ - -/* The iterative refinement is not going to be a winning strategy if */ -/* the ratio SINGLE PRECISION performance over DOUBLE PRECISION */ -/* performance is too small. A reasonable strategy should take the */ -/* number of right-hand sides and the size of the matrix into account. */ -/* This might be done with a call to ILAENV in the future. Up to now, we */ -/* always try iterative refinement. */ - -/* The iterative refinement process is stopped if */ -/* ITER > ITERMAX */ -/* or for all the RHS we have: */ -/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */ -/* where */ -/* o ITER is the number of the current iteration in the iterative */ -/* refinement process */ -/* o RNRM is the infinity-norm of the residual */ -/* o XNRM is the infinity-norm of the solution */ -/* o ANRM is the infinity-operator-norm of the matrix A */ -/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */ -/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */ -/* respectively. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input or input/ouptut) DOUBLE PRECISION array, */ -/* dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ -/* On exit, if iterative refinement has been successfully used */ -/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */ -/* unchanged, if double precision factorization has been used */ -/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */ -/* array A contains the factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T. */ - - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The N-by-NRHS right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS) */ -/* This array is used to hold the residual vectors. */ - -/* SWORK (workspace) REAL array, dimension (N*(N+NRHS)) */ -/* This array is used to use the single precision matrix and the */ -/* right-hand sides or solutions in single precision. */ - -/* ITER (output) INTEGER */ -/* < 0: iterative refinement has failed, double precision */ -/* factorization has been performed */ -/* -1 : the routine fell back to full precision for */ -/* implementation- or machine-specific reasons */ -/* -2 : narrowing the precision induced an overflow, */ -/* the routine fell back to full precision */ -/* -3 : failure of SPOTRF */ -/* -31: stop the iterative refinement after the 30th */ -/* iterations */ -/* > 0: iterative refinement has been sucessfully used. */ -/* Returns the number of iterations */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i of (DOUBLE */ -/* PRECISION) A is not positive definite, so the */ -/* factorization could not be completed, and the solution */ -/* has not been computed. */ - -/* ========= */ - -/* .. Parameters .. */ - - - - -/* .. Local Scalars .. */ - -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - work_dim1 = *n; - work_offset = 1 + work_dim1; - work -= work_offset; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --swork; - - /* Function Body */ - *info = 0; - *iter = 0; - -/* Test the input parameters. */ - - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPOSV", &i__1); - return 0; - } - -/* Quick return if (N.EQ.0). */ - - if (*n == 0) { - return 0; - } - -/* Skip single precision iterative refinement if a priori slower */ -/* than double precision factorization. */ - - if (false) { - *iter = -1; - goto L40; - } - -/* Compute some constants. */ - - anrm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[work_offset]); - eps = dlamch_("Epsilon"); - cte = anrm * eps * sqrt((double) (*n)) * 1.; - -/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */ - - ptsa = 1; - ptsx = ptsa + *n * *n; - -/* Convert B from double precision to single precision and store the */ -/* result in SX. */ - - dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info); - - if (*info != 0) { - *iter = -2; - goto L40; - } - -/* Convert A from double precision to single precision and store the */ -/* result in SA. */ - - dlat2s_(uplo, n, &a[a_offset], lda, &swork[ptsa], n, info); - - if (*info != 0) { - *iter = -2; - goto L40; - } - -/* Compute the Cholesky factorization of SA. */ - - spotrf_(uplo, n, &swork[ptsa], n, info); - - if (*info != 0) { - *iter = -3; - goto L40; - } - -/* Solve the system SA*SX = SB. */ - - spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info); - -/* Convert SX back to double precision */ - - slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info); - -/* Compute R = B - AX (R is WORK). */ - - dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); - - dsymm_("Left", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset], - ldx, &c_b11, &work[work_offset], n); - -/* Check whether the NRHS normwise backward errors satisfy the */ -/* stopping criterion. If yes, set ITER=0 and return. */ - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * - x_dim1], abs(d__1)); - rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + - i__ * work_dim1], abs(d__1)); - if (rnrm > xnrm * cte) { - goto L10; - } - } - -/* If we are here, the NRHS normwise backward errors satisfy the */ -/* stopping criterion. We are good to exit. */ - - *iter = 0; - return 0; - -L10: - - for (iiter = 1; iiter <= 30; ++iiter) { - -/* Convert R (in WORK) from double precision to single precision */ -/* and store the result in SX. */ - - dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info); - - if (*info != 0) { - *iter = -2; - goto L40; - } - -/* Solve the system SA*SX = SR. */ - - spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info); - -/* Convert SX back to double precision and update the current */ -/* iterate. */ - - slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info); - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * - x_dim1 + 1], &c__1); - } - -/* Compute R = B - AX (R is WORK). */ - - dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); - - dsymm_("L", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset], - ldx, &c_b11, &work[work_offset], n); - -/* Check whether the NRHS normwise backward errors satisfy the */ -/* stopping criterion. If yes, set ITER=IITER>0 and return. */ - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * - x_dim1], abs(d__1)); - rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) - + i__ * work_dim1], abs(d__1)); - if (rnrm > xnrm * cte) { - goto L20; - } - } - -/* If we are here, the NRHS normwise backward errors satisfy the */ -/* stopping criterion, we are good to exit. */ - - *iter = iiter; - - return 0; - -L20: - -/* L30: */ - ; - } - -/* If we are at this place of the code, this is because we have */ -/* performed ITER=ITERMAX iterations and never satisified the */ -/* stopping criterion, set up the ITER flag accordingly and follow */ -/* up on double precision routine. */ - - *iter = -31; - -L40: - -/* Single-precision iterative refinement failed to converge to a */ -/* satisfactory solution, so we resort to double precision. */ - - dpotrf_(uplo, n, &a[a_offset], lda, info); - - if (*info != 0) { - return 0; - } - - dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &x[x_offset], ldx, info); - - return 0; - -/* End of DSPOSV. */ - -} /* dsposv_ */ diff --git a/external/clapack/lapack/dsprfs.cpp b/external/clapack/lapack/dsprfs.cpp deleted file mode 100644 index bd7ede6f..00000000 --- a/external/clapack/lapack/dsprfs.cpp +++ /dev/null @@ -1,395 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b12 = -1.; -static double c_b14 = 1.; - -/* Subroutine */ int dsprfs_(const char *uplo, integer *n, integer *nrhs, - double *ap, double *afp, integer *ipiv, double *b, - integer *ldb, double *x, integer *ldx, double *ferr, - double *berr, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s; - integer ik, kk; - double xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - integer count; - bool upper; - double safmin; - double lstres; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPRFS improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is symmetric indefinite */ -/* and packed, and provides error bounds and backward error estimates */ -/* for the solution. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangle of the symmetric matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ - -/* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The factored form of the matrix A. AFP contains the block */ -/* diagonal matrix D and the multipliers used to obtain the */ -/* factor U or L from the factorization A = U*D*U**T or */ -/* A = L*D*L**T as computed by DSPTRF, stored as a packed */ -/* triangular matrix. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSPTRF. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DSPTRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --afp; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *n + 1; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - A * X */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, & - work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L30: */ - } - -/* Compute abs(A)*abs(X) + abs(B). */ - - kk = 1; - if (upper) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - ik = kk; - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; - s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * - x_dim1], abs(d__2)); - ++ik; -/* L40: */ - } - work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk + - s; - kk += k; -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - work[k] += (d__1 = ap[kk], abs(d__1)) * xk; - ik = kk + 1; - i__3 = *n; - for (i__ = k + 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; - s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * - x_dim1], abs(d__2)); - ++ik; -/* L60: */ - } - work[k] += s; - kk += *n - k + 1; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info); - daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(A))* */ -/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(A) is the inverse of A */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(A) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(A'). */ - - dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, - info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L110: */ - } - } else if (kase == 2) { - -/* Multiply by inv(A)*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L120: */ - } - dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, - info); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DSPRFS */ - -} /* dsprfs_ */ diff --git a/external/clapack/lapack/dspsv.cpp b/external/clapack/lapack/dspsv.cpp deleted file mode 100644 index 2fb638cc..00000000 --- a/external/clapack/lapack/dspsv.cpp +++ /dev/null @@ -1,156 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dspsv_(const char *uplo, integer *n, integer *nrhs, double - *ap, integer *ipiv, double *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPSV computes the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric matrix stored in packed format and X */ -/* and B are N-by-NRHS matrices. */ - -/* The diagonal pivoting method is used to factor A as */ -/* A = U * D * U**T, if UPLO = 'U', or */ -/* A = L * D * L**T, if UPLO = 'L', */ -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, D is symmetric and block diagonal with 1-by-1 */ -/* and 2-by-2 diagonal blocks. The factored form of A is then used to */ -/* solve the system of equations A * X = B. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ -/* See below for further details. */ - -/* On exit, the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L from the factorization */ -/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */ -/* a packed triangular matrix in the same storage format as A. */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D, as */ -/* determined by DSPTRF. If IPIV(k) > 0, then rows and columns */ -/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */ -/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */ -/* then rows and columns k-1 and -IPIV(k) were interchanged and */ -/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */ -/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */ -/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */ -/* diagonal block. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular, so the solution could not be */ -/* computed. */ - -/* Further Details */ -/* =============== */ - -/* The packed storage scheme is illustrated by the following example */ -/* when N = 4, UPLO = 'U': */ - -/* Two-dimensional storage of the symmetric matrix A: */ - -/* a11 a12 a13 a14 */ -/* a22 a23 a24 */ -/* a33 a34 (aij = aji) */ -/* a44 */ - -/* Packed storage of the upper triangle of A: */ - -/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ - -/* ===================================================================== */ - -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPSV ", &i__1); - return 0; - } - -/* Compute the factorization A = U*D*U' or A = L*D*L'. */ - - dsptrf_(uplo, n, &ap[1], &ipiv[1], info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dsptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info); - - } - return 0; - -/* End of DSPSV */ - -} /* dspsv_ */ diff --git a/external/clapack/lapack/dspsvx.cpp b/external/clapack/lapack/dspsvx.cpp deleted file mode 100644 index 9ab76748..00000000 --- a/external/clapack/lapack/dspsvx.cpp +++ /dev/null @@ -1,299 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dspsvx_(const char *fact, const char *uplo, integer *n, integer * - nrhs, double *ap, double *afp, integer *ipiv, double *b, - integer *ldb, double *x, integer *ldx, double *rcond, - double *ferr, double *berr, double *work, integer *iwork, - integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1; - - /* Local variables */ - double anorm; - bool nofact; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */ -/* A = L*D*L**T to compute the solution to a real system of linear */ -/* equations A * X = B, where A is an N-by-N symmetric matrix stored */ -/* in packed format and X and B are N-by-NRHS matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */ -/* A = U * D * U**T, if UPLO = 'U', or */ -/* A = L * D * L**T, if UPLO = 'L', */ -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices and D is symmetric and block diagonal with */ -/* 1-by-1 and 2-by-2 diagonal blocks. */ - -/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */ -/* returns with INFO = i. Otherwise, the factored form of A is used */ -/* to estimate the condition number of the matrix A. If the */ -/* reciprocal of the condition number is less than machine precision, */ -/* INFO = N+1 is returned as a warning, but the routine still goes on */ -/* to solve for X and compute error bounds as described below. */ - -/* 3. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 4. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of A has been */ -/* supplied on entry. */ -/* = 'F': On entry, AFP and IPIV contain the factored form of */ -/* A. AP, AFP and IPIV will not be modified. */ -/* = 'N': The matrix A will be copied to AFP and factored. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangle of the symmetric matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ -/* See below for further details. */ - -/* AFP (input or output) DOUBLE PRECISION array, dimension */ -/* (N*(N+1)/2) */ -/* If FACT = 'F', then AFP is an input argument and on entry */ -/* contains the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L from the factorization */ -/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */ -/* a packed triangular matrix in the same storage format as A. */ - -/* If FACT = 'N', then AFP is an output argument and on exit */ -/* contains the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L from the factorization */ -/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */ -/* a packed triangular matrix in the same storage format as A. */ - -/* IPIV (input or output) INTEGER array, dimension (N) */ -/* If FACT = 'F', then IPIV is an input argument and on entry */ -/* contains details of the interchanges and the block structure */ -/* of D, as determined by DSPTRF. */ -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* If FACT = 'N', then IPIV is an output argument and on exit */ -/* contains details of the interchanges and the block structure */ -/* of D, as determined by DSPTRF. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The N-by-NRHS right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The estimate of the reciprocal condition number of the matrix */ -/* A. If RCOND is less than the machine precision (in */ -/* particular, if RCOND = 0), the matrix is singular to working */ -/* precision. This condition is indicated by a return code of */ -/* INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= N: D(i,i) is exactly zero. The factorization */ -/* has been completed but the factor D is exactly */ -/* singular, so the solution and error bounds could */ -/* not be computed. RCOND = 0 is returned. */ -/* = N+1: D is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* Further Details */ -/* =============== */ - -/* The packed storage scheme is illustrated by the following example */ -/* when N = 4, UPLO = 'U': */ - -/* Two-dimensional storage of the symmetric matrix A: */ - -/* a11 a12 a13 a14 */ -/* a22 a23 a24 */ -/* a33 a34 (aij = aji) */ -/* a44 */ - -/* Packed storage of the upper triangle of A: */ - -/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - --afp; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - if (! nofact && ! lsame_(fact, "F")) { - *info = -1; - } else if (! lsame_(uplo, "U") && ! lsame_(uplo, - "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -11; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPSVX", &i__1); - return 0; - } - - if (nofact) { - -/* Compute the factorization A = U*D*U' or A = L*D*L'. */ - - i__1 = *n * (*n + 1) / 2; - dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); - dsptrf_(uplo, n, &afp[1], &ipiv[1], info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A. */ - - anorm = dlansp_("I", uplo, n, &ap[1], &work[1]); - -/* Compute the reciprocal of the condition number of A. */ - - dspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], &iwork[1], - info); - -/* Compute the solution vectors X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dsptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solutions and */ -/* compute error bounds and backward error estimates for them. */ - - dsprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[ - x_offset], ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info); - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - - return 0; - -/* End of DSPSVX */ - -} /* dspsvx_ */ diff --git a/external/clapack/lapack/dsptrd.cpp b/external/clapack/lapack/dsptrd.cpp deleted file mode 100644 index 1f644bd7..00000000 --- a/external/clapack/lapack/dsptrd.cpp +++ /dev/null @@ -1,254 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b8 = 0.; -static double c_b14 = -1.; - -/* Subroutine */ int dsptrd_(const char *uplo, integer *n, double *ap, - double *d__, double *e, double *tau, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, i1, ii, i1i1; - double taui; - double alpha; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPTRD reduces a real symmetric matrix A stored in packed form to */ -/* symmetric tridiagonal form T by an orthogonal similarity */ -/* transformation: Q**T * A * Q = T. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ -/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ -/* of A are overwritten by the corresponding elements of the */ -/* tridiagonal matrix T, and the elements above the first */ -/* superdiagonal, with the array TAU, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors; if UPLO */ -/* = 'L', the diagonal and first subdiagonal of A are over- */ -/* written by the corresponding elements of the tridiagonal */ -/* matrix T, and the elements below the first subdiagonal, with */ -/* the array TAU, represent the orthogonal matrix Q as a product */ -/* of elementary reflectors. See Further Details. */ - -/* D (output) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T: */ -/* D(i) = A(i,i). */ - -/* E (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix T: */ -/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n-1) . . . H(2) H(1). */ - -/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */ -/* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(n-1). */ - -/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */ -/* overwriting A(i+2:n,i), and tau is stored in TAU(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - --tau; - --e; - --d__; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPTRD", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - - if (upper) { - -/* Reduce the upper triangle of A. */ -/* I1 is the index in AP of A(1,I+1). */ - - i1 = *n * (*n - 1) / 2 + 1; - for (i__ = *n - 1; i__ >= 1; --i__) { - -/* Generate elementary reflector H(i) = I - tau * v * v' */ -/* to annihilate A(1:i-1,i+1) */ - - dlarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui); - e[i__] = ap[i1 + i__ - 1]; - - if (taui != 0.) { - -/* Apply H(i) from both sides to A(1:i,1:i) */ - - ap[i1 + i__ - 1] = 1.; - -/* Compute y := tau * A * v storing y in TAU(1:i) */ - - dspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b8, &tau[ - 1], &c__1); - -/* Compute w := y - 1/2 * tau * (y'*v) * v */ - - alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &ap[i1], & - c__1); - daxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1); - -/* Apply the transformation as a rank-2 update: */ -/* A := A - v * w' - w * v' */ - - dspr2_(uplo, &i__, &c_b14, &ap[i1], &c__1, &tau[1], &c__1, & - ap[1]); - - ap[i1 + i__ - 1] = e[i__]; - } - d__[i__ + 1] = ap[i1 + i__]; - tau[i__] = taui; - i1 -= i__; -/* L10: */ - } - d__[1] = ap[1]; - } else { - -/* Reduce the lower triangle of A. II is the index in AP of */ -/* A(i,i) and I1I1 is the index of A(i+1,i+1). */ - - ii = 1; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - i1i1 = ii + *n - i__ + 1; - -/* Generate elementary reflector H(i) = I - tau * v * v' */ -/* to annihilate A(i+2:n,i) */ - - i__2 = *n - i__; - dlarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui); - e[i__] = ap[ii + 1]; - - if (taui != 0.) { - -/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ - - ap[ii + 1] = 1.; - -/* Compute y := tau * A * v storing y in TAU(i:n-1) */ - - i__2 = *n - i__; - dspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & - c_b8, &tau[i__], &c__1); - -/* Compute w := y - 1/2 * tau * (y'*v) * v */ - - i__2 = *n - i__; - alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &ap[ii + - 1], &c__1); - i__2 = *n - i__; - daxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1); - -/* Apply the transformation as a rank-2 update: */ -/* A := A - v * w' - w * v' */ - - i__2 = *n - i__; - dspr2_(uplo, &i__2, &c_b14, &ap[ii + 1], &c__1, &tau[i__], & - c__1, &ap[i1i1]); - - ap[ii + 1] = e[i__]; - } - d__[i__] = ap[ii]; - tau[i__] = taui; - ii = i1i1; -/* L20: */ - } - d__[*n] = ap[ii]; - } - - return 0; - -/* End of DSPTRD */ - -} /* dsptrd_ */ diff --git a/external/clapack/lapack/dsptrf.cpp b/external/clapack/lapack/dsptrf.cpp deleted file mode 100644 index df556f35..00000000 --- a/external/clapack/lapack/dsptrf.cpp +++ /dev/null @@ -1,604 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dsptrf_(const char *uplo, integer *n, double *ap, integer * - ipiv, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double t, r1, d11, d12, d21, d22; - integer kc, kk, kp; - double wk; - integer kx, knc, kpc, npp; - double wkm1, wkp1; - integer imax, jmax; - double alpha; - integer kstep; - bool upper; - double absakk; - double colmax, rowmax; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPTRF computes the factorization of a real symmetric matrix A stored */ -/* in packed format using the Bunch-Kaufman diagonal pivoting method: */ - -/* A = U*D*U**T or A = L*D*L**T */ - -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, and D is symmetric and block diagonal with */ -/* 1-by-1 and 2-by-2 diagonal blocks. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangle of the symmetric matrix */ -/* A, packed columnwise in a linear array. The j-th column of A */ -/* is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* On exit, the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L, stored as a packed triangular */ -/* matrix overwriting A (see below for further details). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D. */ -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular, and division by zero will occur if it */ -/* is used to solve a system of equations. */ - -/* Further Details */ -/* =============== */ - -/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */ -/* Company */ - -/* If UPLO = 'U', then A = U*D*U', where */ -/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */ -/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ -/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I v 0 ) k-s */ -/* U(k) = ( 0 I 0 ) s */ -/* ( 0 0 I ) n-k */ -/* k-s s n-k */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ -/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ -/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */ - -/* If UPLO = 'L', then A = L*D*L', where */ -/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ -/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ -/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I 0 0 ) k-1 */ -/* L(k) = ( 0 I 0 ) s */ -/* ( 0 v I ) n-k-s+1 */ -/* k-1 s n-k-s+1 */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ -/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ -/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ipiv; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPTRF", &i__1); - return 0; - } - -/* Initialize ALPHA for use in choosing pivot block size. */ - - alpha = (sqrt(17.) + 1.) / 8.; - - if (upper) { - -/* Factorize A as U*D*U' using the upper triangle of A */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2 */ - - k = *n; - kc = (*n - 1) * *n / 2 + 1; -L10: - knc = kc; - -/* If K < 1, exit from loop */ - - if (k < 1) { - goto L110; - } - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = ap[kc + k - 1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k > 1) { - i__1 = k - 1; - imax = idamax_(&i__1, &ap[kc], &c__1); - colmax = (d__1 = ap[kc + imax - 1], abs(d__1)); - } else { - colmax = 0.; - } - - if (std::max(absakk,colmax) == 0.) { - -/* Column K is zero: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - rowmax = 0.; - jmax = imax; - kx = imax * (imax + 1) / 2 + imax; - i__1 = k; - for (j = imax + 1; j <= i__1; ++j) { - if ((d__1 = ap[kx], abs(d__1)) > rowmax) { - rowmax = (d__1 = ap[kx], abs(d__1)); - jmax = j; - } - kx += j; -/* L20: */ - } - kpc = (imax - 1) * imax / 2 + 1; - if (imax > 1) { - i__1 = imax - 1; - jmax = idamax_(&i__1, &ap[kpc], &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], abs( - d__1)); - rowmax = std::max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = ap[kpc + imax - 1], abs(d__1)) >= alpha * - rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - } else { - -/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k - kstep + 1; - if (kstep == 2) { - knc = knc - k + 1; - } - if (kp != kk) { - -/* Interchange rows and columns KK and KP in the leading */ -/* submatrix A(1:k,1:k) */ - - i__1 = kp - 1; - dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1); - kx = kpc + kp - 1; - i__1 = kk - 1; - for (j = kp + 1; j <= i__1; ++j) { - kx = kx + j - 1; - t = ap[knc + j - 1]; - ap[knc + j - 1] = ap[kx]; - ap[kx] = t; -/* L30: */ - } - t = ap[knc + kk - 1]; - ap[knc + kk - 1] = ap[kpc + kp - 1]; - ap[kpc + kp - 1] = t; - if (kstep == 2) { - t = ap[kc + k - 2]; - ap[kc + k - 2] = ap[kc + kp - 1]; - ap[kc + kp - 1] = t; - } - } - -/* Update the leading submatrix */ - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column k now holds */ - -/* W(k) = U(k)*D(k) */ - -/* where U(k) is the k-th column of U */ - -/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ - -/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */ - - r1 = 1. / ap[kc + k - 1]; - i__1 = k - 1; - d__1 = -r1; - dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]); - -/* Store U(k) in column k */ - - i__1 = k - 1; - dscal_(&i__1, &r1, &ap[kc], &c__1); - } else { - -/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ - -/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ - -/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ -/* of U */ - -/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ - -/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */ -/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */ - - if (k > 2) { - - d12 = ap[k - 1 + (k - 1) * k / 2]; - d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12; - d11 = ap[k + (k - 1) * k / 2] / d12; - t = 1. / (d11 * d22 - 1.); - d12 = t / d12; - - for (j = k - 2; j >= 1; --j) { - wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] - - ap[j + (k - 1) * k / 2]); - wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k - - 2) * (k - 1) / 2]); - for (i__ = j; i__ >= 1; --i__) { - ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j / - 2] - ap[i__ + (k - 1) * k / 2] * wk - ap[ - i__ + (k - 2) * (k - 1) / 2] * wkm1; -/* L40: */ - } - ap[j + (k - 1) * k / 2] = wk; - ap[j + (k - 2) * (k - 1) / 2] = wkm1; -/* L50: */ - } - - } - - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k - 1] = -kp; - } - -/* Decrease K and return to the start of the main loop */ - - k -= kstep; - kc = knc - k; - goto L10; - - } else { - -/* Factorize A as L*D*L' using the lower triangle of A */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2 */ - - k = 1; - kc = 1; - npp = *n * (*n + 1) / 2; -L60: - knc = kc; - -/* If K > N, exit from loop */ - - if (k > *n) { - goto L110; - } - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = ap[kc], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k < *n) { - i__1 = *n - k; - imax = k + idamax_(&i__1, &ap[kc + 1], &c__1); - colmax = (d__1 = ap[kc + imax - k], abs(d__1)); - } else { - colmax = 0.; - } - - if (std::max(absakk,colmax) == 0.) { - -/* Column K is zero: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - rowmax = 0.; - kx = kc + imax - k; - i__1 = imax - 1; - for (j = k; j <= i__1; ++j) { - if ((d__1 = ap[kx], abs(d__1)) > rowmax) { - rowmax = (d__1 = ap[kx], abs(d__1)); - jmax = j; - } - kx = kx + *n - j; -/* L70: */ - } - kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1; - if (imax < *n) { - i__1 = *n - imax; - jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], abs( - d__1)); - rowmax = std::max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = ap[kpc], abs(d__1)) >= alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - } else { - -/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k + kstep - 1; - if (kstep == 2) { - knc = knc + *n - k + 1; - } - if (kp != kk) { - -/* Interchange rows and columns KK and KP in the trailing */ -/* submatrix A(k:n,k:n) */ - - if (kp < *n) { - i__1 = *n - kp; - dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1], - &c__1); - } - kx = knc + kp - kk; - i__1 = kp - 1; - for (j = kk + 1; j <= i__1; ++j) { - kx = kx + *n - j + 1; - t = ap[knc + j - kk]; - ap[knc + j - kk] = ap[kx]; - ap[kx] = t; -/* L80: */ - } - t = ap[knc]; - ap[knc] = ap[kpc]; - ap[kpc] = t; - if (kstep == 2) { - t = ap[kc + 1]; - ap[kc + 1] = ap[kc + kp - k]; - ap[kc + kp - k] = t; - } - } - -/* Update the trailing submatrix */ - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column k now holds */ - -/* W(k) = L(k)*D(k) */ - -/* where L(k) is the k-th column of L */ - - if (k < *n) { - -/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ - -/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */ - - r1 = 1. / ap[kc]; - i__1 = *n - k; - d__1 = -r1; - dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n - - k + 1]); - -/* Store L(k) in column K */ - - i__1 = *n - k; - dscal_(&i__1, &r1, &ap[kc + 1], &c__1); - } - } else { - -/* 2-by-2 pivot block D(k): columns K and K+1 now hold */ - -/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ - -/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ -/* of L */ - - if (k < *n - 1) { - -/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ - -/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */ -/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */ - - d21 = ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]; - d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21; - d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21; - t = 1. / (d11 * d22 - 1.); - d21 = t / d21; - - i__1 = *n; - for (j = k + 2; j <= i__1; ++j) { - wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) / - 2] - ap[j + k * ((*n << 1) - k - 1) / 2]); - wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) / - 2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]); - - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - ap[i__ + (j - 1) * ((*n << 1) - j) / 2] = ap[i__ - + (j - 1) * ((*n << 1) - j) / 2] - ap[i__ - + (k - 1) * ((*n << 1) - k) / 2] * wk - - ap[i__ + k * ((*n << 1) - k - 1) / 2] * - wkp1; -/* L90: */ - } - - ap[j + (k - 1) * ((*n << 1) - k) / 2] = wk; - ap[j + k * ((*n << 1) - k - 1) / 2] = wkp1; - -/* L100: */ - } - } - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k + 1] = -kp; - } - -/* Increase K and return to the start of the main loop */ - - k += kstep; - kc = knc + *n - k + 2; - goto L60; - - } - -L110: - return 0; - -/* End of DSPTRF */ - -} /* dsptrf_ */ diff --git a/external/clapack/lapack/dsptri.cpp b/external/clapack/lapack/dsptri.cpp deleted file mode 100644 index 4e8e0d23..00000000 --- a/external/clapack/lapack/dsptri.cpp +++ /dev/null @@ -1,389 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b11 = -1.; -static double c_b13 = 0.; - -/* Subroutine */ int dsptri_(const char *uplo, integer *n, double *ap, integer * - ipiv, double *work, integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - double d__; - integer j, k; - double t, ak; - integer kc, kp, kx, kpc, npp; - double akp1; - double temp, akkp1; - integer kstep; - bool upper; - integer kcnext; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPTRI computes the inverse of a real symmetric indefinite matrix */ -/* A in packed storage using the factorization A = U*D*U**T or */ -/* A = L*D*L**T computed by DSPTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the details of the factorization are stored */ -/* as an upper or lower triangular matrix. */ -/* = 'U': Upper triangular, form is A = U*D*U**T; */ -/* = 'L': Lower triangular, form is A = L*D*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the block diagonal matrix D and the multipliers */ -/* used to obtain the factor U or L as computed by DSPTRF, */ -/* stored as a packed triangular matrix. */ - -/* On exit, if INFO = 0, the (symmetric) inverse of the original */ -/* matrix, stored as a packed triangular matrix. The j-th column */ -/* of inv(A) is stored in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', */ -/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSPTRF. */ - -/* 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 */ -/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ -/* inverse could not be computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --work; - --ipiv; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check that the diagonal matrix D is nonsingular. */ - - if (upper) { - -/* Upper triangular storage: examine D from bottom to top */ - - kp = *n * (*n + 1) / 2; - for (*info = *n; *info >= 1; --(*info)) { - if (ipiv[*info] > 0 && ap[kp] == 0.) { - return 0; - } - kp -= *info; -/* L10: */ - } - } else { - -/* Lower triangular storage: examine D from top to bottom. */ - - kp = 1; - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (ipiv[*info] > 0 && ap[kp] == 0.) { - return 0; - } - kp = kp + *n - *info + 1; -/* L20: */ - } - } - *info = 0; - - if (upper) { - -/* Compute inv(A) from the factorization A = U*D*U'. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; - kc = 1; -L30: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L50; - } - - kcnext = kc + k; - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Invert the diagonal block. */ - - ap[kc + k - 1] = 1. / ap[kc + k - 1]; - -/* Compute column K of the inverse. */ - - if (k > 1) { - i__1 = k - 1; - dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); - i__1 = k - 1; - dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & - ap[kc], &c__1); - i__1 = k - 1; - ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], & - c__1); - } - kstep = 1; - } else { - -/* 2 x 2 diagonal block */ - -/* Invert the diagonal block. */ - - t = (d__1 = ap[kcnext + k - 1], abs(d__1)); - ak = ap[kc + k - 1] / t; - akp1 = ap[kcnext + k] / t; - akkp1 = ap[kcnext + k - 1] / t; - d__ = t * (ak * akp1 - 1.); - ap[kc + k - 1] = akp1 / d__; - ap[kcnext + k] = ak / d__; - ap[kcnext + k - 1] = -akkp1 / d__; - -/* Compute columns K and K+1 of the inverse. */ - - if (k > 1) { - i__1 = k - 1; - dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); - i__1 = k - 1; - dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & - ap[kc], &c__1); - i__1 = k - 1; - ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], & - c__1); - i__1 = k - 1; - ap[kcnext + k - 1] -= ddot_(&i__1, &ap[kc], &c__1, &ap[kcnext] -, &c__1); - i__1 = k - 1; - dcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1); - i__1 = k - 1; - dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & - ap[kcnext], &c__1); - i__1 = k - 1; - ap[kcnext + k] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext], & - c__1); - } - kstep = 2; - kcnext = kcnext + k + 1; - } - - kp = (i__1 = ipiv[k], abs(i__1)); - if (kp != k) { - -/* Interchange rows and columns K and KP in the leading */ -/* submatrix A(1:k+1,1:k+1) */ - - kpc = (kp - 1) * kp / 2 + 1; - i__1 = kp - 1; - dswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1); - kx = kpc + kp - 1; - i__1 = k - 1; - for (j = kp + 1; j <= i__1; ++j) { - kx = kx + j - 1; - temp = ap[kc + j - 1]; - ap[kc + j - 1] = ap[kx]; - ap[kx] = temp; -/* L40: */ - } - temp = ap[kc + k - 1]; - ap[kc + k - 1] = ap[kpc + kp - 1]; - ap[kpc + kp - 1] = temp; - if (kstep == 2) { - temp = ap[kc + k + k - 1]; - ap[kc + k + k - 1] = ap[kc + k + kp - 1]; - ap[kc + k + kp - 1] = temp; - } - } - - k += kstep; - kc = kcnext; - goto L30; -L50: - - ; - } else { - -/* Compute inv(A) from the factorization A = L*D*L'. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - npp = *n * (*n + 1) / 2; - k = *n; - kc = npp; -L60: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L80; - } - - kcnext = kc - (*n - k + 2); - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Invert the diagonal block. */ - - ap[kc] = 1. / ap[kc]; - -/* Compute column K of the inverse. */ - - if (k < *n) { - i__1 = *n - k; - dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); - i__1 = *n - k; - dspmv_(uplo, &i__1, &c_b11, &ap[kc + *n - k + 1], &work[1], & - c__1, &c_b13, &ap[kc + 1], &c__1); - i__1 = *n - k; - ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1); - } - kstep = 1; - } else { - -/* 2 x 2 diagonal block */ - -/* Invert the diagonal block. */ - - t = (d__1 = ap[kcnext + 1], abs(d__1)); - ak = ap[kcnext] / t; - akp1 = ap[kc] / t; - akkp1 = ap[kcnext + 1] / t; - d__ = t * (ak * akp1 - 1.); - ap[kcnext] = akp1 / d__; - ap[kc] = ak / d__; - ap[kcnext + 1] = -akkp1 / d__; - -/* Compute columns K-1 and K of the inverse. */ - - if (k < *n) { - i__1 = *n - k; - dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); - i__1 = *n - k; - dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1], - &c__1, &c_b13, &ap[kc + 1], &c__1); - i__1 = *n - k; - ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1); - i__1 = *n - k; - ap[kcnext + 1] -= ddot_(&i__1, &ap[kc + 1], &c__1, &ap[kcnext - + 2], &c__1); - i__1 = *n - k; - dcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1); - i__1 = *n - k; - dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1], - &c__1, &c_b13, &ap[kcnext + 2], &c__1); - i__1 = *n - k; - ap[kcnext] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext + 2], & - c__1); - } - kstep = 2; - kcnext -= *n - k + 3; - } - - kp = (i__1 = ipiv[k], abs(i__1)); - if (kp != k) { - -/* Interchange rows and columns K and KP in the trailing */ -/* submatrix A(k-1:n,k-1:n) */ - - kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1; - if (kp < *n) { - i__1 = *n - kp; - dswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], & - c__1); - } - kx = kc + kp - k; - i__1 = kp - 1; - for (j = k + 1; j <= i__1; ++j) { - kx = kx + *n - j + 1; - temp = ap[kc + j - k]; - ap[kc + j - k] = ap[kx]; - ap[kx] = temp; -/* L70: */ - } - temp = ap[kc]; - ap[kc] = ap[kpc]; - ap[kpc] = temp; - if (kstep == 2) { - temp = ap[kc - *n + k - 1]; - ap[kc - *n + k - 1] = ap[kc - *n + kp - 1]; - ap[kc - *n + kp - 1] = temp; - } - } - - k -= kstep; - kc = kcnext; - goto L60; -L80: - ; - } - - return 0; - -/* End of DSPTRI */ - -} /* dsptri_ */ diff --git a/external/clapack/lapack/dsptrs.cpp b/external/clapack/lapack/dsptrs.cpp deleted file mode 100644 index d7aee7d7..00000000 --- a/external/clapack/lapack/dsptrs.cpp +++ /dev/null @@ -1,433 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b7 = -1.; -static integer c__1 = 1; -static double c_b19 = 1.; - -/* Subroutine */ int dsptrs_(const char *uplo, integer *n, integer *nrhs, - double *ap, integer *ipiv, double *b, integer *ldb, integer * - info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1; - double d__1; - - /* Local variables */ - integer j, k; - double ak, bk; - integer kc, kp; - double akm1, bkm1; - double akm1k; - double denom; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSPTRS solves a system of linear equations A*X = B with a real */ -/* symmetric matrix A stored in packed format using the factorization */ -/* A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the details of the factorization are stored */ -/* as an upper or lower triangular matrix. */ -/* = 'U': Upper triangular, form is A = U*D*U**T; */ -/* = 'L': Lower triangular, form is A = L*D*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The block diagonal matrix D and the multipliers used to */ -/* obtain the factor U or L as computed by DSPTRF, stored as a */ -/* packed triangular matrix. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSPTRF. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --ap; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSPTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B, where A = U*D*U'. */ - -/* First solve U*D*X = B, overwriting B with X. */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = *n; - kc = *n * (*n + 1) / 2 + 1; -L10: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L30; - } - - kc -= k; - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(U(K)), where U(K) is the transformation */ -/* stored in column K of A. */ - - i__1 = k - 1; - dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[ - b_dim1 + 1], ldb); - -/* Multiply by the inverse of the diagonal block. */ - - d__1 = 1. / ap[kc + k - 1]; - dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); - --k; - } else { - -/* 2 x 2 diagonal block */ - -/* Interchange rows K-1 and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k - 1) { - dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(U(K)), where U(K) is the transformation */ -/* stored in columns K-1 and K of A. */ - - i__1 = k - 2; - dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[ - b_dim1 + 1], ldb); - i__1 = k - 2; - dger_(&i__1, nrhs, &c_b7, &ap[kc - (k - 1)], &c__1, &b[k - 1 + - b_dim1], ldb, &b[b_dim1 + 1], ldb); - -/* Multiply by the inverse of the diagonal block. */ - - akm1k = ap[kc + k - 2]; - akm1 = ap[kc - 1] / akm1k; - ak = ap[kc + k - 1] / akm1k; - denom = akm1 * ak - 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - bkm1 = b[k - 1 + j * b_dim1] / akm1k; - bk = b[k + j * b_dim1] / akm1k; - b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; - b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom; -/* L20: */ - } - kc = kc - k + 1; - k += -2; - } - - goto L10; -L30: - -/* Next solve U'*X = B, overwriting B with X. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; - kc = 1; -L40: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L50; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Multiply by inv(U'(K)), where U(K) is the transformation */ -/* stored in column K of A. */ - - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc] -, &c__1, &c_b19, &b[k + b_dim1], ldb); - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - kc += k; - ++k; - } else { - -/* 2 x 2 diagonal block */ - -/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */ -/* stored in columns K and K+1 of A. */ - - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc] -, &c__1, &c_b19, &b[k + b_dim1], ldb); - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc - + k], &c__1, &c_b19, &b[k + 1 + b_dim1], ldb); - -/* Interchange rows K and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - kc = kc + (k << 1) + 1; - k += 2; - } - - goto L40; -L50: - - ; - } else { - -/* Solve A*X = B, where A = L*D*L'. */ - -/* First solve L*D*X = B, overwriting B with X. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; - kc = 1; -L60: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L80; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(L(K)), where L(K) is the transformation */ -/* stored in column K of A. */ - - if (k < *n) { - i__1 = *n - k; - dger_(&i__1, nrhs, &c_b7, &ap[kc + 1], &c__1, &b[k + b_dim1], - ldb, &b[k + 1 + b_dim1], ldb); - } - -/* Multiply by the inverse of the diagonal block. */ - - d__1 = 1. / ap[kc]; - dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); - kc = kc + *n - k + 1; - ++k; - } else { - -/* 2 x 2 diagonal block */ - -/* Interchange rows K+1 and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k + 1) { - dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(L(K)), where L(K) is the transformation */ -/* stored in columns K and K+1 of A. */ - - if (k < *n - 1) { - i__1 = *n - k - 1; - dger_(&i__1, nrhs, &c_b7, &ap[kc + 2], &c__1, &b[k + b_dim1], - ldb, &b[k + 2 + b_dim1], ldb); - i__1 = *n - k - 1; - dger_(&i__1, nrhs, &c_b7, &ap[kc + *n - k + 2], &c__1, &b[k + - 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); - } - -/* Multiply by the inverse of the diagonal block. */ - - akm1k = ap[kc + 1]; - akm1 = ap[kc] / akm1k; - ak = ap[kc + *n - k + 1] / akm1k; - denom = akm1 * ak - 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - bkm1 = b[k + j * b_dim1] / akm1k; - bk = b[k + 1 + j * b_dim1] / akm1k; - b[k + j * b_dim1] = (ak * bkm1 - bk) / denom; - b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; -/* L70: */ - } - kc = kc + (*n - k << 1) + 1; - k += 2; - } - - goto L60; -L80: - -/* Next solve L'*X = B, overwriting B with X. */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = *n; - kc = *n * (*n + 1) / 2 + 1; -L90: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L100; - } - - kc -= *n - k + 1; - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Multiply by inv(L'(K)), where L(K) is the transformation */ -/* stored in column K of A. */ - - if (k < *n) { - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); - } - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - --k; - } else { - -/* 2 x 2 diagonal block */ - -/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */ -/* stored in columns K-1 and K of A. */ - - if (k < *n) { - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &ap[kc - (*n - k)], &c__1, &c_b19, &b[k - 1 + - b_dim1], ldb); - } - -/* Interchange rows K and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - kc -= *n - k + 2; - k += -2; - } - - goto L90; -L100: - ; - } - - return 0; - -/* End of DSPTRS */ - -} /* dsptrs_ */ diff --git a/external/clapack/lapack/dstebz.cpp b/external/clapack/lapack/dstebz.cpp deleted file mode 100644 index 43df27e2..00000000 --- a/external/clapack/lapack/dstebz.cpp +++ /dev/null @@ -1,749 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; -static integer c__0 = 0; - -/* Subroutine */ int dstebz_(const char *range, const char *order, integer *n, double - *vl, double *vu, integer *il, integer *iu, double *abstol, - double *d__, double *e, integer *m, integer *nsplit, - double *w, integer *iblock, integer *isplit, double *work, - integer *iwork, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - double d__1, d__2, d__3, d__4, d__5; - - /* Local variables */ - integer j, ib, jb, ie, je, nb; - double gl; - integer im, in; - double gu; - integer iw; - double wl, wu; - integer nwl; - double ulp, wlu, wul; - integer nwu; - double tmp1, tmp2; - integer iend, ioff, iout, itmp1, jdisc; - integer iinfo; - double atoli; - integer iwoff; - double bnorm; - integer itmax; - double wkill, rtoli, tnorm; - integer ibegin; - integer irange, idiscl; - double safemn; - integer idumma[1]; - integer idiscu, iorder; - bool ncnvrg; - double pivmin; - bool toofew; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ -/* 8-18-00: Increase FUDGE factor for T3E (eca) */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEBZ computes the eigenvalues of a symmetric tridiagonal */ -/* matrix T. The user may ask for all eigenvalues, all eigenvalues */ -/* in the half-open interval (VL, VU], or the IL-th through IU-th */ -/* eigenvalues. */ - -/* To avoid overflow, the matrix must be scaled so that its */ -/* largest element is no greater than overflow**(1/2) * */ -/* underflow**(1/4) in absolute value, and for greatest */ -/* accuracy, it should not be much smaller than that. */ - -/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ -/* Matrix", Report CS41, Computer Science Dept., Stanford */ -/* University, July 21, 1966. */ - -/* Arguments */ -/* ========= */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': ("All") all eigenvalues will be found. */ -/* = 'V': ("Value") all eigenvalues in the half-open interval */ -/* (VL, VU] will be found. */ -/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ -/* entire matrix) will be found. */ - -/* ORDER (input) CHARACTER*1 */ -/* = 'B': ("By Block") the eigenvalues will be grouped by */ -/* split-off block (see IBLOCK, ISPLIT) and */ -/* ordered from smallest to largest within */ -/* the block. */ -/* = 'E': ("Entire matrix") */ -/* the eigenvalues for the entire matrix */ -/* will be ordered from smallest to */ -/* largest. */ - -/* N (input) INTEGER */ -/* The order of the tridiagonal matrix T. N >= 0. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. Eigenvalues less than or equal */ -/* to VL, or greater than VU, will not be returned. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute tolerance for the eigenvalues. An eigenvalue */ -/* (or cluster) is considered to be located if it has been */ -/* determined to lie in an interval whose width is ABSTOL or */ -/* less. If ABSTOL is less than or equal to zero, then ULP*|T| */ -/* will be used, where |T| means the 1-norm of T. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix T. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */ - -/* M (output) INTEGER */ -/* The actual number of eigenvalues found. 0 <= M <= N. */ -/* (See also the description of INFO=2,3.) */ - -/* NSPLIT (output) INTEGER */ -/* The number of diagonal blocks in the matrix T. */ -/* 1 <= NSPLIT <= N. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, the first M elements of W will contain the */ -/* eigenvalues. (DSTEBZ may use the remaining N-M elements as */ -/* workspace.) */ - -/* IBLOCK (output) INTEGER array, dimension (N) */ -/* At each row/column j where E(j) is zero or small, the */ -/* matrix T is considered to split into a block diagonal */ -/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */ -/* block (from 1 to the number of blocks) the eigenvalue W(i) */ -/* belongs. (DSTEBZ may use the remaining N-M elements as */ -/* workspace.) */ - -/* ISPLIT (output) INTEGER array, dimension (N) */ -/* The splitting points, at which T breaks up into submatrices. */ -/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */ -/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ -/* etc., and the NSPLIT-th consists of rows/columns */ -/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ -/* (Only the first NSPLIT elements will actually be used, but */ -/* since the user cannot know a priori what value NSPLIT will */ -/* have, N words must be reserved for ISPLIT.) */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* IWORK (workspace) INTEGER array, dimension (3*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: some or all of the eigenvalues failed to converge or */ -/* were not computed: */ -/* =1 or 3: Bisection failed to converge for some */ -/* eigenvalues; these eigenvalues are flagged by a */ -/* negative block number. The effect is that the */ -/* eigenvalues may not be as accurate as the */ -/* absolute and relative tolerances. This is */ -/* generally caused by unexpectedly inaccurate */ -/* arithmetic. */ -/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */ -/* IL:IU were found. */ -/* Effect: M < IU+1-IL */ -/* Cause: non-monotonic arithmetic, causing the */ -/* Sturm sequence to be non-monotonic. */ -/* Cure: recalculate, using RANGE='A', and pick */ -/* out eigenvalues IL:IU. In some cases, */ -/* increasing the PARAMETER "FUDGE" may */ -/* make things work. */ -/* = 4: RANGE='I', and the Gershgorin interval */ -/* initially used was too small. No eigenvalues */ -/* were computed. */ -/* Probable cause: your machine has sloppy */ -/* floating-point arithmetic. */ -/* Cure: Increase the PARAMETER "FUDGE", */ -/* recompile, and try again. */ - -/* Internal Parameters */ -/* =================== */ - -/* RELFAC DOUBLE PRECISION, default = 2.0e0 */ -/* The relative tolerance. An interval (a,b] lies within */ -/* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), */ -/* where "ulp" is the machine precision (distance from 1 to */ -/* the next larger floating point number.) */ - -/* FUDGE DOUBLE PRECISION, default = 2 */ -/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */ -/* a value of 1 should work, but on machines with sloppy */ -/* arithmetic, this needs to be larger. The default for */ -/* publicly released versions should be large enough to handle */ -/* the worst machine around. Note that this has no effect */ -/* on accuracy of the solution. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --iwork; - --work; - --isplit; - --iblock; - --w; - --e; - --d__; - - /* Function Body */ - *info = 0; - -/* Decode RANGE */ - - if (lsame_(range, "A")) { - irange = 1; - } else if (lsame_(range, "V")) { - irange = 2; - } else if (lsame_(range, "I")) { - irange = 3; - } else { - irange = 0; - } - -/* Decode ORDER */ - - if (lsame_(order, "B")) { - iorder = 2; - } else if (lsame_(order, "E")) { - iorder = 1; - } else { - iorder = 0; - } - -/* Check for Errors */ - - if (irange <= 0) { - *info = -1; - } else if (iorder <= 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (irange == 2) { - if (*vl >= *vu) { - *info = -5; - } - } else if (irange == 3 && (*il < 1 || *il > std::max(1_integer,*n))) { - *info = -6; - } else if (irange == 3 && (*iu < std::min(*n,*il) || *iu > *n)) { - *info = -7; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEBZ", &i__1); - return 0; - } - -/* Initialize error flags */ - - *info = 0; - ncnvrg = false; - toofew = false; - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - -/* Simplifications: */ - - if (irange == 3 && *il == 1 && *iu == *n) { - irange = 1; - } - -/* Get machine constants */ -/* NB is the minimum vector length for vector bisection, or 0 */ -/* if only scalar is to be done. */ - - safemn = dlamch_("S"); - ulp = dlamch_("P"); - rtoli = ulp * 2.; - nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1); - if (nb <= 1) { - nb = 0; - } - -/* Special Case when N=1 */ - - if (*n == 1) { - *nsplit = 1; - isplit[1] = 1; - if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) { - *m = 0; - } else { - w[1] = d__[1]; - iblock[1] = 1; - *m = 1; - } - return 0; - } - -/* Compute Splitting Points */ - - *nsplit = 1; - work[*n] = 0.; - pivmin = 1.; - -/* DIR$ NOVECTOR */ - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing 2nd power */ - d__1 = e[j - 1]; - tmp1 = d__1 * d__1; -/* Computing 2nd power */ - d__2 = ulp; - if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn - > tmp1) { - isplit[*nsplit] = j - 1; - ++(*nsplit); - work[j - 1] = 0.; - } else { - work[j - 1] = tmp1; - pivmin = std::max(pivmin,tmp1); - } -/* L10: */ - } - isplit[*nsplit] = *n; - pivmin *= safemn; - -/* Compute Interval and ATOLI */ - - if (irange == 3) { - -/* RANGE='I': Compute the interval containing eigenvalues */ -/* IL through IU. */ - -/* Compute Gershgorin interval for entire (split) matrix */ -/* and use it as the initial interval */ - - gu = d__[1]; - gl = d__[1]; - tmp1 = 0.; - - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - tmp2 = sqrt(work[j]); -/* Computing MAX */ - d__1 = gu, d__2 = d__[j] + tmp1 + tmp2; - gu = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = gl, d__2 = d__[j] - tmp1 - tmp2; - gl = std::min(d__1,d__2); - tmp1 = tmp2; -/* L20: */ - } - -/* Computing MAX */ - d__1 = gu, d__2 = d__[*n] + tmp1; - gu = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = gl, d__2 = d__[*n] - tmp1; - gl = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = abs(gl), d__2 = abs(gu); - tnorm = std::max(d__1,d__2); - gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002; - gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1; - -/* Compute Iteration parameters */ - - itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2; - if (*abstol <= 0.) { - atoli = ulp * tnorm; - } else { - atoli = *abstol; - } - - work[*n + 1] = gl; - work[*n + 2] = gl; - work[*n + 3] = gu; - work[*n + 4] = gu; - work[*n + 5] = gl; - work[*n + 6] = gu; - iwork[1] = -1; - iwork[2] = -1; - iwork[3] = *n + 1; - iwork[4] = *n + 1; - iwork[5] = *il - 1; - iwork[6] = *iu; - - dlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin, - &d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n - + 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo); - - if (iwork[6] == *iu) { - wl = work[*n + 1]; - wlu = work[*n + 3]; - nwl = iwork[1]; - wu = work[*n + 4]; - wul = work[*n + 2]; - nwu = iwork[4]; - } else { - wl = work[*n + 2]; - wlu = work[*n + 4]; - nwl = iwork[2]; - wu = work[*n + 3]; - wul = work[*n + 1]; - nwu = iwork[3]; - } - - if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) { - *info = 4; - return 0; - } - } else { - -/* RANGE='A' or 'V' -- Set ATOLI */ - -/* Computing MAX */ - d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + ( - d__2 = e[*n - 1], abs(d__2)); - tnorm = std::max(d__3,d__4); - - i__1 = *n - 1; - for (j = 2; j <= i__1; ++j) { -/* Computing MAX */ - d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1] - , abs(d__2)) + (d__3 = e[j], abs(d__3)); - tnorm = std::max(d__4,d__5); -/* L30: */ - } - - if (*abstol <= 0.) { - atoli = ulp * tnorm; - } else { - atoli = *abstol; - } - - if (irange == 2) { - wl = *vl; - wu = *vu; - } else { - wl = 0.; - wu = 0.; - } - } - -/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. */ -/* NWL accumulates the number of eigenvalues .le. WL, */ -/* NWU accumulates the number of eigenvalues .le. WU */ - - *m = 0; - iend = 0; - *info = 0; - nwl = 0; - nwu = 0; - - i__1 = *nsplit; - for (jb = 1; jb <= i__1; ++jb) { - ioff = iend; - ibegin = ioff + 1; - iend = isplit[jb]; - in = iend - ioff; - - if (in == 1) { - -/* Special Case -- IN=1 */ - - if (irange == 1 || wl >= d__[ibegin] - pivmin) { - ++nwl; - } - if (irange == 1 || wu >= d__[ibegin] - pivmin) { - ++nwu; - } - if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin] - - pivmin) { - ++(*m); - w[*m] = d__[ibegin]; - iblock[*m] = jb; - } - } else { - -/* General Case -- IN > 1 */ - -/* Compute Gershgorin Interval */ -/* and use it as the initial interval */ - - gu = d__[ibegin]; - gl = d__[ibegin]; - tmp1 = 0.; - - i__2 = iend - 1; - for (j = ibegin; j <= i__2; ++j) { - tmp2 = (d__1 = e[j], abs(d__1)); -/* Computing MAX */ - d__1 = gu, d__2 = d__[j] + tmp1 + tmp2; - gu = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = gl, d__2 = d__[j] - tmp1 - tmp2; - gl = std::min(d__1,d__2); - tmp1 = tmp2; -/* L40: */ - } - -/* Computing MAX */ - d__1 = gu, d__2 = d__[iend] + tmp1; - gu = std::max(d__1,d__2); -/* Computing MIN */ - d__1 = gl, d__2 = d__[iend] - tmp1; - gl = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = abs(gl), d__2 = abs(gu); - bnorm = std::max(d__1,d__2); - gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1; - gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1; - -/* Compute ATOLI for the current submatrix */ - - if (*abstol <= 0.) { -/* Computing MAX */ - d__1 = abs(gl), d__2 = abs(gu); - atoli = ulp * std::max(d__1,d__2); - } else { - atoli = *abstol; - } - - if (irange > 1) { - if (gu < wl) { - nwl += in; - nwu += in; - goto L70; - } - gl = std::max(gl,wl); - gu = std::min(gu,wu); - if (gl >= gu) { - goto L70; - } - } - -/* Set Up Initial Interval */ - - work[*n + 1] = gl; - work[*n + in + 1] = gu; - dlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, & - pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, & - work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], & - w[*m + 1], &iblock[*m + 1], &iinfo); - - nwl += iwork[1]; - nwu += iwork[in + 1]; - iwoff = *m - iwork[1]; - -/* Compute Eigenvalues */ - - itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(2.) - ) + 2; - dlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, & - pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, & - work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], - &w[*m + 1], &iblock[*m + 1], &iinfo); - -/* Copy Eigenvalues Into W and IBLOCK */ -/* Use -JB for block number for unconverged eigenvalues. */ - - i__2 = iout; - for (j = 1; j <= i__2; ++j) { - tmp1 = (work[j + *n] + work[j + in + *n]) * .5; - -/* Flag non-convergence. */ - - if (j > iout - iinfo) { - ncnvrg = true; - ib = -jb; - } else { - ib = jb; - } - i__3 = iwork[j + in] + iwoff; - for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) { - w[je] = tmp1; - iblock[je] = ib; -/* L50: */ - } -/* L60: */ - } - - *m += im; - } -L70: - ; - } - -/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */ -/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */ - - if (irange == 3) { - im = 0; - idiscl = *il - 1 - nwl; - idiscu = nwu - *iu; - - if (idiscl > 0 || idiscu > 0) { - i__1 = *m; - for (je = 1; je <= i__1; ++je) { - if (w[je] <= wlu && idiscl > 0) { - --idiscl; - } else if (w[je] >= wul && idiscu > 0) { - --idiscu; - } else { - ++im; - w[im] = w[je]; - iblock[im] = iblock[je]; - } -/* L80: */ - } - *m = im; - } - if (idiscl > 0 || idiscu > 0) { - -/* Code to deal with effects of bad arithmetic: */ -/* Some low eigenvalues to be discarded are not in (WL,WLU], */ -/* or high eigenvalues to be discarded are not in (WUL,WU] */ -/* so just kill off the smallest IDISCL/largest IDISCU */ -/* eigenvalues, by simply finding the smallest/largest */ -/* eigenvalue(s). */ - -/* (If N(w) is monotone non-decreasing, this should never */ -/* happen.) */ - - if (idiscl > 0) { - wkill = wu; - i__1 = idiscl; - for (jdisc = 1; jdisc <= i__1; ++jdisc) { - iw = 0; - i__2 = *m; - for (je = 1; je <= i__2; ++je) { - if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) { - iw = je; - wkill = w[je]; - } -/* L90: */ - } - iblock[iw] = 0; -/* L100: */ - } - } - if (idiscu > 0) { - - wkill = wl; - i__1 = idiscu; - for (jdisc = 1; jdisc <= i__1; ++jdisc) { - iw = 0; - i__2 = *m; - for (je = 1; je <= i__2; ++je) { - if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) { - iw = je; - wkill = w[je]; - } -/* L110: */ - } - iblock[iw] = 0; -/* L120: */ - } - } - im = 0; - i__1 = *m; - for (je = 1; je <= i__1; ++je) { - if (iblock[je] != 0) { - ++im; - w[im] = w[je]; - iblock[im] = iblock[je]; - } -/* L130: */ - } - *m = im; - } - if (idiscl < 0 || idiscu < 0) { - toofew = true; - } - } - -/* If ORDER='B', do nothing -- the eigenvalues are already sorted */ -/* by block. */ -/* If ORDER='E', sort the eigenvalues from smallest to largest */ - - if (iorder == 1 && *nsplit > 1) { - i__1 = *m - 1; - for (je = 1; je <= i__1; ++je) { - ie = 0; - tmp1 = w[je]; - i__2 = *m; - for (j = je + 1; j <= i__2; ++j) { - if (w[j] < tmp1) { - ie = j; - tmp1 = w[j]; - } -/* L140: */ - } - - if (ie != 0) { - itmp1 = iblock[ie]; - w[ie] = w[je]; - iblock[ie] = iblock[je]; - w[je] = tmp1; - iblock[je] = itmp1; - } -/* L150: */ - } - } - - *info = 0; - if (ncnvrg) { - ++(*info); - } - if (toofew) { - *info += 2; - } - return 0; - -/* End of DSTEBZ */ - -} /* dstebz_ */ diff --git a/external/clapack/lapack/dstedc.cpp b/external/clapack/lapack/dstedc.cpp deleted file mode 100644 index 387db4ca..00000000 --- a/external/clapack/lapack/dstedc.cpp +++ /dev/null @@ -1,447 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__9 = 9; -static integer c__0 = 0; -static integer c__2 = 2; -static double c_b17 = 0.; -static double c_b18 = 1.; -static integer c__1 = 1; - -/* Subroutine */ int dstedc_(const char *compz, integer *n, double *d__, - double *e, double *z__, integer *ldz, double *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, k, m; - double p; - integer ii, lgn; - double eps, tiny; - integer lwmin; - integer start; - integer finish; - integer liwmin, icompz; - double orgnrm; - bool lquery; - integer smlsiz, storez, strtrw; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a */ -/* symmetric tridiagonal matrix using the divide and conquer method. */ -/* The eigenvectors of a full or band real symmetric matrix can also be */ -/* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this */ -/* matrix to tridiagonal form. */ - -/* This code makes very mild assumptions about floating point */ -/* arithmetic. It will work on machines with a guard digit in */ -/* add/subtract, or on those binary machines without guard digits */ -/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ -/* It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. See DLAED3 for details. */ - -/* Arguments */ -/* ========= */ - -/* COMPZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only. */ -/* = 'I': Compute eigenvectors of tridiagonal matrix also. */ -/* = 'V': Compute eigenvectors of original dense symmetric */ -/* matrix also. On entry, Z contains the orthogonal */ -/* matrix used to reduce the original matrix to */ -/* tridiagonal form. */ - -/* N (input) INTEGER */ -/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the diagonal elements of the tridiagonal matrix. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the subdiagonal elements of the tridiagonal matrix. */ -/* On exit, E has been destroyed. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* On entry, if COMPZ = 'V', then Z contains the orthogonal */ -/* matrix used in the reduction to tridiagonal form. */ -/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ -/* orthonormal eigenvectors of the original symmetric matrix, */ -/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ -/* of the symmetric tridiagonal matrix. */ -/* If COMPZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1. */ -/* If eigenvectors are desired, then LDZ >= max(1,N). */ - -/* WORK (workspace/output) 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 COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */ -/* If COMPZ = 'V' and N > 1 then LWORK must be at least */ -/* ( 1 + 3*N + 2*N*lg N + 3*N**2 ), */ -/* where lg( N ) = smallest integer k such */ -/* that 2**k >= N. */ -/* If COMPZ = 'I' and N > 1 then LWORK must be at least */ -/* ( 1 + 4*N + N**2 ). */ -/* Note that for COMPZ = 'I' or 'V', then if N is less than or */ -/* equal to the minimum divide size, usually 25, then LWORK need */ -/* only be max(1,2*(N-1)). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */ -/* If COMPZ = 'V' and N > 1 then LIWORK must be at least */ -/* ( 6 + 6*N + 5*N*lg N ). */ -/* If COMPZ = 'I' and N > 1 then LIWORK must be at least */ -/* ( 3 + 5*N ). */ -/* Note that for COMPZ = 'I' or 'V', then if N is less than or */ -/* equal to the minimum divide size, usually 25, then LIWORK */ -/* need only be 1. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: The algorithm failed to compute an eigenvalue while */ -/* working on the submatrix lying in rows and columns */ -/* INFO/(N+1) through mod(INFO,N+1). */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ -/* Modified by Francoise Tisseur, University of Tennessee. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1 || *liwork == -1; - - if (lsame_(compz, "N")) { - icompz = 0; - } else if (lsame_(compz, "V")) { - icompz = 1; - } else if (lsame_(compz, "I")) { - icompz = 2; - } else { - icompz = -1; - } - if (icompz < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldz < 1 || icompz > 0 && *ldz < std::max(1_integer,*n)) { - *info = -6; - } - - if (*info == 0) { - -/* Compute the workspace requirements */ - - smlsiz = ilaenv_(&c__9, "DSTEDC", " ", &c__0, &c__0, &c__0, &c__0); - if (*n <= 1 || icompz == 0) { - liwmin = 1; - lwmin = 1; - } else if (*n <= smlsiz) { - liwmin = 1; - lwmin = *n - 1 << 1; - } else { - lgn = (integer) (log((double) (*n)) / log(2.)); - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - if (pow_ii(&c__2, &lgn) < *n) { - ++lgn; - } - if (icompz == 1) { -/* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3; - liwmin = *n * 6 + 6 + *n * 5 * lgn; - } else if (icompz == 2) { -/* Computing 2nd power */ - i__1 = *n; - lwmin = (*n << 2) + 1 + i__1 * i__1; - liwmin = *n * 5 + 3; - } - } - work[1] = (double) lwmin; - iwork[1] = liwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -8; - } else if (*liwork < liwmin && ! lquery) { - *info = -10; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEDC", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - if (*n == 1) { - if (icompz != 0) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* If the following conditional clause is removed, then the routine */ -/* will use the Divide and Conquer routine to compute only the */ -/* eigenvalues, which requires (3N + 3N**2) real workspace and */ -/* (2 + 5N + 2N lg(N)) integer workspace. */ -/* Since on many architectures DSTERF is much faster than any other */ -/* algorithm for finding eigenvalues only, it is used here */ -/* as the default. If the conditional clause is removed, then */ -/* information on the size of workspace needs to be changed. */ - -/* If COMPZ = 'N', use DSTERF to compute the eigenvalues. */ - - if (icompz == 0) { - dsterf_(n, &d__[1], &e[1], info); - goto L50; - } - -/* If N is smaller than the minimum divide size (SMLSIZ+1), then */ -/* solve the problem with another solver. */ - - if (*n <= smlsiz) { - - dsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info); - - } else { - -/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */ -/* use. */ - - if (icompz == 1) { - storez = *n * *n + 1; - } else { - storez = 1; - } - - if (icompz == 2) { - dlaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz); - } - -/* Scale. */ - - orgnrm = dlanst_("M", n, &d__[1], &e[1]); - if (orgnrm == 0.) { - goto L50; - } - - eps = dlamch_("Epsilon"); - - start = 1; - -/* while ( START <= N ) */ - -L10: - if (start <= *n) { - -/* Let FINISH be the position of the next subdiagonal entry */ -/* such that E( FINISH ) <= TINY or FINISH = N if no such */ -/* subdiagonal exists. The matrix identified by the elements */ -/* between START and FINISH constitutes an independent */ -/* sub-problem. */ - - finish = start; -L20: - if (finish < *n) { - tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt(( - d__2 = d__[finish + 1], abs(d__2))); - if ((d__1 = e[finish], abs(d__1)) > tiny) { - ++finish; - goto L20; - } - } - -/* (Sub) Problem determined. Compute its size and solve it. */ - - m = finish - start + 1; - if (m == 1) { - start = finish + 1; - goto L10; - } - if (m > smlsiz) { - -/* Scale. */ - - orgnrm = dlanst_("M", &m, &d__[start], &e[start]); - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ - start], &m, info); - i__1 = m - 1; - i__2 = m - 1; - dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ - start], &i__2, info); - - if (icompz == 1) { - strtrw = 1; - } else { - strtrw = start; - } - dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw + - start * z_dim1], ldz, &work[1], n, &work[storez], & - iwork[1], info); - if (*info != 0) { - *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % - (m + 1) + start - 1; - goto L50; - } - -/* Scale back. */ - - dlascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ - start], &m, info); - - } else { - if (icompz == 1) { - -/* Since QR won't update a Z matrix which is larger than */ -/* the length of D, we must solve the sub-problem in a */ -/* workspace and then multiply back into Z. */ - - dsteqr_("I", &m, &d__[start], &e[start], &work[1], &m, & - work[m * m + 1], info); - dlacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[ - storez], n); - dgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, & - work[1], &m, &c_b17, &z__[start * z_dim1 + 1], - ldz); - } else if (icompz == 2) { - dsteqr_("I", &m, &d__[start], &e[start], &z__[start + - start * z_dim1], ldz, &work[1], info); - } else { - dsterf_(&m, &d__[start], &e[start], info); - } - if (*info != 0) { - *info = start * (*n + 1) + finish; - goto L50; - } - } - - start = finish + 1; - goto L10; - } - -/* endwhile */ - -/* If the problem split any number of times, then the eigenvalues */ -/* will not be properly ordered. Here we permute the eigenvalues */ -/* (and the associated eigenvectors) into ascending order. */ - - if (m != *n) { - if (icompz == 0) { - -/* Use Quick Sort */ - - dlasrt_("I", n, &d__[1], info); - - } else { - -/* Use Selection Sort to minimize swaps of eigenvectors */ - - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - k = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] < p) { - k = j; - p = d__[j]; - } -/* L30: */ - } - if (k != i__) { - d__[k] = d__[i__]; - d__[i__] = p; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * - z_dim1 + 1], &c__1); - } -/* L40: */ - } - } - } - } - -L50: - work[1] = (double) lwmin; - iwork[1] = liwmin; - - return 0; - -/* End of DSTEDC */ - -} /* dstedc_ */ diff --git a/external/clapack/lapack/dstegr.cpp b/external/clapack/lapack/dstegr.cpp deleted file mode 100644 index b29df376..00000000 --- a/external/clapack/lapack/dstegr.cpp +++ /dev/null @@ -1,193 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int dstegr_(const char *jobz, const char *range, integer *n, double * - d__, double *e, double *vl, double *vu, integer *il, - integer *iu, double *abstol, integer *m, double *w, - double *z__, integer *ldz, integer *isuppz, double *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset; - - /* Local variables */ - bool tryrac; - - -/* -- LAPACK computational routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEGR computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ -/* a well defined set of pairwise different real eigenvalues, the corresponding */ -/* real eigenvectors are pairwise orthogonal. */ - -/* The spectrum may be computed either completely or partially by specifying */ -/* either an interval (VL,VU] or a range of indices IL:IU for the desired */ -/* eigenvalues. */ - -/* DSTEGR is a compatability wrapper around the improved DSTEMR routine. */ -/* See DSTEMR for further details. */ - -/* One important change is that the ABSTOL parameter no longer provides any */ -/* benefit and hence is no longer used. */ - -/* Note : DSTEGR and DSTEMR work only on machines which follow */ -/* IEEE-754 floating-point standard in their handling of infinities and */ -/* NaNs. Normal execution may create these exceptiona values and hence */ -/* may abort due to a floating point exception in environments which */ -/* do not conform to the IEEE-754 standard. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the N diagonal elements of the tridiagonal matrix */ -/* T. On exit, D is overwritten. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the (N-1) subdiagonal elements of the tridiagonal */ -/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */ -/* input, but is used internally as workspace. */ -/* On exit, E is overwritten. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* Unused. Was the absolute error tolerance for the */ -/* eigenvalues/eigenvectors in previous versions. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ -/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix T */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ -/* Supplying N columns is always safe. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', then LDZ >= max(1,N). */ - -/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */ -/* The support of the eigenvectors in Z, i.e., the indices */ -/* indicating the nonzero elements in Z. The i-th computed eigenvector */ -/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */ -/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal */ -/* (and minimal) LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,18*N) */ -/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */ -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */ -/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */ -/* if only the eigenvalues are to be computed. */ -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* On exit, INFO */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = 1X, internal error in DLARRE, */ -/* if INFO = 2X, internal error in DLARRV. */ -/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ -/* the nonzero error code returned by DLARRE or */ -/* DLARRV, respectively. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Inderjit Dhillon, IBM Almaden, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, LBNL/NERSC, USA */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - /* Parameter adjustments */ - --d__; - --e; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - *info = 0; - tryrac = false; - dstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[ - z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1] -, liwork, info); - -/* End of DSTEGR */ - - return 0; -} /* dstegr_ */ diff --git a/external/clapack/lapack/dstein.cpp b/external/clapack/lapack/dstein.cpp deleted file mode 100644 index 5ae6cab8..00000000 --- a/external/clapack/lapack/dstein.cpp +++ /dev/null @@ -1,418 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__2 = 2; -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dstein_(integer *n, double *d__, double *e, - integer *m, double *w, integer *iblock, integer *isplit, - double *z__, integer *ldz, double *work, integer *iwork, - integer *ifail, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2, i__3; - double d__1, d__2, d__3, d__4, d__5; - - /* Local variables */ - integer i__, j, b1, j1, bn; - double xj, scl, eps, sep, nrm, tol; - integer its; - double xjm, ztr, eps1; - integer jblk, nblk; - integer jmax; - integer iseed[4], gpind, iinfo; - double ortol; - integer indrv1, indrv2, indrv3, indrv4, indrv5; - integer nrmchk; - integer blksiz; - double onenrm, dtpcrt, pertol; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEIN computes the eigenvectors of a real symmetric tridiagonal */ -/* matrix T corresponding to specified eigenvalues, using inverse */ -/* iteration. */ - -/* The maximum number of iterations allowed for each eigenvector is */ -/* specified by an internal parameter MAXITS (currently set to 5). */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input) DOUBLE PRECISION array, dimension (N) */ -/* The n diagonal elements of the tridiagonal matrix T. */ - -/* E (input) DOUBLE PRECISION array, dimension (N-1) */ -/* The (n-1) subdiagonal elements of the tridiagonal matrix */ -/* T, in elements 1 to N-1. */ - -/* M (input) INTEGER */ -/* The number of eigenvectors to be found. 0 <= M <= N. */ - -/* W (input) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements of W contain the eigenvalues for */ -/* which eigenvectors are to be computed. The eigenvalues */ -/* should be grouped by split-off block and ordered from */ -/* smallest to largest within the block. ( The output array */ -/* W from DSTEBZ with ORDER = 'B' is expected here. ) */ - -/* IBLOCK (input) INTEGER array, dimension (N) */ -/* The submatrix indices associated with the corresponding */ -/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */ -/* the first submatrix from the top, =2 if W(i) belongs to */ -/* the second submatrix, etc. ( The output array IBLOCK */ -/* from DSTEBZ is expected here. ) */ - -/* ISPLIT (input) INTEGER array, dimension (N) */ -/* The splitting points, at which T breaks up into submatrices. */ -/* The first submatrix consists of rows/columns 1 to */ -/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */ -/* through ISPLIT( 2 ), etc. */ -/* ( The output array ISPLIT from DSTEBZ is expected here. ) */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, M) */ -/* The computed eigenvectors. The eigenvector associated */ -/* with the eigenvalue W(i) is stored in the i-th column of */ -/* Z. Any vector which fails to converge is set to its current */ -/* iterate after MAXITS iterations. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* IFAIL (output) INTEGER array, dimension (M) */ -/* On normal exit, all elements of IFAIL are zero. */ -/* If one or more eigenvectors fail to converge after */ -/* MAXITS iterations, then their indices are stored in */ -/* array IFAIL. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, then i eigenvectors failed to converge */ -/* in MAXITS iterations. Their indices are stored in */ -/* array IFAIL. */ - -/* Internal Parameters */ -/* =================== */ - -/* MAXITS INTEGER, default = 5 */ -/* The maximum number of iterations performed. */ - -/* EXTRA INTEGER, default = 2 */ -/* The number of iterations performed after norm growth */ -/* criterion is satisfied, should be at least 1. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --w; - --iblock; - --isplit; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - *info = 0; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - ifail[i__] = 0; -/* L10: */ - } - - if (*n < 0) { - *info = -1; - } else if (*m < 0 || *m > *n) { - *info = -4; - } else if (*ldz < std::max(1_integer,*n)) { - *info = -9; - } else { - i__1 = *m; - for (j = 2; j <= i__1; ++j) { - if (iblock[j] < iblock[j - 1]) { - *info = -6; - goto L30; - } - if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { - *info = -5; - goto L30; - } -/* L20: */ - } -L30: - ; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEIN", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *m == 0) { - return 0; - } else if (*n == 1) { - z__[z_dim1 + 1] = 1.; - return 0; - } - -/* Get machine constants. */ - - eps = dlamch_("Precision"); - -/* Initialize seed for random number generator DLARNV. */ - - for (i__ = 1; i__ <= 4; ++i__) { - iseed[i__ - 1] = 1; -/* L40: */ - } - -/* Initialize pointers. */ - - indrv1 = 0; - indrv2 = indrv1 + *n; - indrv3 = indrv2 + *n; - indrv4 = indrv3 + *n; - indrv5 = indrv4 + *n; - -/* Compute eigenvectors of matrix blocks. */ - - j1 = 1; - i__1 = iblock[*m]; - for (nblk = 1; nblk <= i__1; ++nblk) { - -/* Find starting and ending indices of block nblk. */ - - if (nblk == 1) { - b1 = 1; - } else { - b1 = isplit[nblk - 1] + 1; - } - bn = isplit[nblk]; - blksiz = bn - b1 + 1; - if (blksiz == 1) { - goto L60; - } - gpind = b1; - -/* Compute reorthogonalization criterion and stopping criterion. */ - - onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 = e[b1], abs(d__2)); -/* Computing MAX */ - d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1], - abs(d__2)); - onenrm = std::max(d__3,d__4); - i__2 = bn - 1; - for (i__ = b1 + 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[ - i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3)); - onenrm = std::max(d__4,d__5); -/* L50: */ - } - ortol = onenrm * .001; - - dtpcrt = sqrt(.1 / blksiz); - -/* Loop through eigenvalues of block nblk. */ - -L60: - jblk = 0; - i__2 = *m; - for (j = j1; j <= i__2; ++j) { - if (iblock[j] != nblk) { - j1 = j; - goto L160; - } - ++jblk; - xj = w[j]; - -/* Skip all the work if the block size is one. */ - - if (blksiz == 1) { - work[indrv1 + 1] = 1.; - goto L120; - } - -/* If eigenvalues j and j-1 are too close, add a relatively */ -/* small perturbation. */ - - if (jblk > 1) { - eps1 = (d__1 = eps * xj, abs(d__1)); - pertol = eps1 * 10.; - sep = xj - xjm; - if (sep < pertol) { - xj = xjm + pertol; - } - } - - its = 0; - nrmchk = 0; - -/* Get random starting vector. */ - - dlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]); - -/* Copy the matrix T so it won't be destroyed in factorization. */ - - dcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1); - i__3 = blksiz - 1; - dcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1); - i__3 = blksiz - 1; - dcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1); - -/* Compute LU factors with partial pivoting ( PT = LU ) */ - - tol = 0.; - dlagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[ - indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo); - -/* Update iteration count. */ - -L70: - ++its; - if (its > 5) { - goto L100; - } - -/* Normalize and scale the righthand side vector Pb. */ - -/* Computing MAX */ - d__2 = eps, d__3 = (d__1 = work[indrv4 + blksiz], abs(d__1)); - scl = blksiz * onenrm * std::max(d__2,d__3) / dasum_(&blksiz, &work[ - indrv1 + 1], &c__1); - dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); - -/* Solve the system LU = Pb. */ - - dlagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], & - work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[ - indrv1 + 1], &tol, &iinfo); - -/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */ -/* close enough. */ - - if (jblk == 1) { - goto L90; - } - if ((d__1 = xj - xjm, abs(d__1)) > ortol) { - gpind = j; - } - if (gpind != j) { - i__3 = j - 1; - for (i__ = gpind; i__ <= i__3; ++i__) { - ztr = -ddot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 + - i__ * z_dim1], &c__1); - daxpy_(&blksiz, &ztr, &z__[b1 + i__ * z_dim1], &c__1, & - work[indrv1 + 1], &c__1); -/* L80: */ - } - } - -/* Check the infinity norm of the iterate. */ - -L90: - jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); - nrm = (d__1 = work[indrv1 + jmax], abs(d__1)); - -/* Continue for additional iterations after norm reaches */ -/* stopping criterion. */ - - if (nrm < dtpcrt) { - goto L70; - } - ++nrmchk; - if (nrmchk < 3) { - goto L70; - } - - goto L110; - -/* If stopping criterion was not satisfied, update info and */ -/* store eigenvector number in array ifail. */ - -L100: - ++(*info); - ifail[*info] = j; - -/* Accept iterate as jth eigenvector. */ - -L110: - scl = 1. / dnrm2_(&blksiz, &work[indrv1 + 1], &c__1); - jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); - if (work[indrv1 + jmax] < 0.) { - scl = -scl; - } - dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); -L120: - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - z__[i__ + j * z_dim1] = 0.; -/* L130: */ - } - i__3 = blksiz; - for (i__ = 1; i__ <= i__3; ++i__) { - z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__]; -/* L140: */ - } - -/* Save the shift to check eigenvalue spacing at next */ -/* iteration. */ - - xjm = xj; - -/* L150: */ - } -L160: - ; - } - - return 0; - -/* End of DSTEIN */ - -} /* dstein_ */ diff --git a/external/clapack/lapack/dstemr.cpp b/external/clapack/lapack/dstemr.cpp deleted file mode 100644 index 11c255e0..00000000 --- a/external/clapack/lapack/dstemr.cpp +++ /dev/null @@ -1,681 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b18 = .001; - -/* Subroutine */ int dstemr_(const char *jobz, const char *range, integer *n, double * - d__, double *e, double *vl, double *vu, integer *il, - integer *iu, integer *m, double *w, double *z__, integer *ldz, - integer *nzc, integer *isuppz, bool *tryrac, double *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j; - double r1, r2; - integer jj; - double cs; - integer in; - double sn, wl, wu; - integer iil, iiu; - double eps, tmp; - integer indd, iend, jblk, wend; - double rmin, rmax; - integer itmp; - double tnrm; - integer inde2, itmp2; - double rtol1, rtol2; - double scale; - integer indgp; - integer iinfo, iindw, ilast; - integer lwmin; - bool wantz; - bool alleig; - integer ibegin; - bool indeig; - integer iindbl; - bool valeig; - integer wbegin; - double safmin; - double bignum; - integer inderr, iindwk, indgrs, offset; - double thresh; - integer iinspl, ifirst, indwrk, liwmin, nzcmin; - double pivmin; - integer nsplit; - double smlnum; - bool lquery, zquery; - - -/* -- LAPACK computational routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEMR computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ -/* a well defined set of pairwise different real eigenvalues, the corresponding */ -/* real eigenvectors are pairwise orthogonal. */ - -/* The spectrum may be computed either completely or partially by specifying */ -/* either an interval (VL,VU] or a range of indices IL:IU for the desired */ -/* eigenvalues. */ - -/* Depending on the number of desired eigenvalues, these are computed either */ -/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */ -/* computed by the use of various suitable L D L^T factorizations near clusters */ -/* of close eigenvalues (referred to as RRRs, Relatively Robust */ -/* Representations). An informal sketch of the algorithm follows. */ - -/* For each unreduced block (submatrix) of T, */ -/* (a) Compute T - sigma I = L D L^T, so that L and D */ -/* define all the wanted eigenvalues to high relative accuracy. */ -/* This means that small relative changes in the entries of D and L */ -/* cause only small relative changes in the eigenvalues and */ -/* eigenvectors. The standard (unfactored) representation of the */ -/* tridiagonal matrix T does not have this property in general. */ -/* (b) Compute the eigenvalues to suitable accuracy. */ -/* If the eigenvectors are desired, the algorithm attains full */ -/* accuracy of the computed eigenvalues only right before */ -/* the corresponding vectors have to be computed, see steps c) and d). */ -/* (c) For each cluster of close eigenvalues, select a new */ -/* shift close to the cluster, find a new factorization, and refine */ -/* the shifted eigenvalues to suitable accuracy. */ -/* (d) For each eigenvalue with a large enough relative separation compute */ -/* the corresponding eigenvector by forming a rank revealing twisted */ -/* factorization. Go back to (c) for any clusters that remain. */ - -/* For more details, see: */ -/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* 2004. Also LAPACK Working Note 154. */ -/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* tridiagonal eigenvalue/eigenvector problem", */ -/* Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* UC Berkeley, May 1997. */ - -/* Notes: */ -/* 1.DSTEMR works only on machines which follow IEEE-754 */ -/* floating-point standard in their handling of infinities and NaNs. */ -/* This permits the use of efficient inner loops avoiding a check for */ -/* zero divisors. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the N diagonal elements of the tridiagonal matrix */ -/* T. On exit, D is overwritten. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the (N-1) subdiagonal elements of the tridiagonal */ -/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */ -/* input, but is used internally as workspace. */ -/* On exit, E is overwritten. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ -/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix T */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and can be computed with a workspace */ -/* query by setting NZC = -1, see below. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', then LDZ >= max(1,N). */ - -/* NZC (input) INTEGER */ -/* The number of eigenvectors to be held in the array Z. */ -/* If RANGE = 'A', then NZC >= max(1,N). */ -/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */ -/* If RANGE = 'I', then NZC >= IU-IL+1. */ -/* If NZC = -1, then a workspace query is assumed; the */ -/* routine calculates the number of columns of the array Z that */ -/* are needed to hold the eigenvectors. */ -/* This value is returned as the first entry of the Z array, and */ -/* no error message related to NZC is issued by XERBLA. */ - -/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */ -/* The support of the eigenvectors in Z, i.e., the indices */ -/* indicating the nonzero elements in Z. The i-th computed eigenvector */ -/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */ -/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ - -/* TRYRAC (input/output) LOGICAL */ -/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */ -/* the tridiagonal matrix defines its eigenvalues to high relative */ -/* accuracy. If so, the code uses relative-accuracy preserving */ -/* algorithms that might be (a bit) slower depending on the matrix. */ -/* If the matrix does not define its eigenvalues to high relative */ -/* accuracy, the code can uses possibly faster algorithms. */ -/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */ -/* relatively accurate eigenvalues and can use the fastest possible */ -/* techniques. */ -/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */ -/* does not define its eigenvalues to high relative accuracy. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal */ -/* (and minimal) LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,18*N) */ -/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */ -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */ -/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */ -/* if only the eigenvalues are to be computed. */ -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* On exit, INFO */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = 1X, internal error in DLARRE, */ -/* if INFO = 2X, internal error in DLARRV. */ -/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ -/* the nonzero error code returned by DLARRE or */ -/* DLARRV, respectively. */ - - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Beresford Parlett, University of California, Berkeley, USA */ -/* Jim Demmel, University of California, Berkeley, USA */ -/* Inderjit Dhillon, University of Texas, Austin, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Christof Voemel, University of California, Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - lquery = *lwork == -1 || *liwork == -1; - zquery = *nzc == -1; - *tryrac = *info != 0; -/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */ -/* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */ -/* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */ - if (wantz) { - lwmin = *n * 18; - liwmin = *n * 10; - } else { -/* need less workspace if only the eigenvalues are wanted */ - lwmin = *n * 12; - liwmin = *n << 3; - } - wl = 0.; - wu = 0.; - iil = 0; - iiu = 0; - if (valeig) { -/* We do not reference VL, VU in the cases RANGE = 'I','A' */ -/* The interval (WL, WU] contains all the wanted eigenvalues. */ -/* It is either given by the user or computed in DLARRE. */ - wl = *vl; - wu = *vu; - } else if (indeig) { -/* We do not reference IL, IU in the cases RANGE = 'V','A' */ - iil = *il; - iiu = *iu; - } - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (valeig && *n > 0 && wu <= wl) { - *info = -7; - } else if (indeig && (iil < 1 || iil > *n)) { - *info = -8; - } else if (indeig && (iiu < iil || iiu > *n)) { - *info = -9; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -13; - } else if (*lwork < lwmin && ! lquery) { - *info = -17; - } else if (*liwork < liwmin && ! lquery) { - *info = -19; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = std::min(d__1,d__2); - - if (*info == 0) { - work[1] = (double) lwmin; - iwork[1] = liwmin; - - if (wantz && alleig) { - nzcmin = *n; - } else if (wantz && valeig) { - dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, & - itmp2, info); - } else if (wantz && indeig) { - nzcmin = iiu - iil + 1; - } else { -/* WANTZ .EQ. FALSE. */ - nzcmin = 0; - } - if (zquery && *info == 0) { - z__[z_dim1 + 1] = (double) nzcmin; - } else if (*nzc < nzcmin && ! zquery) { - *info = -14; - } - } - if (*info != 0) { - - i__1 = -(*info); - xerbla_("DSTEMR", &i__1); - - return 0; - } else if (lquery || zquery) { - return 0; - } - -/* Handle N = 0, 1, and 2 cases immediately */ - - *m = 0; - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (alleig || indeig) { - *m = 1; - w[1] = d__[1]; - } else { - if (wl < d__[1] && wu >= d__[1]) { - *m = 1; - w[1] = d__[1]; - } - } - if (wantz && ! zquery) { - z__[z_dim1 + 1] = 1.; - isuppz[1] = 1; - isuppz[2] = 1; - } - return 0; - } - - if (*n == 2) { - if (! wantz) { - dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2); - } else if (wantz && ! zquery) { - dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn); - } - if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) { - ++(*m); - w[*m] = r2; - if (wantz && ! zquery) { - z__[*m * z_dim1 + 1] = -sn; - z__[*m * z_dim1 + 2] = cs; -/* Note: At most one of SN and CS can be zero. */ - if (sn != 0.) { - if (cs != 0.) { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 2; - } else { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 1; - } - } else { - isuppz[(*m << 1) - 1] = 2; - isuppz[*m * 2] = 2; - } - } - } - if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) { - ++(*m); - w[*m] = r1; - if (wantz && ! zquery) { - z__[*m * z_dim1 + 1] = cs; - z__[*m * z_dim1 + 2] = sn; -/* Note: At most one of SN and CS can be zero. */ - if (sn != 0.) { - if (cs != 0.) { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 2; - } else { - isuppz[(*m << 1) - 1] = 1; - isuppz[(*m << 1) - 1] = 1; - } - } else { - isuppz[(*m << 1) - 1] = 2; - isuppz[*m * 2] = 2; - } - } - } - return 0; - } -/* Continue with general N */ - indgrs = 1; - inderr = (*n << 1) + 1; - indgp = *n * 3 + 1; - indd = (*n << 2) + 1; - inde2 = *n * 5 + 1; - indwrk = *n * 6 + 1; - - iinspl = 1; - iindbl = *n + 1; - iindw = (*n << 1) + 1; - iindwk = *n * 3 + 1; - -/* Scale matrix to allowable range, if necessary. */ -/* The allowable range is related to the PIVMIN parameter; see the */ -/* comments in DLARRD. The preference for scaling small values */ -/* up is heuristic; we expect users' matrices not to be close to the */ -/* RMAX threshold. */ - - scale = 1.; - tnrm = dlanst_("M", n, &d__[1], &e[1]); - if (tnrm > 0. && tnrm < rmin) { - scale = rmin / tnrm; - } else if (tnrm > rmax) { - scale = rmax / tnrm; - } - if (scale != 1.) { - dscal_(n, &scale, &d__[1], &c__1); - i__1 = *n - 1; - dscal_(&i__1, &scale, &e[1], &c__1); - tnrm *= scale; - if (valeig) { -/* If eigenvalues in interval have to be found, */ -/* scale (WL, WU] accordingly */ - wl *= scale; - wu *= scale; - } - } - -/* Compute the desired eigenvalues of the tridiagonal after splitting */ -/* into smaller subblocks if the corresponding off-diagonal elements */ -/* are small */ -/* THRESH is the splitting parameter for DLARRE */ -/* A negative THRESH forces the old splitting criterion based on the */ -/* size of the off-diagonal. A positive THRESH switches to splitting */ -/* which preserves relative accuracy. */ - - if (*tryrac) { -/* Test whether the matrix warrants the more expensive relative approach. */ - dlarrr_(n, &d__[1], &e[1], &iinfo); - } else { -/* The user does not care about relative accurately eigenvalues */ - iinfo = -1; - } -/* Set the splitting criterion */ - if (iinfo == 0) { - thresh = eps; - } else { - thresh = -eps; -/* relative accuracy is desired but T does not guarantee it */ - *tryrac = false; - } - - if (*tryrac) { -/* Copy original diagonal, needed to guarantee relative accuracy */ - dcopy_(n, &d__[1], &c__1, &work[indd], &c__1); - } -/* Store the squares of the offdiagonal values of T */ - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing 2nd power */ - d__1 = e[j]; - work[inde2 + j - 1] = d__1 * d__1; -/* L5: */ - } -/* Set the tolerance parameters for bisection */ - if (! wantz) { -/* DLARRE computes the eigenvalues to full precision. */ - rtol1 = eps * 4.; - rtol2 = eps * 4.; - } else { -/* DLARRE computes the eigenvalues to less than full precision. */ -/* DLARRV will refine the eigenvalue approximations, and we can */ -/* need less accurate initial bisection in DLARRE. */ -/* Note: these settings do only affect the subset case and DLARRE */ - rtol1 = sqrt(eps); -/* Computing MAX */ - d__1 = sqrt(eps) * .005, d__2 = eps * 4.; - rtol2 = std::max(d__1,d__2); - } - dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], & - rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[ - inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[ - indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo); - if (iinfo != 0) { - *info = abs(iinfo) + 10; - return 0; - } -/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */ -/* part of the spectrum. All desired eigenvalues are contained in */ -/* (WL,WU] */ - if (wantz) { - -/* Compute the desired eigenvectors corresponding to the computed */ -/* eigenvalues */ - - dlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, & - c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[ - indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[ - z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], & - iinfo); - if (iinfo != 0) { - *info = abs(iinfo) + 20; - return 0; - } - } else { -/* DLARRE computes eigenvalues of the (shifted) root representation */ -/* DLARRV returns the eigenvalues of the unshifted matrix. */ -/* However, if the eigenvectors are not desired by the user, we need */ -/* to apply the corresponding shifts from DLARRE to obtain the */ -/* eigenvalues of the original matrix. */ - i__1 = *m; - for (j = 1; j <= i__1; ++j) { - itmp = iwork[iindbl + j - 1]; - w[j] += e[iwork[iinspl + itmp - 1]]; -/* L20: */ - } - } - - if (*tryrac) { -/* Refine computed eigenvalues so that they are relatively accurate */ -/* with respect to the original matrix T. */ - ibegin = 1; - wbegin = 1; - i__1 = iwork[iindbl + *m - 1]; - for (jblk = 1; jblk <= i__1; ++jblk) { - iend = iwork[iinspl + jblk - 1]; - in = iend - ibegin + 1; - wend = wbegin - 1; -/* check if any eigenvalues have to be refined in this block */ -L36: - if (wend < *m) { - if (iwork[iindbl + wend] == jblk) { - ++wend; - goto L36; - } - } - if (wend < wbegin) { - ibegin = iend + 1; - goto L39; - } - offset = iwork[iindw + wbegin - 1] - 1; - ifirst = iwork[iindw + wbegin - 1]; - ilast = iwork[iindw + wend - 1]; - rtol2 = eps * 4.; - dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1], - &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[ - inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], & - pivmin, &tnrm, &iinfo); - ibegin = iend + 1; - wbegin = wend + 1; -L39: - ; - } - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (scale != 1.) { - d__1 = 1. / scale; - dscal_(m, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in increasing order, then sort them, */ -/* possibly along with eigenvectors. */ - - if (nsplit > 1) { - if (! wantz) { - dlasrt_("I", m, &w[1], &iinfo); - if (iinfo != 0) { - *info = 3; - return 0; - } - } else { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp) { - i__ = jj; - tmp = w[jj]; - } -/* L50: */ - } - if (i__ != 0) { - w[i__] = w[j]; - w[j] = tmp; - if (wantz) { - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * - z_dim1 + 1], &c__1); - itmp = isuppz[(i__ << 1) - 1]; - isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1]; - isuppz[(j << 1) - 1] = itmp; - itmp = isuppz[i__ * 2]; - isuppz[i__ * 2] = isuppz[j * 2]; - isuppz[j * 2] = itmp; - } - } -/* L60: */ - } - } - } - - - work[1] = (double) lwmin; - iwork[1] = liwmin; - return 0; - -/* End of DSTEMR */ - -} /* dstemr_ */ diff --git a/external/clapack/lapack/dsteqr.cpp b/external/clapack/lapack/dsteqr.cpp deleted file mode 100644 index 5757f288..00000000 --- a/external/clapack/lapack/dsteqr.cpp +++ /dev/null @@ -1,586 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b9 = 0.; -static double c_b10 = 1.; -static integer c__0 = 0; -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int dsteqr_(const char *compz, integer *n, double *d__, - double *e, double *z__, integer *ldz, double *work, - integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - double b, c__, f, g; - integer i__, j, k, l, m; - double p, r__, s; - integer l1, ii, mm, lm1, mm1, nm1; - double rt1, rt2, eps; - integer lsv; - double tst, eps2; - integer lend, jtot; - double anorm; - integer lendm1, lendp1; - integer iscale; - double safmin; - double safmax; - integer lendsv; - double ssfmin; - integer nmaxit, icompz; - double ssfmax; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */ -/* symmetric tridiagonal matrix using the implicit QL or QR method. */ -/* The eigenvectors of a full or band symmetric matrix can also be found */ -/* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */ -/* tridiagonal form. */ - -/* Arguments */ -/* ========= */ - -/* COMPZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only. */ -/* = 'V': Compute eigenvalues and eigenvectors of the original */ -/* symmetric matrix. On entry, Z must contain the */ -/* orthogonal matrix used to reduce the original matrix */ -/* to tridiagonal form. */ -/* = 'I': Compute eigenvalues and eigenvectors of the */ -/* tridiagonal matrix. Z is initialized to the identity */ -/* matrix. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the diagonal elements of the tridiagonal matrix. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix. */ -/* On exit, E has been destroyed. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* On entry, if COMPZ = 'V', then Z contains the orthogonal */ -/* matrix used in the reduction to tridiagonal form. */ -/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ -/* orthonormal eigenvectors of the original symmetric matrix, */ -/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ -/* of the symmetric tridiagonal matrix. */ -/* If COMPZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* eigenvectors are desired, then LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */ -/* If COMPZ = 'N', then WORK is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: the algorithm has failed to find all the eigenvalues in */ -/* a total of 30*N iterations; if INFO = i, then i */ -/* elements of E have not converged to zero; on exit, D */ -/* and E contain the elements of a symmetric tridiagonal */ -/* matrix which is orthogonally similar to the original */ -/* matrix. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - *info = 0; - - if (lsame_(compz, "N")) { - icompz = 0; - } else if (lsame_(compz, "V")) { - icompz = 1; - } else if (lsame_(compz, "I")) { - icompz = 2; - } else { - icompz = -1; - } - if (icompz < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldz < 1 || icompz > 0 && *ldz < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEQR", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (icompz == 2) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Determine the unit roundoff and over/underflow thresholds. */ - - eps = dlamch_("E"); -/* Computing 2nd power */ - d__1 = eps; - eps2 = d__1 * d__1; - safmin = dlamch_("S"); - safmax = 1. / safmin; - ssfmax = sqrt(safmax) / 3.; - ssfmin = sqrt(safmin) / eps2; - -/* Compute the eigenvalues and eigenvectors of the tridiagonal */ -/* matrix. */ - - if (icompz == 2) { - dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz); - } - - nmaxit = *n * 30; - jtot = 0; - -/* Determine where the matrix splits and choose QL or QR iteration */ -/* for each block, according to whether top or bottom diagonal */ -/* element is smaller. */ - - l1 = 1; - nm1 = *n - 1; - -L10: - if (l1 > *n) { - goto L160; - } - if (l1 > 1) { - e[l1 - 1] = 0.; - } - if (l1 <= nm1) { - i__1 = nm1; - for (m = l1; m <= i__1; ++m) { - tst = (d__1 = e[m], abs(d__1)); - if (tst == 0.) { - goto L30; - } - if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m - + 1], abs(d__2))) * eps) { - e[m] = 0.; - goto L30; - } -/* L20: */ - } - } - m = *n; - -L30: - l = l1; - lsv = l; - lend = m; - lendsv = lend; - l1 = m + 1; - if (lend == l) { - goto L10; - } - -/* Scale submatrix in rows and columns L to LEND */ - - i__1 = lend - l + 1; - anorm = dlanst_("I", &i__1, &d__[l], &e[l]); - iscale = 0; - if (anorm == 0.) { - goto L10; - } - if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info); - } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info); - } - -/* Choose between QL and QR iteration */ - - if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { - lend = lsv; - l = lendsv; - } - - if (lend > l) { - -/* QL Iteration */ - -/* Look for small subdiagonal element. */ - -L40: - if (l != lend) { - lendm1 = lend - 1; - i__1 = lendm1; - for (m = l; m <= i__1; ++m) { -/* Computing 2nd power */ - d__2 = (d__1 = e[m], abs(d__1)); - tst = d__2 * d__2; - if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - + 1], abs(d__2)) + safmin) { - goto L60; - } -/* L50: */ - } - } - - m = lend; - -L60: - if (m < lend) { - e[m] = 0.; - } - p = d__[l]; - if (m == l) { - goto L80; - } - -/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ -/* to compute its eigensystem. */ - - if (m == l + 1) { - if (icompz > 0) { - dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); - work[l] = c__; - work[*n - 1 + l] = s; - dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & - z__[l * z_dim1 + 1], ldz); - } else { - dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); - } - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.; - l += 2; - if (l <= lend) { - goto L40; - } - goto L140; - } - - if (jtot == nmaxit) { - goto L140; - } - ++jtot; - -/* Form shift. */ - - g = (d__[l + 1] - p) / (e[l] * 2.); - r__ = dlapy2_(&g, &c_b10); - g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); - - s = 1.; - c__ = 1.; - p = 0.; - -/* Inner loop */ - - mm1 = m - 1; - i__1 = l; - for (i__ = mm1; i__ >= i__1; --i__) { - f = s * e[i__]; - b = c__ * e[i__]; - dlartg_(&g, &f, &c__, &s, &r__); - if (i__ != m - 1) { - e[i__ + 1] = r__; - } - g = d__[i__ + 1] - p; - r__ = (d__[i__] - g) * s + c__ * 2. * b; - p = s * r__; - d__[i__ + 1] = g + p; - g = c__ * r__ - b; - -/* If eigenvectors are desired, then save rotations. */ - - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = -s; - } - -/* L70: */ - } - -/* If eigenvectors are desired, then apply saved rotations. */ - - if (icompz > 0) { - mm = m - l + 1; - dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l - * z_dim1 + 1], ldz); - } - - d__[l] -= p; - e[l] = g; - goto L40; - -/* Eigenvalue found. */ - -L80: - d__[l] = p; - - ++l; - if (l <= lend) { - goto L40; - } - goto L140; - - } else { - -/* QR Iteration */ - -/* Look for small superdiagonal element. */ - -L90: - if (l != lend) { - lendp1 = lend + 1; - i__1 = lendp1; - for (m = l; m >= i__1; --m) { -/* Computing 2nd power */ - d__2 = (d__1 = e[m - 1], abs(d__1)); - tst = d__2 * d__2; - if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m - - 1], abs(d__2)) + safmin) { - goto L110; - } -/* L100: */ - } - } - - m = lend; - -L110: - if (m > lend) { - e[m - 1] = 0.; - } - p = d__[l]; - if (m == l) { - goto L130; - } - -/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ -/* to compute its eigensystem. */ - - if (m == l - 1) { - if (icompz > 0) { - dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) - ; - work[m] = c__; - work[*n - 1 + m] = s; - dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & - z__[(l - 1) * z_dim1 + 1], ldz); - } else { - dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); - } - d__[l - 1] = rt1; - d__[l] = rt2; - e[l - 1] = 0.; - l += -2; - if (l >= lend) { - goto L90; - } - goto L140; - } - - if (jtot == nmaxit) { - goto L140; - } - ++jtot; - -/* Form shift. */ - - g = (d__[l - 1] - p) / (e[l - 1] * 2.); - r__ = dlapy2_(&g, &c_b10); - g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); - - s = 1.; - c__ = 1.; - p = 0.; - -/* Inner loop */ - - lm1 = l - 1; - i__1 = lm1; - for (i__ = m; i__ <= i__1; ++i__) { - f = s * e[i__]; - b = c__ * e[i__]; - dlartg_(&g, &f, &c__, &s, &r__); - if (i__ != m) { - e[i__ - 1] = r__; - } - g = d__[i__] - p; - r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; - p = s * r__; - d__[i__] = g + p; - g = c__ * r__ - b; - -/* If eigenvectors are desired, then save rotations. */ - - if (icompz > 0) { - work[i__] = c__; - work[*n - 1 + i__] = s; - } - -/* L120: */ - } - -/* If eigenvectors are desired, then apply saved rotations. */ - - if (icompz > 0) { - mm = l - m + 1; - dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m - * z_dim1 + 1], ldz); - } - - d__[l] -= p; - e[lm1] = g; - goto L90; - -/* Eigenvalue found. */ - -L130: - d__[l] = p; - - --l; - if (l >= lend) { - goto L90; - } - goto L140; - - } - -/* Undo scaling if necessary */ - -L140: - if (iscale == 1) { - i__1 = lendsv - lsv + 1; - dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - i__1 = lendsv - lsv; - dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, - info); - } else if (iscale == 2) { - i__1 = lendsv - lsv + 1; - dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - i__1 = lendsv - lsv; - dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, - info); - } - -/* Check for no convergence to an eigenvalue after a total */ -/* of N*MAXIT iterations. */ - - if (jtot < nmaxit) { - goto L10; - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } -/* L150: */ - } - goto L190; - -/* Order eigenvalues and eigenvectors. */ - -L160: - if (icompz == 0) { - -/* Use Quick Sort */ - - dlasrt_("I", n, &d__[1], info); - - } else { - -/* Use Selection Sort to minimize swaps of eigenvectors */ - - i__1 = *n; - for (ii = 2; ii <= i__1; ++ii) { - i__ = ii - 1; - k = i__; - p = d__[i__]; - i__2 = *n; - for (j = ii; j <= i__2; ++j) { - if (d__[j] < p) { - k = j; - p = d__[j]; - } -/* L170: */ - } - if (k != i__) { - d__[k] = d__[i__]; - d__[i__] = p; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], - &c__1); - } -/* L180: */ - } - } - -L190: - return 0; - -/* End of DSTEQR */ - -} /* dsteqr_ */ diff --git a/external/clapack/lapack/dsterf.cpp b/external/clapack/lapack/dsterf.cpp deleted file mode 100644 index 5abd3ce3..00000000 --- a/external/clapack/lapack/dsterf.cpp +++ /dev/null @@ -1,436 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__0 = 0; -static integer c__1 = 1; -static double c_b32 = 1.; - -/* Subroutine */ int dsterf_(integer *n, double *d__, double *e, - integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1, d__2, d__3; - - /* Local variables */ - double c__; - integer i__, l, m; - double p, r__, s; - integer l1; - double bb, rt1, rt2, eps, rte; - integer lsv; - double eps2, oldc; - integer lend, jtot; - double gamma, alpha, sigma, anorm; - integer iscale; - double oldgam, safmin; - double safmax; - integer lendsv; - double ssfmin; - integer nmaxit; - double ssfmax; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix */ -/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix. */ -/* On exit, E has been destroyed. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: the algorithm failed to find all of the eigenvalues in */ -/* a total of 30*N iterations; if INFO = i, then i */ -/* elements of E have not converged to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --e; - --d__; - - /* Function Body */ - *info = 0; - -/* Quick return if possible */ - - if (*n < 0) { - *info = -1; - i__1 = -(*info); - xerbla_("DSTERF", &i__1); - return 0; - } - if (*n <= 1) { - return 0; - } - -/* Determine the unit roundoff for this environment. */ - - eps = dlamch_("E"); -/* Computing 2nd power */ - d__1 = eps; - eps2 = d__1 * d__1; - safmin = dlamch_("S"); - safmax = 1. / safmin; - ssfmax = sqrt(safmax) / 3.; - ssfmin = sqrt(safmin) / eps2; - -/* Compute the eigenvalues of the tridiagonal matrix. */ - - nmaxit = *n * 30; - sigma = 0.; - jtot = 0; - -/* Determine where the matrix splits and choose QL or QR iteration */ -/* for each block, according to whether top or bottom diagonal */ -/* element is smaller. */ - - l1 = 1; - -L10: - if (l1 > *n) { - goto L170; - } - if (l1 > 1) { - e[l1 - 1] = 0.; - } - i__1 = *n - 1; - for (m = l1; m <= i__1; ++m) { - if ((d__3 = e[m], abs(d__3)) <= sqrt((d__1 = d__[m], abs(d__1))) * - sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { - e[m] = 0.; - goto L30; - } -/* L20: */ - } - m = *n; - -L30: - l = l1; - lsv = l; - lend = m; - lendsv = lend; - l1 = m + 1; - if (lend == l) { - goto L10; - } - -/* Scale submatrix in rows and columns L to LEND */ - - i__1 = lend - l + 1; - anorm = dlanst_("I", &i__1, &d__[l], &e[l]); - iscale = 0; - if (anorm > ssfmax) { - iscale = 1; - i__1 = lend - l + 1; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, - info); - } else if (anorm < ssfmin) { - iscale = 2; - i__1 = lend - l + 1; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, - info); - i__1 = lend - l; - dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, - info); - } - - i__1 = lend - 1; - for (i__ = l; i__ <= i__1; ++i__) { -/* Computing 2nd power */ - d__1 = e[i__]; - e[i__] = d__1 * d__1; -/* L40: */ - } - -/* Choose between QL and QR iteration */ - - if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { - lend = lsv; - l = lendsv; - } - - if (lend >= l) { - -/* QL Iteration */ - -/* Look for small subdiagonal element. */ - -L50: - if (l != lend) { - i__1 = lend - 1; - for (m = l; m <= i__1; ++m) { - if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m - + 1], abs(d__1))) { - goto L70; - } -/* L60: */ - } - } - m = lend; - -L70: - if (m < lend) { - e[m] = 0.; - } - p = d__[l]; - if (m == l) { - goto L90; - } - -/* If remaining matrix is 2 by 2, use DLAE2 to compute its */ -/* eigenvalues. */ - - if (m == l + 1) { - rte = sqrt(e[l]); - dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); - d__[l] = rt1; - d__[l + 1] = rt2; - e[l] = 0.; - l += 2; - if (l <= lend) { - goto L50; - } - goto L150; - } - - if (jtot == nmaxit) { - goto L150; - } - ++jtot; - -/* Form shift. */ - - rte = sqrt(e[l]); - sigma = (d__[l + 1] - p) / (rte * 2.); - r__ = dlapy2_(&sigma, &c_b32); - sigma = p - rte / (sigma + d_sign(&r__, &sigma)); - - c__ = 1.; - s = 0.; - gamma = d__[m] - sigma; - p = gamma * gamma; - -/* Inner loop */ - - i__1 = l; - for (i__ = m - 1; i__ >= i__1; --i__) { - bb = e[i__]; - r__ = p + bb; - if (i__ != m - 1) { - e[i__ + 1] = s * r__; - } - oldc = c__; - c__ = p / r__; - s = bb / r__; - oldgam = gamma; - alpha = d__[i__]; - gamma = c__ * (alpha - sigma) - s * oldgam; - d__[i__ + 1] = oldgam + (alpha - gamma); - if (c__ != 0.) { - p = gamma * gamma / c__; - } else { - p = oldc * bb; - } -/* L80: */ - } - - e[l] = s * p; - d__[l] = sigma + gamma; - goto L50; - -/* Eigenvalue found. */ - -L90: - d__[l] = p; - - ++l; - if (l <= lend) { - goto L50; - } - goto L150; - - } else { - -/* QR Iteration */ - -/* Look for small superdiagonal element. */ - -L100: - i__1 = lend + 1; - for (m = l; m >= i__1; --m) { - if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m - - 1], abs(d__1))) { - goto L120; - } -/* L110: */ - } - m = lend; - -L120: - if (m > lend) { - e[m - 1] = 0.; - } - p = d__[l]; - if (m == l) { - goto L140; - } - -/* If remaining matrix is 2 by 2, use DLAE2 to compute its */ -/* eigenvalues. */ - - if (m == l - 1) { - rte = sqrt(e[l - 1]); - dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); - d__[l] = rt1; - d__[l - 1] = rt2; - e[l - 1] = 0.; - l += -2; - if (l >= lend) { - goto L100; - } - goto L150; - } - - if (jtot == nmaxit) { - goto L150; - } - ++jtot; - -/* Form shift. */ - - rte = sqrt(e[l - 1]); - sigma = (d__[l - 1] - p) / (rte * 2.); - r__ = dlapy2_(&sigma, &c_b32); - sigma = p - rte / (sigma + d_sign(&r__, &sigma)); - - c__ = 1.; - s = 0.; - gamma = d__[m] - sigma; - p = gamma * gamma; - -/* Inner loop */ - - i__1 = l - 1; - for (i__ = m; i__ <= i__1; ++i__) { - bb = e[i__]; - r__ = p + bb; - if (i__ != m) { - e[i__ - 1] = s * r__; - } - oldc = c__; - c__ = p / r__; - s = bb / r__; - oldgam = gamma; - alpha = d__[i__ + 1]; - gamma = c__ * (alpha - sigma) - s * oldgam; - d__[i__] = oldgam + (alpha - gamma); - if (c__ != 0.) { - p = gamma * gamma / c__; - } else { - p = oldc * bb; - } -/* L130: */ - } - - e[l - 1] = s * p; - d__[l] = sigma + gamma; - goto L100; - -/* Eigenvalue found. */ - -L140: - d__[l] = p; - - --l; - if (l >= lend) { - goto L100; - } - goto L150; - - } - -/* Undo scaling if necessary */ - -L150: - if (iscale == 1) { - i__1 = lendsv - lsv + 1; - dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - } - if (iscale == 2) { - i__1 = lendsv - lsv + 1; - dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], - n, info); - } - -/* Check for no convergence to an eigenvalue after a total */ -/* of N*MAXIT iterations. */ - - if (jtot < nmaxit) { - goto L10; - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } -/* L160: */ - } - goto L180; - -/* Sort eigenvalues in increasing order. */ - -L170: - dlasrt_("I", n, &d__[1], info); - -L180: - return 0; - -/* End of DSTERF */ - -} /* dsterf_ */ diff --git a/external/clapack/lapack/dstev.cpp b/external/clapack/lapack/dstev.cpp deleted file mode 100644 index 705b7f40..00000000 --- a/external/clapack/lapack/dstev.cpp +++ /dev/null @@ -1,188 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dstev_(const char *jobz, integer *n, double *d__, - double *e, double *z__, integer *ldz, double *work, - integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1; - double d__1; - - /* Local variables */ - double eps; - integer imax; - double rmin, rmax, tnrm; - double sigma; - bool wantz; - integer iscale; - double safmin; - double bignum; - double smlnum; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEV computes all eigenvalues and, optionally, eigenvectors of a */ -/* real symmetric tridiagonal matrix A. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix */ -/* A. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix A, stored in elements 1 to N-1 of E. */ -/* On exit, the contents of E are destroyed. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ -/* eigenvectors of the matrix A, with the i-th column of Z */ -/* holding the eigenvector associated with D(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */ -/* If JOBZ = 'N', WORK is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the algorithm failed to converge; i */ -/* off-diagonal elements of E did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -6; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEV ", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); - rmax = sqrt(bignum); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - tnrm = dlanst_("M", n, &d__[1], &e[1]); - if (tnrm > 0. && tnrm < rmin) { - iscale = 1; - sigma = rmin / tnrm; - } else if (tnrm > rmax) { - iscale = 1; - sigma = rmax / tnrm; - } - if (iscale == 1) { - dscal_(n, &sigma, &d__[1], &c__1); - i__1 = *n - 1; - dscal_(&i__1, &sigma, &e[1], &c__1); - } - -/* For eigenvalues only, call DSTERF. For eigenvalues and */ -/* eigenvectors, call DSTEQR. */ - - if (! wantz) { - dsterf_(n, &d__[1], &e[1], info); - } else { - dsteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (iscale == 1) { - if (*info == 0) { - imax = *n; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &d__[1], &c__1); - } - - return 0; - -/* End of DSTEV */ - -} /* dstev_ */ diff --git a/external/clapack/lapack/dstevd.cpp b/external/clapack/lapack/dstevd.cpp deleted file mode 100644 index 116c7c38..00000000 --- a/external/clapack/lapack/dstevd.cpp +++ /dev/null @@ -1,247 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dstevd_(const char *jobz, integer *n, double *d__, - double *e, double *z__, integer *ldz, double *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1; - double d__1; - - /* Local variables */ - double eps, rmin, rmax, tnrm; - double sigma; - integer lwmin; - bool wantz; - integer iscale; - double safmin; - double bignum; - integer liwmin; - double smlnum; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a */ -/* real symmetric tridiagonal matrix. If eigenvectors are desired, it */ -/* uses a divide and conquer algorithm. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix */ -/* A. */ -/* On exit, if INFO = 0, the eigenvalues in ascending order. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix A, stored in elements 1 to N-1 of E. */ -/* On exit, the contents of E are destroyed. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ -/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ -/* eigenvectors of the matrix A, with the i-th column of Z */ -/* holding the eigenvector associated with D(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace/output) 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 JOBZ = 'N' or N <= 1 then LWORK must be at least 1. */ -/* If JOBZ = 'V' and N > 1 then LWORK must be at least */ -/* ( 1 + 4*N + N**2 ). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. */ -/* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the algorithm failed to converge; i */ -/* off-diagonal elements of E did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - lquery = *lwork == -1 || *liwork == -1; - - *info = 0; - liwmin = 1; - lwmin = 1; - if (*n > 1 && wantz) { -/* Computing 2nd power */ - i__1 = *n; - lwmin = (*n << 2) + 1 + i__1 * i__1; - liwmin = *n * 5 + 3; - } - - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldz < 1 || wantz && *ldz < *n) { - *info = -6; - } - - if (*info == 0) { - work[1] = (double) lwmin; - iwork[1] = liwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -8; - } else if (*liwork < liwmin && ! lquery) { - *info = -10; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEVD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); - rmax = sqrt(bignum); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - tnrm = dlanst_("M", n, &d__[1], &e[1]); - if (tnrm > 0. && tnrm < rmin) { - iscale = 1; - sigma = rmin / tnrm; - } else if (tnrm > rmax) { - iscale = 1; - sigma = rmax / tnrm; - } - if (iscale == 1) { - dscal_(n, &sigma, &d__[1], &c__1); - i__1 = *n - 1; - dscal_(&i__1, &sigma, &e[1], &c__1); - } - -/* For eigenvalues only, call DSTERF. For eigenvalues and */ -/* eigenvectors, call DSTEDC. */ - - if (! wantz) { - dsterf_(n, &d__[1], &e[1], info); - } else { - dstedc_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], lwork, - &iwork[1], liwork, info); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (iscale == 1) { - d__1 = 1. / sigma; - dscal_(n, &d__1, &d__[1], &c__1); - } - - work[1] = (double) lwmin; - iwork[1] = liwmin; - - return 0; - -/* End of DSTEVD */ - -} /* dstevd_ */ diff --git a/external/clapack/lapack/dstevr.cpp b/external/clapack/lapack/dstevr.cpp deleted file mode 100644 index 86033327..00000000 --- a/external/clapack/lapack/dstevr.cpp +++ /dev/null @@ -1,511 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__10 = 10; -static integer c__1 = 1; -static integer c__2 = 2; -static integer c__3 = 3; -static integer c__4 = 4; - -/* Subroutine */ int dstevr_(const char *jobz, const char *range, integer *n, double * - d__, double *e, double *vl, double *vu, integer *il, - integer *iu, double *abstol, integer *m, double *w, - double *z__, integer *ldz, integer *isuppz, double *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, jj; - double eps, vll, vuu, tmp1; - integer imax; - double rmin, rmax; - bool test; - double tnrm; - integer itmp1; - double sigma; - char order[1]; - integer lwmin; - bool wantz; - bool alleig, indeig; - integer iscale, ieeeok, indibl, indifl; - bool valeig; - double safmin; - double bignum; - integer indisp; - integer indiwo; - integer liwmin; - bool tryrac; - integer nsplit; - double smlnum; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEVR computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric tridiagonal matrix T. Eigenvalues and */ -/* eigenvectors can be selected by specifying either a range of values */ -/* or a range of indices for the desired eigenvalues. */ - -/* Whenever possible, DSTEVR calls DSTEMR to compute the */ -/* eigenspectrum using Relatively Robust Representations. DSTEMR */ -/* computes eigenvalues by the dqds algorithm, while orthogonal */ -/* eigenvectors are computed from various "good" L D L^T representations */ -/* (also known as Relatively Robust Representations). Gram-Schmidt */ -/* orthogonalization is avoided as far as possible. More specifically, */ -/* the various steps of the algorithm are as follows. For the i-th */ -/* unreduced block of T, */ -/* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T */ -/* is a relatively robust representation, */ -/* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high */ -/* relative accuracy by the dqds algorithm, */ -/* (c) If there is a cluster of close eigenvalues, "choose" sigma_i */ -/* close to the cluster, and go to step (a), */ -/* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, */ -/* compute the corresponding eigenvector by forming a */ -/* rank-revealing twisted factorization. */ -/* The desired accuracy of the output can be specified by the input */ -/* parameter ABSTOL. */ - -/* For more details, see "A new O(n^2) algorithm for the symmetric */ -/* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, */ -/* Computer Science Division Technical Report No. UCB//CSD-97-971, */ -/* UC Berkeley, May 1997. */ - - -/* Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested */ -/* on machines which conform to the ieee-754 floating point standard. */ -/* DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and */ -/* when partial spectrum requests are made. */ - -/* Normal execution of DSTEMR may create NaNs and infinities and */ -/* hence may abort due to a floating point exception in environments */ -/* which do not handle NaNs and infinities in the ieee standard default */ -/* manner. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ -/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ -/* ********* DSTEIN are called */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix */ -/* A. */ -/* On exit, D may be multiplied by a constant factor chosen */ -/* to avoid over/underflow in computing the eigenvalues. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1)) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix A in elements 1 to N-1 of E. */ -/* On exit, E may be multiplied by a constant factor chosen */ -/* to avoid over/underflow in computing the eigenvalues. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing A to tridiagonal form. */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices */ -/* with Guaranteed High Relative Accuracy," by Demmel and */ -/* Kahan, LAPACK Working Note #3. */ - -/* If high relative accuracy is important, set ABSTOL to */ -/* DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ -/* eigenvalues are computed to high relative accuracy when */ -/* possible in future releases. The current code does not */ -/* make any guarantees about high relative accuracy, but */ -/* future releases will. See J. Barlow and J. Demmel, */ -/* "Computing Accurate Eigensystems of Scaled Diagonally */ -/* Dominant Matrices", LAPACK Working Note #7, for a discussion */ -/* of which matrices define their eigenvalues to high relative */ -/* accuracy. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */ -/* The support of the eigenvectors in Z, i.e., the indices */ -/* indicating the nonzero elements in Z. The i-th eigenvector */ -/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* ISUPPZ( 2*i ). */ -/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal (and */ -/* minimal) LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,20*N). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal (and */ -/* minimal) LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: Internal error */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Inderjit Dhillon, IBM Almaden, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Ken Stanley, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - ieeeok = ilaenv_(&c__10, "DSTEVR", "N", &c__1, &c__2, &c__3, &c__4); - - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - lquery = *lwork == -1 || *liwork == -1; -/* Computing MAX */ - i__1 = 1, i__2 = *n * 20; - lwmin = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = std::max(i__1,i__2); - - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -7; - } - } else if (indeig) { - if (*il < 1 || *il > std::max(1_integer,*n)) { - *info = -8; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -9; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -14; - } - } - - if (*info == 0) { - work[1] = (double) lwmin; - iwork[1] = liwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -17; - } else if (*liwork < liwmin && ! lquery) { - *info = -19; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEVR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (alleig || indeig) { - *m = 1; - w[1] = d__[1]; - } else { - if (*vl < d__[1] && *vu >= d__[1]) { - *m = 1; - w[1] = d__[1]; - } - } - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = std::min(d__1,d__2); - - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - vll = *vl; - vuu = *vu; - - tnrm = dlanst_("M", n, &d__[1], &e[1]); - if (tnrm > 0. && tnrm < rmin) { - iscale = 1; - sigma = rmin / tnrm; - } else if (tnrm > rmax) { - iscale = 1; - sigma = rmax / tnrm; - } - if (iscale == 1) { - dscal_(n, &sigma, &d__[1], &c__1); - i__1 = *n - 1; - dscal_(&i__1, &sigma, &e[1], &c__1); - if (valeig) { - vll = *vl * sigma; - vuu = *vu * sigma; - } - } -/* Initialize indices into workspaces. Note: These indices are used only */ -/* if DSTERF or DSTEMR fail. */ -/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */ -/* stores the block indices of each of the M<=N eigenvalues. */ - indibl = 1; -/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */ -/* stores the starting and finishing indices of each block. */ - indisp = indibl + *n; -/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ -/* that corresponding to eigenvectors that fail to converge in */ -/* DSTEIN. This information is discarded; if any fail, the driver */ -/* returns INFO > 0. */ - indifl = indisp + *n; -/* INDIWO is the offset of the remaining integer workspace. */ - indiwo = indisp + *n; - -/* If all eigenvalues are desired, then */ -/* call DSTERF or DSTEMR. If this fails for some eigenvalue, then */ -/* try DSTEBZ. */ - - - test = false; - if (indeig) { - if (*il == 1 && *iu == *n) { - test = true; - } - } - if ((alleig || test) && ieeeok == 1) { - i__1 = *n - 1; - dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1); - if (! wantz) { - dcopy_(n, &d__[1], &c__1, &w[1], &c__1); - dsterf_(n, &w[1], &work[1], info); - } else { - dcopy_(n, &d__[1], &c__1, &work[*n + 1], &c__1); - if (*abstol <= *n * 2. * eps) { - tryrac = true; - } else { - tryrac = false; - } - i__1 = *lwork - (*n << 1); - dstemr_(jobz, "A", n, &work[*n + 1], &work[1], vl, vu, il, iu, m, - &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &work[ - (*n << 1) + 1], &i__1, &iwork[1], liwork, info); - - } - if (*info == 0) { - *m = *n; - goto L10; - } - *info = 0; - } - -/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, & - nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[1], &iwork[ - indiwo], info); - - if (wantz) { - dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], & - z__[z_offset], ldz, &work[1], &iwork[indiwo], &iwork[indifl], - info); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - -L10: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L20: */ - } - - if (i__ != 0) { - itmp1 = iwork[i__]; - w[i__] = w[j]; - iwork[i__] = iwork[j]; - w[j] = tmp1; - iwork[j] = itmp1; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - } -/* L30: */ - } - } - -/* Causes problems with tests 19 & 20: */ -/* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 */ - - - work[1] = (double) lwmin; - iwork[1] = liwmin; - return 0; - -/* End of DSTEVR */ - -} /* dstevr_ */ diff --git a/external/clapack/lapack/dstevx.cpp b/external/clapack/lapack/dstevx.cpp deleted file mode 100644 index aa0a02f4..00000000 --- a/external/clapack/lapack/dstevx.cpp +++ /dev/null @@ -1,398 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dstevx_(const char *jobz, const char *range, integer *n, double * - d__, double *e, double *vl, double *vu, integer *il, - integer *iu, double *abstol, integer *m, double *w, - double *z__, integer *ldz, double *work, integer *iwork, - integer *ifail, integer *info) -{ - /* System generated locals */ - integer z_dim1, z_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, jj; - double eps, vll, vuu, tmp1; - integer imax; - double rmin, rmax; - bool test; - double tnrm; - integer itmp1; - double sigma; - char order[1]; - bool wantz; - bool alleig, indeig; - integer iscale, indibl; - bool valeig; - double safmin; - double bignum; - integer indisp; - integer indiwo; - integer indwrk; - integer nsplit; - double smlnum; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSTEVX computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric tridiagonal matrix A. Eigenvalues and */ -/* eigenvectors can be selected by specifying either a range of values */ -/* or a range of indices for the desired eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 0. */ - -/* D (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the n diagonal elements of the tridiagonal matrix */ -/* A. */ -/* On exit, D may be multiplied by a constant factor chosen */ -/* to avoid over/underflow in computing the eigenvalues. */ - -/* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1)) */ -/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ -/* matrix A in elements 1 to N-1 of E. */ -/* On exit, E may be multiplied by a constant factor chosen */ -/* to avoid over/underflow in computing the eigenvalues. */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less */ -/* than or equal to zero, then EPS*|T| will be used in */ -/* its place, where |T| is the 1-norm of the tridiagonal */ -/* matrix. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ -/* If this routine returns with INFO>0, indicating that some */ -/* eigenvectors did not converge, try setting ABSTOL to */ -/* 2*DLAMCH('S'). */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices */ -/* with Guaranteed High Relative Accuracy," by Demmel and */ -/* Kahan, LAPACK Working Note #3. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If an eigenvector fails to converge (INFO > 0), then that */ -/* column of Z contains the latest approximation to the */ -/* eigenvector, and the index of the eigenvector is returned */ -/* in IFAIL. If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) */ - -/* IWORK (workspace) INTEGER array, dimension (5*N) */ - -/* IFAIL (output) INTEGER array, dimension (N) */ -/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ -/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ -/* indices of the eigenvectors that failed to converge. */ -/* If JOBZ = 'N', then IFAIL is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* Their indices are stored in array IFAIL. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --d__; - --e; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -7; - } - } else if (indeig) { - if (*il < 1 || *il > std::max(1_integer,*n)) { - *info = -8; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -9; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -14; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSTEVX", &i__1); - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (alleig || indeig) { - *m = 1; - w[1] = d__[1]; - } else { - if (*vl < d__[1] && *vu >= d__[1]) { - *m = 1; - w[1] = d__[1]; - } - } - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = std::min(d__1,d__2); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - if (valeig) { - vll = *vl; - vuu = *vu; - } else { - vll = 0.; - vuu = 0.; - } - tnrm = dlanst_("M", n, &d__[1], &e[1]); - if (tnrm > 0. && tnrm < rmin) { - iscale = 1; - sigma = rmin / tnrm; - } else if (tnrm > rmax) { - iscale = 1; - sigma = rmax / tnrm; - } - if (iscale == 1) { - dscal_(n, &sigma, &d__[1], &c__1); - i__1 = *n - 1; - dscal_(&i__1, &sigma, &e[1], &c__1); - if (valeig) { - vll = *vl * sigma; - vuu = *vu * sigma; - } - } - -/* If all eigenvalues are desired and ABSTOL is less than zero, then */ -/* call DSTERF or SSTEQR. If this fails for some eigenvalue, then */ -/* try DSTEBZ. */ - - test = false; - if (indeig) { - if (*il == 1 && *iu == *n) { - test = true; - } - } - if ((alleig || test) && *abstol <= 0.) { - dcopy_(n, &d__[1], &c__1, &w[1], &c__1); - i__1 = *n - 1; - dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1); - indwrk = *n + 1; - if (! wantz) { - dsterf_(n, &w[1], &work[1], info); - } else { - dsteqr_("I", n, &w[1], &work[1], &z__[z_offset], ldz, &work[ - indwrk], info); - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - ifail[i__] = 0; -/* L10: */ - } - } - } - if (*info == 0) { - *m = *n; - goto L20; - } - *info = 0; - } - -/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - indwrk = 1; - indibl = 1; - indisp = indibl + *n; - indiwo = indisp + *n; - dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, & - nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], & - iwork[indiwo], info); - - if (wantz) { - dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], & - z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1], - info); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - -L20: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L30: */ - } - - if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; - w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; - w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - if (*info != 0) { - itmp1 = ifail[i__]; - ifail[i__] = ifail[j]; - ifail[j] = itmp1; - } - } -/* L40: */ - } - } - - return 0; - -/* End of DSTEVX */ - -} /* dstevx_ */ diff --git a/external/clapack/lapack/dsycon.cpp b/external/clapack/lapack/dsycon.cpp deleted file mode 100644 index d4db05b3..00000000 --- a/external/clapack/lapack/dsycon.cpp +++ /dev/null @@ -1,184 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dsycon_(const char *uplo, integer *n, double *a, integer * - lda, integer *ipiv, double *anorm, double *rcond, double * - work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - - /* Local variables */ - integer i__, kase; - integer isave[3]; - bool upper; - double ainvnm; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYCON estimates the reciprocal of the condition number (in the */ -/* 1-norm) of a real symmetric matrix A using the factorization */ -/* A = U*D*U**T or A = L*D*L**T computed by DSYTRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the details of the factorization are stored */ -/* as an upper or lower triangular matrix. */ -/* = 'U': Upper triangular, form is A = U*D*U**T; */ -/* = 'L': Lower triangular, form is A = L*D*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The block diagonal matrix D and the multipliers used to */ -/* obtain the factor U or L as computed by DSYTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSYTRF. */ - -/* ANORM (input) DOUBLE PRECISION */ -/* The 1-norm of the original matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ -/* estimate of the 1-norm of inv(A) computed in this routine. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else if (*anorm < 0.) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm <= 0.) { - return 0; - } - -/* Check that the diagonal matrix D is nonsingular. */ - - if (upper) { - -/* Upper triangular storage: examine D from bottom to top */ - - for (i__ = *n; i__ >= 1; --i__) { - if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { - return 0; - } -/* L10: */ - } - } else { - -/* Lower triangular storage: examine D from top to bottom. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { - return 0; - } -/* L20: */ - } - } - -/* Estimate the 1-norm of the inverse. */ - - kase = 0; -L30: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - -/* Multiply by inv(L*D*L') or inv(U*D*U'). */ - - dsytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n, - info); - goto L30; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - - return 0; - -/* End of DSYCON */ - -} /* dsycon_ */ diff --git a/external/clapack/lapack/dsyequb.cpp b/external/clapack/lapack/dsyequb.cpp deleted file mode 100644 index 3245bc2a..00000000 --- a/external/clapack/lapack/dsyequb.cpp +++ /dev/null @@ -1,309 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -int dsyequb_(const char *uplo, integer *n, double *a, integer *lda, double *s, double *scond, - double *amax, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1, d__2, d__3; - - /* Local variables */ - double d__; - integer i__, j; - double t, u, c0, c1, c2, si; - bool up; - double avg, std, tol, base; - integer iter; - double smin, smax, scale, sumsq, bignum, smlnum; - - -/* -- LAPACK routine (version 3.2) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYEQUB computes row and column scalings intended to equilibrate a */ -/* symmetric matrix A and reduce its condition number */ -/* (with respect to the two-norm). S contains the scale factors, */ -/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ -/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ -/* choice of S puts the condition number of B within a factor N of the */ -/* smallest possible condition number over all possible diagonal */ -/* scalings. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The N-by-N symmetric matrix whose scaling */ -/* factors are to be computed. Only the diagonal elements of A */ -/* are referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* S (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, S contains the scale factors for A. */ - -/* SCOND (output) DOUBLE PRECISION */ -/* If INFO = 0, S contains the ratio of the smallest S(i) to */ -/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ -/* large nor too small, it is not worth scaling by S. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ - -/* Further Details */ -/* ======= ======= */ - -/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */ -/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */ -/* DOI 10.1023/B:NUMA.0000016606.32820.69 */ -/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --s; - --work; - - /* Function Body */ - *info = 0; - if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYEQUB", &i__1); - return 0; - } - up = lsame_(uplo, "U"); - *amax = 0.; - -/* Quick return if possible. */ - - if (*n == 0) { - *scond = 1.; - return 0; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - s[i__] = 0.; - } - *amax = 0.; - if (up) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - s[i__] = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - s[j] = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - *amax = std::max(d__2,d__3); - } -/* Computing MAX */ - d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); - s[j] = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); - *amax = std::max(d__2,d__3); - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); - s[j] = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); - *amax = std::max(d__2,d__3); - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - s[i__] = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - s[j] = std::max(d__2,d__3); -/* Computing MAX */ - d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - *amax = std::max(d__2,d__3); - } - } - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - s[j] = 1. / s[j]; - } - tol = 1. / sqrt(*n * 2.); - for (iter = 1; iter <= 100; ++iter) { - scale = 0.; - sumsq = 0.; -/* BETA = |A|S */ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; - } - if (up) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ - j]; - work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ - i__]; - } - work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j]; - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j]; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ - j]; - work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ - i__]; - } - } - } -/* avg = s^T beta / n */ - avg = 0.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - avg += s[i__] * work[i__]; - } - avg /= *n; - std = 0.; - i__1 = *n * 3; - for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) { - work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg; - } - dlassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq); - std = scale * sqrt(sumsq / *n); - if (std < tol * avg) { - goto L999; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - t = (d__1 = a[i__ + i__ * a_dim1], abs(d__1)); - si = s[i__]; - c2 = (*n - 1) * t; - c1 = (*n - 2) * (work[i__] - t * si); - c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg; - d__ = c1 * c1 - c0 * 4 * c2; - if (d__ <= 0.) { - *info = -1; - return 0; - } - si = c0 * -2 / (c1 + sqrt(d__)); - d__ = si - s[i__]; - u = 0.; - if (up) { - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t = (d__1 = a[j + i__ * a_dim1], abs(d__1)); - u += s[j] * t; - work[j] += d__ * t; - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - u += s[j] * t; - work[j] += d__ * t; - } - } else { - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - u += s[j] * t; - work[j] += d__ * t; - } - i__2 = *n; - for (j = i__ + 1; j <= i__2; ++j) { - t = (d__1 = a[j + i__ * a_dim1], abs(d__1)); - u += s[j] * t; - work[j] += d__ * t; - } - } - avg += (u + work[i__]) * d__ / *n; - s[i__] = si; - } - } -L999: - smlnum = dlamch_("SAFEMIN"); - bignum = 1. / smlnum; - smin = bignum; - smax = 0.; - t = 1. / sqrt(avg); - base = dlamch_("B"); - u = 1. / log(base); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = (integer) (u * log(s[i__] * t)); - s[i__] = pow_di(&base, &i__2); -/* Computing MIN */ - d__1 = smin, d__2 = s[i__]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = smax, d__2 = s[i__]; - smax = std::max(d__1,d__2); - } - *scond = std::max(smin,smlnum) / std::min(smax,bignum); - - return 0; -} /* dsyequb_ */ diff --git a/external/clapack/lapack/dsyev.cpp b/external/clapack/lapack/dsyev.cpp deleted file mode 100644 index b2c04de0..00000000 --- a/external/clapack/lapack/dsyev.cpp +++ /dev/null @@ -1,249 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__0 = 0; -static double c_b17 = 1.; - -/* Subroutine */ int dsyev_(const char *jobz, const char *uplo, integer *n, double *a, - integer *lda, double *w, double *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer nb; - double eps; - integer inde; - double anrm; - integer imax; - double rmin, rmax; - double sigma; - integer iinfo; - bool lower, wantz; - integer iscale; - double safmin; - double bignum; - integer indtau; - integer indwrk; - integer llwork; - double smlnum; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYEV computes all eigenvalues and, optionally, eigenvectors of a */ -/* real symmetric matrix A. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of A contains the */ -/* upper triangular part of the matrix A. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ -/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ -/* orthonormal eigenvectors of the matrix A. */ -/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */ -/* or the upper triangle (if UPLO='U') of A, including the */ -/* diagonal, is destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of the array WORK. LWORK >= max(1,3*N-1). */ -/* For optimal efficiency, LWORK >= (NB+2)*N, */ -/* where NB is the blocksize for DSYTRD returned by ILAENV. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the algorithm failed to converge; i */ -/* off-diagonal elements of an intermediate tridiagonal */ -/* form did not converge to zero. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --w; - --work; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - lower = lsame_(uplo, "L"); - lquery = *lwork == -1; - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } - - if (*info == 0) { - nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = 1, i__2 = (nb + 2) * *n; - lwkopt = std::max(i__1,i__2); - work[1] = (double) lwkopt; - -/* Computing MAX */ - i__1 = 1, i__2 = *n * 3 - 1; - if (*lwork < std::max(i__1,i__2) && ! lquery) { - *info = -8; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYEV ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - w[1] = a[a_dim1 + 1]; - work[1] = 2.; - if (wantz) { - a[a_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); - rmax = sqrt(bignum); - -/* Scale matrix to allowable range, if necessary. */ - - anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); - iscale = 0; - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, - info); - } - -/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ - - inde = 1; - indtau = inde + *n; - indwrk = indtau + *n; - llwork = *lwork - indwrk + 1; - dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], & - work[indwrk], &llwork, &iinfo); - -/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ -/* DORGTR to generate the orthogonal matrix, then call DSTEQR. */ - - if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); - } else { - dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & - llwork, &iinfo); - dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau], - info); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (iscale == 1) { - if (*info == 0) { - imax = *n; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - -/* Set WORK(1) to optimal workspace size. */ - - work[1] = (double) lwkopt; - - return 0; - -/* End of DSYEV */ - -} /* dsyev_ */ diff --git a/external/clapack/lapack/dsyevd.cpp b/external/clapack/lapack/dsyevd.cpp deleted file mode 100644 index a3d4ccb5..00000000 --- a/external/clapack/lapack/dsyevd.cpp +++ /dev/null @@ -1,314 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__0 = 0; -static double c_b17 = 1.; - -/* Subroutine */ int dsyevd_(const char *jobz, const char *uplo, integer *n, double * - a, integer *lda, double *w, double *work, integer *lwork, - integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - double d__1; - - /* Local variables */ - double eps; - integer inde; - double anrm, rmin, rmax; - integer lopt; - double sigma; - integer iinfo, lwmin, liopt; - bool lower, wantz; - integer indwk2, llwrk2; - integer iscale; - double safmin; - double bignum; - integer indtau; - integer indwrk, liwmin; - integer llwork; - double smlnum; - bool lquery; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a */ -/* real symmetric matrix A. If eigenvectors are desired, it uses a */ -/* divide and conquer algorithm. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Because of large use of BLAS of level 3, DSYEVD needs N**2 more */ -/* workspace than DSYEVX. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of A contains the */ -/* upper triangular part of the matrix A. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ -/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ -/* orthonormal eigenvectors of the matrix A. */ -/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */ -/* or the upper triangle (if UPLO='U') of A, including the */ -/* diagonal, is destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* WORK (workspace/output) 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 N <= 1, LWORK must be at least 1. */ -/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. */ -/* If JOBZ = 'V' and N > 1, LWORK must be at least */ -/* 1 + 6*N + 2*N**2. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If N <= 1, LIWORK must be at least 1. */ -/* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */ -/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed */ -/* to converge; i off-diagonal elements of an intermediate */ -/* tridiagonal form did not converge to zero; */ -/* if INFO = i and JOBZ = 'V', then the algorithm failed */ -/* to compute an eigenvalue while working on the submatrix */ -/* lying in rows and columns INFO/(N+1) through */ -/* mod(INFO,N+1). */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Jeff Rutter, Computer Science Division, University of California */ -/* at Berkeley, USA */ -/* Modified by Francoise Tisseur, University of Tennessee. */ - -/* Modified description of INFO. Sven, 16 Feb 05. */ -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ - -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --w; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - lower = lsame_(uplo, "L"); - lquery = *lwork == -1 || *liwork == -1; - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } - - if (*info == 0) { - if (*n <= 1) { - liwmin = 1; - lwmin = 1; - lopt = lwmin; - liopt = liwmin; - } else { - if (wantz) { - liwmin = *n * 5 + 3; -/* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); - } else { - liwmin = 1; - lwmin = (*n << 1) + 1; - } -/* Computing MAX */ - i__1 = lwmin, i__2 = (*n << 1) + ilaenv_(&c__1, "DSYTRD", uplo, n, - &c_n1, &c_n1, &c_n1); - lopt = std::max(i__1,i__2); - liopt = liwmin; - } - work[1] = (double) lopt; - iwork[1] = liopt; - - if (*lwork < lwmin && ! lquery) { - *info = -8; - } else if (*liwork < liwmin && ! lquery) { - *info = -10; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYEVD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - w[1] = a[a_dim1 + 1]; - if (wantz) { - a[a_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); - rmax = sqrt(bignum); - -/* Scale matrix to allowable range, if necessary. */ - - anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); - iscale = 0; - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, - info); - } - -/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ - - inde = 1; - indtau = inde + *n; - indwrk = indtau + *n; - llwork = *lwork - indwrk + 1; - indwk2 = indwrk + *n * *n; - llwrk2 = *lwork - indwk2 + 1; - - dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], & - work[indwrk], &llwork, &iinfo); - lopt = (integer) ((*n << 1) + work[indwrk]); - -/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ -/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ -/* tridiagonal matrix, then call DORMTR to multiply it by the */ -/* Householder transformations stored in A. */ - - if (! wantz) { - dsterf_(n, &w[1], &work[inde], info); - } else { - dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & - llwrk2, &iwork[1], liwork, info); - dormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[ - indwrk], n, &work[indwk2], &llwrk2, &iinfo); - dlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda); -/* Computing MAX */ -/* Computing 2nd power */ - i__3 = *n; - i__1 = lopt, i__2 = *n * 6 + 1 + (i__3 * i__3 << 1); - lopt = std::max(i__1,i__2); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - - if (iscale == 1) { - d__1 = 1. / sigma; - dscal_(n, &d__1, &w[1], &c__1); - } - - work[1] = (double) lopt; - iwork[1] = liopt; - - return 0; - -/* End of DSYEVD */ - -} /* dsyevd_ */ diff --git a/external/clapack/lapack/dsyevr.cpp b/external/clapack/lapack/dsyevr.cpp deleted file mode 100644 index c161b9e6..00000000 --- a/external/clapack/lapack/dsyevr.cpp +++ /dev/null @@ -1,606 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__10 = 10; -static integer c__1 = 1; -static integer c__2 = 2; -static integer c__3 = 3; -static integer c__4 = 4; -static integer c_n1 = -1; - -/* Subroutine */ int dsyevr_(const char *jobz, const char *range, const char *uplo, integer *n, - double *a, integer *lda, double *vl, double *vu, integer * - il, integer *iu, double *abstol, integer *m, double *w, - double *z__, integer *ldz, integer *isuppz, double *work, - integer *lwork, integer *iwork, integer *liwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, nb, jj; - double eps, vll, vuu, tmp1; - integer indd, inde; - double anrm; - integer imax; - double rmin, rmax; - integer inddd, indee; - double sigma; - integer iinfo; - char order[1]; - integer indwk; - integer lwmin; - bool lower, wantz; - bool alleig, indeig; - integer iscale, ieeeok, indibl, indifl; - bool valeig; - double safmin; - double abstll, bignum; - integer indtau, indisp; - integer indiwo, indwkn; - integer liwmin; - bool tryrac; - integer llwrkn, llwork, nsplit; - double smlnum; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYEVR computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ -/* selected by specifying either a range of values or a range of */ -/* indices for the desired eigenvalues. */ - -/* DSYEVR first reduces the matrix A to tridiagonal form T with a call */ -/* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute */ -/* the eigenspectrum using Relatively Robust Representations. DSTEMR */ -/* computes eigenvalues by the dqds algorithm, while orthogonal */ -/* eigenvectors are computed from various "good" L D L^T representations */ -/* (also known as Relatively Robust Representations). Gram-Schmidt */ -/* orthogonalization is avoided as far as possible. More specifically, */ -/* the various steps of the algorithm are as follows. */ - -/* For each unreduced block (submatrix) of T, */ -/* (a) Compute T - sigma I = L D L^T, so that L and D */ -/* define all the wanted eigenvalues to high relative accuracy. */ -/* This means that small relative changes in the entries of D and L */ -/* cause only small relative changes in the eigenvalues and */ -/* eigenvectors. The standard (unfactored) representation of the */ -/* tridiagonal matrix T does not have this property in general. */ -/* (b) Compute the eigenvalues to suitable accuracy. */ -/* If the eigenvectors are desired, the algorithm attains full */ -/* accuracy of the computed eigenvalues only right before */ -/* the corresponding vectors have to be computed, see steps c) and d). */ -/* (c) For each cluster of close eigenvalues, select a new */ -/* shift close to the cluster, find a new factorization, and refine */ -/* the shifted eigenvalues to suitable accuracy. */ -/* (d) For each eigenvalue with a large enough relative separation compute */ -/* the corresponding eigenvector by forming a rank revealing twisted */ -/* factorization. Go back to (c) for any clusters that remain. */ - -/* The desired accuracy of the output can be specified by the input */ -/* parameter ABSTOL. */ - -/* For more details, see DSTEMR's documentation and: */ -/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* 2004. Also LAPACK Working Note 154. */ -/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* tridiagonal eigenvalue/eigenvector problem", */ -/* Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* UC Berkeley, May 1997. */ - - -/* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested */ -/* on machines which conform to the ieee-754 floating point standard. */ -/* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and */ -/* when partial spectrum requests are made. */ - -/* Normal execution of DSTEMR may create NaNs and infinities and */ -/* hence may abort due to a floating point exception in environments */ -/* which do not handle NaNs and infinities in the ieee standard default */ -/* manner. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ -/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ -/* ********* DSTEIN are called */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of A contains the */ -/* upper triangular part of the matrix A. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ -/* On exit, the lower triangle (if UPLO='L') or the upper */ -/* triangle (if UPLO='U') of A, including the diagonal, is */ -/* destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing A to tridiagonal form. */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices */ -/* with Guaranteed High Relative Accuracy," by Demmel and */ -/* Kahan, LAPACK Working Note #3. */ - -/* If high relative accuracy is important, set ABSTOL to */ -/* DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ -/* eigenvalues are computed to high relative accuracy when */ -/* possible in future releases. The current code does not */ -/* make any guarantees about high relative accuracy, but */ -/* future releases will. See J. Barlow and J. Demmel, */ -/* "Computing Accurate Eigensystems of Scaled Diagonally */ -/* Dominant Matrices", LAPACK Working Note #7, for a discussion */ -/* of which matrices define their eigenvalues to high relative */ -/* accuracy. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* The first M elements contain the selected eigenvalues in */ -/* ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ -/* Supplying N columns is always safe. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */ -/* The support of the eigenvectors in Z, i.e., the indices */ -/* indicating the nonzero elements in Z. The i-th eigenvector */ -/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* ISUPPZ( 2*i ). */ -/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1,26*N). */ -/* For optimal efficiency, LWORK >= (NB+6)*N, */ -/* where NB is the max of the blocksize for DSYTRD and DORMTR */ -/* returned by ILAENV. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: Internal error */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Inderjit Dhillon, IBM Almaden, USA */ -/* Osni Marques, LBNL/NERSC, USA */ -/* Ken Stanley, Computer Science Division, University of */ -/* California at Berkeley, USA */ -/* Jason Riedy, Computer Science Division, University of */ -/* California at Berkeley, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --isuppz; - --work; - --iwork; - - /* Function Body */ - ieeeok = ilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4); - - lower = lsame_(uplo, "L"); - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - - lquery = *lwork == -1 || *liwork == -1; - -/* Computing MAX */ - i__1 = 1, i__2 = *n * 26; - lwmin = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = std::max(i__1,i__2); - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -8; - } - } else if (indeig) { - if (*il < 1 || *il > std::max(1_integer,*n)) { - *info = -9; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -10; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -15; - } else if (*lwork < lwmin && ! lquery) { - *info = -18; - } else if (*liwork < liwmin && ! lquery) { - *info = -20; - } - } - - if (*info == 0) { - nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, & - c_n1); - nb = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = (nb + 1) * *n; - lwkopt = std::max(i__1,lwmin); - work[1] = (double) lwkopt; - iwork[1] = liwmin; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYEVR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - work[1] = 1.; - return 0; - } - - if (*n == 1) { - work[1] = 7.; - if (alleig || indeig) { - *m = 1; - w[1] = a[a_dim1 + 1]; - } else { - if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { - *m = 1; - w[1] = a[a_dim1 + 1]; - } - } - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = std::min(d__1,d__2); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - abstll = *abstol; - vll = *vl; - vuu = *vu; - anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - if (lower) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j + 1; - dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); -/* L10: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); -/* L20: */ - } - } - if (*abstol > 0.) { - abstll = *abstol * sigma; - } - if (valeig) { - vll = *vl * sigma; - vuu = *vu * sigma; - } - } -/* Initialize indices into workspaces. Note: The IWORK indices are */ -/* used only if DSTERF or DSTEMR fail. */ -/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */ -/* elementary reflectors used in DSYTRD. */ - indtau = 1; -/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */ - indd = indtau + *n; -/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */ -/* tridiagonal matrix from DSYTRD. */ - inde = indd + *n; -/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */ -/* -written by DSTEMR (the DSTERF path copies the diagonal to W). */ - inddd = inde + *n; -/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */ -/* -written while computing the eigenvalues in DSTERF and DSTEMR. */ - indee = inddd + *n; -/* INDWK is the starting offset of the left-over workspace, and */ -/* LLWORK is the remaining workspace size. */ - indwk = indee + *n; - llwork = *lwork - indwk + 1; -/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */ -/* stores the block indices of each of the M<=N eigenvalues. */ - indibl = 1; -/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */ -/* stores the starting and finishing indices of each block. */ - indisp = indibl + *n; -/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ -/* that corresponding to eigenvectors that fail to converge in */ -/* DSTEIN. This information is discarded; if any fail, the driver */ -/* returns INFO > 0. */ - indifl = indisp + *n; -/* INDIWO is the offset of the remaining integer workspace. */ - indiwo = indisp + *n; - -/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ - - dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ - indtau], &work[indwk], &llwork, &iinfo); - -/* If all eigenvalues are desired */ -/* then call DSTERF or DSTEMR and DORMTR. */ - - if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) { - if (! wantz) { - dcopy_(n, &work[indd], &c__1, &w[1], &c__1); - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dsterf_(n, &w[1], &work[indee], info); - } else { - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dcopy_(n, &work[indd], &c__1, &work[inddd], &c__1); - - if (*abstol <= *n * 0. * eps) { - tryrac = true; - } else { - tryrac = false; - } - dstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu, - m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, & - work[indwk], lwork, &iwork[1], liwork, info); - - - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by DSTEIN. */ - - if (wantz && *info == 0) { - indwkn = inde; - llwrkn = *lwork - indwkn + 1; - dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau] -, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); - } - } - - - if (*info == 0) { -/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are */ -/* undefined. */ - *m = *n; - goto L30; - } - *info = 0; - } - -/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */ -/* Also call DSTEBZ and DSTEIN if DSTEMR fails. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ - inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwk], &iwork[indiwo], info); - - if (wantz) { - dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ - indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], & - iwork[indifl], info); - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by DSTEIN. */ - - indwkn = inde; - llwrkn = *lwork - indwkn + 1; - dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ - z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - -/* Jump here if DSTEMR/DSTEIN succeeded. */ -L30: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. */ -/* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do */ -/* not return this detailed information to the user. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L40: */ - } - - if (i__ != 0) { - w[i__] = w[j]; - w[j] = tmp1; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - } -/* L50: */ - } - } - -/* Set WORK(1) to optimal workspace size. */ - - work[1] = (double) lwkopt; - iwork[1] = liwmin; - - return 0; - -/* End of DSYEVR */ - -} /* dsyevr_ */ diff --git a/external/clapack/lapack/dsyevx.cpp b/external/clapack/lapack/dsyevx.cpp deleted file mode 100644 index c4f9c2db..00000000 --- a/external/clapack/lapack/dsyevx.cpp +++ /dev/null @@ -1,490 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dsyevx_(const char *jobz, const char *range, const char *uplo, integer *n, - double *a, integer *lda, double *vl, double *vu, integer * - il, integer *iu, double *abstol, integer *m, double *w, - double *z__, integer *ldz, double *work, integer *lwork, - integer *iwork, integer *ifail, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, nb, jj; - double eps, vll, vuu, tmp1; - integer indd, inde; - double anrm; - integer imax; - double rmin, rmax; - bool test; - integer itmp1, indee; - double sigma; - integer iinfo; - char order[1]; - bool lower, wantz; - bool alleig, indeig; - integer iscale, indibl; - bool valeig; - double safmin; - double abstll, bignum; - integer indtau, indisp; - integer indiwo, indwkn; - integer indwrk, lwkmin; - integer llwrkn, llwork, nsplit; - double smlnum; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYEVX computes selected eigenvalues and, optionally, eigenvectors */ -/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ -/* selected by specifying either a range of values or a range of indices */ -/* for the desired eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of A contains the */ -/* upper triangular part of the matrix A. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ -/* On exit, the lower triangle (if UPLO='L') or the upper */ -/* triangle (if UPLO='U') of A, including the diagonal, is */ -/* destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing A to tridiagonal form. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ -/* If this routine returns with INFO>0, indicating that some */ -/* eigenvectors did not converge, try setting ABSTOL to */ -/* 2*DLAMCH('S'). */ - -/* See "Computing Small Singular Values of Bidiagonal Matrices */ -/* with Guaranteed High Relative Accuracy," by Demmel and */ -/* Kahan, LAPACK Working Note #3. */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* On normal exit, the first M elements contain the selected */ -/* eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* If an eigenvector fails to converge, then that column of Z */ -/* contains the latest approximation to the eigenvector, and the */ -/* index of the eigenvector is returned in IFAIL. */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* otherwise 8*N. */ -/* For optimal efficiency, LWORK >= (NB+3)*N, */ -/* where NB is the max of the blocksize for DSYTRD and DORMTR */ -/* returned by ILAENV. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (5*N) */ - -/* IFAIL (output) INTEGER array, dimension (N) */ -/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ -/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ -/* indices of the eigenvectors that failed to converge. */ -/* If JOBZ = 'N', then IFAIL is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* Their indices are stored in array IFAIL. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - lower = lsame_(uplo, "L"); - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - lquery = *lwork == -1; - - *info = 0; - if (! (wantz || lsame_(jobz, "N"))) { - *info = -1; - } else if (! (alleig || valeig || indeig)) { - *info = -2; - } else if (! (lower || lsame_(uplo, "U"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -8; - } - } else if (indeig) { - if (*il < 1 || *il > std::max(1_integer,*n)) { - *info = -9; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -10; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -15; - } - } - - if (*info == 0) { - if (*n <= 1) { - lwkmin = 1; - work[1] = (double) lwkmin; - } else { - lwkmin = *n << 3; - nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, - &c_n1); - nb = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = lwkmin, i__2 = (nb + 3) * *n; - lwkopt = std::max(i__1,i__2); - work[1] = (double) lwkopt; - } - - if (*lwork < lwkmin && ! lquery) { - *info = -17; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYEVX", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (alleig || indeig) { - *m = 1; - w[1] = a[a_dim1 + 1]; - } else { - if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { - *m = 1; - w[1] = a[a_dim1 + 1]; - } - } - if (wantz) { - z__[z_dim1 + 1] = 1.; - } - return 0; - } - -/* Get machine constants. */ - - safmin = dlamch_("Safe minimum"); - eps = dlamch_("Precision"); - smlnum = safmin / eps; - bignum = 1. / smlnum; - rmin = sqrt(smlnum); -/* Computing MIN */ - d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); - rmax = std::min(d__1,d__2); - -/* Scale matrix to allowable range, if necessary. */ - - iscale = 0; - abstll = *abstol; - if (valeig) { - vll = *vl; - vuu = *vu; - } - anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); - if (anrm > 0. && anrm < rmin) { - iscale = 1; - sigma = rmin / anrm; - } else if (anrm > rmax) { - iscale = 1; - sigma = rmax / anrm; - } - if (iscale == 1) { - if (lower) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j + 1; - dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); -/* L10: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); -/* L20: */ - } - } - if (*abstol > 0.) { - abstll = *abstol * sigma; - } - if (valeig) { - vll = *vl * sigma; - vuu = *vu * sigma; - } - } - -/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ - - indtau = 1; - inde = indtau + *n; - indd = inde + *n; - indwrk = indd + *n; - llwork = *lwork - indwrk + 1; - dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ - indtau], &work[indwrk], &llwork, &iinfo); - -/* If all eigenvalues are desired and ABSTOL is less than or equal to */ -/* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for */ -/* some eigenvalue, then try DSTEBZ. */ - - test = false; - if (indeig) { - if (*il == 1 && *iu == *n) { - test = true; - } - } - if ((alleig || test) && *abstol <= 0.) { - dcopy_(n, &work[indd], &c__1, &w[1], &c__1); - indee = indwrk + (*n << 1); - if (! wantz) { - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dsterf_(n, &w[1], &work[indee], info); - } else { - dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz); - dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] -, &llwork, &iinfo); - i__1 = *n - 1; - dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); - dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ - indwrk], info); - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - ifail[i__] = 0; -/* L30: */ - } - } - } - if (*info == 0) { - *m = *n; - goto L40; - } - *info = 0; - } - -/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ - - if (wantz) { - *(unsigned char *)order = 'B'; - } else { - *(unsigned char *)order = 'E'; - } - indibl = 1; - indisp = indibl + *n; - indiwo = indisp + *n; - dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ - inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); - - if (wantz) { - dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ - indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); - -/* Apply orthogonal matrix used in reduction to tridiagonal */ -/* form to eigenvectors returned by DSTEIN. */ - - indwkn = inde; - llwrkn = *lwork - indwkn + 1; - dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ - z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); - } - -/* If matrix was scaled, then rescale eigenvalues appropriately. */ - -L40: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } - d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); - } - -/* If eigenvalues are not in order, then sort them, along with */ -/* eigenvectors. */ - - if (wantz) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - i__ = 0; - tmp1 = w[j]; - i__2 = *m; - for (jj = j + 1; jj <= i__2; ++jj) { - if (w[jj] < tmp1) { - i__ = jj; - tmp1 = w[jj]; - } -/* L50: */ - } - - if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; - w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; - w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; - dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], - &c__1); - if (*info != 0) { - itmp1 = ifail[i__]; - ifail[i__] = ifail[j]; - ifail[j] = itmp1; - } - } -/* L60: */ - } - } - -/* Set WORK(1) to optimal workspace size. */ - - work[1] = (double) lwkopt; - - return 0; - -/* End of DSYEVX */ - -} /* dsyevx_ */ diff --git a/external/clapack/lapack/dsygs2.cpp b/external/clapack/lapack/dsygs2.cpp deleted file mode 100644 index 7a2bcc66..00000000 --- a/external/clapack/lapack/dsygs2.cpp +++ /dev/null @@ -1,276 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b6 = -1.; -static integer c__1 = 1; -static double c_b27 = 1.; - -/* Subroutine */ int dsygs2_(integer *itype, const char *uplo, integer *n, - double *a, integer *lda, double *b, integer *ldb, integer * - info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer k; - double ct, akk, bkk; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYGS2 reduces a real symmetric-definite generalized eigenproblem */ -/* to standard form. */ - -/* If ITYPE = 1, the problem is A*x = lambda*B*x, */ -/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */ - -/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ -/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */ - -/* B must have been previously factorized as U'*U or L*L' by DPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */ -/* = 2 or 3: compute U*A*U' or L'*A*L. */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored, and how B has been factorized. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n by n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the transformed matrix, stored in the */ -/* same format as A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */ -/* The triangular factor from the Cholesky factorization of B, */ -/* as returned by DPOTRF. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYGS2", &i__1); - return 0; - } - - if (*itype == 1) { - if (upper) { - -/* Compute inv(U')*A*inv(U) */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - -/* Update the upper triangle of A(k:n,k:n) */ - - akk = a[k + k * a_dim1]; - bkk = b[k + k * b_dim1]; -/* Computing 2nd power */ - d__1 = bkk; - akk /= d__1 * d__1; - a[k + k * a_dim1] = akk; - if (k < *n) { - i__2 = *n - k; - d__1 = 1. / bkk; - dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda); - ct = akk * -.5; - i__2 = *n - k; - daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( - k + 1) * a_dim1], lda); - i__2 = *n - k; - dsyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda, - &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1) - * a_dim1], lda); - i__2 = *n - k; - daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( - k + 1) * a_dim1], lda); - i__2 = *n - k; - dtrsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + ( - k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], - lda); - } -/* L10: */ - } - } else { - -/* Compute inv(L)*A*inv(L') */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - -/* Update the lower triangle of A(k:n,k:n) */ - - akk = a[k + k * a_dim1]; - bkk = b[k + k * b_dim1]; -/* Computing 2nd power */ - d__1 = bkk; - akk /= d__1 * d__1; - a[k + k * a_dim1] = akk; - if (k < *n) { - i__2 = *n - k; - d__1 = 1. / bkk; - dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1); - ct = akk * -.5; - i__2 = *n - k; - daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + - 1 + k * a_dim1], &c__1); - i__2 = *n - k; - dsyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1, - &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1) - * a_dim1], lda); - i__2 = *n - k; - daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + - 1 + k * a_dim1], &c__1); - i__2 = *n - k; - dtrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1 - + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1], - &c__1); - } -/* L20: */ - } - } - } else { - if (upper) { - -/* Compute U*A*U' */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - -/* Update the upper triangle of A(1:k,1:k) */ - - akk = a[k + k * a_dim1]; - bkk = b[k + k * b_dim1]; - i__2 = k - 1; - dtrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset], - ldb, &a[k * a_dim1 + 1], &c__1); - ct = akk * .5; - i__2 = k - 1; - daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + - 1], &c__1); - i__2 = k - 1; - dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k * - b_dim1 + 1], &c__1, &a[a_offset], lda); - i__2 = k - 1; - daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + - 1], &c__1); - i__2 = k - 1; - dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1); -/* Computing 2nd power */ - d__1 = bkk; - a[k + k * a_dim1] = akk * (d__1 * d__1); -/* L30: */ - } - } else { - -/* Compute L'*A*L */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - -/* Update the lower triangle of A(1:k,1:k) */ - - akk = a[k + k * a_dim1]; - bkk = b[k + k * b_dim1]; - i__2 = k - 1; - dtrmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset], - ldb, &a[k + a_dim1], lda); - ct = akk * .5; - i__2 = k - 1; - daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); - i__2 = k - 1; - dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k + - b_dim1], ldb, &a[a_offset], lda); - i__2 = k - 1; - daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); - i__2 = k - 1; - dscal_(&i__2, &bkk, &a[k + a_dim1], lda); -/* Computing 2nd power */ - d__1 = bkk; - a[k + k * a_dim1] = akk * (d__1 * d__1); -/* L40: */ - } - } - } - return 0; - -/* End of DSYGS2 */ - -} /* dsygs2_ */ diff --git a/external/clapack/lapack/dsygst.cpp b/external/clapack/lapack/dsygst.cpp deleted file mode 100644 index 15f13cfe..00000000 --- a/external/clapack/lapack/dsygst.cpp +++ /dev/null @@ -1,318 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b14 = 1.; -static double c_b16 = -.5; -static double c_b19 = -1.; -static double c_b52 = .5; - -/* Subroutine */ int dsygst_(integer *itype, const char *uplo, integer *n, - double *a, integer *lda, double *b, integer *ldb, integer * - info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - - /* Local variables */ - integer k, kb, nb; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYGST reduces a real symmetric-definite generalized eigenproblem */ -/* to standard form. */ - -/* If ITYPE = 1, the problem is A*x = lambda*B*x, */ -/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */ - -/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ -/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */ - -/* B must have been previously factorized as U**T*U or L*L**T by DPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */ -/* = 2 or 3: compute U*A*U**T or L**T*A*L. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored and B is factored as */ -/* U**T*U; */ -/* = 'L': Lower triangle of A is stored and B is factored as */ -/* L*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the transformed matrix, stored in the */ -/* same format as A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */ -/* The triangular factor from the Cholesky factorization of B, */ -/* as returned by DPOTRF. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYGST", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DSYGST", uplo, n, &c_n1, &c_n1, &c_n1); - - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - dsygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); - } else { - -/* Use blocked code */ - - if (*itype == 1) { - if (upper) { - -/* Compute inv(U')*A*inv(U) */ - - i__1 = *n; - i__2 = nb; - for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { -/* Computing MIN */ - i__3 = *n - k + 1; - kb = std::min(i__3,nb); - -/* Update the upper triangle of A(k:n,k:n) */ - - dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + - k * b_dim1], ldb, info); - if (k + kb <= *n) { - i__3 = *n - k - kb + 1; - dtrsm_("Left", uplo, "Transpose", "Non-unit", &kb, & - i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k + - (k + kb) * a_dim1], lda); - i__3 = *n - k - kb + 1; - dsymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * - a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, - &c_b14, &a[k + (k + kb) * a_dim1], lda); - i__3 = *n - k - kb + 1; - dsyr2k_(uplo, "Transpose", &i__3, &kb, &c_b19, &a[k + - (k + kb) * a_dim1], lda, &b[k + (k + kb) * - b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * - a_dim1], lda); - i__3 = *n - k - kb + 1; - dsymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * - a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, - &c_b14, &a[k + (k + kb) * a_dim1], lda); - i__3 = *n - k - kb + 1; - dtrsm_("Right", uplo, "No transpose", "Non-unit", &kb, - &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1] -, ldb, &a[k + (k + kb) * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute inv(L)*A*inv(L') */ - - i__2 = *n; - i__1 = nb; - for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { -/* Computing MIN */ - i__3 = *n - k + 1; - kb = std::min(i__3,nb); - -/* Update the lower triangle of A(k:n,k:n) */ - - dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + - k * b_dim1], ldb, info); - if (k + kb <= *n) { - i__3 = *n - k - kb + 1; - dtrsm_("Right", uplo, "Transpose", "Non-unit", &i__3, - &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k + - kb + k * a_dim1], lda); - i__3 = *n - k - kb + 1; - dsymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * - a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & - c_b14, &a[k + kb + k * a_dim1], lda); - i__3 = *n - k - kb + 1; - dsyr2k_(uplo, "No transpose", &i__3, &kb, &c_b19, &a[ - k + kb + k * a_dim1], lda, &b[k + kb + k * - b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * - a_dim1], lda); - i__3 = *n - k - kb + 1; - dsymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * - a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & - c_b14, &a[k + kb + k * a_dim1], lda); - i__3 = *n - k - kb + 1; - dtrsm_("Left", uplo, "No transpose", "Non-unit", & - i__3, &kb, &c_b14, &b[k + kb + (k + kb) * - b_dim1], ldb, &a[k + kb + k * a_dim1], lda); - } -/* L20: */ - } - } - } else { - if (upper) { - -/* Compute U*A*U' */ - - i__1 = *n; - i__2 = nb; - for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { -/* Computing MIN */ - i__3 = *n - k + 1; - kb = std::min(i__3,nb); - -/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */ - - i__3 = k - 1; - dtrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, & - kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1], - lda) - ; - i__3 = k - 1; - dsymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * - a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ - k * a_dim1 + 1], lda); - i__3 = k - 1; - dsyr2k_(uplo, "No transpose", &i__3, &kb, &c_b14, &a[k * - a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, - &a[a_offset], lda); - i__3 = k - 1; - dsymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * - a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ - k * a_dim1 + 1], lda); - i__3 = k - 1; - dtrmm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb, - &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 + - 1], lda); - dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + - k * b_dim1], ldb, info); -/* L30: */ - } - } else { - -/* Compute L'*A*L */ - - i__2 = *n; - i__1 = nb; - for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { -/* Computing MIN */ - i__3 = *n - k + 1; - kb = std::min(i__3,nb); - -/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */ - - i__3 = k - 1; - dtrmm_("Right", uplo, "No transpose", "Non-unit", &kb, & - i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1], - lda); - i__3 = k - 1; - dsymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * - a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + - a_dim1], lda); - i__3 = k - 1; - dsyr2k_(uplo, "Transpose", &i__3, &kb, &c_b14, &a[k + - a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[ - a_offset], lda); - i__3 = k - 1; - dsymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * - a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + - a_dim1], lda); - i__3 = k - 1; - dtrmm_("Left", uplo, "Transpose", "Non-unit", &kb, &i__3, - &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1], - lda); - dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + - k * b_dim1], ldb, info); -/* L40: */ - } - } - } - } - return 0; - -/* End of DSYGST */ - -} /* dsygst_ */ diff --git a/external/clapack/lapack/dsygv.cpp b/external/clapack/lapack/dsygv.cpp deleted file mode 100644 index 7be19afb..00000000 --- a/external/clapack/lapack/dsygv.cpp +++ /dev/null @@ -1,257 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b16 = 1.; - -/* Subroutine */ int dsygv_(integer *itype, const char *jobz, const char *uplo, integer * - n, double *a, integer *lda, double *b, integer *ldb, - double *w, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - - /* Local variables */ - integer nb, neig; - char trans[1]; - bool upper; - bool wantz; - integer lwkmin; - integer lwkopt; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYGV computes all the eigenvalues, and optionally, the eigenvectors */ -/* of a real generalized symmetric-definite eigenproblem, of the form */ -/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */ -/* Here A and B are assumed to be symmetric and B is also */ -/* positive definite. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* Specifies the problem type to be solved: */ -/* = 1: A*x = (lambda)*B*x */ -/* = 2: A*B*x = (lambda)*x */ -/* = 3: B*A*x = (lambda)*x */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangles of A and B are stored; */ -/* = 'L': Lower triangles of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of A contains the */ -/* upper triangular part of the matrix A. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ - -/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ -/* matrix Z of eigenvectors. The eigenvectors are normalized */ -/* as follows: */ -/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ -/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ -/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */ -/* or the lower triangle (if UPLO='L') of A, including the */ -/* diagonal, is destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the symmetric positive definite matrix B. */ -/* If UPLO = 'U', the leading N-by-N upper triangular part of B */ -/* contains the upper triangular part of the matrix B. */ -/* If UPLO = 'L', the leading N-by-N lower triangular part of B */ -/* contains the lower triangular part of the matrix B. */ - -/* On exit, if INFO <= N, the part of B containing the matrix is */ -/* overwritten by the triangular factor U or L from the Cholesky */ -/* factorization B = U**T*U or B = L*L**T. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of the array WORK. LWORK >= max(1,3*N-1). */ -/* For optimal efficiency, LWORK >= (NB+2)*N, */ -/* where NB is the blocksize for DSYTRD returned by ILAENV. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: DPOTRF or DSYEV returned an error code: */ -/* <= N: if INFO = i, DSYEV failed to converge; */ -/* i off-diagonal elements of an intermediate */ -/* tridiagonal form did not converge to zero; */ -/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ -/* minor of order i of B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --w; - --work; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - - *info = 0; - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! (wantz || lsame_(jobz, "N"))) { - *info = -2; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } - - if (*info == 0) { -/* Computing MAX */ - i__1 = 1, i__2 = *n * 3 - 1; - lwkmin = std::max(i__1,i__2); - nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = lwkmin, i__2 = (nb + 2) * *n; - lwkopt = std::max(i__1,i__2); - work[1] = (double) lwkopt; - - if (*lwork < lwkmin && ! lquery) { - *info = -11; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYGV ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Form a Cholesky factorization of B. */ - - dpotrf_(uplo, n, &b[b_offset], ldb, info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem and solve. */ - - dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); - dsyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, info); - - if (wantz) { - -/* Backtransform eigenvectors to the original problem. */ - - neig = *n; - if (*info > 0) { - neig = *info - 1; - } - if (*itype == 1 || *itype == 2) { - -/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ -/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ - - if (upper) { - *(unsigned char *)trans = 'N'; - } else { - *(unsigned char *)trans = 'T'; - } - - dtrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[ - b_offset], ldb, &a[a_offset], lda); - - } else if (*itype == 3) { - -/* For B*A*x=(lambda)*x; */ -/* backtransform eigenvectors: x = L*y or U'*y */ - - if (upper) { - *(unsigned char *)trans = 'T'; - } else { - *(unsigned char *)trans = 'N'; - } - - dtrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[ - b_offset], ldb, &a[a_offset], lda); - } - } - - work[1] = (double) lwkopt; - return 0; - -/* End of DSYGV */ - -} /* dsygv_ */ diff --git a/external/clapack/lapack/dsygvd.cpp b/external/clapack/lapack/dsygvd.cpp deleted file mode 100644 index bf4a76fd..00000000 --- a/external/clapack/lapack/dsygvd.cpp +++ /dev/null @@ -1,312 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b11 = 1.; - -/* Subroutine */ int dsygvd_(integer *itype, const char *jobz, const char *uplo, integer * - n, double *a, integer *lda, double *b, integer *ldb, - double *w, double *work, integer *lwork, integer *iwork, - integer *liwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer lopt; - integer lwmin; - char trans[1]; - integer liopt; - bool upper, wantz; - integer liwmin; - bool lquery; - - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYGVD computes all the eigenvalues, and optionally, the eigenvectors */ -/* of a real generalized symmetric-definite eigenproblem, of the form */ -/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ -/* B are assumed to be symmetric and B is also positive definite. */ -/* If eigenvectors are desired, it uses a divide and conquer algorithm. */ - -/* The divide and conquer algorithm makes very mild assumptions about */ -/* floating point arithmetic. It will work on machines with a guard */ -/* digit in add/subtract, or on those binary machines without guard */ -/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ -/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ -/* without guard digits, but we know of none. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* Specifies the problem type to be solved: */ -/* = 1: A*x = (lambda)*B*x */ -/* = 2: A*B*x = (lambda)*x */ -/* = 3: B*A*x = (lambda)*x */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangles of A and B are stored; */ -/* = 'L': Lower triangles of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of A contains the */ -/* upper triangular part of the matrix A. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ - -/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ -/* matrix Z of eigenvectors. The eigenvectors are normalized */ -/* as follows: */ -/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ -/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ -/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */ -/* or the lower triangle (if UPLO='L') of A, including the */ -/* diagonal, is destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, the symmetric matrix B. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of B contains the */ -/* upper triangular part of the matrix B. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of B contains */ -/* the lower triangular part of the matrix B. */ - -/* On exit, if INFO <= N, the part of B containing the matrix is */ -/* overwritten by the triangular factor U or L from the Cholesky */ -/* factorization B = U**T*U or B = L*L**T. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, the eigenvalues in ascending order. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* If N <= 1, LWORK >= 1. */ -/* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. */ -/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal sizes of the WORK and IWORK */ -/* arrays, returns these values as the first entries of the WORK */ -/* and IWORK arrays, and no error message related to LWORK or */ -/* LIWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If N <= 1, LIWORK >= 1. */ -/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */ -/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal sizes of the WORK and */ -/* IWORK arrays, returns these values as the first entries of */ -/* the WORK and IWORK arrays, and no error message related to */ -/* LWORK or LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: DPOTRF or DSYEVD returned an error code: */ -/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */ -/* failed to converge; i off-diagonal elements of an */ -/* intermediate tridiagonal form did not converge to */ -/* zero; */ -/* if INFO = i and JOBZ = 'V', then the algorithm */ -/* failed to compute an eigenvalue while working on */ -/* the submatrix lying in rows and columns INFO/(N+1) */ -/* through mod(INFO,N+1); */ -/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ -/* minor of order i of B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ - -/* Modified so that no backsubstitution is performed if DSYEVD fails to */ -/* converge (NEIG in old code could be greater than N causing out of */ -/* bounds reference to A - reported by Ralf Meyer). Also corrected the */ -/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */ -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --w; - --work; - --iwork; - - /* Function Body */ - wantz = lsame_(jobz, "V"); - upper = lsame_(uplo, "U"); - lquery = *lwork == -1 || *liwork == -1; - - *info = 0; - if (*n <= 1) { - liwmin = 1; - lwmin = 1; - } else if (wantz) { - liwmin = *n * 5 + 3; -/* Computing 2nd power */ - i__1 = *n; - lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); - } else { - liwmin = 1; - lwmin = (*n << 1) + 1; - } - lopt = lwmin; - liopt = liwmin; - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! (wantz || lsame_(jobz, "N"))) { - *info = -2; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } - - if (*info == 0) { - work[1] = (double) lopt; - iwork[1] = liopt; - - if (*lwork < lwmin && ! lquery) { - *info = -11; - } else if (*liwork < liwmin && ! lquery) { - *info = -13; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYGVD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Form a Cholesky factorization of B. */ - - dpotrf_(uplo, n, &b[b_offset], ldb, info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem and solve. */ - - dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); - dsyevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &iwork[ - 1], liwork, info); -/* Computing MAX */ - d__1 = (double) lopt; - lopt = (integer) std::max(d__1,work[1]); -/* Computing MAX */ - d__1 = (double) liopt, d__2 = (double) iwork[1]; - liopt = (integer) std::max(d__1,d__2); - - if (wantz && *info == 0) { - -/* Backtransform eigenvectors to the original problem. */ - - if (*itype == 1 || *itype == 2) { - -/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ -/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ - - if (upper) { - *(unsigned char *)trans = 'N'; - } else { - *(unsigned char *)trans = 'T'; - } - - dtrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset] -, ldb, &a[a_offset], lda); - - } else if (*itype == 3) { - -/* For B*A*x=(lambda)*x; */ -/* backtransform eigenvectors: x = L*y or U'*y */ - - if (upper) { - *(unsigned char *)trans = 'T'; - } else { - *(unsigned char *)trans = 'N'; - } - - dtrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset] -, ldb, &a[a_offset], lda); - } - } - - work[1] = (double) lopt; - iwork[1] = liopt; - - return 0; - -/* End of DSYGVD */ - -} /* dsygvd_ */ diff --git a/external/clapack/lapack/dsygvx.cpp b/external/clapack/lapack/dsygvx.cpp deleted file mode 100644 index cfd397e2..00000000 --- a/external/clapack/lapack/dsygvx.cpp +++ /dev/null @@ -1,364 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static double c_b19 = 1.; - -/* Subroutine */ int dsygvx_(integer *itype, const char *jobz, const char *range, const char * - uplo, integer *n, double *a, integer *lda, double *b, integer - *ldb, double *vl, double *vu, integer *il, integer *iu, - double *abstol, integer *m, double *w, double *z__, - integer *ldz, double *work, integer *lwork, integer *iwork, - integer *ifail, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2; - - /* Local variables */ - integer nb; - char trans[1]; - bool upper, wantz, alleig, indeig, valeig; - integer lwkmin; - integer lwkopt; - bool lquery; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYGVX computes selected eigenvalues, and optionally, eigenvectors */ -/* of a real generalized symmetric-definite eigenproblem, of the form */ -/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */ -/* and B are assumed to be symmetric and B is also positive definite. */ -/* Eigenvalues and eigenvectors can be selected by specifying either a */ -/* range of values or a range of indices for the desired eigenvalues. */ - -/* Arguments */ -/* ========= */ - -/* ITYPE (input) INTEGER */ -/* Specifies the problem type to be solved: */ -/* = 1: A*x = (lambda)*B*x */ -/* = 2: A*B*x = (lambda)*x */ -/* = 3: B*A*x = (lambda)*x */ - -/* JOBZ (input) CHARACTER*1 */ -/* = 'N': Compute eigenvalues only; */ -/* = 'V': Compute eigenvalues and eigenvectors. */ - -/* RANGE (input) CHARACTER*1 */ -/* = 'A': all eigenvalues will be found. */ -/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ -/* will be found. */ -/* = 'I': the IL-th through IU-th eigenvalues will be found. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A and B are stored; */ -/* = 'L': Lower triangle of A and B are stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix pencil (A,B). N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of A contains the */ -/* upper triangular part of the matrix A. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of A contains */ -/* the lower triangular part of the matrix A. */ - -/* On exit, the lower triangle (if UPLO='L') or the upper */ -/* triangle (if UPLO='U') of A, including the diagonal, is */ -/* destroyed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ -/* On entry, the symmetric matrix B. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of B contains the */ -/* upper triangular part of the matrix B. If UPLO = 'L', */ -/* the leading N-by-N lower triangular part of B contains */ -/* the lower triangular part of the matrix B. */ - -/* On exit, if INFO <= N, the part of B containing the matrix is */ -/* overwritten by the triangular factor U or L from the Cholesky */ -/* factorization B = U**T*U or B = L*L**T. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* VL (input) DOUBLE PRECISION */ -/* VU (input) DOUBLE PRECISION */ -/* If RANGE='V', the lower and upper bounds of the interval to */ -/* be searched for eigenvalues. VL < VU. */ -/* Not referenced if RANGE = 'A' or 'I'. */ - -/* IL (input) INTEGER */ -/* IU (input) INTEGER */ -/* If RANGE='I', the indices (in ascending order) of the */ -/* smallest and largest eigenvalues to be returned. */ -/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ -/* Not referenced if RANGE = 'A' or 'V'. */ - -/* ABSTOL (input) DOUBLE PRECISION */ -/* The absolute error tolerance for the eigenvalues. */ -/* An approximate eigenvalue is accepted as converged */ -/* when it is determined to lie in an interval [a,b] */ -/* of width less than or equal to */ - -/* ABSTOL + EPS * max( |a|,|b| ) , */ - -/* where EPS is the machine precision. If ABSTOL is less than */ -/* or equal to zero, then EPS*|T| will be used in its place, */ -/* where |T| is the 1-norm of the tridiagonal matrix obtained */ -/* by reducing A to tridiagonal form. */ - -/* Eigenvalues will be computed most accurately when ABSTOL is */ -/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ -/* If this routine returns with INFO>0, indicating that some */ -/* eigenvectors did not converge, try setting ABSTOL to */ -/* 2*DLAMCH('S'). */ - -/* M (output) INTEGER */ -/* The total number of eigenvalues found. 0 <= M <= N. */ -/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ - -/* W (output) DOUBLE PRECISION array, dimension (N) */ -/* On normal exit, the first M elements contain the selected */ -/* eigenvalues in ascending order. */ - -/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ -/* If JOBZ = 'N', then Z is not referenced. */ -/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ -/* contain the orthonormal eigenvectors of the matrix A */ -/* corresponding to the selected eigenvalues, with the i-th */ -/* column of Z holding the eigenvector associated with W(i). */ -/* The eigenvectors are normalized as follows: */ -/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ -/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ - -/* If an eigenvector fails to converge, then that column of Z */ -/* contains the latest approximation to the eigenvector, and the */ -/* index of the eigenvector is returned in IFAIL. */ -/* Note: the user must ensure that at least max(1,M) columns are */ -/* supplied in the array Z; if RANGE = 'V', the exact value of M */ -/* is not known in advance and an upper bound must be used. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1, and if */ -/* JOBZ = 'V', LDZ >= max(1,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of the array WORK. LWORK >= max(1,8*N). */ -/* For optimal efficiency, LWORK >= (NB+3)*N, */ -/* where NB is the blocksize for DSYTRD returned by ILAENV. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (5*N) */ - -/* IFAIL (output) INTEGER array, dimension (N) */ -/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ -/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ -/* indices of the eigenvectors that failed to converge. */ -/* If JOBZ = 'N', then IFAIL is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: DPOTRF or DSYEVX returned an error code: */ -/* <= N: if INFO = i, DSYEVX failed to converge; */ -/* i eigenvectors failed to converge. Their indices */ -/* are stored in array IFAIL. */ -/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ -/* minor of order i of B is not positive definite. */ -/* The factorization of B could not be completed and */ -/* no eigenvalues or eigenvectors were computed. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --w; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - --iwork; - --ifail; - - /* Function Body */ - upper = lsame_(uplo, "U"); - wantz = lsame_(jobz, "V"); - alleig = lsame_(range, "A"); - valeig = lsame_(range, "V"); - indeig = lsame_(range, "I"); - lquery = *lwork == -1; - - *info = 0; - if (*itype < 1 || *itype > 3) { - *info = -1; - } else if (! (wantz || lsame_(jobz, "N"))) { - *info = -2; - } else if (! (alleig || valeig || indeig)) { - *info = -3; - } else if (! (upper || lsame_(uplo, "L"))) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else { - if (valeig) { - if (*n > 0 && *vu <= *vl) { - *info = -11; - } - } else if (indeig) { - if (*il < 1 || *il > std::max(1_integer,*n)) { - *info = -12; - } else if (*iu < std::min(*n,*il) || *iu > *n) { - *info = -13; - } - } - } - if (*info == 0) { - if (*ldz < 1 || wantz && *ldz < *n) { - *info = -18; - } - } - - if (*info == 0) { -/* Computing MAX */ - i__1 = 1, i__2 = *n << 3; - lwkmin = std::max(i__1,i__2); - nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = lwkmin, i__2 = (nb + 3) * *n; - lwkopt = std::max(i__1,i__2); - work[1] = (double) lwkopt; - - if (*lwork < lwkmin && ! lquery) { - *info = -20; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYGVX", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - *m = 0; - if (*n == 0) { - return 0; - } - -/* Form a Cholesky factorization of B. */ - - dpotrf_(uplo, n, &b[b_offset], ldb, info); - if (*info != 0) { - *info = *n + *info; - return 0; - } - -/* Transform problem to standard eigenvalue problem and solve. */ - - dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); - dsyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol, - m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], &ifail[ - 1], info); - - if (wantz) { - -/* Backtransform eigenvectors to the original problem. */ - - if (*info > 0) { - *m = *info - 1; - } - if (*itype == 1 || *itype == 2) { - -/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ -/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ - - if (upper) { - *(unsigned char *)trans = 'N'; - } else { - *(unsigned char *)trans = 'T'; - } - - dtrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset] -, ldb, &z__[z_offset], ldz); - - } else if (*itype == 3) { - -/* For B*A*x=(lambda)*x; */ -/* backtransform eigenvectors: x = L*y or U'*y */ - - if (upper) { - *(unsigned char *)trans = 'T'; - } else { - *(unsigned char *)trans = 'N'; - } - - dtrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset] -, ldb, &z__[z_offset], ldz); - } - } - -/* Set WORK(1) to optimal workspace size. */ - - work[1] = (double) lwkopt; - - return 0; - -/* End of DSYGVX */ - -} /* dsygvx_ */ diff --git a/external/clapack/lapack/dsyrfs.cpp b/external/clapack/lapack/dsyrfs.cpp deleted file mode 100644 index aacbe49e..00000000 --- a/external/clapack/lapack/dsyrfs.cpp +++ /dev/null @@ -1,403 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b12 = -1.; -static double c_b14 = 1.; - -/* Subroutine */ int dsyrfs_(const char *uplo, integer *n, integer *nrhs, - double *a, integer *lda, double *af, integer *ldaf, integer * - ipiv, double *b, integer *ldb, double *x, integer *ldx, - double *ferr, double *berr, double *work, integer *iwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s, xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - integer count; - bool upper; - double safmin; - double lstres; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYRFS improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is symmetric indefinite, and */ -/* provides error bounds and backward error estimates for the solution. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of A contains the upper triangular part */ -/* of the matrix A, and the strictly lower triangular part of A */ -/* is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of A contains the lower triangular part of */ -/* the matrix A, and the strictly upper triangular part of A is */ -/* not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* The factored form of the matrix A. AF contains the block */ -/* diagonal matrix D and the multipliers used to obtain the */ -/* factor U or L from the factorization A = U*D*U**T or */ -/* A = L*D*L**T as computed by DSYTRF. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSYTRF. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DSYTRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -10; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *n + 1; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - A * X */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, - &c_b14, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L30: */ - } - -/* Compute abs(A)*abs(X) + abs(B). */ - - if (upper) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ - i__ + j * x_dim1], abs(d__2)); -/* L40: */ - } - work[k] = work[k] + (d__1 = a[k + k * a_dim1], abs(d__1)) * - xk + s; -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - work[k] += (d__1 = a[k + k * a_dim1], abs(d__1)) * xk; - i__3 = *n; - for (i__ = k + 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ - i__ + j * x_dim1], abs(d__2)); -/* L60: */ - } - work[k] += s; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n - + 1], n, info); - daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(A))* */ -/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(A) is the inverse of A */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(A) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(A'). */ - - dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ - *n + 1], n, info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L110: */ - } - } else if (kase == 2) { - -/* Multiply by inv(A)*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L120: */ - } - dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ - *n + 1], n, info); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DSYRFS */ - -} /* dsyrfs_ */ diff --git a/external/clapack/lapack/dsyrfsx.cpp b/external/clapack/lapack/dsyrfsx.cpp deleted file mode 100644 index 990b5762..00000000 --- a/external/clapack/lapack/dsyrfsx.cpp +++ /dev/null @@ -1,593 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c_n1 = -1; -static integer c__0 = 0; -static integer c__1 = 1; - -int dsyrfsx_(const char *uplo, const char *equed, integer *n, integer *nrhs, double *a, - integer *lda, double *af, integer *ldaf, integer *ipiv, double *s, double *b, integer *ldb, - double *x, integer *ldx, double *rcond, double *berr, integer *n_err_bnds__, - double *err_bnds_norm__, double *err_bnds_comp__, integer *nparams, double *params, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, - err_bnds_comp_dim1, err_bnds_comp_offset, i__1; - double d__1, d__2; - - /* Local variables */ - double illrcond_thresh__, unstable_thresh__, err_lbnd__; - integer ref_type__, j; - double rcond_tmp__; - integer prec_type__; - double cwise_wrong__; - char norm[1]; - bool ignore_cwise__; - double anorm; - bool rcequ; - integer ithresh, n_norms__; - double rthresh; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYRFSX improves the computed solution to a system of linear */ -/* equations when the coefficient matrix is symmetric indefinite, and */ -/* provides error bounds and backward error estimates for the */ -/* solution. In addition to normwise error bound, the code provides */ -/* maximum componentwise error bound if possible. See comments for */ -/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */ - -/* The original system of linear equations may have been equilibrated */ -/* before calling this routine, as described by arguments EQUED and S */ -/* below. In this case, the solution and error bounds returned are */ -/* for the original unequilibrated system. */ - -/* Arguments */ -/* ========= */ - -/* Some optional parameters are bundled in the PARAMS array. These */ -/* settings determine how refinement is performed, but often the */ -/* defaults are acceptable. If the defaults are acceptable, users */ -/* can pass NPARAMS = 0 which prevents the source code from accessing */ -/* the PARAMS argument. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* EQUED (input) CHARACTER*1 */ -/* Specifies the form of equilibration that was done to A */ -/* before calling this routine. This is needed to compute */ -/* the solution and error bounds correctly. */ -/* = 'N': No equilibration */ -/* = 'Y': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(S) * A * diag(S). */ -/* The right hand side B has been changed accordingly. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of A contains the upper triangular */ -/* part of the matrix A, and the strictly lower triangular */ -/* part of A is not referenced. If UPLO = 'L', the leading */ -/* N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* The factored form of the matrix A. AF contains the block */ -/* diagonal matrix D and the multipliers used to obtain the */ -/* factor U or L from the factorization A = U*D*U**T or A = */ -/* L*D*L**T as computed by DSYTRF. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSYTRF. */ - -/* S (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The scale factors for A. If EQUED = 'Y', A is multiplied on */ -/* the left and right by diag(S). S is an input argument if FACT = */ -/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ -/* = 'Y', each element of S must be positive. If S is output, each */ -/* element of S is a power of the radix. If S is input, each element */ -/* of S should be a power of the radix to ensure a reliable solution */ -/* and error estimates. Scaling by powers of the radix does not cause */ -/* rounding errors unless the result underflows or overflows. */ -/* Rounding errors during scaling lead to refining with a matrix that */ -/* is not equivalent to the input matrix, producing error estimates */ -/* that may not be reliable. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DGETRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* Reciprocal scaled condition number. This is an estimate of the */ -/* reciprocal Skeel condition number of the matrix A after */ -/* equilibration (if done). If this is less than the machine */ -/* precision (in particular, if it is zero), the matrix is singular */ -/* to working precision. Note that the error may still be small even */ -/* if this number is very small and the matrix appears ill- */ -/* conditioned. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* Componentwise relative backward error. This is the */ -/* componentwise relative backward error of each solution vector X(j) */ -/* (i.e., the smallest relative change in any element of A or B that */ -/* makes X(j) an exact solution). */ - -/* N_ERR_BNDS (input) INTEGER */ -/* Number of error bounds to return for each right hand side */ -/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */ -/* ERR_BNDS_COMP below. */ - -/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ -/* For each right-hand side, this array contains information about */ -/* various error bounds and condition numbers corresponding to the */ -/* normwise relative error, which is defined as follows: */ - -/* Normwise relative error in the ith solution vector: */ -/* max_j (abs(XTRUE(j,i) - X(j,i))) */ -/* ------------------------------ */ -/* max_j abs(X(j,i)) */ - -/* The array is indexed by the type of error information as described */ -/* below. There currently are up to three pieces of information */ -/* returned. */ - -/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ -/* right-hand side. */ - -/* The second index in ERR_BNDS_NORM(:,err) contains the following */ -/* three fields: */ -/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ -/* reciprocal condition number is less than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). */ - -/* err = 2 "Guaranteed" error bound: The estimated forward error, */ -/* almost certainly within a factor of 10 of the true error */ -/* so long as the next entry is greater than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ -/* be trusted if the previous boolean is true. */ - -/* err = 3 Reciprocal condition number: Estimated normwise */ -/* reciprocal condition number. Compared with the threshold */ -/* sqrt(n) * dlamch('Epsilon') to determine if the error */ -/* estimate is "guaranteed". These reciprocal condition */ -/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ -/* appropriately scaled matrix Z. */ -/* Let Z = S*A, where S scales each row by a power of the */ -/* radix so all absolute row sums of Z are approximately 1. */ - -/* See Lapack Working Note 165 for further details and extra */ -/* cautions. */ - -/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ -/* For each right-hand side, this array contains information about */ -/* various error bounds and condition numbers corresponding to the */ -/* componentwise relative error, which is defined as follows: */ - -/* Componentwise relative error in the ith solution vector: */ -/* abs(XTRUE(j,i) - X(j,i)) */ -/* max_j ---------------------- */ -/* abs(X(j,i)) */ - -/* The array is indexed by the right-hand side i (on which the */ -/* componentwise relative error depends), and the type of error */ -/* information as described below. There currently are up to three */ -/* pieces of information returned for each right-hand side. If */ -/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ -/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ -/* the first (:,N_ERR_BNDS) entries are returned. */ - -/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ -/* right-hand side. */ - -/* The second index in ERR_BNDS_COMP(:,err) contains the following */ -/* three fields: */ -/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ -/* reciprocal condition number is less than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). */ - -/* err = 2 "Guaranteed" error bound: The estimated forward error, */ -/* almost certainly within a factor of 10 of the true error */ -/* so long as the next entry is greater than the threshold */ -/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ -/* be trusted if the previous boolean is true. */ - -/* err = 3 Reciprocal condition number: Estimated componentwise */ -/* reciprocal condition number. Compared with the threshold */ -/* sqrt(n) * dlamch('Epsilon') to determine if the error */ -/* estimate is "guaranteed". These reciprocal condition */ -/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ -/* appropriately scaled matrix Z. */ -/* Let Z = S*(A*diag(x)), where x is the solution for the */ -/* current right-hand side and S scales each row of */ -/* A*diag(x) by a power of the radix so all absolute row */ -/* sums of Z are approximately 1. */ - -/* See Lapack Working Note 165 for further details and extra */ -/* cautions. */ - -/* NPARAMS (input) INTEGER */ -/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */ -/* PARAMS array is never referenced and default values are used. */ - -/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */ -/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */ -/* that entry will be filled with default value used for that */ -/* parameter. Only positions up to NPARAMS are accessed; defaults */ -/* are used for higher-numbered parameters. */ - -/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ -/* refinement or not. */ -/* Default: 1.0D+0 */ -/* = 0.0 : No refinement is performed, and no error bounds are */ -/* computed. */ -/* = 1.0 : Use the double-precision refinement algorithm, */ -/* possibly with doubled-single computations if the */ -/* compilation environment does not support DOUBLE */ -/* PRECISION. */ -/* (other values are reserved for future use) */ - -/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ -/* computations allowed for refinement. */ -/* Default: 10 */ -/* Aggressive: Set to 100 to permit convergence using approximate */ -/* factorizations or factorizations other than LU. If */ -/* the factorization uses a technique other than */ -/* Gaussian elimination, the guarantees in */ -/* err_bnds_norm and err_bnds_comp may no longer be */ -/* trustworthy. */ - -/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ -/* will attempt to find a solution with small componentwise */ -/* relative error in the double-precision algorithm. Positive */ -/* is true, 0.0 is false. */ -/* Default: 1.0 (attempt componentwise convergence) */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: Successful exit. The solution to every right-hand side is */ -/* guaranteed. */ -/* < 0: If INFO = -i, the i-th argument had an illegal value */ -/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly singular, so */ -/* the solution and error bounds could not be computed. RCOND = 0 */ -/* is returned. */ -/* = N+J: The solution corresponding to the Jth right-hand side is */ -/* not guaranteed. The solutions corresponding to other right- */ -/* hand sides K with K > J may not be guaranteed as well, but */ -/* only the first such right-hand side is reported. If a small */ -/* componentwise error is not requested (PARAMS(3) = 0.0) then */ -/* the Jth right-hand side is the first with a normwise error */ -/* bound that is not guaranteed (the smallest J such */ -/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ -/* the Jth right-hand side is the first with either a normwise or */ -/* componentwise error bound that is not guaranteed (the smallest */ -/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ -/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ -/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ -/* about all of the right-hand sides check ERR_BNDS_NORM or */ -/* ERR_BNDS_COMP. */ - -/* ================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Check the input parameters. */ - - /* Parameter adjustments */ - err_bnds_comp_dim1 = *nrhs; - err_bnds_comp_offset = 1 + err_bnds_comp_dim1; - err_bnds_comp__ -= err_bnds_comp_offset; - err_bnds_norm_dim1 = *nrhs; - err_bnds_norm_offset = 1 + err_bnds_norm_dim1; - err_bnds_norm__ -= err_bnds_norm_offset; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --ipiv; - --s; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --berr; - --params; - --work; - --iwork; - - /* Function Body */ - *info = 0; - ref_type__ = 1; - if (*nparams >= 1) { - if (params[1] < 0.) { - params[1] = 1.; - } else { - ref_type__ = (integer) params[1]; - } - } - -/* Set default parameters. */ - - illrcond_thresh__ = (double) (*n) * dlamch_("Epsilon"); - ithresh = 10; - rthresh = .5; - unstable_thresh__ = .25; - ignore_cwise__ = false; - - if (*nparams >= 2) { - if (params[2] < 0.) { - params[2] = (double) ithresh; - } else { - ithresh = (integer) params[2]; - } - } - if (*nparams >= 3) { - if (params[3] < 0.) { - if (ignore_cwise__) { - params[3] = 0.; - } else { - params[3] = 1.; - } - } else { - ignore_cwise__ = params[3] == 0.; - } - } - if (ref_type__ == 0 || *n_err_bnds__ == 0) { - n_norms__ = 0; - } else if (ignore_cwise__) { - n_norms__ = 1; - } else { - n_norms__ = 2; - } - - rcequ = lsame_(equed, "Y"); - -/* Test input parameters. */ - - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! rcequ && ! lsame_(equed, "N")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -8; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -11; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -13; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYRFSX", &i__1); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0 || *nrhs == 0) { - *rcond = 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - berr[j] = 0.; - if (*n_err_bnds__ >= 1) { - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } else if (*n_err_bnds__ >= 2) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.; - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.; - } else if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.; - } - } - return 0; - } - -/* Default to failure. */ - - *rcond = 0.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - berr[j] = 1.; - if (*n_err_bnds__ >= 1) { - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } else if (*n_err_bnds__ >= 2) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - } else if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.; - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.; - } - } - -/* Compute the norm of A and the reciprocal of the condition */ -/* number of A. */ - - *(unsigned char *)norm = 'I'; - anorm = dlansy_(norm, uplo, n, &a[a_offset], lda, &work[1]); - dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], - &iwork[1], info); - -/* Perform refinement on each right-hand side */ - - if (ref_type__ != 0) { - prec_type__ = ilaprec_("E"); - dla_syrfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda, - &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset], - ldb, &x[x_offset], ldx, &berr[1], &n_norms__, & - err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[ - err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n << - 1) + 1], &work[1], rcond, &ithresh, &rthresh, & - unstable_thresh__, &ignore_cwise__, info, 1_integer); - } -/* Computing MAX */ - d__1 = 10., d__2 = sqrt((double) (*n)); - err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon"); - if (*n_err_bnds__ >= 1 && n_norms__ >= 1) { - -/* Compute scaled normwise condition number cond(A*C). */ - - if (rcequ) { - rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[ - af_offset], ldaf, &ipiv[1], &c_n1, &s[1], info, &work[1], - &iwork[1], 1_integer); - } else { - rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[ - af_offset], ldaf, &ipiv[1], &c__0, &s[1], info, &work[1], - &iwork[1], 1_integer); - } - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Cap the error at 1.0. */ - - if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 - << 1)] > 1.) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - } - -/* Threshold the error (see LAWN). */ - - if (rcond_tmp__ < illrcond_thresh__) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; - err_bnds_norm__[j + err_bnds_norm_dim1] = 0.; - if (*info <= *n) { - *info = *n + j; - } - } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < - err_lbnd__) { - err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__; - err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; - } - -/* Save the condition number. */ - - if (*n_err_bnds__ >= 3) { - err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__; - } - } - } - if (*n_err_bnds__ >= 1 && n_norms__ >= 2) { - -/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */ -/* each right-hand side using the current solution as an estimate of */ -/* the true solution. If the componentwise error estimate is too */ -/* large, then the solution is a lousy estimate of truth and the */ -/* estimated RCOND may be too optimistic. To avoid misleading users, */ -/* the inverse condition number is set to 0.0 when the estimated */ -/* cwise error is at least CWISE_WRONG. */ - - cwise_wrong__ = sqrt(dlamch_("Epsilon")); - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < - cwise_wrong__) { - rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[ - af_offset], ldaf, &ipiv[1], &c__1, &x[j * x_dim1 + 1], - info, &work[1], &iwork[1], 1_integer); - } else { - rcond_tmp__ = 0.; - } - -/* Cap the error at 1.0. */ - - if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 - << 1)] > 1.) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - } - -/* Threshold the error (see LAWN). */ - - if (rcond_tmp__ < illrcond_thresh__) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; - err_bnds_comp__[j + err_bnds_comp_dim1] = 0.; - if (params[3] == 1. && *info < *n + j) { - *info = *n + j; - } - } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < - err_lbnd__) { - err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__; - err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; - } - -/* Save the condition number. */ - - if (*n_err_bnds__ >= 3) { - err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__; - } - } - } - - return 0; - -/* End of DSYRFSX */ - -} /* dsyrfsx_ */ diff --git a/external/clapack/lapack/dsysv.cpp b/external/clapack/lapack/dsysv.cpp deleted file mode 100644 index 24665922..00000000 --- a/external/clapack/lapack/dsysv.cpp +++ /dev/null @@ -1,193 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dsysv_(const char *uplo, integer *n, integer *nrhs, double - *a, integer *lda, integer *ipiv, double *b, integer *ldb, - double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - integer nb; - integer lwkopt; - bool lquery; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYSV computes the solution to a real system of linear equations */ -/* A * X = B, */ -/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ -/* matrices. */ - -/* The diagonal pivoting method is used to factor A as */ -/* A = U * D * U**T, if UPLO = 'U', or */ -/* A = L * D * L**T, if UPLO = 'L', */ -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, and D is symmetric and block diagonal with */ -/* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */ -/* used to solve the system of equations A * X = B. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the block diagonal matrix D and the */ -/* multipliers used to obtain the factor U or L from the */ -/* factorization A = U*D*U**T or A = L*D*L**T as computed by */ -/* DSYTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D, as */ -/* determined by DSYTRF. If IPIV(k) > 0, then rows and columns */ -/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */ -/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */ -/* then rows and columns k-1 and -IPIV(k) were interchanged and */ -/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */ -/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */ -/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */ -/* diagonal block. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of WORK. LWORK >= 1, and for best performance */ -/* LWORK >= max(1,N*NB), where NB is the optimal blocksize for */ -/* DSYTRF. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular, so the solution could not be computed. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } else if (*lwork < 1 && ! lquery) { - *info = -10; - } - - if (*info == 0) { - if (*n == 0) { - lwkopt = 1; - } else { - nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1); - lwkopt = *n * nb; - } - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYSV ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Compute the factorization A = U*D*U' or A = L*D*L'. */ - - dsytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dsytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb, - info); - - } - - work[1] = (double) lwkopt; - - return 0; - -/* End of DSYSV */ - -} /* dsysv_ */ diff --git a/external/clapack/lapack/dsysvx.cpp b/external/clapack/lapack/dsysvx.cpp deleted file mode 100644 index 508f9c04..00000000 --- a/external/clapack/lapack/dsysvx.cpp +++ /dev/null @@ -1,337 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; - -/* Subroutine */ int dsysvx_(const char *fact, const char *uplo, integer *n, integer * - nrhs, double *a, integer *lda, double *af, integer *ldaf, - integer *ipiv, double *b, integer *ldb, double *x, integer * - ldx, double *rcond, double *ferr, double *berr, - double *work, integer *lwork, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, i__1, i__2; - - /* Local variables */ - integer nb; - double anorm; - bool nofact; - integer lwkopt; - bool lquery; - -/* -- LAPACK driver routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYSVX uses the diagonal pivoting factorization to compute the */ -/* solution to a real system of linear equations A * X = B, */ -/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ -/* matrices. */ - -/* Error bounds on the solution and a condition estimate are also */ -/* provided. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */ -/* The form of the factorization is */ -/* A = U * D * U**T, if UPLO = 'U', or */ -/* A = L * D * L**T, if UPLO = 'L', */ -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, and D is symmetric and block diagonal with */ -/* 1-by-1 and 2-by-2 diagonal blocks. */ - -/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */ -/* returns with INFO = i. Otherwise, the factored form of A is used */ -/* to estimate the condition number of the matrix A. If the */ -/* reciprocal of the condition number is less than machine precision, */ -/* INFO = N+1 is returned as a warning, but the routine still goes on */ -/* to solve for X and compute error bounds as described below. */ - -/* 3. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 4. Iterative refinement is applied to improve the computed solution */ -/* matrix and calculate error bounds and backward error estimates */ -/* for it. */ - -/* Arguments */ -/* ========= */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of A has been */ -/* supplied on entry. */ -/* = 'F': On entry, AF and IPIV contain the factored form of */ -/* A. AF and IPIV will not be modified. */ -/* = 'N': The matrix A will be copied to AF and factored. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of A contains the upper triangular part */ -/* of the matrix A, and the strictly lower triangular part of A */ -/* is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of A contains the lower triangular part of */ -/* the matrix A, and the strictly upper triangular part of A is */ -/* not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* If FACT = 'F', then AF is an input argument and on entry */ -/* contains the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L from the factorization */ -/* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF. */ - -/* If FACT = 'N', then AF is an output argument and on exit */ -/* returns the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L from the factorization */ -/* A = U*D*U**T or A = L*D*L**T. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* IPIV (input or output) INTEGER array, dimension (N) */ -/* If FACT = 'F', then IPIV is an input argument and on entry */ -/* contains details of the interchanges and the block structure */ -/* of D, as determined by DSYTRF. */ -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* If FACT = 'N', then IPIV is an output argument and on exit */ -/* contains details of the interchanges and the block structure */ -/* of D, as determined by DSYTRF. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The N-by-NRHS right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The estimate of the reciprocal condition number of the matrix */ -/* A. If RCOND is less than the machine precision (in */ -/* particular, if RCOND = 0), the matrix is singular to working */ -/* precision. This condition is indicated by a return code of */ -/* INFO > 0. */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of WORK. LWORK >= max(1,3*N), and for best */ -/* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where */ -/* NB is the optimal blocksize for DSYTRF. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= N: D(i,i) is exactly zero. The factorization */ -/* has been completed but the factor D is exactly */ -/* singular, so the solution and error bounds could */ -/* not be computed. RCOND = 0 is returned. */ -/* = N+1: D is nonsingular, but RCOND is less than machine */ -/* precision, meaning that the matrix is singular */ -/* to working precision. Nevertheless, the */ -/* solution and error bounds are computed because */ -/* there are a number of situations where the */ -/* computed solution can be more accurate than the */ -/* value of RCOND would suggest. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - lquery = *lwork == -1; - if (! nofact && ! lsame_(fact, "F")) { - *info = -1; - } else if (! lsame_(uplo, "U") && ! lsame_(uplo, - "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -8; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -11; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -13; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = 1, i__2 = *n * 3; - if (*lwork < std::max(i__1,i__2) && ! lquery) { - *info = -18; - } - } - - if (*info == 0) { -/* Computing MAX */ - i__1 = 1, i__2 = *n * 3; - lwkopt = std::max(i__1,i__2); - if (nofact) { - nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1); -/* Computing MAX */ - i__1 = lwkopt, i__2 = *n * nb; - lwkopt = std::max(i__1,i__2); - } - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYSVX", &i__1); - return 0; - } else if (lquery) { - return 0; - } - - if (nofact) { - -/* Compute the factorization A = U*D*U' or A = L*D*L'. */ - - dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); - dsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork, - info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - *rcond = 0.; - return 0; - } - } - -/* Compute the norm of the matrix A. */ - - anorm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[1]); - -/* Compute the reciprocal of the condition number of A. */ - - dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], - &iwork[1], info); - -/* Compute the solution vectors X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, - info); - -/* Use iterative refinement to improve the computed solutions and */ -/* compute error bounds and backward error estimates for them. */ - - dsyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], - &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] -, &iwork[1], info); - -/* Set INFO = N+1 if the matrix is singular to working precision. */ - - if (*rcond < dlamch_("Epsilon")) { - *info = *n + 1; - } - - work[1] = (double) lwkopt; - - return 0; - -/* End of DSYSVX */ - -} /* dsysvx_ */ diff --git a/external/clapack/lapack/dsysvxx.cpp b/external/clapack/lapack/dsysvxx.cpp deleted file mode 100644 index 54b8e002..00000000 --- a/external/clapack/lapack/dsysvxx.cpp +++ /dev/null @@ -1,595 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dsysvxx_(const char *fact, const char *uplo, integer *n, integer * - nrhs, double *a, integer *lda, double *af, integer *ldaf, - integer *ipiv, char *equed, double *s, double *b, integer * - ldb, double *x, integer *ldx, double *rcond, double * - rpvgrw, double *berr, integer *n_err_bnds__, double * - err_bnds_norm__, double *err_bnds_comp__, integer *nparams, - double *params, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, - err_bnds_comp_dim1, err_bnds_comp_offset, i__1; - double d__1, d__2; - - /* Local variables */ - integer j; - double amax, smin, smax; - double scond; - bool equil, rcequ, nofact; - double bignum; - integer infequ; - double smlnum; - - -/* -- LAPACK routine (version 3.2.1) -- */ -/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ -/* -- Jason Riedy of Univ. of California Berkeley. -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley and NAG Ltd. -- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYSVXX uses the diagonal pivoting factorization to compute the */ -/* solution to a double precision system of linear equations A * X = B, where A */ -/* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. */ - -/* If requested, both normwise and maximum componentwise error bounds */ -/* are returned. DSYSVXX will return a solution with a tiny */ -/* guaranteed error (O(eps) where eps is the working machine */ -/* precision) unless the matrix is very ill-conditioned, in which */ -/* case a warning is returned. Relevant condition numbers also are */ -/* calculated and returned. */ - -/* DSYSVXX accepts user-provided factorizations and equilibration */ -/* factors; see the definitions of the FACT and EQUED options. */ -/* Solving with refinement and using a factorization from a previous */ -/* DSYSVXX call will also produce a solution with either O(eps) */ -/* errors or warnings, but we cannot make that claim for general */ -/* user-provided factorizations and equilibration factors if they */ -/* differ from what DSYSVXX would itself produce. */ - -/* Description */ -/* =========== */ - -/* The following steps are performed: */ - -/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */ -/* the system: */ - -/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */ - -/* Whether or not the system will be equilibrated depends on the */ -/* scaling of the matrix A, but if equilibration is used, A is */ -/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ - -/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */ -/* the matrix A (after equilibration if FACT = 'E') as */ - -/* A = U * D * U**T, if UPLO = 'U', or */ -/* A = L * D * L**T, if UPLO = 'L', */ - -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, and D is symmetric and block diagonal with */ -/* 1-by-1 and 2-by-2 diagonal blocks. */ - -/* 3. If some D(i,i)=0, so that D is exactly singular, then the */ -/* routine returns with INFO = i. Otherwise, the factored form of A */ -/* is used to estimate the condition number of the matrix A (see */ -/* argument RCOND). If the reciprocal of the condition number is */ -/* less than machine precision, the routine still goes on to solve */ -/* for X and compute error bounds as described below. */ - -/* 4. The system of equations is solved for X using the factored form */ -/* of A. */ - -/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ -/* the routine will use iterative refinement to try to get a small */ -/* error and error bounds. Refinement calculates the residual to at */ -/* least twice the working precision. */ - -/* 6. If equilibration was used, the matrix X is premultiplied by */ -/* diag(R) so that it solves the original system before */ -/* equilibration. */ - -/* Arguments */ -/* ========= */ - -/* Some optional parameters are bundled in the PARAMS array. These */ -/* settings determine how refinement is performed, but often the */ -/* defaults are acceptable. If the defaults are acceptable, users */ -/* can pass NPARAMS = 0 which prevents the source code from accessing */ -/* the PARAMS argument. */ - -/* FACT (input) CHARACTER*1 */ -/* Specifies whether or not the factored form of the matrix A is */ -/* supplied on entry, and if not, whether the matrix A should be */ -/* equilibrated before it is factored. */ -/* = 'F': On entry, AF and IPIV contain the factored form of A. */ -/* If EQUED is not 'N', the matrix A has been */ -/* equilibrated with scaling factors given by S. */ -/* A, AF, and IPIV are not modified. */ -/* = 'N': The matrix A will be copied to AF and factored. */ -/* = 'E': The matrix A will be equilibrated if necessary, then */ -/* copied to AF and factored. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The number of linear equations, i.e., the order of the */ -/* matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of A contains the upper triangular */ -/* part of the matrix A, and the strictly lower triangular */ -/* part of A is not referenced. If UPLO = 'L', the leading */ -/* N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ -/* diag(S)*A*diag(S). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* If FACT = 'F', then AF is an input argument and on entry */ -/* contains the block diagonal matrix D and the multipliers */ -/* used to obtain the factor U or L from the factorization A = */ -/* U*D*U**T or A = L*D*L**T as computed by DSYTRF. */ - -/* If FACT = 'N', then AF is an output argument and on exit */ -/* returns the block diagonal matrix D and the multipliers */ -/* used to obtain the factor U or L from the factorization A = */ -/* U*D*U**T or A = L*D*L**T. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* IPIV (input or output) INTEGER array, dimension (N) */ -/* If FACT = 'F', then IPIV is an input argument and on entry */ -/* contains details of the interchanges and the block */ -/* structure of D, as determined by DSYTRF. If IPIV(k) > 0, */ -/* then rows and columns k and IPIV(k) were interchanged and */ -/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */ -/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */ -/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */ -/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */ -/* then rows and columns k+1 and -IPIV(k) were interchanged */ -/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* If FACT = 'N', then IPIV is an output argument and on exit */ -/* contains details of the interchanges and the block */ -/* structure of D, as determined by DSYTRF. */ - -/* EQUED (input or output) CHARACTER*1 */ -/* Specifies the form of equilibration that was done. */ -/* = 'N': No equilibration (always true if FACT = 'N'). */ -/* = 'Y': Both row and column equilibration, i.e., A has been */ -/* replaced by diag(S) * A * diag(S). */ -/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ -/* output argument. */ - -/* S (input or output) DOUBLE PRECISION array, dimension (N) */ -/* The scale factors for A. If EQUED = 'Y', A is multiplied on */ -/* the left and right by diag(S). S is an input argument if FACT = */ -/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ -/* = 'Y', each element of S must be positive. If S is output, each */ -/* element of S is a power of the radix. If S is input, each element */ -/* of S should be a power of the radix to ensure a reliable solution */ -/* and error estimates. Scaling by powers of the radix does not cause */ -/* rounding errors unless the result underflows or overflows. */ -/* Rounding errors during scaling lead to refining with a matrix that */ -/* is not equivalent to the input matrix, producing error estimates */ -/* that may not be reliable. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the N-by-NRHS right hand side matrix B. */ -/* On exit, */ -/* if EQUED = 'N', B is not modified; */ -/* if EQUED = 'Y', B is overwritten by diag(S)*B; */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* If INFO = 0, the N-by-NRHS solution matrix X to the original */ -/* system of equations. Note that A and B are modified on exit if */ -/* EQUED .ne. 'N', and the solution to the equilibrated system is */ -/* inv(diag(S))*X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* Reciprocal scaled condition number. This is an estimate of the */ -/* reciprocal Skeel condition number of the matrix A after */ -/* equilibration (if done). If this is less than the machine */ -/* precision (in particular, if it is zero), the matrix is singular */ -/* to working precision. Note that the error may still be small even */ -/* if this number is very small and the matrix appears ill- */ -/* conditioned. */ - -/* RPVGRW (output) DOUBLE PRECISION */ -/* Reciprocal pivot growth. On exit, this contains the reciprocal */ -/* pivot growth factor norm(A)/norm(U). The "max absolute element" */ -/* norm is used. If this is much less than 1, then the stability of */ -/* the LU factorization of the (equilibrated) matrix A could be poor. */ -/* This also means that the solution X, estimated condition numbers, */ -/* and error bounds could be unreliable. If factorization fails with */ -/* 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ -/* has been completed, but the factor U is exactly singular, so */ -/* the solution and error bounds could not be computed. RCOND = 0 */ -/* is returned. */ -/* = N+J: The solution corresponding to the Jth right-hand side is */ -/* not guaranteed. The solutions corresponding to other right- */ -/* hand sides K with K > J may not be guaranteed as well, but */ -/* only the first such right-hand side is reported. If a small */ -/* componentwise error is not requested (PARAMS(3) = 0.0) then */ -/* the Jth right-hand side is the first with a normwise error */ -/* bound that is not guaranteed (the smallest J such */ -/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ -/* the Jth right-hand side is the first with either a normwise or */ -/* componentwise error bound that is not guaranteed (the smallest */ -/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ -/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ -/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ -/* about all of the right-hand sides check ERR_BNDS_NORM or */ -/* ERR_BNDS_COMP. */ - -/* ================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - err_bnds_comp_dim1 = *nrhs; - err_bnds_comp_offset = 1 + err_bnds_comp_dim1; - err_bnds_comp__ -= err_bnds_comp_offset; - err_bnds_norm_dim1 = *nrhs; - err_bnds_norm_offset = 1 + err_bnds_norm_dim1; - err_bnds_norm__ -= err_bnds_norm_offset; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --ipiv; - --s; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --berr; - --params; - --work; - --iwork; - - /* Function Body */ - *info = 0; - nofact = lsame_(fact, "N"); - equil = lsame_(fact, "E"); - smlnum = dlamch_("Safe minimum"); - bignum = 1. / smlnum; - if (nofact || equil) { - *(unsigned char *)equed = 'N'; - rcequ = false; - } else { - rcequ = lsame_(equed, "Y"); - } - -/* Default is failure. If an input parameter is wrong or */ -/* factorization fails, make everything look horrible. Only the */ -/* pivot growth is set here, the rest is initialized in DSYRFSX. */ - - *rpvgrw = 0.; - -/* Test the input parameters. PARAMS is not tested until DSYRFSX. */ - - if (! nofact && ! equil && ! lsame_(fact, "F")) { - *info = -1; - } else if (! lsame_(uplo, "U") && ! lsame_(uplo, - "L")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldaf < std::max(1_integer,*n)) { - *info = -8; - } else if (lsame_(fact, "F") && ! (rcequ || lsame_( - equed, "N"))) { - *info = -9; - } else { - if (rcequ) { - smin = bignum; - smax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = smin, d__2 = s[j]; - smin = std::min(d__1,d__2); -/* Computing MAX */ - d__1 = smax, d__2 = s[j]; - smax = std::max(d__1,d__2); -/* L10: */ - } - if (smin <= 0.) { - *info = -10; - } else if (*n > 0) { - scond = std::max(smin,smlnum) / min(smax,bignum); - } else { - scond = 1.; - } - } - if (*info == 0) { - if (*ldb < std::max(1_integer,*n)) { - *info = -12; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -14; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYSVXX", &i__1); - return 0; - } - - if (equil) { - -/* Compute row and column scalings to equilibrate the matrix A. */ - - dsyequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], & - infequ); - if (infequ == 0) { - -/* Equilibrate the matrix. */ - - dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); - rcequ = lsame_(equed, "Y"); - } - } - -/* Scale the right-hand side. */ - - if (rcequ) { - dlascl2_(n, nrhs, &s[1], &b[b_offset], ldb); - } - - if (nofact || equil) { - -/* Compute the LU factorization of A. */ - - dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); - i__1 = std::max(1_integer,*n) * 5; - dsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1, - info); - -/* Return if INFO is non-zero. */ - - if (*info > 0) { - -/* Pivot in column INFO is exactly 0 */ -/* Compute the reciprocal pivot growth factor of the */ -/* leading rank-deficient INFO columns of A. */ - - if (*n > 0) { - *rpvgrw = dla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, & - af[af_offset], ldaf, &ipiv[1], &work[1], 1_integer); - } - return 0; - } - } - -/* Compute the reciprocal pivot growth factor RPVGRW. */ - - if (*n > 0) { - *rpvgrw = dla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &af[ - af_offset], ldaf, &ipiv[1], &work[1], 1_integer); - } - -/* Compute the solution matrix X. */ - - dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); - dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, info); - -/* Use iterative refinement to improve the computed solution and */ -/* compute error bounds and backward error estimates for it. */ - - dsyrfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, & - ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, & - berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], & - err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[ - 1], &iwork[1], info); - -/* Scale solutions. */ - - if (rcequ) { - dlascl2_(n, nrhs, &s[1], &x[x_offset], ldx); - } - - return 0; - -/* End of DSYSVXX */ - -} /* dsysvxx_ */ diff --git a/external/clapack/lapack/dsytd2.cpp b/external/clapack/lapack/dsytd2.cpp deleted file mode 100644 index cc96229f..00000000 --- a/external/clapack/lapack/dsytd2.cpp +++ /dev/null @@ -1,280 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b8 = 0.; -static double c_b14 = -1.; - -/* Subroutine */ int dsytd2_(const char *uplo, integer *n, double *a, integer * - lda, double *d__, double *e, double *tau, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__; - double taui; - double alpha; - bool upper; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */ -/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n-by-n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n-by-n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ -/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ -/* of A are overwritten by the corresponding elements of the */ -/* tridiagonal matrix T, and the elements above the first */ -/* superdiagonal, with the array TAU, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors; if UPLO */ -/* = 'L', the diagonal and first subdiagonal of A are over- */ -/* written by the corresponding elements of the tridiagonal */ -/* matrix T, and the elements below the first subdiagonal, 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,N). */ - -/* D (output) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T: */ -/* D(i) = A(i,i). */ - -/* E (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix T: */ -/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n-1) . . . H(2) H(1). */ - -/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ -/* A(1:i-1,i+1), and tau in TAU(i). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(n-1). */ - -/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ -/* and tau in TAU(i). */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( d e v2 v3 v4 ) ( d ) */ -/* ( d e v3 v4 ) ( e d ) */ -/* ( d e v4 ) ( v1 e d ) */ -/* ( d e ) ( v1 v2 e d ) */ -/* ( d ) ( v1 v2 v3 e d ) */ - -/* where d and e denote diagonal and off-diagonal elements of T, and vi */ -/* denotes an element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --d__; - --e; - --tau; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTD2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - - if (upper) { - -/* Reduce the upper triangle of A */ - - for (i__ = *n - 1; i__ >= 1; --i__) { - -/* Generate elementary reflector H(i) = I - tau * v * v' */ -/* to annihilate A(1:i-1,i+1) */ - - dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 - + 1], &c__1, &taui); - e[i__] = a[i__ + (i__ + 1) * a_dim1]; - - if (taui != 0.) { - -/* Apply H(i) from both sides to A(1:i,1:i) */ - - a[i__ + (i__ + 1) * a_dim1] = 1.; - -/* Compute x := tau * A * v storing x in TAU(1:i) */ - - dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * - a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1); - -/* Compute w := x - 1/2 * tau * (x'*v) * v */ - - alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) - * a_dim1 + 1], &c__1); - daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ - 1], &c__1); - -/* Apply the transformation as a rank-2 update: */ -/* A := A - v * w' - w * v' */ - - dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, - &tau[1], &c__1, &a[a_offset], lda); - - a[i__ + (i__ + 1) * a_dim1] = e[i__]; - } - d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1]; - tau[i__] = taui; -/* L10: */ - } - d__[1] = a[a_dim1 + 1]; - } else { - -/* Reduce the lower triangle of A */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) = I - tau * v * v' */ -/* to annihilate A(i+2:n,i) */ - - i__2 = *n - i__; -/* Computing MIN */ - i__3 = i__ + 2; - dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *n)+ i__ * - a_dim1], &c__1, &taui); - e[i__] = a[i__ + 1 + i__ * a_dim1]; - - if (taui != 0.) { - -/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ - - a[i__ + 1 + i__ * a_dim1] = 1.; - -/* Compute x := tau * A * v storing y in TAU(i:n-1) */ - - i__2 = *n - i__; - dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ - i__], &c__1); - -/* Compute w := x - 1/2 * tau * (x'*v) * v */ - - i__2 = *n - i__; - alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + - 1 + i__ * a_dim1], &c__1); - i__2 = *n - i__; - daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ - i__], &c__1); - -/* Apply the transformation as a rank-2 update: */ -/* A := A - v * w' - w * v' */ - - i__2 = *n - i__; - dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, - &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], - lda); - - a[i__ + 1 + i__ * a_dim1] = e[i__]; - } - d__[i__] = a[i__ + i__ * a_dim1]; - tau[i__] = taui; -/* L20: */ - } - d__[*n] = a[*n + *n * a_dim1]; - } - - return 0; - -/* End of DSYTD2 */ - -} /* dsytd2_ */ diff --git a/external/clapack/lapack/dsytf2.cpp b/external/clapack/lapack/dsytf2.cpp deleted file mode 100644 index 6fa1d269..00000000 --- a/external/clapack/lapack/dsytf2.cpp +++ /dev/null @@ -1,583 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dsytf2_(const char *uplo, integer *n, double *a, integer * - lda, integer *ipiv, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double t, r1, d11, d12, d21, d22; - integer kk, kp; - double wk, wkm1, wkp1; - integer imax, jmax; - double alpha; - integer kstep; - bool upper; - double absakk; - double colmax, rowmax; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYTF2 computes the factorization of a real symmetric matrix A using */ -/* the Bunch-Kaufman diagonal pivoting method: */ - -/* A = U*D*U' or A = L*D*L' */ - -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, U' is the transpose of U, and D is symmetric and */ -/* block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored: */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n-by-n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n-by-n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L (see below for further details). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D. */ -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular, and division by zero will occur if it */ -/* is used to solve a system of equations. */ - -/* Further Details */ -/* =============== */ - -/* 09-29-06 - patch from */ -/* Bobby Cheng, MathWorks */ - -/* Replace l.204 and l.372 */ -/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */ -/* by */ -/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */ - -/* 01-01-96 - Based on modifications by */ -/* J. Lewis, Boeing Computer Services Company */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ -/* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */ -/* Company */ - -/* If UPLO = 'U', then A = U*D*U', where */ -/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */ -/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ -/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I v 0 ) k-s */ -/* U(k) = ( 0 I 0 ) s */ -/* ( 0 0 I ) n-k */ -/* k-s s n-k */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ -/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ -/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */ - -/* If UPLO = 'L', then A = L*D*L', where */ -/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ -/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ -/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I 0 0 ) k-1 */ -/* L(k) = ( 0 I 0 ) s */ -/* ( 0 v I ) n-k-s+1 */ -/* k-1 s n-k-s+1 */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ -/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ -/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTF2", &i__1); - return 0; - } - -/* Initialize ALPHA for use in choosing pivot block size. */ - - alpha = (sqrt(17.) + 1.) / 8.; - - if (upper) { - -/* Factorize A as U*D*U' using the upper triangle of A */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2 */ - - k = *n; -L10: - -/* If K < 1, exit from loop */ - - if (k < 1) { - goto L70; - } - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k > 1) { - i__1 = k - 1; - imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1); - colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); - } else { - colmax = 0.; - } - - if (std::max(absakk,colmax) == 0. || disnan_(&absakk)) { - -/* Column K is zero or contains a NaN: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - i__1 = k - imax; - jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * a_dim1], - lda); - rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); - if (imax > 1) { - i__1 = imax - 1; - jmax = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], - abs(d__1)); - rowmax = std::max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >= - alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - } else { - -/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k - kstep + 1; - if (kp != kk) { - -/* Interchange rows and columns KK and KP in the leading */ -/* submatrix A(1:k,1:k) */ - - i__1 = kp - 1; - dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], - &c__1); - i__1 = kk - kp - 1; - dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + - 1) * a_dim1], lda); - t = a[kk + kk * a_dim1]; - a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; - a[kp + kp * a_dim1] = t; - if (kstep == 2) { - t = a[k - 1 + k * a_dim1]; - a[k - 1 + k * a_dim1] = a[kp + k * a_dim1]; - a[kp + k * a_dim1] = t; - } - } - -/* Update the leading submatrix */ - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column k now holds */ - -/* W(k) = U(k)*D(k) */ - -/* where U(k) is the k-th column of U */ - -/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ - -/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */ - - r1 = 1. / a[k + k * a_dim1]; - i__1 = k - 1; - d__1 = -r1; - dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[ - a_offset], lda); - -/* Store U(k) in column k */ - - i__1 = k - 1; - dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); - } else { - -/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ - -/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ - -/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ -/* of U */ - -/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ - -/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */ -/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */ - - if (k > 2) { - - d12 = a[k - 1 + k * a_dim1]; - d22 = a[k - 1 + (k - 1) * a_dim1] / d12; - d11 = a[k + k * a_dim1] / d12; - t = 1. / (d11 * d22 - 1.); - d12 = t / d12; - - for (j = k - 2; j >= 1; --j) { - wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k - * a_dim1]); - wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * - a_dim1]); - for (i__ = j; i__ >= 1; --i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] * wk - a[i__ + (k - 1) * - a_dim1] * wkm1; -/* L20: */ - } - a[j + k * a_dim1] = wk; - a[j + (k - 1) * a_dim1] = wkm1; -/* L30: */ - } - - } - - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k - 1] = -kp; - } - -/* Decrease K and return to the start of the main loop */ - - k -= kstep; - goto L10; - - } else { - -/* Factorize A as L*D*L' using the lower triangle of A */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2 */ - - k = 1; -L40: - -/* If K > N, exit from loop */ - - if (k > *n) { - goto L70; - } - kstep = 1; - -/* Determine rows and columns to be interchanged and whether */ -/* a 1-by-1 or 2-by-2 pivot block will be used */ - - absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); - -/* IMAX is the row-index of the largest off-diagonal element in */ -/* column K, and COLMAX is its absolute value */ - - if (k < *n) { - i__1 = *n - k; - imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1); - colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); - } else { - colmax = 0.; - } - - if (std::max(absakk,colmax) == 0. || disnan_(&absakk)) { - -/* Column K is zero or contains a NaN: set INFO and continue */ - - if (*info == 0) { - *info = k; - } - kp = k; - } else { - if (absakk >= alpha * colmax) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else { - -/* JMAX is the column-index of the largest off-diagonal */ -/* element in row IMAX, and ROWMAX is its absolute value */ - - i__1 = imax - k; - jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda); - rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); - if (imax < *n) { - i__1 = *n - imax; - jmax = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1], - &c__1); -/* Computing MAX */ - d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], - abs(d__1)); - rowmax = std::max(d__2,d__3); - } - - if (absakk >= alpha * colmax * (colmax / rowmax)) { - -/* no interchange, use 1-by-1 pivot block */ - - kp = k; - } else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >= - alpha * rowmax) { - -/* interchange rows and columns K and IMAX, use 1-by-1 */ -/* pivot block */ - - kp = imax; - } else { - -/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ -/* pivot block */ - - kp = imax; - kstep = 2; - } - } - - kk = k + kstep - 1; - if (kp != kk) { - -/* Interchange rows and columns KK and KP in the trailing */ -/* submatrix A(k:n,k:n) */ - - if (kp < *n) { - i__1 = *n - kp; - dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 - + kp * a_dim1], &c__1); - } - i__1 = kp - kk - 1; - dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + - 1) * a_dim1], lda); - t = a[kk + kk * a_dim1]; - a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; - a[kp + kp * a_dim1] = t; - if (kstep == 2) { - t = a[k + 1 + k * a_dim1]; - a[k + 1 + k * a_dim1] = a[kp + k * a_dim1]; - a[kp + k * a_dim1] = t; - } - } - -/* Update the trailing submatrix */ - - if (kstep == 1) { - -/* 1-by-1 pivot block D(k): column k now holds */ - -/* W(k) = L(k)*D(k) */ - -/* where L(k) is the k-th column of L */ - - if (k < *n) { - -/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ - -/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */ - - d11 = 1. / a[k + k * a_dim1]; - i__1 = *n - k; - d__1 = -d11; - dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, & - a[k + 1 + (k + 1) * a_dim1], lda); - -/* Store L(k) in column K */ - - i__1 = *n - k; - dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1); - } - } else { - -/* 2-by-2 pivot block D(k) */ - - if (k < *n - 1) { - -/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ - -/* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))' */ - -/* where L(k) and L(k+1) are the k-th and (k+1)-th */ -/* columns of L */ - - d21 = a[k + 1 + k * a_dim1]; - d11 = a[k + 1 + (k + 1) * a_dim1] / d21; - d22 = a[k + k * a_dim1] / d21; - t = 1. / (d11 * d22 - 1.); - d21 = t / d21; - - i__1 = *n; - for (j = k + 2; j <= i__1; ++j) { - - wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * - a_dim1]); - wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k - * a_dim1]); - - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] * wk - a[i__ + (k + 1) * - a_dim1] * wkp1; -/* L50: */ - } - - a[j + k * a_dim1] = wk; - a[j + (k + 1) * a_dim1] = wkp1; - -/* L60: */ - } - } - } - } - -/* Store details of the interchanges in IPIV */ - - if (kstep == 1) { - ipiv[k] = kp; - } else { - ipiv[k] = -kp; - ipiv[k + 1] = -kp; - } - -/* Increase K and return to the start of the main loop */ - - k += kstep; - goto L40; - - } - -L70: - - return 0; - -/* End of DSYTF2 */ - -} /* dsytf2_ */ diff --git a/external/clapack/lapack/dsytrd.cpp b/external/clapack/lapack/dsytrd.cpp deleted file mode 100644 index 61fe7a60..00000000 --- a/external/clapack/lapack/dsytrd.cpp +++ /dev/null @@ -1,337 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; -static double c_b22 = -1.; -static double c_b23 = 1.; - -/* Subroutine */ int dsytrd_(const char *uplo, integer *n, double *a, integer * - lda, double *d__, double *e, double *tau, double * - work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, nb, kk, nx, iws; - integer nbmin, iinfo; - bool upper; - integer ldwork, lwkopt; - bool lquery; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYTRD reduces a real symmetric matrix A to real symmetric */ -/* tridiagonal form T by an orthogonal similarity transformation: */ -/* Q**T * A * Q = T. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ -/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ -/* of A are overwritten by the corresponding elements of the */ -/* tridiagonal matrix T, and the elements above the first */ -/* superdiagonal, with the array TAU, represent the orthogonal */ -/* matrix Q as a product of elementary reflectors; if UPLO */ -/* = 'L', the diagonal and first subdiagonal of A are over- */ -/* written by the corresponding elements of the tridiagonal */ -/* matrix T, and the elements below the first subdiagonal, 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,N). */ - -/* D (output) DOUBLE PRECISION array, dimension (N) */ -/* The diagonal elements of the tridiagonal matrix T: */ -/* D(i) = A(i,i). */ - -/* E (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The off-diagonal elements of the tridiagonal matrix T: */ -/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ - -/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ -/* The scalar factors of the elementary reflectors (see Further */ -/* Details). */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= 1. */ -/* For optimum performance LWORK >= N*NB, where NB is the */ -/* optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(n-1) . . . H(2) H(1). */ - -/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ -/* A(1:i-1,i+1), and tau in TAU(i). */ - -/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ -/* reflectors */ - -/* Q = H(1) H(2) . . . H(n-1). */ - -/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ -/* and tau in TAU(i). */ - -/* The contents of A on exit are illustrated by the following examples */ -/* with n = 5: */ - -/* if UPLO = 'U': if UPLO = 'L': */ - -/* ( d e v2 v3 v4 ) ( d ) */ -/* ( d e v3 v4 ) ( e d ) */ -/* ( d e v4 ) ( v1 e d ) */ -/* ( d e ) ( v1 v2 e d ) */ -/* ( d ) ( v1 v2 v3 e d ) */ - -/* where d and e denote diagonal and off-diagonal elements of T, and vi */ -/* denotes an element of the vector defining H(i). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --d__; - --e; - --tau; - --work; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else if (*lwork < 1 && ! lquery) { - *info = -9; - } - - if (*info == 0) { - -/* Determine the block size. */ - - nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTRD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - work[1] = 1.; - return 0; - } - - nx = *n; - iws = 1; - if (nb > 1 && nb < *n) { - -/* Determine when to cross over from blocked to unblocked code */ -/* (last block is always handled by unblocked code). */ - -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, "DSYTRD", uplo, n, &c_n1, &c_n1, & - c_n1); - nx = std::max(i__1,i__2); - if (nx < *n) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: determine the */ -/* minimum value of NB, and reduce NB or force use of */ -/* unblocked code by setting NX = N. */ - -/* Computing MAX */ - i__1 = *lwork / ldwork; - nb = std::max(i__1,1_integer); - nbmin = ilaenv_(&c__2, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); - if (nb < nbmin) { - nx = *n; - } - } - } else { - nx = *n; - } - } else { - nb = 1; - } - - if (upper) { - -/* Reduce the upper triangle of A. */ -/* Columns 1:kk are handled by the unblocked method. */ - - kk = *n - (*n - nx + nb - 1) / nb * nb; - i__1 = kk + 1; - i__2 = -nb; - for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { - -/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ -/* matrix W which is needed to update the unreduced part of */ -/* the matrix */ - - i__3 = i__ + nb - 1; - dlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & - work[1], &ldwork); - -/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ -/* update of the form: A := A - V*W' - W*V' */ - - i__3 = i__ - 1; - dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 - + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda); - -/* Copy superdiagonal elements back into A, and diagonal */ -/* elements into D */ - - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j - 1 + j * a_dim1] = e[j - 1]; - d__[j] = a[j + j * a_dim1]; -/* L10: */ - } -/* L20: */ - } - -/* Use unblocked code to reduce the last or only block */ - - dsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo); - } else { - -/* Reduce the lower triangle of A */ - - i__2 = *n - nx; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { - -/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ -/* matrix W which is needed to update the unreduced part of */ -/* the matrix */ - - i__3 = *n - i__ + 1; - dlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & - tau[i__], &work[1], &ldwork); - -/* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */ -/* an update of the form: A := A - V*W' - W*V' */ - - i__3 = *n - i__ - nb + 1; - dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + - i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ - i__ + nb + (i__ + nb) * a_dim1], lda); - -/* Copy subdiagonal elements back into A, and diagonal */ -/* elements into D */ - - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a[j + 1 + j * a_dim1] = e[j]; - d__[j] = a[j + j * a_dim1]; -/* L30: */ - } -/* L40: */ - } - -/* Use unblocked code to reduce the last or only block */ - - i__1 = *n - i__ + 1; - dsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], - &tau[i__], &iinfo); - } - - work[1] = (double) lwkopt; - return 0; - -/* End of DSYTRD */ - -} /* dsytrd_ */ diff --git a/external/clapack/lapack/dsytrf.cpp b/external/clapack/lapack/dsytrf.cpp deleted file mode 100644 index 8f21a1a2..00000000 --- a/external/clapack/lapack/dsytrf.cpp +++ /dev/null @@ -1,321 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; - -/* Subroutine */ int dsytrf_(const char *uplo, integer *n, double *a, integer * - lda, integer *ipiv, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer j, k, kb, nb, iws; - - integer nbmin, iinfo; - bool upper; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYTRF computes the factorization of a real symmetric matrix A using */ -/* the Bunch-Kaufman diagonal pivoting method. The form of the */ -/* factorization is */ - -/* A = U*D*U**T or A = L*D*L**T */ - -/* where U (or L) is a product of permutation and unit upper (lower) */ -/* triangular matrices, and D is symmetric and block diagonal with */ -/* 1-by-1 and 2-by-2 diagonal blocks. */ - -/* This is the blocked version of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, the block diagonal matrix D and the multipliers used */ -/* to obtain the factor U or L (see below for further details). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (output) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D. */ -/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ -/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ -/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ -/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ -/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ -/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ -/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The length of WORK. LWORK >=1. For best performance */ -/* LWORK >= N*NB, where NB is the block size returned by ILAENV. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ -/* has been completed, but the block diagonal matrix D is */ -/* exactly singular, and division by zero will occur if it */ -/* is used to solve a system of equations. */ - -/* Further Details */ -/* =============== */ - -/* If UPLO = 'U', then A = U*D*U', where */ -/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */ -/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ -/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I v 0 ) k-s */ -/* U(k) = ( 0 I 0 ) s */ -/* ( 0 0 I ) n-k */ -/* k-s s n-k */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ -/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ -/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */ - -/* If UPLO = 'L', then A = L*D*L', where */ -/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ -/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ -/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ -/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ -/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ -/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ - -/* ( I 0 0 ) k-1 */ -/* L(k) = ( 0 I 0 ) s */ -/* ( 0 v I ) n-k-s+1 */ -/* k-1 s n-k-s+1 */ - -/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ -/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ -/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - --work; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - lquery = *lwork == -1; - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } else if (*lwork < 1 && ! lquery) { - *info = -7; - } - - if (*info == 0) { - -/* Determine the block size */ - - nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1); - lwkopt = *n * nb; - work[1] = (double) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTRF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - - nbmin = 2; - ldwork = *n; - if (nb > 1 && nb < *n) { - iws = ldwork * nb; - if (*lwork < iws) { -/* Computing MAX */ - i__1 = *lwork / ldwork; - nb = std::max(i__1,1_integer); -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DSYTRF", uplo, n, &c_n1, &c_n1, & - c_n1); - nbmin = std::max(i__1,i__2); - } - } else { - iws = 1; - } - if (nb < nbmin) { - nb = *n; - } - - if (upper) { - -/* Factorize A as U*D*U' using the upper triangle of A */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* KB, where KB is the number of columns factorized by DLASYF; */ -/* KB is either NB or NB-1, or K for the last block */ - - k = *n; -L10: - -/* If K < 1, exit from loop */ - - if (k < 1) { - goto L40; - } - - if (k > nb) { - -/* Factorize columns k-kb+1:k of A and use blocked code to */ -/* update columns 1:k-kb */ - - dlasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1], - &ldwork, &iinfo); - } else { - -/* Use unblocked code to factorize columns 1:k of A */ - - dsytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo); - kb = k; - } - -/* Set INFO on the first occurrence of a zero pivot */ - - if (*info == 0 && iinfo > 0) { - *info = iinfo; - } - -/* Decrease K and return to the start of the main loop */ - - k -= kb; - goto L10; - - } else { - -/* Factorize A as L*D*L' using the lower triangle of A */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* KB, where KB is the number of columns factorized by DLASYF; */ -/* KB is either NB or NB-1, or N-K+1 for the last block */ - - k = 1; -L20: - -/* If K > N, exit from loop */ - - if (k > *n) { - goto L40; - } - - if (k <= *n - nb) { - -/* Factorize columns k:k+kb-1 of A and use blocked code to */ -/* update columns k+kb:n */ - - i__1 = *n - k + 1; - dlasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], - &work[1], &ldwork, &iinfo); - } else { - -/* Use unblocked code to factorize columns k:n of A */ - - i__1 = *n - k + 1; - dsytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo); - kb = *n - k + 1; - } - -/* Set INFO on the first occurrence of a zero pivot */ - - if (*info == 0 && iinfo > 0) { - *info = iinfo + k - 1; - } - -/* Adjust IPIV */ - - i__1 = k + kb - 1; - for (j = k; j <= i__1; ++j) { - if (ipiv[j] > 0) { - ipiv[j] = ipiv[j] + k - 1; - } else { - ipiv[j] = ipiv[j] - k + 1; - } -/* L30: */ - } - -/* Increase K and return to the start of the main loop */ - - k += kb; - goto L20; - - } - -L40: - work[1] = (double) lwkopt; - return 0; - -/* End of DSYTRF */ - -} /* dsytrf_ */ diff --git a/external/clapack/lapack/dsytri.cpp b/external/clapack/lapack/dsytri.cpp deleted file mode 100644 index 0f16c9a4..00000000 --- a/external/clapack/lapack/dsytri.cpp +++ /dev/null @@ -1,375 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b11 = -1.; -static double c_b13 = 0.; - -/* Subroutine */ int dsytri_(const char *uplo, integer *n, double *a, integer * - lda, integer *ipiv, double *work, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - double d__1; - - /* Local variables */ - double d__; - integer k; - double t, ak; - integer kp; - double akp1; - double temp, akkp1; - integer kstep; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYTRI computes the inverse of a real symmetric indefinite matrix */ -/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ -/* DSYTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the details of the factorization are stored */ -/* as an upper or lower triangular matrix. */ -/* = 'U': Upper triangular, form is A = U*D*U**T; */ -/* = 'L': Lower triangular, form is A = L*D*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the block diagonal matrix D and the multipliers */ -/* used to obtain the factor U or L as computed by DSYTRF. */ - -/* On exit, if INFO = 0, the (symmetric) inverse of the original */ -/* matrix. If UPLO = 'U', the upper triangular part of the */ -/* inverse is formed and the part of A below the diagonal is not */ -/* referenced; if UPLO = 'L' the lower triangular part of the */ -/* inverse is formed and the part of A above the diagonal is */ -/* not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSYTRF. */ - -/* 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 */ -/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ -/* inverse could not be computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - --work; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check that the diagonal matrix D is nonsingular. */ - - if (upper) { - -/* Upper triangular storage: examine D from bottom to top */ - - for (*info = *n; *info >= 1; --(*info)) { - if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L10: */ - } - } else { - -/* Lower triangular storage: examine D from top to bottom. */ - - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L20: */ - } - } - *info = 0; - - if (upper) { - -/* Compute inv(A) from the factorization A = U*D*U'. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; -L30: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L40; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Invert the diagonal block. */ - - a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; - -/* Compute column K of the inverse. */ - - if (k > 1) { - i__1 = k - 1; - dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); - i__1 = k - 1; - dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & - c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); - i__1 = k - 1; - a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * - a_dim1 + 1], &c__1); - } - kstep = 1; - } else { - -/* 2 x 2 diagonal block */ - -/* Invert the diagonal block. */ - - t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1)); - ak = a[k + k * a_dim1] / t; - akp1 = a[k + 1 + (k + 1) * a_dim1] / t; - akkp1 = a[k + (k + 1) * a_dim1] / t; - d__ = t * (ak * akp1 - 1.); - a[k + k * a_dim1] = akp1 / d__; - a[k + 1 + (k + 1) * a_dim1] = ak / d__; - a[k + (k + 1) * a_dim1] = -akkp1 / d__; - -/* Compute columns K and K+1 of the inverse. */ - - if (k > 1) { - i__1 = k - 1; - dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); - i__1 = k - 1; - dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & - c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); - i__1 = k - 1; - a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * - a_dim1 + 1], &c__1); - i__1 = k - 1; - a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], & - c__1, &a[(k + 1) * a_dim1 + 1], &c__1); - i__1 = k - 1; - dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & - c__1); - i__1 = k - 1; - dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & - c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1); - i__1 = k - 1; - a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & - a[(k + 1) * a_dim1 + 1], &c__1); - } - kstep = 2; - } - - kp = (i__1 = ipiv[k], abs(i__1)); - if (kp != k) { - -/* Interchange rows and columns K and KP in the leading */ -/* submatrix A(1:k+1,1:k+1) */ - - i__1 = kp - 1; - dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & - c__1); - i__1 = k - kp - 1; - dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * - a_dim1], lda); - temp = a[k + k * a_dim1]; - a[k + k * a_dim1] = a[kp + kp * a_dim1]; - a[kp + kp * a_dim1] = temp; - if (kstep == 2) { - temp = a[k + (k + 1) * a_dim1]; - a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1]; - a[kp + (k + 1) * a_dim1] = temp; - } - } - - k += kstep; - goto L30; -L40: - - ; - } else { - -/* Compute inv(A) from the factorization A = L*D*L'. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = *n; -L50: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L60; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Invert the diagonal block. */ - - a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; - -/* Compute column K of the inverse. */ - - if (k < *n) { - i__1 = *n - k; - dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); - i__1 = *n - k; - dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, - &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & - c__1); - i__1 = *n - k; - a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + - k * a_dim1], &c__1); - } - kstep = 1; - } else { - -/* 2 x 2 diagonal block */ - -/* Invert the diagonal block. */ - - t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1)); - ak = a[k - 1 + (k - 1) * a_dim1] / t; - akp1 = a[k + k * a_dim1] / t; - akkp1 = a[k + (k - 1) * a_dim1] / t; - d__ = t * (ak * akp1 - 1.); - a[k - 1 + (k - 1) * a_dim1] = akp1 / d__; - a[k + k * a_dim1] = ak / d__; - a[k + (k - 1) * a_dim1] = -akkp1 / d__; - -/* Compute columns K-1 and K of the inverse. */ - - if (k < *n) { - i__1 = *n - k; - dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); - i__1 = *n - k; - dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, - &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & - c__1); - i__1 = *n - k; - a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + - k * a_dim1], &c__1); - i__1 = *n - k; - a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1] -, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1); - i__1 = *n - k; - dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & - c__1); - i__1 = *n - k; - dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, - &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1] -, &c__1); - i__1 = *n - k; - a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & - a[k + 1 + (k - 1) * a_dim1], &c__1); - } - kstep = 2; - } - - kp = (i__1 = ipiv[k], abs(i__1)); - if (kp != k) { - -/* Interchange rows and columns K and KP in the trailing */ -/* submatrix A(k-1:n,k-1:n) */ - - if (kp < *n) { - i__1 = *n - kp; - dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * - a_dim1], &c__1); - } - i__1 = kp - k - 1; - dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * - a_dim1], lda); - temp = a[k + k * a_dim1]; - a[k + k * a_dim1] = a[kp + kp * a_dim1]; - a[kp + kp * a_dim1] = temp; - if (kstep == 2) { - temp = a[k + (k - 1) * a_dim1]; - a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1]; - a[kp + (k - 1) * a_dim1] = temp; - } - } - - k -= kstep; - goto L50; -L60: - ; - } - - return 0; - -/* End of DSYTRI */ - -} /* dsytri_ */ diff --git a/external/clapack/lapack/dsytrs.cpp b/external/clapack/lapack/dsytrs.cpp deleted file mode 100644 index a42495ea..00000000 --- a/external/clapack/lapack/dsytrs.cpp +++ /dev/null @@ -1,430 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b7 = -1.; -static integer c__1 = 1; -static double c_b19 = 1.; - -/* Subroutine */ int dsytrs_(const char *uplo, integer *n, integer *nrhs, - double *a, integer *lda, integer *ipiv, double *b, integer * - ldb, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - double d__1; - - /* Local variables */ - integer j, k; - double ak, bk; - integer kp; - double akm1, bkm1; - double akm1k; - double denom; - bool upper; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DSYTRS solves a system of linear equations A*X = B with a real */ -/* symmetric matrix A using the factorization A = U*D*U**T or */ -/* A = L*D*L**T computed by DSYTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the details of the factorization are stored */ -/* as an upper or lower triangular matrix. */ -/* = 'U': Upper triangular, form is A = U*D*U**T; */ -/* = 'L': Lower triangular, form is A = L*D*L**T. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The block diagonal matrix D and the multipliers used to */ -/* obtain the factor U or L as computed by DSYTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* Details of the interchanges and the block structure of D */ -/* as determined by DSYTRF. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DSYTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B, where A = U*D*U'. */ - -/* First solve U*D*X = B, overwriting B with X. */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = *n; -L10: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L30; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(U(K)), where U(K) is the transformation */ -/* stored in column K of A. */ - - i__1 = k - 1; - dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + - b_dim1], ldb, &b[b_dim1 + 1], ldb); - -/* Multiply by the inverse of the diagonal block. */ - - d__1 = 1. / a[k + k * a_dim1]; - dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); - --k; - } else { - -/* 2 x 2 diagonal block */ - -/* Interchange rows K-1 and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k - 1) { - dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(U(K)), where U(K) is the transformation */ -/* stored in columns K-1 and K of A. */ - - i__1 = k - 2; - dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + - b_dim1], ldb, &b[b_dim1 + 1], ldb); - i__1 = k - 2; - dger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k - - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb); - -/* Multiply by the inverse of the diagonal block. */ - - akm1k = a[k - 1 + k * a_dim1]; - akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k; - ak = a[k + k * a_dim1] / akm1k; - denom = akm1 * ak - 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - bkm1 = b[k - 1 + j * b_dim1] / akm1k; - bk = b[k + j * b_dim1] / akm1k; - b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; - b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom; -/* L20: */ - } - k += -2; - } - - goto L10; -L30: - -/* Next solve U'*X = B, overwriting B with X. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; -L40: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L50; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Multiply by inv(U'(K)), where U(K) is the transformation */ -/* stored in column K of A. */ - - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * - a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - ++k; - } else { - -/* 2 x 2 diagonal block */ - -/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */ -/* stored in columns K and K+1 of A. */ - - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * - a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); - i__1 = k - 1; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[(k - + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + b_dim1], - ldb); - -/* Interchange rows K and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - k += 2; - } - - goto L40; -L50: - - ; - } else { - -/* Solve A*X = B, where A = L*D*L'. */ - -/* First solve L*D*X = B, overwriting B with X. */ - -/* K is the main loop index, increasing from 1 to N in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = 1; -L60: - -/* If K > N, exit from loop. */ - - if (k > *n) { - goto L80; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(L(K)), where L(K) is the transformation */ -/* stored in column K of A. */ - - if (k < *n) { - i__1 = *n - k; - dger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k - + b_dim1], ldb, &b[k + 1 + b_dim1], ldb); - } - -/* Multiply by the inverse of the diagonal block. */ - - d__1 = 1. / a[k + k * a_dim1]; - dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); - ++k; - } else { - -/* 2 x 2 diagonal block */ - -/* Interchange rows K+1 and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k + 1) { - dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - -/* Multiply by inv(L(K)), where L(K) is the transformation */ -/* stored in columns K and K+1 of A. */ - - if (k < *n - 1) { - i__1 = *n - k - 1; - dger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k - + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); - i__1 = *n - k - 1; - dger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1, - &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); - } - -/* Multiply by the inverse of the diagonal block. */ - - akm1k = a[k + 1 + k * a_dim1]; - akm1 = a[k + k * a_dim1] / akm1k; - ak = a[k + 1 + (k + 1) * a_dim1] / akm1k; - denom = akm1 * ak - 1.; - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - bkm1 = b[k + j * b_dim1] / akm1k; - bk = b[k + 1 + j * b_dim1] / akm1k; - b[k + j * b_dim1] = (ak * bkm1 - bk) / denom; - b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; -/* L70: */ - } - k += 2; - } - - goto L60; -L80: - -/* Next solve L'*X = B, overwriting B with X. */ - -/* K is the main loop index, decreasing from N to 1 in steps of */ -/* 1 or 2, depending on the size of the diagonal blocks. */ - - k = *n; -L90: - -/* If K < 1, exit from loop. */ - - if (k < 1) { - goto L100; - } - - if (ipiv[k] > 0) { - -/* 1 x 1 diagonal block */ - -/* Multiply by inv(L'(K)), where L(K) is the transformation */ -/* stored in column K of A. */ - - if (k < *n) { - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + - b_dim1], ldb); - } - -/* Interchange rows K and IPIV(K). */ - - kp = ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - --k; - } else { - -/* 2 x 2 diagonal block */ - -/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */ -/* stored in columns K-1 and K of A. */ - - if (k < *n) { - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + - b_dim1], ldb); - i__1 = *n - k; - dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], - ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[ - k - 1 + b_dim1], ldb); - } - -/* Interchange rows K and -IPIV(K). */ - - kp = -ipiv[k]; - if (kp != k) { - dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); - } - k += -2; - } - - goto L90; -L100: - ; - } - - return 0; - -/* End of DSYTRS */ - -} /* dsytrs_ */ diff --git a/external/clapack/lapack/dtbcon.cpp b/external/clapack/lapack/dtbcon.cpp deleted file mode 100644 index 9c57c7a4..00000000 --- a/external/clapack/lapack/dtbcon.cpp +++ /dev/null @@ -1,223 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dtbcon_(const char *norm, const char *uplo, const char *diag, integer *n, - integer *kd, double *ab, integer *ldab, double *rcond, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1; - double d__1; - - /* Local variables */ - integer ix, kase, kase1; - double scale; - integer isave[3]; - double anorm; - bool upper; - double xnorm; - double ainvnm; - bool onenrm; - char normin[1]; - double smlnum; - bool nounit; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTBCON estimates the reciprocal of the condition number of a */ -/* triangular band matrix A, in either the 1-norm or the infinity-norm. */ - -/* The norm of A is computed and an estimate is obtained for */ -/* norm(inv(A)), then the reciprocal of the condition number is */ -/* computed as */ -/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals or subdiagonals of the */ -/* triangular band matrix A. KD >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangular band matrix A, stored in the */ -/* first kd+1 rows of the array. The j-th column of A is stored */ -/* in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ -/* If DIAG = 'U', the diagonal elements of A are not referenced */ -/* and are assumed to be 1. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); - nounit = lsame_(diag, "N"); - - if (! onenrm && ! lsame_(norm, "I")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*kd < 0) { - *info = -5; - } else if (*ldab < *kd + 1) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTBCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *rcond = 1.; - return 0; - } - - *rcond = 0.; - smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n); - -/* Compute the norm of the triangular matrix A. */ - - anorm = dlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]); - -/* Continue only if ANORM > 0. */ - - if (anorm > 0.) { - -/* Estimate the norm of the inverse of A. */ - - ainvnm = 0.; - *(unsigned char *)normin = 'N'; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kase = 0; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(A). */ - - dlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[ - ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + - 1], info) - ; - } else { - -/* Multiply by inv(A'). */ - - dlatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset] -, ldab, &work[1], &scale, &work[(*n << 1) + 1], info); - } - *(unsigned char *)normin = 'Y'; - -/* Multiply by 1/SCALE if doing so will not cause overflow. */ - - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - xnorm = (d__1 = work[ix], abs(d__1)); - if (scale < xnorm * smlnum || scale == 0.) { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / anorm / ainvnm; - } - } - -L20: - return 0; - -/* End of DTBCON */ - -} /* dtbcon_ */ diff --git a/external/clapack/lapack/dtbrfs.cpp b/external/clapack/lapack/dtbrfs.cpp deleted file mode 100644 index a36180d1..00000000 --- a/external/clapack/lapack/dtbrfs.cpp +++ /dev/null @@ -1,496 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b19 = -1.; - -/* Subroutine */ int dtbrfs_(const char *uplo, const char *trans, const char *diag, integer *n, - integer *kd, integer *nrhs, double *ab, integer *ldab, double - *b, integer *ldb, double *x, integer *ldx, double *ferr, - double *berr, double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, - i__2, i__3, i__4, i__5; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s, xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - bool upper; - double safmin; - bool notran; - char transt[1]; - bool nounit; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTBRFS provides error bounds and backward error estimates for the */ -/* solution to a system of linear equations with a triangular band */ -/* coefficient matrix. */ - -/* The solution matrix X must be computed by DTBTRS or some other */ -/* means before entering this routine. DTBRFS does not do iterative */ -/* refinement because doing so cannot improve the backward error. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals or subdiagonals of the */ -/* triangular band matrix A. KD >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangular band matrix A, stored in the */ -/* first kd+1 rows of the array. The j-th column of A is stored */ -/* in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ -/* If DIAG = 'U', the diagonal elements of A are not referenced */ -/* and are assumed to be 1. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* The solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - notran = lsame_(trans, "N"); - nounit = lsame_(diag, "N"); - - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*kd < 0) { - *info = -5; - } else if (*nrhs < 0) { - *info = -6; - } else if (*ldab < *kd + 1) { - *info = -8; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -10; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTBRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *kd + 2; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Compute residual R = B - op(A) * X, */ -/* where op(A) = A or A', depending on TRANS. */ - - dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*n + 1], - &c__1); - daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L20: */ - } - - if (notran) { - -/* Compute abs(A)*abs(X) + abs(B). */ - - if (upper) { - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); -/* Computing MAX */ - i__3 = 1, i__4 = k - *kd; - i__5 = k; - for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) { - work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k * - ab_dim1], abs(d__1)) * xk; -/* L30: */ - } -/* L40: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); -/* Computing MAX */ - i__5 = 1, i__3 = k - *kd; - i__4 = k - 1; - for (i__ = std::max(i__5,i__3); i__ <= i__4; ++i__) { - work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k * - ab_dim1], abs(d__1)) * xk; -/* L50: */ - } - work[k] += xk; -/* L60: */ - } - } - } else { - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); -/* Computing MIN */ - i__5 = *n, i__3 = k + *kd; - i__4 = std::min(i__5,i__3); - for (i__ = k; i__ <= i__4; ++i__) { - work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1] - , abs(d__1)) * xk; -/* L70: */ - } -/* L80: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); -/* Computing MIN */ - i__5 = *n, i__3 = k + *kd; - i__4 = std::min(i__5,i__3); - for (i__ = k + 1; i__ <= i__4; ++i__) { - work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1] - , abs(d__1)) * xk; -/* L90: */ - } - work[k] += xk; -/* L100: */ - } - } - } - } else { - -/* Compute abs(A')*abs(X) + abs(B). */ - - if (upper) { - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; -/* Computing MAX */ - i__4 = 1, i__5 = k - *kd; - i__3 = k; - for (i__ = std::max(i__4,i__5); i__ <= i__3; ++i__) { - s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1], - abs(d__1)) * (d__2 = x[i__ + j * x_dim1], - abs(d__2)); -/* L110: */ - } - work[k] += s; -/* L120: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = (d__1 = x[k + j * x_dim1], abs(d__1)); -/* Computing MAX */ - i__3 = 1, i__4 = k - *kd; - i__5 = k - 1; - for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) { - s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1], - abs(d__1)) * (d__2 = x[i__ + j * x_dim1], - abs(d__2)); -/* L130: */ - } - work[k] += s; -/* L140: */ - } - } - } else { - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; -/* Computing MIN */ - i__3 = *n, i__4 = k + *kd; - i__5 = std::min(i__3,i__4); - for (i__ = k; i__ <= i__5; ++i__) { - s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs( - d__1)) * (d__2 = x[i__ + j * x_dim1], abs( - d__2)); -/* L150: */ - } - work[k] += s; -/* L160: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = (d__1 = x[k + j * x_dim1], abs(d__1)); -/* Computing MIN */ - i__3 = *n, i__4 = k + *kd; - i__5 = std::min(i__3,i__4); - for (i__ = k + 1; i__ <= i__5; ++i__) { - s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs( - d__1)) * (d__2 = x[i__ + j * x_dim1], abs( - d__2)); -/* L170: */ - } - work[k] += s; -/* L180: */ - } - } - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L190: */ - } - berr[j] = s; - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(op(A)))* */ -/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(op(A)) is the inverse of op(A) */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(op(A)) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L200: */ - } - - kase = 0; -L210: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(op(A)'). */ - - dtbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[ - *n + 1], &c__1); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L220: */ - } - } else { - -/* Multiply by inv(op(A))*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L230: */ - } - dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[* - n + 1], &c__1); - } - goto L210; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L240: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L250: */ - } - - return 0; - -/* End of DTBRFS */ - -} /* dtbrfs_ */ diff --git a/external/clapack/lapack/dtbtrs.cpp b/external/clapack/lapack/dtbtrs.cpp deleted file mode 100644 index 8f8c4ce6..00000000 --- a/external/clapack/lapack/dtbtrs.cpp +++ /dev/null @@ -1,188 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dtbtrs_(const char *uplo, const char *trans, const char *diag, integer *n, - integer *kd, integer *nrhs, double *ab, integer *ldab, double - *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - integer j; - bool upper; - bool nounit; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTBTRS solves a triangular system of the form */ - -/* A * X = B or A**T * X = B, */ - -/* where A is a triangular band matrix of order N, and B is an */ -/* N-by NRHS matrix. A check is made to verify that A is nonsingular. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of superdiagonals or subdiagonals of the */ -/* triangular band matrix A. KD >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangular band matrix A, stored in the */ -/* first kd+1 rows of AB. The j-th column of A is stored */ -/* in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ -/* If DIAG = 'U', the diagonal elements of A are not referenced */ -/* and are assumed to be 1. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, if INFO = 0, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ -/* indicating that the matrix is singular and the */ -/* solutions X have not been computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*kd < 0) { - *info = -5; - } else if (*nrhs < 0) { - *info = -6; - } else if (*ldab < *kd + 1) { - *info = -8; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTBTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity. */ - - if (nounit) { - if (upper) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (ab[*kd + 1 + *info * ab_dim1] == 0.) { - return 0; - } -/* L10: */ - } - } else { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (ab[*info * ab_dim1 + 1] == 0.) { - return 0; - } -/* L20: */ - } - } - } - *info = 0; - -/* Solve A * X = B or A' * X = B. */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1 - + 1], &c__1); -/* L30: */ - } - - return 0; - -/* End of DTBTRS */ - -} /* dtbtrs_ */ diff --git a/external/clapack/lapack/dtfsm.cpp b/external/clapack/lapack/dtfsm.cpp deleted file mode 100644 index 0fba53db..00000000 --- a/external/clapack/lapack/dtfsm.cpp +++ /dev/null @@ -1,850 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b23 = -1.; -static double c_b27 = 1.; - -int dtfsm_(const char *transr, const char *side, const char *uplo, const char *trans, - const char *diag, integer *m, integer *n, double *alpha, double *a, double *b, integer *ldb) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, k, m1, m2, n1, n2, info; - bool normaltransr, lside, lower, misodd, nisodd, notrans; - - -/* -- LAPACK routine (version 3.2.1) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Level 3 BLAS like routine for A in RFP Format. */ - -/* DTFSM solves the matrix equation */ - -/* op( A )*X = alpha*B or X*op( A ) = alpha*B */ - -/* where alpha is a scalar, X and B are m by n matrices, 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'. */ - -/* A is in Rectangular Full Packed (RFP) Format. */ - -/* The matrix X is overwritten on B. */ - -/* Arguments */ -/* ========== */ - -/* TRANSR - (input) CHARACTER */ -/* = 'N': The Normal Form of RFP A is stored; */ -/* = 'T': The Transpose Form of RFP A is stored. */ - -/* SIDE - (input) CHARACTER */ -/* On entry, SIDE specifies whether op( A ) appears on the left */ -/* or right of X as follows: */ - -/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ - -/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ - -/* Unchanged on exit. */ - -/* UPLO - (input) CHARACTER */ -/* On entry, UPLO specifies whether the RFP matrix A came from */ -/* an upper or lower triangular matrix as follows: */ -/* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */ -/* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */ - -/* Unchanged on exit. */ - -/* TRANS - (input) CHARACTER */ -/* On entry, TRANS specifies the form of op( A ) to be used */ -/* in the matrix multiplication as follows: */ - -/* TRANS = 'N' or 'n' op( A ) = A. */ - -/* TRANS = 'T' or 't' op( A ) = A'. */ - -/* Unchanged on exit. */ - -/* DIAG - (input) CHARACTER */ -/* On entry, DIAG specifies whether or not RFP 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 - (input) INTEGER. */ -/* On entry, M specifies the number of rows of B. M must be at */ -/* least zero. */ -/* Unchanged on exit. */ - -/* N - (input) INTEGER. */ -/* On entry, N specifies the number of columns of B. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - (input) 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 - (input) DOUBLE PRECISION array, dimension (NT); */ -/* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. */ -/* RFP Format is described by TRANSR, UPLO and N as follows: */ -/* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */ -/* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */ -/* TRANSR = 'T' then RFP is the transpose of RFP A as */ -/* defined when TRANSR = 'N'. The contents of RFP A are defined */ -/* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT */ -/* elements of upper packed A either in normal or */ -/* transpose Format. If UPLO = 'L' the RFP A contains */ -/* the NT elements of lower packed A either in normal or */ -/* transpose Format. The LDA of RFP A is (N+1)/2 when */ -/* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */ -/* even and is N when is odd. */ -/* See the Note below for more details. Unchanged on exit. */ - -/* B - (input/ouptut) DOUBLE PRECISION array, DIMENSION (LDB,N) */ -/* Before entry, the leading m by n part of the array B must */ -/* contain the right-hand side matrix B, and on exit is */ -/* overwritten by the solution matrix X. */ - -/* LDB - (input) 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. */ - -/* Further Details */ -/* =============== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* Reference */ -/* ========= */ - -/* ===================================================================== */ - -/* .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - b_dim1 = *ldb - 1 - 0 + 1; - b_offset = 0 + b_dim1 * 0; - b -= b_offset; - - /* Function Body */ - info = 0; - normaltransr = lsame_(transr, "N"); - lside = lsame_(side, "L"); - lower = lsame_(uplo, "L"); - notrans = lsame_(trans, "N"); - if (! normaltransr && ! lsame_(transr, "T")) { - info = -1; - } else if (! lside && ! lsame_(side, "R")) { - info = -2; - } else if (! lower && ! lsame_(uplo, "U")) { - info = -3; - } else if (! notrans && ! lsame_(trans, "T")) { - info = -4; - } else if (! lsame_(diag, "N") && ! lsame_(diag, - "U")) { - info = -5; - } else if (*m < 0) { - info = -6; - } else if (*n < 0) { - info = -7; - } else if (*ldb < std::max(1_integer,*m)) { - info = -11; - } - if (info != 0) { - i__1 = -info; - xerbla_("DTFSM ", &i__1); - return 0; - } - -/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Quick return when ALPHA.EQ.(0D+0) */ - - if (*alpha == 0.) { - i__1 = *n - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = *m - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - b[i__ + j * b_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } - return 0; - } - - if (lside) { - -/* SIDE = 'L' */ - -/* A is M-by-M. */ -/* If M is odd, set NISODD = .TRUE., and M1 and M2. */ -/* If M is even, NISODD = .FALSE., and M. */ - - if (*m % 2 == 0) { - misodd = false; - k = *m / 2; - } else { - misodd = true; - if (lower) { - m2 = *m / 2; - m1 = *m - m2; - } else { - m1 = *m / 2; - m2 = *m - m1; - } - } - - - if (misodd) { - -/* SIDE = 'L' and N is odd */ - - if (normaltransr) { - -/* SIDE = 'L', N is odd, and TRANSR = 'N' */ - - if (lower) { - -/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */ - - if (notrans) { - -/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ -/* TRANS = 'N' */ - - if (*m == 1) { - dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &b[b_offset], ldb); - } else { - dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &b[b_offset], ldb); - dgemm_("N", "N", &m2, n, &m1, &c_b23, &a[m1], m, &b[b_offset], ldb, alpha, &b[m1], ldb); - dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[*m], m, &b[m1], ldb); - } - - } else { - -/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ -/* TRANS = 'T' */ - - if (*m == 1) { - dtrsm_("L", "L", "T", diag, &m1, n, alpha, a, m, &b[b_offset], ldb); - } else { - dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m], m, &b[m1], ldb); - dgemm_("T", "N", &m1, n, &m2, &c_b23, &a[m1], m, &b[m1], ldb, alpha, &b[b_offset], ldb); - dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, a, m, &b[b_offset], ldb); - } - - } - - } else { - -/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */ - - if (! notrans) { - -/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ -/* TRANS = 'N' */ - - dtrsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m, &b[b_offset], ldb); - dgemm_("T", "N", &m2, n, &m1, &c_b23, a, m, &b[b_offset], ldb, alpha, &b[m1], ldb); - dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[m1], m, &b[m1], ldb); - - } else { - -/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ -/* TRANS = 'T' */ - - dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m, &b[m1], ldb); - dgemm_("N", "N", &m1, n, &m2, &c_b23, a, m, &b[m1], ldb, alpha, &b[b_offset], ldb); - dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, &a[m2], m, &b[b_offset], ldb); - - } - - } - - } else { - -/* SIDE = 'L', N is odd, and TRANSR = 'T' */ - - if (lower) { - -/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' */ - - if (notrans) { - -/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */ -/* TRANS = 'N' */ - - if (*m == 1) { - dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb); - } else { - dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb); - dgemm_("T", "N", &m2, n, &m1, &c_b23, &a[m1 * m1], &m1, &b[b_offset], ldb, alpha, &b[m1], ldb); - dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[1], &m1, &b[m1], ldb); - } - - } else { - -/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */ -/* TRANS = 'T' */ - - if (*m == 1) { - dtrsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb); - } else { - dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[1], &m1, &b[m1], ldb); - dgemm_("N", "N", &m1, n, &m2, &c_b23, &a[m1 * m1], &m1, &b[m1], ldb, alpha, &b[b_offset], ldb); - dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, a, &m1, &b[b_offset], ldb); - } - - } - - } else { - -/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' */ - - if (! notrans) { - -/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */ -/* TRANS = 'N' */ - - dtrsm_("L", "U", "T", diag, &m1, n, alpha, &a[m2 * m2], &m2, &b[b_offset], ldb); - dgemm_("N", "N", &m2, n, &m1, &c_b23, a, &m2, &b[b_offset], ldb, alpha, &b[m1], ldb); - dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[m1 * m2], &m2, &b[m1], ldb); - - } else { - -/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */ -/* TRANS = 'T' */ - - dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[m1 * m2], &m2, &b[m1], ldb); - dgemm_("T", "N", &m1, n, &m2, &c_b23, a, &m2, &b[m1], ldb, alpha, &b[b_offset], ldb); - dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, &a[m2 * m2], &m2, &b[b_offset], ldb); - - } - - } - - } - - } else { - -/* SIDE = 'L' and N is even */ - - if (normaltransr) { - -/* SIDE = 'L', N is even, and TRANSR = 'N' */ - - if (lower) { - -/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */ - - if (notrans) { - -/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ -/* and TRANS = 'N' */ - - i__1 = *m + 1; - dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[1], &i__1, &b[b_offset], ldb); - i__1 = *m + 1; - dgemm_("N", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, &b[b_offset], ldb, alpha, &b[k], ldb); - i__1 = *m + 1; - dtrsm_("L", "U", "T", diag, &k, n, &c_b27, a, &i__1, &b[k], ldb); - - } else { - -/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ -/* and TRANS = 'T' */ - - i__1 = *m + 1; - dtrsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, &b[k], ldb); - i__1 = *m + 1; - dgemm_("T", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, &b[k], ldb, alpha, &b[b_offset], ldb); - i__1 = *m + 1; - dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[1], &i__1, &b[b_offset], ldb); - - } - - } else { - -/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */ - - if (! notrans) { - -/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ -/* and TRANS = 'N' */ - - i__1 = *m + 1; - dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], &i__1, &b[b_offset], ldb); - i__1 = *m + 1; - dgemm_("T", "N", &k, n, &k, &c_b23, a, &i__1, &b[b_offset], ldb, alpha, &b[k], ldb); - i__1 = *m + 1; - dtrsm_("L", "U", "T", diag, &k, n, &c_b27, &a[k], &i__1, &b[k], ldb); - - } else { - -/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ -/* and TRANS = 'T' */ - i__1 = *m + 1; - dtrsm_("L", "U", "N", diag, &k, n, alpha, &a[k], &i__1, &b[k], ldb); - i__1 = *m + 1; - dgemm_("N", "N", &k, n, &k, &c_b23, a, &i__1, &b[k], ldb, alpha, &b[b_offset], ldb); - i__1 = *m + 1; - dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[k + 1], &i__1, &b[b_offset], ldb); - - } - - } - - } else { - -/* SIDE = 'L', N is even, and TRANSR = 'T' */ - - if (lower) { - -/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' */ - - if (notrans) { - -/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */ -/* and TRANS = 'N' */ - - dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k], &k, &b[b_offset], ldb); - dgemm_("T", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &k, &b[b_offset], ldb, alpha, &b[k], ldb); - dtrsm_("L", "L", "N", diag, &k, n, &c_b27, a, &k, &b[k], ldb); - - } else { - -/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */ -/* and TRANS = 'T' */ - - dtrsm_("L", "L", "T", diag, &k, n, alpha, a, &k, &b[k], ldb); - dgemm_("N", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &k, &b[k], ldb, alpha, &b[b_offset], ldb); - dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k], &k, &b[b_offset], ldb); - - } - - } else { - -/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' */ - - if (! notrans) { - -/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */ -/* and TRANS = 'N' */ - - dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k * (k + 1)], &k, &b[b_offset], ldb); - dgemm_("N", "N", &k, n, &k, &c_b23, a, &k, &b[b_offset], ldb, alpha, &b[k], ldb); - dtrsm_("L", "L", "N", diag, &k, n, &c_b27, &a[k * k], &k, &b[k], ldb); - - } else { - -/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */ -/* and TRANS = 'T' */ - - dtrsm_("L", "L", "T", diag, &k, n, alpha, &a[k * k], &k, &b[k], ldb); - dgemm_("T", "N", &k, n, &k, &c_b23, a, &k, &b[k], ldb, alpha, &b[b_offset], ldb); - dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k * (k + 1)], &k, &b[b_offset], ldb); - - } - - } - - } - - } - - } else { - -/* SIDE = 'R' */ - -/* A is N-by-N. */ -/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ -/* If N is even, NISODD = .FALSE., and K. */ - - if (*n % 2 == 0) { - nisodd = false; - k = *n / 2; - } else { - nisodd = true; - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - } - - if (nisodd) { - -/* SIDE = 'R' and N is odd */ - - if (normaltransr) { - -/* SIDE = 'R', N is odd, and TRANSR = 'N' */ - - if (lower) { - -/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */ - - if (notrans) { - -/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ -/* TRANS = 'N' */ - - dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[*n], n, &b[n1 * b_dim1], ldb); - dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, &a[n1], n, alpha, b, ldb); - dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, a, n, b, ldb); - - } else { - -/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ -/* TRANS = 'T' */ - - dtrsm_("R", "L", "T", diag, m, &n1, alpha, a, n, b, ldb); - dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, &a[n1], n, alpha, &b[n1 * b_dim1], ldb); - dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[*n], n, &b[n1 * b_dim1], ldb); - - } - - } else { - -/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */ - - if (notrans) { - -/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ -/* TRANS = 'N' */ - - dtrsm_("R", "L", "T", diag, m, &n1, alpha, &a[n2], n, b, ldb); - dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, a, n, alpha, &b[n1 * b_dim1], ldb); - dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[n1], n, &b[n1 * b_dim1], ldb); - - } else { - -/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ -/* TRANS = 'T' */ - - dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[n1], n, &b[n1 * b_dim1], ldb); - dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, a, n, alpha, b, ldb); - dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, &a[n2], n, b, ldb); - - } - - } - - } else { - -/* SIDE = 'R', N is odd, and TRANSR = 'T' */ - - if (lower) { - -/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' */ - - if (notrans) { - -/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */ -/* TRANS = 'N' */ - - dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1, &b[n1 * b_dim1], ldb); - dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, &a[n1 * n1], &n1, alpha, b, ldb); - dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, a, &n1, b, ldb); - - } else { - -/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */ -/* TRANS = 'T' */ - - dtrsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b, ldb); - dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, &a[n1 * n1], &n1, alpha, &b[n1 * b_dim1], ldb); - dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[1], &n1, &b[n1 * b_dim1], ldb); - - } - - } else { - -/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' */ - - if (notrans) { - -/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */ -/* TRANS = 'N' */ - - dtrsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2], &n2, b, ldb); - dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, a, &n2, alpha, &b[n1 * b_dim1], ldb); - dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[n1 * n2], &n2, &b[n1 * b_dim1], ldb); - - } else { - -/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */ -/* TRANS = 'T' */ - - dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2], &n2, &b[n1 * b_dim1], ldb); - dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, a, &n2, alpha, b, ldb); - dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, &a[n2 * n2], &n2, b, ldb); - - } - - } - - } - - } else { - -/* SIDE = 'R' and N is even */ - - if (normaltransr) { - -/* SIDE = 'R', N is even, and TRANSR = 'N' */ - - if (lower) { - -/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */ - - if (notrans) { - -/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ -/* and TRANS = 'N' */ - - i__1 = *n + 1; - dtrsm_("R", "U", "T", diag, m, &k, alpha, a, &i__1, &b[k * b_dim1], ldb); - i__1 = *n + 1; - dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, &a[k + 1], &i__1, alpha, b, ldb); - i__1 = *n + 1; - dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[1], &i__1, b, ldb); - - } else { - -/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ -/* and TRANS = 'T' */ - - i__1 = *n + 1; - dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[1], &i__1, b, ldb); - i__1 = *n + 1; - dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, &a[k + 1], &i__1, alpha, &b[k * b_dim1], ldb); - i__1 = *n + 1; - dtrsm_("R", "U", "N", diag, m, &k, &c_b27, a, &i__1, &b[k * b_dim1], ldb); - - } - - } else { - -/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */ - - if (notrans) { - -/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ -/* and TRANS = 'N' */ - - i__1 = *n + 1; - dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[k + 1], &i__1, b, ldb); - i__1 = *n + 1; - dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, a, &i__1, alpha, &b[k * b_dim1], ldb); - i__1 = *n + 1; - dtrsm_("R", "U", "N", diag, m, &k, &c_b27, &a[k], &i__1, &b[k * b_dim1], ldb); - - } else { - -/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ -/* and TRANS = 'T' */ - - i__1 = *n + 1; - dtrsm_("R", "U", "T", diag, m, &k, alpha, &a[k], &i__1, &b[k * b_dim1], ldb); - i__1 = *n + 1; - dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, a, &i__1, alpha, b, ldb); - i__1 = *n + 1; - dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[k + 1], &i__1, b, ldb); - - } - - } - - } else { - -/* SIDE = 'R', N is even, and TRANSR = 'T' */ - - if (lower) { - -/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' */ - - if (notrans) { - -/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */ -/* and TRANS = 'N' */ - - dtrsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k * b_dim1], ldb); - dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, &a[(k + 1) * k], &k, alpha, b, ldb); - dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[k], &k, b, ldb); - - } else { - -/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */ -/* and TRANS = 'T' */ - - dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k, b, ldb); - dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, &a[(k + 1) * k], &k, alpha, &b[k * b_dim1], ldb); - dtrsm_("R", "L", "T", diag, m, &k, &c_b27, a, &k, &b[k * b_dim1], ldb); - - } - - } else { - -/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' */ - - if (notrans) { - -/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */ -/* and TRANS = 'N' */ - - dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) * k], &k, b, ldb); - dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, a, &k, alpha, &b[k * b_dim1], ldb); - dtrsm_("R", "L", "T", diag, m, &k, &c_b27, &a[k * k], &k, &b[k * b_dim1], ldb); - - } else { - -/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */ -/* and TRANS = 'T' */ - - dtrsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], &k, &b[k * b_dim1], ldb); - dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, a, &k, alpha, b, ldb); - dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[(k + 1) * k], &k, b, ldb); - - } - - } - - } - - } - } - - return 0; - -/* End of DTFSM */ - -} /* dtfsm_ */ diff --git a/external/clapack/lapack/dtftri.cpp b/external/clapack/lapack/dtftri.cpp deleted file mode 100644 index ba6c073e..00000000 --- a/external/clapack/lapack/dtftri.cpp +++ /dev/null @@ -1,440 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b13 = -1.; -static double c_b18 = 1.; - -int dtftri_(const char *transr, const char *uplo, const char *diag, integer *n, double *a, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer k, n1, n2; - bool normaltransr, lower, nisodd; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTFTRI computes the inverse of a triangular matrix A stored in RFP */ -/* format. */ - -/* This is a Level 3 BLAS version of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': The Normal TRANSR of RFP A is stored; */ -/* = 'T': The Transpose TRANSR of RFP A is stored. */ - -/* UPLO (input) CHARACTER */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (0:nt-1); */ -/* nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian */ -/* Positive Definite matrix A in RFP format. RFP format is */ -/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ -/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ -/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */ -/* the transpose of RFP A as defined when */ -/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ -/* follows: If UPLO = 'U' the RFP A contains the nt elements of */ -/* upper packed A; If UPLO = 'L' the RFP A contains the nt */ -/* elements of lower packed A. The LDA of RFP A is (N+1)/2 when */ -/* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */ -/* even and N is odd. See the Note below for more details. */ - -/* On exit, the (triangular) inverse of the original matrix, in */ -/* the same storage format. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ -/* matrix is singular and its inverse can not be computed. */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - *info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - if (! normaltransr && ! lsame_(transr, "T")) { - *info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - *info = -2; - } else if (! lsame_(diag, "N") && ! lsame_(diag, - "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTFTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* If N is odd, set NISODD = .TRUE. */ -/* If N is even, set K = N/2 and NISODD = .FALSE. */ - - if (*n % 2 == 0) { - k = *n / 2; - nisodd = false; - } else { - nisodd = true; - } - -/* Set N1 and N2 depending on LOWER */ - - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - - -/* start execution: there are eight cases */ - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ -/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ -/* T1 -> a(0), T2 -> a(n), S -> a(n1) */ - - dtrtri_("L", diag, &n1, a, n, info); - if (*info > 0) { - return 0; - } - dtrmm_("R", "L", "N", diag, &n2, &n1, &c_b13, a, n, &a[n1], n); - dtrtri_("U", diag, &n2, &a[*n], n, info) - ; - if (*info > 0) { - *info += n1; - } - if (*info > 0) { - return 0; - } - dtrmm_("L", "U", "T", diag, &n2, &n1, &c_b18, &a[*n], n, &a[ - n1], n); - - } else { - -/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ -/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ -/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ - - dtrtri_("L", diag, &n1, &a[n2], n, info) - ; - if (*info > 0) { - return 0; - } - dtrmm_("L", "L", "T", diag, &n1, &n2, &c_b13, &a[n2], n, a, n); - dtrtri_("U", diag, &n2, &a[n1], n, info) - ; - if (*info > 0) { - *info += n1; - } - if (*info > 0) { - return 0; - } - dtrmm_("R", "U", "N", diag, &n1, &n2, &c_b18, &a[n1], n, a, n); - - } - - } else { - -/* N is odd and TRANSR = 'T' */ - - if (lower) { - -/* SRPA for LOWER, TRANSPOSE and N is odd */ -/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */ - - dtrtri_("U", diag, &n1, a, &n1, info); - if (*info > 0) { - return 0; - } - dtrmm_("L", "U", "N", diag, &n1, &n2, &c_b13, a, &n1, &a[n1 * n1], &n1); - dtrtri_("L", diag, &n2, &a[1], &n1, info); - if (*info > 0) { - *info += n1; - } - if (*info > 0) { - return 0; - } - dtrmm_("R", "L", "T", diag, &n1, &n2, &c_b18, &a[1], &n1, &a[n1 * n1], &n1); - - } else { - -/* SRPA for UPPER, TRANSPOSE and N is odd */ -/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */ - - dtrtri_("U", diag, &n1, &a[n2 * n2], &n2, info); - if (*info > 0) { - return 0; - } - dtrmm_("R", "U", "T", diag, &n2, &n1, &c_b13, &a[n2 * n2], &n2, a, &n2); - dtrtri_("L", diag, &n2, &a[n1 * n2], &n2, info); - if (*info > 0) { - *info += n1; - } - if (*info > 0) { - return 0; - } - dtrmm_("L", "L", "N", diag, &n2, &n1, &c_b18, &a[n1 * n2], &n2, a, &n2); - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ -/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ -/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ - - i__1 = *n + 1; - dtrtri_("L", diag, &k, &a[1], &i__1, info); - if (*info > 0) { - return 0; - } - i__1 = *n + 1; - i__2 = *n + 1; - dtrmm_("R", "L", "N", diag, &k, &k, &c_b13, &a[1], &i__1, &a[k + 1], &i__2); - i__1 = *n + 1; - dtrtri_("U", diag, &k, a, &i__1, info); - if (*info > 0) { - *info += k; - } - if (*info > 0) { - return 0; - } - i__1 = *n + 1; - i__2 = *n + 1; - dtrmm_("L", "U", "T", diag, &k, &k, &c_b18, a, &i__1, &a[k + 1], &i__2) - ; - - } else { - -/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ -/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ -/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ - - i__1 = *n + 1; - dtrtri_("L", diag, &k, &a[k + 1], &i__1, info); - if (*info > 0) { - return 0; - } - i__1 = *n + 1; - i__2 = *n + 1; - dtrmm_("L", "L", "T", diag, &k, &k, &c_b13, &a[k + 1], &i__1, a, &i__2); - i__1 = *n + 1; - dtrtri_("U", diag, &k, &a[k], &i__1, info); - if (*info > 0) { - *info += k; - } - if (*info > 0) { - return 0; - } - i__1 = *n + 1; - i__2 = *n + 1; - dtrmm_("R", "U", "N", diag, &k, &k, &c_b18, &a[k], &i__1, a, &i__2); - } - } else { - -/* N is even and TRANSR = 'T' */ - - if (lower) { - -/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ -/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ -/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ - - dtrtri_("U", diag, &k, &a[k], &k, info); - if (*info > 0) { - return 0; - } - dtrmm_("L", "U", "N", diag, &k, &k, &c_b13, &a[k], &k, &a[k * (k + 1)], &k); - dtrtri_("L", diag, &k, a, &k, info); - if (*info > 0) { - *info += k; - } - if (*info > 0) { - return 0; - } - dtrmm_("R", "L", "T", diag, &k, &k, &c_b18, a, &k, &a[k * (k + 1)], &k) - ; - } else { - -/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ -/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ -/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ - - dtrtri_("U", diag, &k, &a[k * (k + 1)], &k, info); - if (*info > 0) { - return 0; - } - dtrmm_("R", "U", "T", diag, &k, &k, &c_b13, &a[k * (k + 1)], &k, a, &k); - dtrtri_("L", diag, &k, &a[k * k], &k, info); - if (*info > 0) { - *info += k; - } - if (*info > 0) { - return 0; - } - dtrmm_("L", "L", "N", diag, &k, &k, &c_b18, &a[k * k], &k, a, &k); - } - } - } - - return 0; - -/* End of DTFTRI */ - -} /* dtftri_ */ diff --git a/external/clapack/lapack/dtfttp.cpp b/external/clapack/lapack/dtfttp.cpp deleted file mode 100644 index 3ad24c89..00000000 --- a/external/clapack/lapack/dtfttp.cpp +++ /dev/null @@ -1,493 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dtfttp_(const char *transr, const char *uplo, integer *n, double *arf, double *ap, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp; - bool normaltransr, lower, nisodd; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTFTTP copies a triangular matrix A from rectangular full packed */ -/* format (TF) to standard packed format (TP). */ - -/* Arguments */ -/* ========= */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': ARF is in Normal format; */ -/* = 'T': ARF is in Transpose format; */ - -/* UPLO (input) CHARACTER */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* ARF (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ -/* On entry, the upper or lower triangular matrix A stored in */ -/* RFP format. For a further discussion see Notes below. */ - -/* AP (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ -/* On exit, the upper or lower triangular matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - *info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - if (! normaltransr && ! lsame_(transr, "T")) { - *info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTFTTP", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (normaltransr) { - ap[0] = arf[0]; - } else { - ap[0] = arf[0]; - } - return 0; - } - -/* Size of array ARF(0:NT-1) */ - - nt = *n * (*n + 1) / 2; - -/* Set N1 and N2 depending on LOWER */ - - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - -/* If N is odd, set NISODD = .TRUE. */ -/* If N is even, set K = N/2 and NISODD = .FALSE. */ - -/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ -/* where noe = 0 if n is even, noe = 1 if n is odd */ - - if (*n % 2 == 0) { - k = *n / 2; - nisodd = false; - lda = *n + 1; - } else { - nisodd = true; - lda = *n; - } - -/* ARF^C has lda rows and n+1-noe cols */ - - if (! normaltransr) { - lda = (*n + 1) / 2; - } - -/* start execution: there are eight cases */ - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ -/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ -/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */ - - ijp = 0; - jp = 0; - i__1 = n2; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = j; i__ <= i__2; ++i__) { - ij = i__ + jp; - ap[ijp] = arf[ij]; - ++ijp; - } - jp += lda; - } - i__1 = n2 - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__2 = n2; - for (j = i__ + 1; j <= i__2; ++j) { - ij = i__ + j * lda; - ap[ijp] = arf[ij]; - ++ijp; - } - } - - } else { - -/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ -/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ -/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ - - ijp = 0; - i__1 = n1 - 1; - for (j = 0; j <= i__1; ++j) { - ij = n2 + j; - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - ap[ijp] = arf[ij]; - ++ijp; - ij += lda; - } - } - js = 0; - i__1 = *n - 1; - for (j = n1; j <= i__1; ++j) { - ij = js; - i__2 = js + j; - for (ij = js; ij <= i__2; ++ij) { - ap[ijp] = arf[ij]; - ++ijp; - } - js += lda; - } - - } - - } else { - -/* N is odd and TRANSR = 'T' */ - - if (lower) { - -/* SRPA for LOWER, TRANSPOSE and N is odd */ -/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */ -/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */ - - ijp = 0; - i__1 = n2; - for (i__ = 0; i__ <= i__1; ++i__) { - i__2 = *n * lda - 1; - i__3 = lda; - for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= i__2; ij += i__3) { - ap[ijp] = arf[ij]; - ++ijp; - } - } - js = 1; - i__1 = n2 - 1; - for (j = 0; j <= i__1; ++j) { - i__3 = js + n2 - j - 1; - for (ij = js; ij <= i__3; ++ij) { - ap[ijp] = arf[ij]; - ++ijp; - } - js = js + lda + 1; - } - - } else { - -/* SRPA for UPPER, TRANSPOSE and N is odd */ -/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */ -/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */ - - ijp = 0; - js = n2 * lda; - i__1 = n1 - 1; - for (j = 0; j <= i__1; ++j) { - i__3 = js + j; - for (ij = js; ij <= i__3; ++ij) { - ap[ijp] = arf[ij]; - ++ijp; - } - js += lda; - } - i__1 = n1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__3 = i__ + (n1 + i__) * lda; - i__2 = lda; - for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += i__2) { - ap[ijp] = arf[ij]; - ++ijp; - } - } - - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ -/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ -/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ - - ijp = 0; - jp = 0; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = j; i__ <= i__2; ++i__) { - ij = i__ + 1 + jp; - ap[ijp] = arf[ij]; - ++ijp; - } - jp += lda; - } - i__1 = k - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__2 = k - 1; - for (j = i__; j <= i__2; ++j) { - ij = i__ + j * lda; - ap[ijp] = arf[ij]; - ++ijp; - } - } - - } else { - -/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ -/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ -/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ - - ijp = 0; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - ij = k + 1 + j; - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - ap[ijp] = arf[ij]; - ++ijp; - ij += lda; - } - } - js = 0; - i__1 = *n - 1; - for (j = k; j <= i__1; ++j) { - ij = js; - i__2 = js + j; - for (ij = js; ij <= i__2; ++ij) { - ap[ijp] = arf[ij]; - ++ijp; - } - js += lda; - } - - } - - } else { - -/* N is even and TRANSR = 'T' */ - - if (lower) { - -/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ -/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ -/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ - - ijp = 0; - i__1 = k - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__2 = (*n + 1) * lda - 1; - i__3 = lda; - for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : ij <= i__2; ij += i__3) { - ap[ijp] = arf[ij]; - ++ijp; - } - } - js = 0; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__3 = js + k - j - 1; - for (ij = js; ij <= i__3; ++ij) { - ap[ijp] = arf[ij]; - ++ijp; - } - js = js + lda + 1; - } - - } else { - -/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ -/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ -/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ - - ijp = 0; - js = (k + 1) * lda; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__3 = js + j; - for (ij = js; ij <= i__3; ++ij) { - ap[ijp] = arf[ij]; - ++ijp; - } - js += lda; - } - i__1 = k - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__3 = i__ + (k + i__) * lda; - i__2 = lda; - for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += i__2) { - ap[ijp] = arf[ij]; - ++ijp; - } - } - - } - - } - - } - - return 0; - -/* End of DTFTTP */ - -} /* dtfttp_ */ diff --git a/external/clapack/lapack/dtfttr.cpp b/external/clapack/lapack/dtfttr.cpp deleted file mode 100644 index 904420a7..00000000 --- a/external/clapack/lapack/dtfttr.cpp +++ /dev/null @@ -1,474 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dtfttr_(const char *transr, const char *uplo, integer *n, double *arf, double *a, integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2; - bool normaltransr, lower, nisodd; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTFTTR copies a triangular matrix A from rectangular full packed */ -/* format (TF) to standard full format (TR). */ - -/* Arguments */ -/* ========= */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': ARF is in Normal format; */ -/* = 'T': ARF is in Transpose format. */ - -/* UPLO (input) CHARACTER */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrices ARF and A. N >= 0. */ - -/* ARF (input) DOUBLE PRECISION array, dimension (N*(N+1)/2). */ -/* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */ -/* matrix A in RFP format. See the "Notes" below for more */ -/* details. */ - -/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On exit, the triangular matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of the array A contains */ -/* the upper triangular matrix, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of the array A contains */ -/* the lower triangular matrix, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* Reference */ -/* ========= */ - -/* ===================================================================== */ - -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda - 1 - 0 + 1; - a_offset = 0 + a_dim1 * 0; - a -= a_offset; - - /* Function Body */ - *info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - if (! normaltransr && ! lsame_(transr, "T")) { - *info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTFTTR", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 1) { - if (*n == 1) { - a[0] = arf[0]; - } - return 0; - } - -/* Size of array ARF(0:nt-1) */ - - nt = *n * (*n + 1) / 2; - -/* set N1 and N2 depending on LOWER: for N even N1=N2=K */ - - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - -/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ -/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ -/* N--by--(N+1)/2. */ - - if (*n % 2 == 0) { - k = *n / 2; - nisodd = false; - if (! lower) { - np1x2 = *n + *n + 2; - } - } else { - nisodd = true; - if (! lower) { - nx2 = *n + *n; - } - } - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* N is odd, TRANSR = 'N', and UPLO = 'L' */ - - ij = 0; - i__1 = n2; - for (j = 0; j <= i__1; ++j) { - i__2 = n2 + j; - for (i__ = n1; i__ <= i__2; ++i__) { - a[n2 + j + i__ * a_dim1] = arf[ij]; - ++ij; - } - i__2 = *n - 1; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = arf[ij]; - ++ij; - } - } - - } else { - -/* N is odd, TRANSR = 'N', and UPLO = 'U' */ - - ij = nt - *n; - i__1 = n1; - for (j = *n - 1; j >= i__1; --j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = arf[ij]; - ++ij; - } - i__2 = n1 - 1; - for (l = j - n1; l <= i__2; ++l) { - a[j - n1 + l * a_dim1] = arf[ij]; - ++ij; - } - ij -= nx2; - } - - } - - } else { - -/* N is odd and TRANSR = 'T' */ - - if (lower) { - -/* N is odd, TRANSR = 'T', and UPLO = 'L' */ - - ij = 0; - i__1 = n2 - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - a[j + i__ * a_dim1] = arf[ij]; - ++ij; - } - i__2 = *n - 1; - for (i__ = n1 + j; i__ <= i__2; ++i__) { - a[i__ + (n1 + j) * a_dim1] = arf[ij]; - ++ij; - } - } - i__1 = *n - 1; - for (j = n2; j <= i__1; ++j) { - i__2 = n1 - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - a[j + i__ * a_dim1] = arf[ij]; - ++ij; - } - } - - } else { - -/* N is odd, TRANSR = 'T', and UPLO = 'U' */ - - ij = 0; - i__1 = n1; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = n1; i__ <= i__2; ++i__) { - a[j + i__ * a_dim1] = arf[ij]; - ++ij; - } - } - i__1 = n1 - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = arf[ij]; - ++ij; - } - i__2 = *n - 1; - for (l = n2 + j; l <= i__2; ++l) { - a[n2 + j + l * a_dim1] = arf[ij]; - ++ij; - } - } - - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* N is even, TRANSR = 'N', and UPLO = 'L' */ - - ij = 0; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = k + j; - for (i__ = k; i__ <= i__2; ++i__) { - a[k + j + i__ * a_dim1] = arf[ij]; - ++ij; - } - i__2 = *n - 1; - for (i__ = j; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = arf[ij]; - ++ij; - } - } - - } else { - -/* N is even, TRANSR = 'N', and UPLO = 'U' */ - - ij = nt - *n - 1; - i__1 = k; - for (j = *n - 1; j >= i__1; --j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = arf[ij]; - ++ij; - } - i__2 = k - 1; - for (l = j - k; l <= i__2; ++l) { - a[j - k + l * a_dim1] = arf[ij]; - ++ij; - } - ij -= np1x2; - } - - } - - } else { - -/* N is even and TRANSR = 'T' */ - - if (lower) { - -/* N is even, TRANSR = 'T', and UPLO = 'L' */ - - ij = 0; - j = k; - i__1 = *n - 1; - for (i__ = k; i__ <= i__1; ++i__) { - a[i__ + j * a_dim1] = arf[ij]; - ++ij; - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - a[j + i__ * a_dim1] = arf[ij]; - ++ij; - } - i__2 = *n - 1; - for (i__ = k + 1 + j; i__ <= i__2; ++i__) { - a[i__ + (k + 1 + j) * a_dim1] = arf[ij]; - ++ij; - } - } - i__1 = *n - 1; - for (j = k - 1; j <= i__1; ++j) { - i__2 = k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - a[j + i__ * a_dim1] = arf[ij]; - ++ij; - } - } - - } else { - -/* N is even, TRANSR = 'T', and UPLO = 'U' */ - - ij = 0; - i__1 = k; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = k; i__ <= i__2; ++i__) { - a[j + i__ * a_dim1] = arf[ij]; - ++ij; - } - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - a[i__ + j * a_dim1] = arf[ij]; - ++ij; - } - i__2 = *n - 1; - for (l = k + 1 + j; l <= i__2; ++l) { - a[k + 1 + j + l * a_dim1] = arf[ij]; - ++ij; - } - } -/* Note that here, on exit of the loop, J = K-1 */ - i__1 = j; - for (i__ = 0; i__ <= i__1; ++i__) { - a[i__ + j * a_dim1] = arf[ij]; - ++ij; - } - - } - - } - - } - - return 0; - -/* End of DTFTTR */ - -} /* dtfttr_ */ diff --git a/external/clapack/lapack/dtgevc.cpp b/external/clapack/lapack/dtgevc.cpp deleted file mode 100644 index c56cf3a7..00000000 --- a/external/clapack/lapack/dtgevc.cpp +++ /dev/null @@ -1,1388 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static bool c_true = true; -static integer c__2 = 2; -static double c_b34 = 1.; -static integer c__1 = 1; -static double c_b36 = 0.; -static bool c_false = false; - -/* Subroutine */ int dtgevc_(const char *side, const char *howmny, bool *select, - integer *n, double *s, integer *lds, double *p, integer *ldp, - double *vl, integer *ldvl, double *vr, integer *ldvr, integer - *mm, integer *m, double *work, integer *info) -{ - /* System generated locals */ - integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1, - vr_offset, i__1, i__2, i__3, i__4, i__5; - double d__1, d__2, d__3, d__4, d__5, d__6; - - /* Local variables */ - integer i__, j, ja, jc, je, na, im, jr, jw, nw; - double big; - bool lsa, lsb; - double ulp, sum[4] /* was [2][2] */; - integer ibeg, ieig, iend; - double dmin__, temp, xmax, sump[4] /* was [2][2] */, sums[4] - /* was [2][2] */; - double cim2a, cim2b, cre2a, cre2b, temp2, bdiag[2], acoef, scale; - bool ilall; - integer iside; - double sbeta; - bool il2by2; - integer iinfo; - double small; - bool compl_x; // djmw changed variable from "compl" to compl_x because the c++ compiler protested. - double anorm, bnorm; - bool compr; - double temp2i; - double temp2r; - bool ilabad, ilbbad; - double acoefa, bcoefa, cimaga, cimagb; - bool ilback; - double bcoefi, ascale, bscale, creala, crealb; - double bcoefr, salfar, safmin; - double xscale, bignum; - bool ilcomp, ilcplx; - integer ihwmny; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - - -/* Purpose */ -/* ======= */ - -/* DTGEVC computes some or all of the right and/or left eigenvectors of */ -/* a pair of real matrices (S,P), where S is a quasi-triangular matrix */ -/* and P is upper triangular. Matrix pairs of this type are produced by */ -/* the generalized Schur factorization of a matrix pair (A,B): */ - -/* A = Q*S*Z**T, B = Q*P*Z**T */ - -/* as computed by DGGHRD + DHGEQZ. */ - -/* The right eigenvector x and the left eigenvector y of (S,P) */ -/* corresponding to an eigenvalue w are defined by: */ - -/* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */ - -/* where y**H denotes the conjugate tranpose of y. */ -/* The eigenvalues are not input to this routine, but are computed */ -/* directly from the diagonal blocks of S and P. */ - -/* This routine returns the matrices X and/or Y of right and left */ -/* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */ -/* where Z and Q are input matrices. */ -/* If Q and Z are the orthogonal factors from the generalized Schur */ -/* factorization of a matrix pair (A,B), then Z*X and Q*Y */ -/* are the matrices of right and left eigenvectors of (A,B). */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'R': compute right eigenvectors only; */ -/* = 'L': compute left eigenvectors only; */ -/* = 'B': compute both right and left eigenvectors. */ - -/* HOWMNY (input) CHARACTER*1 */ -/* = 'A': compute all right and/or left eigenvectors; */ -/* = 'B': compute all right and/or left eigenvectors, */ -/* backtransformed by the matrices in VR and/or VL; */ -/* = 'S': compute selected right and/or left eigenvectors, */ -/* specified by the bool array SELECT. */ - -/* SELECT (input) LOGICAL array, dimension (N) */ -/* If HOWMNY='S', SELECT specifies the eigenvectors to be */ -/* computed. If w(j) is a real eigenvalue, the corresponding */ -/* real eigenvector is computed if SELECT(j) is .TRUE.. */ -/* If w(j) and w(j+1) are the real and imaginary parts of a */ -/* complex eigenvalue, the corresponding complex eigenvector */ -/* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., */ -/* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is */ -/* set to .FALSE.. */ -/* Not referenced if HOWMNY = 'A' or 'B'. */ - -/* N (input) INTEGER */ -/* The order of the matrices S and P. N >= 0. */ - -/* S (input) DOUBLE PRECISION array, dimension (LDS,N) */ -/* The upper quasi-triangular matrix S from a generalized Schur */ -/* factorization, as computed by DHGEQZ. */ - -/* LDS (input) INTEGER */ -/* The leading dimension of array S. LDS >= max(1,N). */ - -/* P (input) DOUBLE PRECISION array, dimension (LDP,N) */ -/* The upper triangular matrix P from a generalized Schur */ -/* factorization, as computed by DHGEQZ. */ -/* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks */ -/* of S must be in positive diagonal form. */ - -/* LDP (input) INTEGER */ -/* The leading dimension of array P. LDP >= max(1,N). */ - -/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */ -/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ -/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ -/* of left Schur vectors returned by DHGEQZ). */ -/* On exit, if SIDE = 'L' or 'B', VL contains: */ -/* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */ -/* if HOWMNY = 'B', the matrix Q*Y; */ -/* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */ -/* SELECT, stored consecutively in the columns of */ -/* VL, in the same order as their eigenvalues. */ - -/* A complex eigenvector corresponding to a complex eigenvalue */ -/* is stored in two consecutive columns, the first holding the */ -/* real part, and the second the imaginary part. */ - -/* Not referenced if SIDE = 'R'. */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of array VL. LDVL >= 1, and if */ -/* SIDE = 'L' or 'B', LDVL >= N. */ - -/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */ -/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ -/* contain an N-by-N matrix Z (usually the orthogonal matrix Z */ -/* of right Schur vectors returned by DHGEQZ). */ - -/* On exit, if SIDE = 'R' or 'B', VR contains: */ -/* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */ -/* if HOWMNY = 'B' or 'b', the matrix Z*X; */ -/* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) */ -/* specified by SELECT, stored consecutively in the */ -/* columns of VR, in the same order as their */ -/* eigenvalues. */ - -/* A complex eigenvector corresponding to a complex eigenvalue */ -/* is stored in two consecutive columns, the first holding the */ -/* real part and the second the imaginary part. */ - -/* Not referenced if SIDE = 'L'. */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the array VR. LDVR >= 1, and if */ -/* SIDE = 'R' or 'B', LDVR >= N. */ - -/* MM (input) INTEGER */ -/* The number of columns in the arrays VL and/or VR. MM >= M. */ - -/* M (output) INTEGER */ -/* The number of columns in the arrays VL and/or VR actually */ -/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */ -/* is set to N. Each selected real eigenvector occupies one */ -/* column and each selected complex eigenvector occupies two */ -/* columns. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit. */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex */ -/* eigenvalue. */ - -/* Further Details */ -/* =============== */ - -/* Allocation of workspace: */ -/* ---------- -- --------- */ - -/* WORK( j ) = 1-norm of j-th column of A, above the diagonal */ -/* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal */ -/* WORK( 2*N+1:3*N ) = real part of eigenvector */ -/* WORK( 3*N+1:4*N ) = imaginary part of eigenvector */ -/* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector */ -/* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector */ - -/* Rowwise vs. columnwise solution methods: */ -/* ------- -- ---------- -------- ------- */ - -/* Finding a generalized eigenvector consists basically of solving the */ -/* singular triangular system */ - -/* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) */ - -/* Consider finding the i-th right eigenvector (assume all eigenvalues */ -/* are real). The equation to be solved is: */ -/* n i */ -/* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 */ -/* k=j k=j */ - -/* where C = (A - w B) (The components v(i+1:n) are 0.) */ - -/* The "rowwise" method is: */ - -/* (1) v(i) := 1 */ -/* for j = i-1,. . .,1: */ -/* i */ -/* (2) compute s = - sum C(j,k) v(k) and */ -/* k=j+1 */ - -/* (3) v(j) := s / C(j,j) */ - -/* Step 2 is sometimes called the "dot product" step, since it is an */ -/* inner product between the j-th row and the portion of the eigenvector */ -/* that has been computed so far. */ - -/* The "columnwise" method consists basically in doing the sums */ -/* for all the rows in parallel. As each v(j) is computed, the */ -/* contribution of v(j) times the j-th column of C is added to the */ -/* partial sums. Since FORTRAN arrays are stored columnwise, this has */ -/* the advantage that at each step, the elements of C that are accessed */ -/* are adjacent to one another, whereas with the rowwise method, the */ -/* elements accessed at a step are spaced LDS (and LDP) words apart. */ - -/* When finding left eigenvectors, the matrix in question is the */ -/* transpose of the one in storage, so the rowwise method then */ -/* actually accesses columns of A and B at each step, and so is the */ -/* preferred method. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and Test the input parameters */ - - /* Parameter adjustments */ - --select; - s_dim1 = *lds; - s_offset = 1 + s_dim1; - s -= s_offset; - p_dim1 = *ldp; - p_offset = 1 + p_dim1; - p -= p_offset; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --work; - - /* Function Body */ - if (lsame_(howmny, "A")) { - ihwmny = 1; - ilall = true; - ilback = false; - } else if (lsame_(howmny, "S")) { - ihwmny = 2; - ilall = false; - ilback = false; - } else if (lsame_(howmny, "B")) { - ihwmny = 3; - ilall = true; - ilback = true; - } else { - ihwmny = -1; - ilall = true; - } - - if (lsame_(side, "R")) { - iside = 1; - compl_x = false; - compr = true; - } else if (lsame_(side, "L")) { - iside = 2; - compl_x = true; - compr = false; - } else if (lsame_(side, "B")) { - iside = 3; - compl_x = true; - compr = true; - } else { - iside = -1; - } - - *info = 0; - if (iside < 0) { - *info = -1; - } else if (ihwmny < 0) { - *info = -2; - } else if (*n < 0) { - *info = -4; - } else if (*lds < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldp < std::max(1_integer,*n)) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGEVC", &i__1); - return 0; - } - -/* Count the number of eigenvectors to be computed */ - - if (! ilall) { - im = 0; - ilcplx = false; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (ilcplx) { - ilcplx = false; - goto L10; - } - if (j < *n) { - if (s[j + 1 + j * s_dim1] != 0.) { - ilcplx = true; - } - } - if (ilcplx) { - if (select[j] || select[j + 1]) { - im += 2; - } - } else { - if (select[j]) { - ++im; - } - } -L10: - ; - } - } else { - im = *n; - } - -/* Check 2-by-2 diagonal blocks of A, B */ - - ilabad = false; - ilbbad = false; - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - if (s[j + 1 + j * s_dim1] != 0.) { - if (p[j + j * p_dim1] == 0. || p[j + 1 + (j + 1) * p_dim1] == 0. - || p[j + (j + 1) * p_dim1] != 0.) { - ilbbad = true; - } - if (j < *n - 1) { - if (s[j + 2 + (j + 1) * s_dim1] != 0.) { - ilabad = true; - } - } - } -/* L20: */ - } - - if (ilabad) { - *info = -5; - } else if (ilbbad) { - *info = -7; - } else if (compl_x && *ldvl < *n || *ldvl < 1) { - *info = -10; - } else if (compr && *ldvr < *n || *ldvr < 1) { - *info = -12; - } else if (*mm < im) { - *info = -13; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGEVC", &i__1); - return 0; - } - -/* Quick return if possible */ - - *m = im; - if (*n == 0) { - return 0; - } - -/* Machine Constants */ - - safmin = dlamch_("Safe minimum"); - big = 1. / safmin; - dlabad_(&safmin, &big); - ulp = dlamch_("Epsilon") * dlamch_("Base"); - small = safmin * *n / ulp; - big = 1. / small; - bignum = 1. / (safmin * *n); - -/* Compute the 1-norm of each column of the strictly upper triangular */ -/* part (i.e., excluding all elements belonging to the diagonal */ -/* blocks) of A and B to check for possible overflow in the */ -/* triangular solver. */ - - anorm = (d__1 = s[s_dim1 + 1], abs(d__1)); - if (*n > 1) { - anorm += (d__1 = s[s_dim1 + 2], abs(d__1)); - } - bnorm = (d__1 = p[p_dim1 + 1], abs(d__1)); - work[1] = 0.; - work[*n + 1] = 0.; - - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - temp = 0.; - temp2 = 0.; - if (s[j + (j - 1) * s_dim1] == 0.) { - iend = j - 1; - } else { - iend = j - 2; - } - i__2 = iend; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += (d__1 = s[i__ + j * s_dim1], abs(d__1)); - temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1)); -/* L30: */ - } - work[j] = temp; - work[*n + j] = temp2; -/* Computing MIN */ - i__3 = j + 1; - i__2 = std::min(i__3,*n); - for (i__ = iend + 1; i__ <= i__2; ++i__) { - temp += (d__1 = s[i__ + j * s_dim1], abs(d__1)); - temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1)); -/* L40: */ - } - anorm = std::max(anorm,temp); - bnorm = std::max(bnorm,temp2); -/* L50: */ - } - ascale = 1. / std::max(anorm,safmin); - bscale = 1. / std::max(bnorm,safmin); - -/* Left eigenvectors */ - - if (compl_x) { - ieig = 0; - -/* Main loop over eigenvalues */ - - ilcplx = false; - i__1 = *n; - for (je = 1; je <= i__1; ++je) { - -/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ -/* (b) this would be the second of a complex pair. */ -/* Check for complex eigenvalue, so as to be sure of which */ -/* entry(-ies) of SELECT to look at. */ - - if (ilcplx) { - ilcplx = false; - goto L220; - } - nw = 1; - if (je < *n) { - if (s[je + 1 + je * s_dim1] != 0.) { - ilcplx = true; - nw = 2; - } - } - if (ilall) { - ilcomp = true; - } else if (ilcplx) { - ilcomp = select[je] || select[je + 1]; - } else { - ilcomp = select[je]; - } - if (! ilcomp) { - goto L220; - } - -/* Decide if (a) singular pencil, (b) real eigenvalue, or */ -/* (c) complex eigenvalue. */ - - if (! ilcplx) { - if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && ( - d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) { - -/* Singular matrix pencil -- return unit eigenvector */ - - ++ieig; - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vl[jr + ieig * vl_dim1] = 0.; -/* L60: */ - } - vl[ieig + ieig * vl_dim1] = 1.; - goto L220; - } - } - -/* Clear vector */ - - i__2 = nw * *n; - for (jr = 1; jr <= i__2; ++jr) { - work[(*n << 1) + jr] = 0.; -/* L70: */ - } -/* T */ -/* Compute coefficients in ( a A - b B ) y = 0 */ -/* a is ACOEF */ -/* b is BCOEFR + i*BCOEFI */ - - if (! ilcplx) { - -/* Real eigenvalue */ - -/* Computing MAX */ - d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4 - = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale, - d__3 = std::max(d__3,d__4); - temp = 1. / std::max(d__3,safmin); - salfar = temp * s[je + je * s_dim1] * ascale; - sbeta = temp * p[je + je * p_dim1] * bscale; - acoef = sbeta * ascale; - bcoefr = salfar * bscale; - bcoefi = 0.; - -/* Scale to avoid underflow */ - - scale = 1.; - lsa = abs(sbeta) >= safmin && abs(acoef) < small; - lsb = abs(salfar) >= safmin && abs(bcoefr) < small; - if (lsa) { - scale = small / abs(sbeta) * std::min(anorm,big); - } - if (lsb) { -/* Computing MAX */ - d__1 = scale, d__2 = small / abs(salfar) * std::min(bnorm,big); - scale = std::max(d__1,d__2); - } - if (lsa || lsb) { -/* Computing MIN */ -/* Computing MAX */ - d__3 = 1., d__4 = abs(acoef), d__3 = std::max(d__3,d__4), d__4 - = abs(bcoefr); - d__1 = scale, d__2 = 1. / (safmin * std::max(d__3,d__4)); - scale = std::min(d__1,d__2); - if (lsa) { - acoef = ascale * (scale * sbeta); - } else { - acoef = scale * acoef; - } - if (lsb) { - bcoefr = bscale * (scale * salfar); - } else { - bcoefr = scale * bcoefr; - } - } - acoefa = abs(acoef); - bcoefa = abs(bcoefr); - -/* First component is 1 */ - - work[(*n << 1) + je] = 1.; - xmax = 1.; - } else { - -/* Complex eigenvalue */ - - d__1 = safmin * 100.; - dlag2_(&s[je + je * s_dim1], lds, &p[je + je * p_dim1], ldp, & - d__1, &acoef, &temp, &bcoefr, &temp2, &bcoefi); - bcoefi = -bcoefi; - if (bcoefi == 0.) { - *info = je; - return 0; - } - -/* Scale to avoid over/underflow */ - - acoefa = abs(acoef); - bcoefa = abs(bcoefr) + abs(bcoefi); - scale = 1.; - if (acoefa * ulp < safmin && acoefa >= safmin) { - scale = safmin / ulp / acoefa; - } - if (bcoefa * ulp < safmin && bcoefa >= safmin) { -/* Computing MAX */ - d__1 = scale, d__2 = safmin / ulp / bcoefa; - scale = std::max(d__1,d__2); - } - if (safmin * acoefa > ascale) { - scale = ascale / (safmin * acoefa); - } - if (safmin * bcoefa > bscale) { -/* Computing MIN */ - d__1 = scale, d__2 = bscale / (safmin * bcoefa); - scale = std::min(d__1,d__2); - } - if (scale != 1.) { - acoef = scale * acoef; - acoefa = abs(acoef); - bcoefr = scale * bcoefr; - bcoefi = scale * bcoefi; - bcoefa = abs(bcoefr) + abs(bcoefi); - } - -/* Compute first two components of eigenvector */ - - temp = acoef * s[je + 1 + je * s_dim1]; - temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * - p_dim1]; - temp2i = -bcoefi * p[je + je * p_dim1]; - if (abs(temp) > abs(temp2r) + abs(temp2i)) { - work[(*n << 1) + je] = 1.; - work[*n * 3 + je] = 0.; - work[(*n << 1) + je + 1] = -temp2r / temp; - work[*n * 3 + je + 1] = -temp2i / temp; - } else { - work[(*n << 1) + je + 1] = 1.; - work[*n * 3 + je + 1] = 0.; - temp = acoef * s[je + (je + 1) * s_dim1]; - work[(*n << 1) + je] = (bcoefr * p[je + 1 + (je + 1) * - p_dim1] - acoef * s[je + 1 + (je + 1) * s_dim1]) / - temp; - work[*n * 3 + je] = bcoefi * p[je + 1 + (je + 1) * p_dim1] - / temp; - } -/* Computing MAX */ - d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 = - work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(* - n << 1) + je + 1], abs(d__3)) + (d__4 = work[*n * 3 + - je + 1], abs(d__4)); - xmax = std::max(d__5,d__6); - } - -/* Computing MAX */ - d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 = - std::max(d__1,d__2); - dmin__ = std::max(d__1,safmin); - -/* T */ -/* Triangular solve of (a A - b B) y = 0 */ - -/* T */ -/* (rowwise in (a A - b B) , or columnwise in (a A - b B) ) */ - - il2by2 = false; - - i__2 = *n; - for (j = je + nw; j <= i__2; ++j) { - if (il2by2) { - il2by2 = false; - goto L160; - } - - na = 1; - bdiag[0] = p[j + j * p_dim1]; - if (j < *n) { - if (s[j + 1 + j * s_dim1] != 0.) { - il2by2 = true; - bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; - na = 2; - } - } - -/* Check whether scaling is necessary for dot products */ - - xscale = 1. / std::max(1.,xmax); -/* Computing MAX */ - d__1 = work[j], d__2 = work[*n + j], d__1 = std::max(d__1,d__2), - d__2 = acoefa * work[j] + bcoefa * work[*n + j]; - temp = std::max(d__1,d__2); - if (il2by2) { -/* Computing MAX */ - d__1 = temp, d__2 = work[j + 1], d__1 = std::max(d__1,d__2), - d__2 = work[*n + j + 1], d__1 = std::max(d__1,d__2), - d__2 = acoefa * work[j + 1] + bcoefa * work[*n + - j + 1]; - temp = std::max(d__1,d__2); - } - if (temp > bignum * xscale) { - i__3 = nw - 1; - for (jw = 0; jw <= i__3; ++jw) { - i__4 = j - 1; - for (jr = je; jr <= i__4; ++jr) { - work[(jw + 2) * *n + jr] = xscale * work[(jw + 2) - * *n + jr]; -/* L80: */ - } -/* L90: */ - } - xmax *= xscale; - } - -/* Compute dot products */ - -/* j-1 */ -/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */ -/* k=je */ - -/* To reduce the op count, this is done as */ - -/* _ j-1 _ j-1 */ -/* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) */ -/* k=je k=je */ - -/* which may cause underflow problems if A or B are close */ -/* to underflow. (E.g., less than SMALL.) */ - - -/* A series of compiler directives to defeat vectorization */ -/* for the next loop */ - -/* $PL$ CMCHAR=' ' */ -/* DIR$ NEXTSCALAR */ -/* $DIR SCALAR */ -/* DIR$ NEXT SCALAR */ -/* VD$L NOVECTOR */ -/* DEC$ NOVECTOR */ -/* VD$ NOVECTOR */ -/* VDIR NOVECTOR */ -/* VOCL LOOP,SCALAR */ -/* IBM PREFER SCALAR */ -/* $PL$ CMCHAR='*' */ - - i__3 = nw; - for (jw = 1; jw <= i__3; ++jw) { - -/* $PL$ CMCHAR=' ' */ -/* DIR$ NEXTSCALAR */ -/* $DIR SCALAR */ -/* DIR$ NEXT SCALAR */ -/* VD$L NOVECTOR */ -/* DEC$ NOVECTOR */ -/* VD$ NOVECTOR */ -/* VDIR NOVECTOR */ -/* VOCL LOOP,SCALAR */ -/* IBM PREFER SCALAR */ -/* $PL$ CMCHAR='*' */ - - i__4 = na; - for (ja = 1; ja <= i__4; ++ja) { - sums[ja + (jw << 1) - 3] = 0.; - sump[ja + (jw << 1) - 3] = 0.; - - i__5 = j - 1; - for (jr = je; jr <= i__5; ++jr) { - sums[ja + (jw << 1) - 3] += s[jr + (j + ja - 1) * - s_dim1] * work[(jw + 1) * *n + jr]; - sump[ja + (jw << 1) - 3] += p[jr + (j + ja - 1) * - p_dim1] * work[(jw + 1) * *n + jr]; -/* L100: */ - } -/* L110: */ - } -/* L120: */ - } - -/* $PL$ CMCHAR=' ' */ -/* DIR$ NEXTSCALAR */ -/* $DIR SCALAR */ -/* DIR$ NEXT SCALAR */ -/* VD$L NOVECTOR */ -/* DEC$ NOVECTOR */ -/* VD$ NOVECTOR */ -/* VDIR NOVECTOR */ -/* VOCL LOOP,SCALAR */ -/* IBM PREFER SCALAR */ -/* $PL$ CMCHAR='*' */ - - i__3 = na; - for (ja = 1; ja <= i__3; ++ja) { - if (ilcplx) { - sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ - ja - 1] - bcoefi * sump[ja + 1]; - sum[ja + 1] = -acoef * sums[ja + 1] + bcoefr * sump[ - ja + 1] + bcoefi * sump[ja - 1]; - } else { - sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ - ja - 1]; - } -/* L130: */ - } - -/* T */ -/* Solve ( a A - b B ) y = SUM(,) */ -/* with scaling and perturbation of the denominator */ - - dlaln2_(&c_true, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1] -, lds, bdiag, &bdiag[1], sum, &c__2, &bcoefr, &bcoefi, - &work[(*n << 1) + j], n, &scale, &temp, &iinfo); - if (scale < 1.) { - i__3 = nw - 1; - for (jw = 0; jw <= i__3; ++jw) { - i__4 = j - 1; - for (jr = je; jr <= i__4; ++jr) { - work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * - *n + jr]; -/* L140: */ - } -/* L150: */ - } - xmax = scale * xmax; - } - xmax = std::max(xmax,temp); -L160: - ; - } - -/* Copy eigenvector to VL, back transforming if */ -/* HOWMNY='B'. */ - - ++ieig; - if (ilback) { - i__2 = nw - 1; - for (jw = 0; jw <= i__2; ++jw) { - i__3 = *n + 1 - je; - dgemv_("N", n, &i__3, &c_b34, &vl[je * vl_dim1 + 1], ldvl, - &work[(jw + 2) * *n + je], &c__1, &c_b36, &work[( - jw + 4) * *n + 1], &c__1); -/* L170: */ - } - dlacpy_(" ", n, &nw, &work[(*n << 2) + 1], n, &vl[je * - vl_dim1 + 1], ldvl); - ibeg = 1; - } else { - dlacpy_(" ", n, &nw, &work[(*n << 1) + 1], n, &vl[ieig * - vl_dim1 + 1], ldvl); - ibeg = je; - } - -/* Scale eigenvector */ - - xmax = 0.; - if (ilcplx) { - i__2 = *n; - for (j = ibeg; j <= i__2; ++j) { -/* Computing MAX */ - d__3 = xmax, d__4 = (d__1 = vl[j + ieig * vl_dim1], abs( - d__1)) + (d__2 = vl[j + (ieig + 1) * vl_dim1], - abs(d__2)); - xmax = std::max(d__3,d__4); -/* L180: */ - } - } else { - i__2 = *n; - for (j = ibeg; j <= i__2; ++j) { -/* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = vl[j + ieig * vl_dim1], abs( - d__1)); - xmax = std::max(d__2,d__3); -/* L190: */ - } - } - - if (xmax > safmin) { - xscale = 1. / xmax; - - i__2 = nw - 1; - for (jw = 0; jw <= i__2; ++jw) { - i__3 = *n; - for (jr = ibeg; jr <= i__3; ++jr) { - vl[jr + (ieig + jw) * vl_dim1] = xscale * vl[jr + ( - ieig + jw) * vl_dim1]; -/* L200: */ - } -/* L210: */ - } - } - ieig = ieig + nw - 1; - -L220: - ; - } - } - -/* Right eigenvectors */ - - if (compr) { - ieig = im + 1; - -/* Main loop over eigenvalues */ - - ilcplx = false; - for (je = *n; je >= 1; --je) { - -/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ -/* (b) this would be the second of a complex pair. */ -/* Check for complex eigenvalue, so as to be sure of which */ -/* entry(-ies) of SELECT to look at -- if complex, SELECT(JE) */ -/* or SELECT(JE-1). */ -/* If this is a complex pair, the 2-by-2 diagonal block */ -/* corresponding to the eigenvalue is in rows/columns JE-1:JE */ - - if (ilcplx) { - ilcplx = false; - goto L500; - } - nw = 1; - if (je > 1) { - if (s[je + (je - 1) * s_dim1] != 0.) { - ilcplx = true; - nw = 2; - } - } - if (ilall) { - ilcomp = true; - } else if (ilcplx) { - ilcomp = select[je] || select[je - 1]; - } else { - ilcomp = select[je]; - } - if (! ilcomp) { - goto L500; - } - -/* Decide if (a) singular pencil, (b) real eigenvalue, or */ -/* (c) complex eigenvalue. */ - - if (! ilcplx) { - if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && ( - d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) { - -/* Singular matrix pencil -- unit eigenvector */ - - --ieig; - i__1 = *n; - for (jr = 1; jr <= i__1; ++jr) { - vr[jr + ieig * vr_dim1] = 0.; -/* L230: */ - } - vr[ieig + ieig * vr_dim1] = 1.; - goto L500; - } - } - -/* Clear vector */ - - i__1 = nw - 1; - for (jw = 0; jw <= i__1; ++jw) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - work[(jw + 2) * *n + jr] = 0.; -/* L240: */ - } -/* L250: */ - } - -/* Compute coefficients in ( a A - b B ) x = 0 */ -/* a is ACOEF */ -/* b is BCOEFR + i*BCOEFI */ - - if (! ilcplx) { - -/* Real eigenvalue */ - -/* Computing MAX */ - d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4 - = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale, - d__3 = std::max(d__3,d__4); - temp = 1. / std::max(d__3,safmin); - salfar = temp * s[je + je * s_dim1] * ascale; - sbeta = temp * p[je + je * p_dim1] * bscale; - acoef = sbeta * ascale; - bcoefr = salfar * bscale; - bcoefi = 0.; - -/* Scale to avoid underflow */ - - scale = 1.; - lsa = abs(sbeta) >= safmin && abs(acoef) < small; - lsb = abs(salfar) >= safmin && abs(bcoefr) < small; - if (lsa) { - scale = small / abs(sbeta) * std::min(anorm,big); - } - if (lsb) { -/* Computing MAX */ - d__1 = scale, d__2 = small / abs(salfar) * std::min(bnorm,big); - scale = std::max(d__1,d__2); - } - if (lsa || lsb) { -/* Computing MIN */ -/* Computing MAX */ - d__3 = 1., d__4 = abs(acoef), d__3 = std::max(d__3,d__4), d__4 - = abs(bcoefr); - d__1 = scale, d__2 = 1. / (safmin * std::max(d__3,d__4)); - scale = std::min(d__1,d__2); - if (lsa) { - acoef = ascale * (scale * sbeta); - } else { - acoef = scale * acoef; - } - if (lsb) { - bcoefr = bscale * (scale * salfar); - } else { - bcoefr = scale * bcoefr; - } - } - acoefa = abs(acoef); - bcoefa = abs(bcoefr); - -/* First component is 1 */ - - work[(*n << 1) + je] = 1.; - xmax = 1.; - -/* Compute contribution from column JE of A and B to sum */ -/* (See "Further Details", above.) */ - - i__1 = je - 1; - for (jr = 1; jr <= i__1; ++jr) { - work[(*n << 1) + jr] = bcoefr * p[jr + je * p_dim1] - - acoef * s[jr + je * s_dim1]; -/* L260: */ - } - } else { - -/* Complex eigenvalue */ - - d__1 = safmin * 100.; - dlag2_(&s[je - 1 + (je - 1) * s_dim1], lds, &p[je - 1 + (je - - 1) * p_dim1], ldp, &d__1, &acoef, &temp, &bcoefr, & - temp2, &bcoefi); - if (bcoefi == 0.) { - *info = je - 1; - return 0; - } - -/* Scale to avoid over/underflow */ - - acoefa = abs(acoef); - bcoefa = abs(bcoefr) + abs(bcoefi); - scale = 1.; - if (acoefa * ulp < safmin && acoefa >= safmin) { - scale = safmin / ulp / acoefa; - } - if (bcoefa * ulp < safmin && bcoefa >= safmin) { -/* Computing MAX */ - d__1 = scale, d__2 = safmin / ulp / bcoefa; - scale = std::max(d__1,d__2); - } - if (safmin * acoefa > ascale) { - scale = ascale / (safmin * acoefa); - } - if (safmin * bcoefa > bscale) { -/* Computing MIN */ - d__1 = scale, d__2 = bscale / (safmin * bcoefa); - scale = std::min(d__1,d__2); - } - if (scale != 1.) { - acoef = scale * acoef; - acoefa = abs(acoef); - bcoefr = scale * bcoefr; - bcoefi = scale * bcoefi; - bcoefa = abs(bcoefr) + abs(bcoefi); - } - -/* Compute first two components of eigenvector */ -/* and contribution to sums */ - - temp = acoef * s[je + (je - 1) * s_dim1]; - temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * - p_dim1]; - temp2i = -bcoefi * p[je + je * p_dim1]; - if (abs(temp) >= abs(temp2r) + abs(temp2i)) { - work[(*n << 1) + je] = 1.; - work[*n * 3 + je] = 0.; - work[(*n << 1) + je - 1] = -temp2r / temp; - work[*n * 3 + je - 1] = -temp2i / temp; - } else { - work[(*n << 1) + je - 1] = 1.; - work[*n * 3 + je - 1] = 0.; - temp = acoef * s[je - 1 + je * s_dim1]; - work[(*n << 1) + je] = (bcoefr * p[je - 1 + (je - 1) * - p_dim1] - acoef * s[je - 1 + (je - 1) * s_dim1]) / - temp; - work[*n * 3 + je] = bcoefi * p[je - 1 + (je - 1) * p_dim1] - / temp; - } - -/* Computing MAX */ - d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 = - work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(* - n << 1) + je - 1], abs(d__3)) + (d__4 = work[*n * 3 + - je - 1], abs(d__4)); - xmax = std::max(d__5,d__6); - -/* Compute contribution from columns JE and JE-1 */ -/* of A and B to the sums. */ - - creala = acoef * work[(*n << 1) + je - 1]; - cimaga = acoef * work[*n * 3 + je - 1]; - crealb = bcoefr * work[(*n << 1) + je - 1] - bcoefi * work[*n - * 3 + je - 1]; - cimagb = bcoefi * work[(*n << 1) + je - 1] + bcoefr * work[*n - * 3 + je - 1]; - cre2a = acoef * work[(*n << 1) + je]; - cim2a = acoef * work[*n * 3 + je]; - cre2b = bcoefr * work[(*n << 1) + je] - bcoefi * work[*n * 3 - + je]; - cim2b = bcoefi * work[(*n << 1) + je] + bcoefr * work[*n * 3 - + je]; - i__1 = je - 2; - for (jr = 1; jr <= i__1; ++jr) { - work[(*n << 1) + jr] = -creala * s[jr + (je - 1) * s_dim1] - + crealb * p[jr + (je - 1) * p_dim1] - cre2a * s[ - jr + je * s_dim1] + cre2b * p[jr + je * p_dim1]; - work[*n * 3 + jr] = -cimaga * s[jr + (je - 1) * s_dim1] + - cimagb * p[jr + (je - 1) * p_dim1] - cim2a * s[jr - + je * s_dim1] + cim2b * p[jr + je * p_dim1]; -/* L270: */ - } - } - -/* Computing MAX */ - d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 = - std::max(d__1,d__2); - dmin__ = std::max(d__1,safmin); - -/* Columnwise triangular solve of (a A - b B) x = 0 */ - - il2by2 = false; - for (j = je - nw; j >= 1; --j) { - -/* If a 2-by-2 block, is in position j-1:j, wait until */ -/* next iteration to process it (when it will be j:j+1) */ - - if (! il2by2 && j > 1) { - if (s[j + (j - 1) * s_dim1] != 0.) { - il2by2 = true; - goto L370; - } - } - bdiag[0] = p[j + j * p_dim1]; - if (il2by2) { - na = 2; - bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; - } else { - na = 1; - } - -/* Compute x(j) (and x(j+1), if 2-by-2 block) */ - - dlaln2_(&c_false, &na, &nw, &dmin__, &acoef, &s[j + j * - s_dim1], lds, bdiag, &bdiag[1], &work[(*n << 1) + j], - n, &bcoefr, &bcoefi, sum, &c__2, &scale, &temp, & - iinfo); - if (scale < 1.) { - - i__1 = nw - 1; - for (jw = 0; jw <= i__1; ++jw) { - i__2 = je; - for (jr = 1; jr <= i__2; ++jr) { - work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * - *n + jr]; -/* L280: */ - } -/* L290: */ - } - } -/* Computing MAX */ - d__1 = scale * xmax; - xmax = std::max(d__1,temp); - - i__1 = nw; - for (jw = 1; jw <= i__1; ++jw) { - i__2 = na; - for (ja = 1; ja <= i__2; ++ja) { - work[(jw + 1) * *n + j + ja - 1] = sum[ja + (jw << 1) - - 3]; -/* L300: */ - } -/* L310: */ - } - -/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */ - - if (j > 1) { - -/* Check whether scaling is necessary for sum. */ - - xscale = 1. / std::max(1.,xmax); - temp = acoefa * work[j] + bcoefa * work[*n + j]; - if (il2by2) { -/* Computing MAX */ - d__1 = temp, d__2 = acoefa * work[j + 1] + bcoefa * - work[*n + j + 1]; - temp = std::max(d__1,d__2); - } -/* Computing MAX */ - d__1 = std::max(temp,acoefa); - temp = std::max(d__1,bcoefa); - if (temp > bignum * xscale) { - - i__1 = nw - 1; - for (jw = 0; jw <= i__1; ++jw) { - i__2 = je; - for (jr = 1; jr <= i__2; ++jr) { - work[(jw + 2) * *n + jr] = xscale * work[(jw - + 2) * *n + jr]; -/* L320: */ - } -/* L330: */ - } - xmax *= xscale; - } - -/* Compute the contributions of the off-diagonals of */ -/* column j (and j+1, if 2-by-2 block) of A and B to the */ -/* sums. */ - - - i__1 = na; - for (ja = 1; ja <= i__1; ++ja) { - if (ilcplx) { - creala = acoef * work[(*n << 1) + j + ja - 1]; - cimaga = acoef * work[*n * 3 + j + ja - 1]; - crealb = bcoefr * work[(*n << 1) + j + ja - 1] - - bcoefi * work[*n * 3 + j + ja - 1]; - cimagb = bcoefi * work[(*n << 1) + j + ja - 1] + - bcoefr * work[*n * 3 + j + ja - 1]; - i__2 = j - 1; - for (jr = 1; jr <= i__2; ++jr) { - work[(*n << 1) + jr] = work[(*n << 1) + jr] - - creala * s[jr + (j + ja - 1) * s_dim1] - + crealb * p[jr + (j + ja - 1) * - p_dim1]; - work[*n * 3 + jr] = work[*n * 3 + jr] - - cimaga * s[jr + (j + ja - 1) * s_dim1] - + cimagb * p[jr + (j + ja - 1) * - p_dim1]; -/* L340: */ - } - } else { - creala = acoef * work[(*n << 1) + j + ja - 1]; - crealb = bcoefr * work[(*n << 1) + j + ja - 1]; - i__2 = j - 1; - for (jr = 1; jr <= i__2; ++jr) { - work[(*n << 1) + jr] = work[(*n << 1) + jr] - - creala * s[jr + (j + ja - 1) * s_dim1] - + crealb * p[jr + (j + ja - 1) * - p_dim1]; -/* L350: */ - } - } -/* L360: */ - } - } - il2by2 = false; -L370: - ; - } - -/* Copy eigenvector to VR, back transforming if */ -/* HOWMNY='B'. */ - - ieig -= nw; - if (ilback) { - - i__1 = nw - 1; - for (jw = 0; jw <= i__1; ++jw) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - work[(jw + 4) * *n + jr] = work[(jw + 2) * *n + 1] * - vr[jr + vr_dim1]; -/* L380: */ - } - -/* A series of compiler directives to defeat */ -/* vectorization for the next loop */ - - - i__2 = je; - for (jc = 2; jc <= i__2; ++jc) { - i__3 = *n; - for (jr = 1; jr <= i__3; ++jr) { - work[(jw + 4) * *n + jr] += work[(jw + 2) * *n + - jc] * vr[jr + jc * vr_dim1]; -/* L390: */ - } -/* L400: */ - } -/* L410: */ - } - - i__1 = nw - 1; - for (jw = 0; jw <= i__1; ++jw) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 4) * *n + - jr]; -/* L420: */ - } -/* L430: */ - } - - iend = *n; - } else { - i__1 = nw - 1; - for (jw = 0; jw <= i__1; ++jw) { - i__2 = *n; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 2) * *n + - jr]; -/* L440: */ - } -/* L450: */ - } - - iend = je; - } - -/* Scale eigenvector */ - - xmax = 0.; - if (ilcplx) { - i__1 = iend; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - d__3 = xmax, d__4 = (d__1 = vr[j + ieig * vr_dim1], abs( - d__1)) + (d__2 = vr[j + (ieig + 1) * vr_dim1], - abs(d__2)); - xmax = std::max(d__3,d__4); -/* L460: */ - } - } else { - i__1 = iend; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = vr[j + ieig * vr_dim1], abs( - d__1)); - xmax = std::max(d__2,d__3); -/* L470: */ - } - } - - if (xmax > safmin) { - xscale = 1. / xmax; - i__1 = nw - 1; - for (jw = 0; jw <= i__1; ++jw) { - i__2 = iend; - for (jr = 1; jr <= i__2; ++jr) { - vr[jr + (ieig + jw) * vr_dim1] = xscale * vr[jr + ( - ieig + jw) * vr_dim1]; -/* L480: */ - } -/* L490: */ - } - } -L500: - ; - } - } - - return 0; - -/* End of DTGEVC */ - -} /* dtgevc_ */ diff --git a/external/clapack/lapack/dtgex2.cpp b/external/clapack/lapack/dtgex2.cpp deleted file mode 100644 index 96208ac0..00000000 --- a/external/clapack/lapack/dtgex2.cpp +++ /dev/null @@ -1,663 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__4 = 4; -static double c_b5 = 0.; -static integer c__1 = 1; -static integer c__2 = 2; -static double c_b42 = 1.; -static double c_b48 = -1.; -static integer c__0 = 0; - -/* Subroutine */ int dtgex2_(bool *wantq, bool *wantz, integer *n, - double *a, integer *lda, double *b, integer *ldb, double * - q, integer *ldq, double *z__, integer *ldz, integer *j1, integer * - n1, integer *n2, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, - z_offset, i__1, i__2; - double d__1; - - /* Local variables */ - double f, g; - integer i__, m; - double s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2] - , ar[2], sa, sb, li[16] /* was [4][4] */, ir[16] /* - was [4][4] */, ss, ws, eps; - bool weak; - double ddum; - integer idum; - double taul[4], dsum; - double taur[4], scpy[16] /* was [4][4] */, tcpy[16] /* was [4][4] */; - double scale, bqra21, brqa21; - double licop[16] /* was [4][4] */; - integer linfo; - double ircop[16] /* was [4][4] */, dnorm; - integer iwork[4]; - double dscale; - bool dtrong; - double thresh, smlnum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */ -/* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */ -/* (A, B) by an orthogonal equivalence transformation. */ - -/* (A, B) must be in generalized real Schur canonical form (as returned */ -/* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ -/* diagonal blocks. B is upper triangular. */ - -/* Optionally, the matrices Q and Z of generalized Schur vectors are */ -/* updated. */ - -/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */ -/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */ - - -/* Arguments */ -/* ========= */ - -/* WANTQ (input) LOGICAL */ -/* .TRUE. : update the left transformation matrix Q; */ -/* .FALSE.: do not update Q. */ - -/* WANTZ (input) LOGICAL */ -/* .TRUE. : update the right transformation matrix Z; */ -/* .FALSE.: do not update Z. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION arrays, dimensions (LDA,N) */ -/* On entry, the matrix A in the pair (A, B). */ -/* On exit, the updated matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION arrays, dimensions (LDB,N) */ -/* On entry, the matrix B in the pair (A, B). */ -/* On exit, the updated matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ -/* On exit, the updated matrix Q. */ -/* Not referenced if WANTQ = .FALSE.. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= 1. */ -/* If WANTQ = .TRUE., LDQ >= N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */ -/* On exit, the updated matrix Z. */ -/* Not referenced if WANTZ = .FALSE.. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1. */ -/* If WANTZ = .TRUE., LDZ >= N. */ - -/* J1 (input) INTEGER */ -/* The index to the first block (A11, B11). 1 <= J1 <= N. */ - -/* N1 (input) INTEGER */ -/* The order of the first block (A11, B11). N1 = 0, 1 or 2. */ - -/* N2 (input) INTEGER */ -/* The order of the second block (A22, B22). N2 = 0, 1 or 2. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)). */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */ - -/* INFO (output) INTEGER */ -/* =0: Successful exit */ -/* >0: If INFO = 1, the transformed matrix (A, B) would be */ -/* too far from generalized Schur form; the blocks are */ -/* not swapped and (A, B) and (Q, Z) are unchanged. */ -/* The problem of swapping is too ill-conditioned. */ -/* <0: If INFO = -16: LWORK is too small. Appropriate value */ -/* for LWORK is returned in WORK(1). */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* In the current code both weak and strong stability tests are */ -/* performed. The user can omit the strong stability test by changing */ -/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */ -/* details. */ - -/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ -/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ -/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ -/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ - -/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ -/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ -/* Estimation: Theory, Algorithms and Software, */ -/* Report UMINF - 94.04, Department of Computing Science, Umea */ -/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ -/* Note 87. To appear in Numerical Algorithms, 1996. */ - -/* ===================================================================== */ -/* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO */ -/* loops. Sven Hammarling, 1/5/02. */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - *info = 0; - -/* Quick return if possible */ - - if (*n <= 1 || *n1 <= 0 || *n2 <= 0) { - return 0; - } - if (*n1 > *n || *j1 + *n1 > *n) { - return 0; - } - m = *n1 + *n2; -/* Computing MAX */ - i__1 = 1, i__2 = *n * m, i__1 = std::max(i__1,i__2), i__2 = m * m << 1; - if (*lwork < std::max(i__1,i__2)) { - *info = -16; -/* Computing MAX */ - i__1 = 1, i__2 = *n * m, i__1 = std::max(i__1,i__2), i__2 = m * m << 1; - work[1] = (double) std::max(i__1,i__2); - return 0; - } - - weak = false; - dtrong = false; - -/* Make a local copy of selected block */ - - dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4); - dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4); - dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4); - dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4); - -/* Compute threshold for testing acceptance of swapping. */ - - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; - dscale = 0.; - dsum = 1.; - dlacpy_("Full", &m, &m, s, &c__4, &work[1], &m); - i__1 = m * m; - dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum); - dlacpy_("Full", &m, &m, t, &c__4, &work[1], &m); - i__1 = m * m; - dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum); - dnorm = dscale * sqrt(dsum); -/* Computing MAX */ - d__1 = eps * 10. * dnorm; - thresh = std::max(d__1,smlnum); - - if (m == 2) { - -/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */ - -/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */ -/* using Givens rotations and perform the swap tentatively. */ - - f = s[5] * t[0] - t[5] * s[0]; - g = s[5] * t[4] - t[5] * s[4]; - sb = abs(t[5]); - sa = abs(s[5]); - dlartg_(&f, &g, &ir[4], ir, &ddum); - ir[1] = -ir[4]; - ir[5] = ir[0]; - drot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]); - drot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]); - if (sa >= sb) { - dlartg_(s, &s[1], li, &li[1], &ddum); - } else { - dlartg_(t, &t[1], li, &li[1], &ddum); - } - drot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]); - drot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]); - li[5] = li[0]; - li[4] = -li[1]; - -/* Weak stability test: */ -/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */ - - ws = abs(s[1]) + abs(t[1]); - weak = ws <= thresh; - if (! weak) { - goto L70; - } - - if (true) { - -/* Strong stability test: */ -/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */ - - dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m - + 1], &m); - dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & - work[1], &m); - dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & - c_b42, &work[m * m + 1], &m); - dscale = 0.; - dsum = 1.; - i__1 = m * m; - dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); - - dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m - + 1], &m); - dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & - work[1], &m); - dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & - c_b42, &work[m * m + 1], &m); - i__1 = m * m; - dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); - ss = dscale * sqrt(dsum); - dtrong = ss <= thresh; - if (! dtrong) { - goto L70; - } - } - -/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ -/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ - - i__1 = *j1 + 1; - drot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], - &c__1, ir, &ir[1]); - i__1 = *j1 + 1; - drot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], - &c__1, ir, &ir[1]); - i__1 = *n - *j1 + 1; - drot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], - lda, li, &li[1]); - i__1 = *n - *j1 + 1; - drot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], - ldb, li, &li[1]); - -/* Set N1-by-N2 (2,1) - blocks to ZERO. */ - - a[*j1 + 1 + *j1 * a_dim1] = 0.; - b[*j1 + 1 + *j1 * b_dim1] = 0.; - -/* Accumulate transformations into Q and Z if requested. */ - - if (*wantz) { - drot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + - 1], &c__1, ir, &ir[1]); - } - if (*wantq) { - drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], - &c__1, li, &li[1]); - } - -/* Exit with INFO = 0 if swap was successfully performed. */ - - return 0; - - } else { - -/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */ -/* and 2-by-2 blocks. */ - -/* Solve the generalized Sylvester equation */ -/* S11 * R - L * S22 = SCALE * S12 */ -/* T11 * R - L * T22 = SCALE * T12 */ -/* for R and L. Solutions in LI and IR. */ - - dlacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4); - dlacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + ( - *n1 + 1 << 2) - 5], &c__4); - dtgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5] -, &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, & - t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, & - dsum, &dscale, iwork, &idum, &linfo); - -/* Compute orthogonal matrix QL: */ - -/* QL' * LI = [ TL ] */ -/* [ 0 ] */ -/* where */ -/* LI = [ -L ] */ -/* [ SCALE * identity(N2) ] */ - - i__1 = *n2; - for (i__ = 1; i__ <= i__1; ++i__) { - dscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1); - li[*n1 + i__ + (i__ << 2) - 5] = scale; -/* L10: */ - } - dgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo); - if (linfo != 0) { - goto L70; - } - dorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo); - if (linfo != 0) { - goto L70; - } - -/* Compute orthogonal matrix RQ: */ - -/* IR * RQ' = [ 0 TR], */ - -/* where IR = [ SCALE * identity(N1), R ] */ - - i__1 = *n1; - for (i__ = 1; i__ <= i__1; ++i__) { - ir[*n2 + i__ + (i__ << 2) - 5] = scale; -/* L20: */ - } - dgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo); - if (linfo != 0) { - goto L70; - } - dorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo); - if (linfo != 0) { - goto L70; - } - -/* Perform the swapping tentatively: */ - - dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & - work[1], &m); - dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, - s, &c__4); - dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & - work[1], &m); - dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, - t, &c__4); - dlacpy_("F", &m, &m, s, &c__4, scpy, &c__4); - dlacpy_("F", &m, &m, t, &c__4, tcpy, &c__4); - dlacpy_("F", &m, &m, ir, &c__4, ircop, &c__4); - dlacpy_("F", &m, &m, li, &c__4, licop, &c__4); - -/* Triangularize the B-part by an RQ factorization. */ -/* Apply transformation (from left) to A-part, giving S. */ - - dgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo); - if (linfo != 0) { - goto L70; - } - dormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], & - linfo); - if (linfo != 0) { - goto L70; - } - dormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], & - linfo); - if (linfo != 0) { - goto L70; - } - -/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */ - - dscale = 0.; - dsum = 1.; - i__1 = *n2; - for (i__ = 1; i__ <= i__1; ++i__) { - dlassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum); -/* L30: */ - } - brqa21 = dscale * sqrt(dsum); - -/* Triangularize the B-part by a QR factorization. */ -/* Apply transformation (from right) to A-part, giving S. */ - - dgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo); - if (linfo != 0) { - goto L70; - } - dorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1] -, info); - dorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[ - 1], info); - if (linfo != 0) { - goto L70; - } - -/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */ - - dscale = 0.; - dsum = 1.; - i__1 = *n2; - for (i__ = 1; i__ <= i__1; ++i__) { - dlassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, & - dsum); -/* L40: */ - } - bqra21 = dscale * sqrt(dsum); - -/* Decide which method to use. */ -/* Weak stability test: */ -/* F-norm(S21) <= O(EPS * F-norm((S, T))) */ - - if (bqra21 <= brqa21 && bqra21 <= thresh) { - dlacpy_("F", &m, &m, scpy, &c__4, s, &c__4); - dlacpy_("F", &m, &m, tcpy, &c__4, t, &c__4); - dlacpy_("F", &m, &m, ircop, &c__4, ir, &c__4); - dlacpy_("F", &m, &m, licop, &c__4, li, &c__4); - } else if (brqa21 >= thresh) { - goto L70; - } - -/* Set lower triangle of B-part to zero */ - - i__1 = m - 1; - i__2 = m - 1; - dlaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4); - - if (true) { - -/* Strong stability test: */ -/* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */ - - dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m - + 1], &m); - dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & - work[1], &m); - dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & - c_b42, &work[m * m + 1], &m); - dscale = 0.; - dsum = 1.; - i__1 = m * m; - dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); - - dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m - + 1], &m); - dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & - work[1], &m); - dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & - c_b42, &work[m * m + 1], &m); - i__1 = m * m; - dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); - ss = dscale * sqrt(dsum); - dtrong = ss <= thresh; - if (! dtrong) { - goto L70; - } - - } - -/* If the swap is accepted ("weakly" and "strongly"), apply the */ -/* transformations and set N1-by-N2 (2,1)-block to zero. */ - - dlaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4); - -/* copy back M-by-M diagonal block starting at index J1 of (A, B) */ - - dlacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda) - ; - dlacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb) - ; - dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4); - -/* Standardize existing 2-by-2 blocks. */ - - i__1 = m * m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L50: */ - } - work[1] = 1.; - t[0] = 1.; - idum = *lwork - m * m - 2; - if (*n2 > 1) { - dlagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb, - ar, ai, be, &work[1], &work[2], t, &t[1]); - work[m + 1] = -work[2]; - work[m + 2] = work[1]; - t[*n2 + (*n2 << 2) - 5] = t[0]; - t[4] = -t[1]; - } - work[m * m] = 1.; - t[m + (m << 2) - 5] = 1.; - - if (*n1 > 1) { - dlagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 + - (*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1], - &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[* - n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]); - work[m * m] = work[*n2 * m + *n2 + 1]; - work[m * m - 1] = -work[*n2 * m + *n2 + 2]; - t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5]; - t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5]; - } - dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + * - n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2); - dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) * - a_dim1], lda); - dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + * - n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2); - dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) * - b_dim1], ldb); - dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, & - work[m * m + 1], &m); - dlacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4); - dgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1], - lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], - n2); - dlacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1], - lda); - dgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1], - ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], - n2); - dlacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1], - ldb); - dgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, & - work[1], &m); - dlacpy_("Full", &m, &m, &work[1], &m, ir, &c__4); - -/* Accumulate transformations into Q and Z if requested. */ - - if (*wantq) { - dgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li, - &c__4, &c_b5, &work[1], n); - dlacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq); - - } - - if (*wantz) { - dgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz, - ir, &c__4, &c_b5, &work[1], n); - dlacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz); - - } - -/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ -/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ - - i__ = *j1 + m; - if (i__ <= *n) { - i__1 = *n - i__ + 1; - dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ * - a_dim1], lda, &c_b5, &work[1], &m); - i__1 = *n - i__ + 1; - dlacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1], - lda); - i__1 = *n - i__ + 1; - dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ * - b_dim1], lda, &c_b5, &work[1], &m); - i__1 = *n - i__ + 1; - dlacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1], - ldb); - } - i__ = *j1 - 1; - if (i__ > 0) { - dgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda, - ir, &c__4, &c_b5, &work[1], &i__); - dlacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1], - lda); - dgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb, - ir, &c__4, &c_b5, &work[1], &i__); - dlacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1], - ldb); - } - -/* Exit with INFO = 0 if swap was successfully performed. */ - - return 0; - - } - -/* Exit with INFO = 1 if swap was rejected. */ - -L70: - - *info = 1; - return 0; - -/* End of DTGEX2 */ - -} /* dtgex2_ */ diff --git a/external/clapack/lapack/dtgexc.cpp b/external/clapack/lapack/dtgexc.cpp deleted file mode 100644 index d4d02b8d..00000000 --- a/external/clapack/lapack/dtgexc.cpp +++ /dev/null @@ -1,498 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int dtgexc_(bool *wantq, bool *wantz, integer *n, - double *a, integer *lda, double *b, integer *ldb, double * - q, integer *ldq, double *z__, integer *ldz, integer *ifst, - integer *ilst, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, - z_offset, i__1; - - /* Local variables */ - integer nbf, nbl, here, lwmin; - integer nbnext; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTGEXC reorders the generalized real Schur decomposition of a real */ -/* matrix pair (A,B) using an orthogonal equivalence transformation */ - -/* (A, B) = Q * (A, B) * Z', */ - -/* so that the diagonal block of (A, B) with row index IFST is moved */ -/* to row ILST. */ - -/* (A, B) must be in generalized real Schur canonical form (as returned */ -/* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ -/* diagonal blocks. B is upper triangular. */ - -/* Optionally, the matrices Q and Z of generalized Schur vectors are */ -/* updated. */ - -/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */ -/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */ - - -/* Arguments */ -/* ========= */ - -/* WANTQ (input) LOGICAL */ -/* .TRUE. : update the left transformation matrix Q; */ -/* .FALSE.: do not update Q. */ - -/* WANTZ (input) LOGICAL */ -/* .TRUE. : update the right transformation matrix Z; */ -/* .FALSE.: do not update Z. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the matrix A in generalized real Schur canonical */ -/* form. */ -/* On exit, the updated matrix A, again in generalized */ -/* real Schur canonical form. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ -/* On entry, the matrix B in generalized real Schur canonical */ -/* form (A,B). */ -/* On exit, the updated matrix B, again in generalized */ -/* real Schur canonical form (A,B). */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ -/* On exit, the updated matrix Q. */ -/* If WANTQ = .FALSE., Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= 1. */ -/* If WANTQ = .TRUE., LDQ >= N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* On entry, if WANTZ = .TRUE., the orthogonal matrix Z. */ -/* On exit, the updated matrix Z. */ -/* If WANTZ = .FALSE., Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1. */ -/* If WANTZ = .TRUE., LDZ >= N. */ - -/* IFST (input/output) INTEGER */ -/* ILST (input/output) INTEGER */ -/* Specify the reordering of the diagonal blocks of (A, B). */ -/* The block with row index IFST is moved to row ILST, by a */ -/* sequence of swapping between adjacent blocks. */ -/* On exit, if IFST pointed on entry to the second row of */ -/* a 2-by-2 block, it is changed to point to the first row; */ -/* ILST always points to the first row of the block in its */ -/* final position (which may differ from its input value by */ -/* +1 or -1). 1 <= IFST, ILST <= N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* =0: successful exit. */ -/* <0: if INFO = -i, the i-th argument had an illegal value. */ -/* =1: The transformed matrix pair (A, B) would be too far */ -/* from generalized Schur form; the problem is ill- */ -/* conditioned. (A, B) may have been partially reordered, */ -/* and ILST points to the first row of the current */ -/* position of the block being moved. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ -/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ -/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ -/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test input arguments. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldq < 1 || *wantq && *ldq < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldz < 1 || *wantz && *ldz < std::max(1_integer,*n)) { - *info = -11; - } else if (*ifst < 1 || *ifst > *n) { - *info = -12; - } else if (*ilst < 1 || *ilst > *n) { - *info = -13; - } - - if (*info == 0) { - if (*n <= 1) { - lwmin = 1; - } else { - lwmin = (*n << 2) + 16; - } - work[1] = (double) lwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -15; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGEXC", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n <= 1) { - return 0; - } - -/* Determine the first row of the specified block and find out */ -/* if it is 1-by-1 or 2-by-2. */ - - if (*ifst > 1) { - if (a[*ifst + (*ifst - 1) * a_dim1] != 0.) { - --(*ifst); - } - } - nbf = 1; - if (*ifst < *n) { - if (a[*ifst + 1 + *ifst * a_dim1] != 0.) { - nbf = 2; - } - } - -/* Determine the first row of the final block */ -/* and find out if it is 1-by-1 or 2-by-2. */ - - if (*ilst > 1) { - if (a[*ilst + (*ilst - 1) * a_dim1] != 0.) { - --(*ilst); - } - } - nbl = 1; - if (*ilst < *n) { - if (a[*ilst + 1 + *ilst * a_dim1] != 0.) { - nbl = 2; - } - } - if (*ifst == *ilst) { - return 0; - } - - if (*ifst < *ilst) { - -/* Update ILST. */ - - if (nbf == 2 && nbl == 1) { - --(*ilst); - } - if (nbf == 1 && nbl == 2) { - ++(*ilst); - } - - here = *ifst; - -L10: - -/* Swap with next one below. */ - - if (nbf == 1 || nbf == 2) { - -/* Current block either 1-by-1 or 2-by-2. */ - - nbnext = 1; - if (here + nbf + 1 <= *n) { - if (a[here + nbf + 1 + (here + nbf) * a_dim1] != 0.) { - nbnext = 2; - } - } - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ - q_offset], ldq, &z__[z_offset], ldz, &here, &nbf, &nbnext, - &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - here += nbnext; - -/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */ - - if (nbf == 2) { - if (a[here + 1 + here * a_dim1] == 0.) { - nbf = 3; - } - } - - } else { - -/* Current block consists of two 1-by-1 blocks, each of which */ -/* must be swapped individually. */ - - nbnext = 1; - if (here + 3 <= *n) { - if (a[here + 3 + (here + 2) * a_dim1] != 0.) { - nbnext = 2; - } - } - i__1 = here + 1; - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ - q_offset], ldq, &z__[z_offset], ldz, &i__1, &c__1, & - nbnext, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - if (nbnext == 1) { - -/* Swap two 1-by-1 blocks. */ - - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, - &q[q_offset], ldq, &z__[z_offset], ldz, &here, &c__1, - &c__1, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - ++here; - - } else { - -/* Recompute NBNEXT in case of 2-by-2 split. */ - - if (a[here + 2 + (here + 1) * a_dim1] == 0.) { - nbnext = 1; - } - if (nbnext == 2) { - -/* 2-by-2 block did not split. */ - - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], - ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & - here, &c__1, &nbnext, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - here += 2; - } else { - -/* 2-by-2 block did split. */ - - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], - ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & - here, &c__1, &c__1, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - ++here; - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], - ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & - here, &c__1, &c__1, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - ++here; - } - - } - } - if (here < *ilst) { - goto L10; - } - } else { - here = *ifst; - -L20: - -/* Swap with next one below. */ - - if (nbf == 1 || nbf == 2) { - -/* Current block either 1-by-1 or 2-by-2. */ - - nbnext = 1; - if (here >= 3) { - if (a[here - 1 + (here - 2) * a_dim1] != 0.) { - nbnext = 2; - } - } - i__1 = here - nbnext; - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ - q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &nbf, - &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - here -= nbnext; - -/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */ - - if (nbf == 2) { - if (a[here + 1 + here * a_dim1] == 0.) { - nbf = 3; - } - } - - } else { - -/* Current block consists of two 1-by-1 blocks, each of which */ -/* must be swapped individually. */ - - nbnext = 1; - if (here >= 3) { - if (a[here - 1 + (here - 2) * a_dim1] != 0.) { - nbnext = 2; - } - } - i__1 = here - nbnext; - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ - q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, & - c__1, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - if (nbnext == 1) { - -/* Swap two 1-by-1 blocks. */ - - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, - &q[q_offset], ldq, &z__[z_offset], ldz, &here, & - nbnext, &c__1, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - --here; - } else { - -/* Recompute NBNEXT in case of 2-by-2 split. */ - - if (a[here + (here - 1) * a_dim1] == 0.) { - nbnext = 1; - } - if (nbnext == 2) { - -/* 2-by-2 block did not split. */ - - i__1 = here - 1; - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], - ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & - i__1, &c__2, &c__1, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - here += -2; - } else { - -/* 2-by-2 block did split. */ - - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], - ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & - here, &c__1, &c__1, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - --here; - dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], - ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & - here, &c__1, &c__1, &work[1], lwork, info); - if (*info != 0) { - *ilst = here; - return 0; - } - --here; - } - } - } - if (here > *ilst) { - goto L20; - } - } - *ilst = here; - work[1] = (double) lwmin; - return 0; - -/* End of DTGEXC */ - -} /* dtgexc_ */ diff --git a/external/clapack/lapack/dtgsen.cpp b/external/clapack/lapack/dtgsen.cpp deleted file mode 100644 index 14b3a2f8..00000000 --- a/external/clapack/lapack/dtgsen.cpp +++ /dev/null @@ -1,800 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__2 = 2; -static double c_b28 = 1.; - -/* Subroutine */ int dtgsen_(integer *ijob, bool *wantq, bool *wantz, - bool *select, integer *n, double *a, integer *lda, double * - b, integer *ldb, double *alphar, double *alphai, double * - beta, double *q, integer *ldq, double *z__, integer *ldz, - integer *m, double *pl, double *pr, double *dif, - double *work, integer *lwork, integer *iwork, integer *liwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, - z_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, k, n1, n2, kk, ks, mn2, ijb; - double eps; - integer kase; - bool pair; - integer ierr; - double dsum; - bool swap; - integer isave[3]; - bool wantd; - integer lwmin; - bool wantp; - bool wantd1, wantd2; - double dscale, rdscal; - integer liwmin; - double smlnum; - bool lquery; - - -/* -- LAPACK routine (version 3.1.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* January 2007 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTGSEN reorders the generalized real Schur decomposition of a real */ -/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */ -/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */ -/* appears in the leading diagonal blocks of the upper quasi-triangular */ -/* matrix A and the upper triangular B. The leading columns of Q and */ -/* Z form orthonormal bases of the corresponding left and right eigen- */ -/* spaces (deflating subspaces). (A, B) must be in generalized real */ -/* Schur canonical form (as returned by DGGES), i.e. A is block upper */ -/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */ -/* triangular. */ - -/* DTGSEN also computes the generalized eigenvalues */ - -/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */ - -/* of the reordered matrix pair (A, B). */ - -/* Optionally, DTGSEN computes the estimates of reciprocal condition */ -/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */ -/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */ -/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */ -/* the selected cluster and the eigenvalues outside the cluster, resp., */ -/* and norms of "projections" onto left and right eigenspaces w.r.t. */ -/* the selected cluster in the (1,1)-block. */ - -/* Arguments */ -/* ========= */ - -/* IJOB (input) INTEGER */ -/* Specifies whether condition numbers are required for the */ -/* cluster of eigenvalues (PL and PR) or the deflating subspaces */ -/* (Difu and Difl): */ -/* =0: Only reorder w.r.t. SELECT. No extras. */ -/* =1: Reciprocal of norms of "projections" onto left and right */ -/* eigenspaces w.r.t. the selected cluster (PL and PR). */ -/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */ -/* (DIF(1:2)). */ -/* =3: Estimate of Difu and Difl. 1-norm-based estimate */ -/* (DIF(1:2)). */ -/* About 5 times as expensive as IJOB = 2. */ -/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */ -/* version to get it all. */ -/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */ - -/* WANTQ (input) LOGICAL */ -/* .TRUE. : update the left transformation matrix Q; */ -/* .FALSE.: do not update Q. */ - -/* WANTZ (input) LOGICAL */ -/* .TRUE. : update the right transformation matrix Z; */ -/* .FALSE.: do not update Z. */ - -/* SELECT (input) LOGICAL array, dimension (N) */ -/* SELECT specifies the eigenvalues in the selected cluster. */ -/* To select a real eigenvalue w(j), SELECT(j) must be set to */ -/* .TRUE.. To select a complex conjugate pair of eigenvalues */ -/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ -/* either SELECT(j) or SELECT(j+1) or both must be set to */ -/* .TRUE.; a complex conjugate pair of eigenvalues must be */ -/* either both included in the cluster or both excluded. */ - -/* N (input) INTEGER */ -/* The order of the matrices A and B. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */ -/* On entry, the upper quasi-triangular matrix A, with (A, B) in */ -/* generalized real Schur canonical form. */ -/* On exit, A is overwritten by the reordered matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */ -/* On entry, the upper triangular matrix B, with (A, B) in */ -/* generalized real Schur canonical form. */ -/* On exit, B is overwritten by the reordered matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ -/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ -/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */ -/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */ -/* form (S,T) that would result if the 2-by-2 diagonal blocks of */ -/* the real generalized Schur form of (A,B) were further reduced */ -/* to triangular form using complex unitary transformations. */ -/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ -/* positive, then the j-th and (j+1)-st eigenvalues are a */ -/* complex conjugate pair, with ALPHAI(j+1) negative. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */ -/* On exit, Q has been postmultiplied by the left orthogonal */ -/* transformation matrix which reorder (A, B); The leading M */ -/* columns of Q form orthonormal bases for the specified pair of */ -/* left eigenspaces (deflating subspaces). */ -/* If WANTQ = .FALSE., Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= 1; */ -/* and if WANTQ = .TRUE., LDQ >= N. */ - -/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ -/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */ -/* On exit, Z has been postmultiplied by the left orthogonal */ -/* transformation matrix which reorder (A, B); The leading M */ -/* columns of Z form orthonormal bases for the specified pair of */ -/* left eigenspaces (deflating subspaces). */ -/* If WANTZ = .FALSE., Z is not referenced. */ - -/* LDZ (input) INTEGER */ -/* The leading dimension of the array Z. LDZ >= 1; */ -/* If WANTZ = .TRUE., LDZ >= N. */ - -/* M (output) INTEGER */ -/* The dimension of the specified pair of left and right eigen- */ -/* spaces (deflating subspaces). 0 <= M <= N. */ - -/* PL (output) DOUBLE PRECISION */ -/* PR (output) DOUBLE PRECISION */ -/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */ -/* reciprocal of the norm of "projections" onto left and right */ -/* eigenspaces with respect to the selected cluster. */ -/* 0 < PL, PR <= 1. */ -/* If M = 0 or M = N, PL = PR = 1. */ -/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */ - -/* DIF (output) DOUBLE PRECISION array, dimension (2). */ -/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */ -/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */ -/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */ -/* estimates of Difu and Difl. */ -/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */ -/* If IJOB = 0 or 1, DIF is not referenced. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, */ -/* dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= 4*N+16. */ -/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */ -/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* IF IJOB = 0, IWORK is not referenced. Otherwise, */ -/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. LIWORK >= 1. */ -/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */ -/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* =0: Successful exit. */ -/* <0: If INFO = -i, the i-th argument had an illegal value. */ -/* =1: Reordering of (A, B) failed because the transformed */ -/* matrix pair (A, B) would be too far from generalized */ -/* Schur form; the problem is very ill-conditioned. */ -/* (A, B) may have been partially reordered. */ -/* If requested, 0 is returned in DIF(*), PL and PR. */ - -/* Further Details */ -/* =============== */ - -/* DTGSEN first collects the selected eigenvalues by computing */ -/* orthogonal U and W that move them to the top left corner of (A, B). */ -/* In other words, the selected eigenvalues are the eigenvalues of */ -/* (A11, B11) in: */ - -/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */ -/* ( 0 A22),( 0 B22) n2 */ -/* n1 n2 n1 n2 */ - -/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */ -/* of U and W span the specified pair of left and right eigenspaces */ -/* (deflating subspaces) of (A, B). */ - -/* If (A, B) has been obtained from the generalized real Schur */ -/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */ -/* reordered generalized real Schur form of (C, D) is given by */ - -/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */ - -/* and the first n1 columns of Q*U and Z*W span the corresponding */ -/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */ - -/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */ -/* then its value may differ significantly from its value before */ -/* reordering. */ - -/* The reciprocal condition numbers of the left and right eigenspaces */ -/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */ -/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */ - -/* The Difu and Difl are defined as: */ - -/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */ -/* and */ -/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */ - -/* where sigma-min(Zu) is the smallest singular value of the */ -/* (2*n1*n2)-by-(2*n1*n2) matrix */ - -/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */ -/* [ kron(In2, B11) -kron(B22', In1) ]. */ - -/* Here, Inx is the identity matrix of size nx and A22' is the */ -/* transpose of A22. kron(X, Y) is the Kronecker product between */ -/* the matrices X and Y. */ - -/* When DIF(2) is small, small changes in (A, B) can cause large changes */ -/* in the deflating subspace. An approximate (asymptotic) bound on the */ -/* maximum angular error in the computed deflating subspaces is */ - -/* EPS * norm((A, B)) / DIF(2), */ - -/* where EPS is the machine precision. */ - -/* The reciprocal norm of the projectors on the left and right */ -/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */ -/* They are computed as follows. First we compute L and R so that */ -/* P*(A, B)*Q is block diagonal, where */ - -/* P = ( I -L ) n1 Q = ( I R ) n1 */ -/* ( 0 I ) n2 and ( 0 I ) n2 */ -/* n1 n2 n1 n2 */ - -/* and (L, R) is the solution to the generalized Sylvester equation */ - -/* A11*R - L*A22 = -A12 */ -/* B11*R - L*B22 = -B12 */ - -/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */ -/* An approximate (asymptotic) bound on the average absolute error of */ -/* the selected eigenvalues is */ - -/* EPS * norm((A, B)) / PL. */ - -/* There are also global error bounds which valid for perturbations up */ -/* to a certain restriction: A lower bound (x) on the smallest */ -/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */ -/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */ -/* (i.e. (A + E, B + F), is */ - -/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */ - -/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */ - -/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */ -/* (L', R') and unperturbed (L, R) left and right deflating subspaces */ -/* associated with the selected cluster in the (1,1)-blocks can be */ -/* bounded as */ - -/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */ -/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */ - -/* See LAPACK User's Guide section 4.11 or the following references */ -/* for more information. */ - -/* Note that if the default method for computing the Frobenius-norm- */ -/* based estimate DIF is not wanted (see DLATDF), then the parameter */ -/* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */ -/* (IJOB = 2 will be used)). See DTGSYL for more details. */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* References */ -/* ========== */ - -/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ -/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ -/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ -/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ - -/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ -/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ -/* Estimation: Theory, Algorithms and Software, */ -/* Report UMINF - 94.04, Department of Computing Science, Umea */ -/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ -/* Note 87. To appear in Numerical Algorithms, 1996. */ - -/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ -/* for Solving the Generalized Sylvester Equation and Estimating the */ -/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ -/* Department of Computing Science, Umea University, S-901 87 Umea, */ -/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ -/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */ -/* 1996. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test the input parameters */ - - /* Parameter adjustments */ - --select; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alphar; - --alphai; - --beta; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - z_dim1 = *ldz; - z_offset = 1 + z_dim1; - z__ -= z_offset; - --dif; - --work; - --iwork; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1 || *liwork == -1; - - if (*ijob < 0 || *ijob > 5) { - *info = -1; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldq < 1 || *wantq && *ldq < *n) { - *info = -14; - } else if (*ldz < 1 || *wantz && *ldz < *n) { - *info = -16; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGSEN", &i__1); - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; - ierr = 0; - - wantp = *ijob == 1 || *ijob >= 4; - wantd1 = *ijob == 2 || *ijob == 4; - wantd2 = *ijob == 3 || *ijob == 5; - wantd = wantd1 || wantd2; - -/* Set M to the dimension of the specified pair of deflating */ -/* subspaces. */ - - *m = 0; - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (pair) { - pair = false; - } else { - if (k < *n) { - if (a[k + 1 + k * a_dim1] == 0.) { - if (select[k]) { - ++(*m); - } - } else { - pair = true; - if (select[k] || select[k + 1]) { - *m += 2; - } - } - } else { - if (select[*n]) { - ++(*m); - } - } - } -/* L10: */ - } - - if (*ijob == 1 || *ijob == 2 || *ijob == 4) { -/* Computing MAX */ - i__1 = 1, i__2 = (*n << 2) + 16, i__1 = std::max(i__1,i__2), i__2 = (*m << - 1) * (*n - *m); - lwmin = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n + 6; - liwmin = std::max(i__1,i__2); - } else if (*ijob == 3 || *ijob == 5) { -/* Computing MAX */ - i__1 = 1, i__2 = (*n << 2) + 16, i__1 = std::max(i__1,i__2), i__2 = (*m << - 2) * (*n - *m); - lwmin = std::max(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = std::max(i__1,i__2), i__2 = - *n + 6; - liwmin = std::max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = 1, i__2 = (*n << 2) + 16; - lwmin = std::max(i__1,i__2); - liwmin = 1; - } - - work[1] = (double) lwmin; - iwork[1] = liwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -22; - } else if (*liwork < liwmin && ! lquery) { - *info = -24; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGSEN", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible. */ - - if (*m == *n || *m == 0) { - if (wantp) { - *pl = 1.; - *pr = 1.; - } - if (wantd) { - dscale = 0.; - dsum = 1.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum); - dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum); -/* L20: */ - } - dif[1] = dscale * sqrt(dsum); - dif[2] = dif[1]; - } - goto L60; - } - -/* Collect the selected blocks at the top-left corner of (A, B). */ - - ks = 0; - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (pair) { - pair = false; - } else { - - swap = select[k]; - if (k < *n) { - if (a[k + 1 + k * a_dim1] != 0.) { - pair = true; - swap = swap || select[k + 1]; - } - } - - if (swap) { - ++ks; - -/* Swap the K-th block to position KS. */ -/* Perform the reordering of diagonal blocks in (A, B) */ -/* by orthogonal transformation matrices and update */ -/* Q and Z accordingly (if requested): */ - - kk = k; - if (k != ks) { - dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], - ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk, - &ks, &work[1], lwork, &ierr); - } - - if (ierr > 0) { - -/* Swap is rejected: exit. */ - - *info = 1; - if (wantp) { - *pl = 0.; - *pr = 0.; - } - if (wantd) { - dif[1] = 0.; - dif[2] = 0.; - } - goto L60; - } - - if (pair) { - ++ks; - } - } - } -/* L30: */ - } - if (wantp) { - -/* Solve generalized Sylvester equation for R and L */ -/* and compute PL and PR. */ - - n1 = *m; - n2 = *n - *m; - i__ = n1 + 1; - ijb = 0; - dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1); - dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 + - 1], &n1); - i__1 = *lwork - (n1 << 1) * n2; - dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1] -, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ * - b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], & - work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); - -/* Estimate the reciprocal of norms of "projections" onto left */ -/* and right eigenspaces. */ - - rdscal = 0.; - dsum = 1.; - i__1 = n1 * n2; - dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum); - *pl = rdscal * sqrt(dsum); - if (*pl == 0.) { - *pl = 1.; - } else { - *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl)); - } - rdscal = 0.; - dsum = 1.; - i__1 = n1 * n2; - dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum); - *pr = rdscal * sqrt(dsum); - if (*pr == 0.) { - *pr = 1.; - } else { - *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr)); - } - } - - if (wantd) { - -/* Compute estimates of Difu and Difl. */ - - if (wantd1) { - n1 = *m; - n2 = *n - *m; - i__ = n1 + 1; - ijb = 3; - -/* Frobenius norm-based Difu-estimate. */ - - i__1 = *lwork - (n1 << 1) * n2; - dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * - a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + - i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, & - dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], & - ierr); - -/* Frobenius norm-based Difl-estimate. */ - - i__1 = *lwork - (n1 << 1) * n2; - dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[ - a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1], - ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale, - &dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], & - ierr); - } else { - - -/* Compute 1-norm-based estimates of Difu and Difl using */ -/* reversed communication with DLACN2. In each step a */ -/* generalized Sylvester equation or a transposed variant */ -/* is solved. */ - - kase = 0; - n1 = *m; - n2 = *n - *m; - i__ = n1 + 1; - ijb = 0; - mn2 = (n1 << 1) * n2; - -/* 1-norm-based estimate of Difu. */ - -L40: - dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase, - isave); - if (kase != 0) { - if (kase == 1) { - -/* Solve generalized Sylvester equation. */ - - i__1 = *lwork - (n1 << 1) * n2; - dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + - i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], - ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + - 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 + - 1], &i__1, &iwork[1], &ierr); - } else { - -/* Solve the transposed variant. */ - - i__1 = *lwork - (n1 << 1) * n2; - dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + - i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], - ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + - 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 + - 1], &i__1, &iwork[1], &ierr); - } - goto L40; - } - dif[1] = dscale / dif[1]; - -/* 1-norm-based estimate of Difl. */ - -L50: - dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase, - isave); - if (kase != 0) { - if (kase == 1) { - -/* Solve generalized Sylvester equation. */ - - i__1 = *lwork - (n1 << 1) * n2; - dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, - &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * - b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + - 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 + - 1], &i__1, &iwork[1], &ierr); - } else { - -/* Solve the transposed variant. */ - - i__1 = *lwork - (n1 << 1) * n2; - dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, - &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * - b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + - 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 + - 1], &i__1, &iwork[1], &ierr); - } - goto L50; - } - dif[2] = dscale / dif[2]; - - } - } - -L60: - -/* Compute generalized eigenvalues of reordered pair (A, B) and */ -/* normalize the generalized Schur form. */ - - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (pair) { - pair = false; - } else { - - if (k < *n) { - if (a[k + 1 + k * a_dim1] != 0.) { - pair = true; - } - } - - if (pair) { - -/* Compute the eigenvalue(s) at position K. */ - - work[1] = a[k + k * a_dim1]; - work[2] = a[k + 1 + k * a_dim1]; - work[3] = a[k + (k + 1) * a_dim1]; - work[4] = a[k + 1 + (k + 1) * a_dim1]; - work[5] = b[k + k * b_dim1]; - work[6] = b[k + 1 + k * b_dim1]; - work[7] = b[k + (k + 1) * b_dim1]; - work[8] = b[k + 1 + (k + 1) * b_dim1]; - d__1 = smlnum * eps; - dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], & - beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]); - alphai[k + 1] = -alphai[k]; - - } else { - - if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) { - -/* If B(K,K) is negative, make it positive */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - a[k + i__ * a_dim1] = -a[k + i__ * a_dim1]; - b[k + i__ * b_dim1] = -b[k + i__ * b_dim1]; - q[i__ + k * q_dim1] = -q[i__ + k * q_dim1]; -/* L70: */ - } - } - - alphar[k] = a[k + k * a_dim1]; - alphai[k] = 0.; - beta[k] = b[k + k * b_dim1]; - - } - } -/* L80: */ - } - - work[1] = (double) lwmin; - iwork[1] = liwmin; - - return 0; - -/* End of DTGSEN */ - -} /* dtgsen_ */ diff --git a/external/clapack/lapack/dtgsja.cpp b/external/clapack/lapack/dtgsja.cpp deleted file mode 100644 index 124e236e..00000000 --- a/external/clapack/lapack/dtgsja.cpp +++ /dev/null @@ -1,596 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b13 = 0.; -static double c_b14 = 1.; -static integer c__1 = 1; -static double c_b43 = -1.; - -/* Subroutine */ int dtgsja_(const char *jobu, const char *jobv, const char *jobq, integer *m, - integer *p, integer *n, integer *k, integer *l, double *a, - integer *lda, double *b, integer *ldb, double *tola, - double *tolb, double *alpha, double *beta, double *u, - integer *ldu, double *v, integer *ldv, double *q, integer * - ldq, double *work, integer *ncycle, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, - u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; - double d__1; - - /* Local variables */ - integer i__, j; - double a1, a2, a3, b1, b2, b3, csq, csu, csv, snq, rwk, snu, snv; - double gamma; - bool initq, initu, initv, wantq, upper; - double error, ssmin; - bool wantu, wantv; - integer kcycle; - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTGSJA computes the generalized singular value decomposition (GSVD) */ -/* of two real upper triangular (or trapezoidal) matrices A and B. */ - -/* On entry, it is assumed that matrices A and B have the following */ -/* forms, which may be obtained by the preprocessing subroutine DGGSVP */ -/* from a general M-by-N matrix A and P-by-N matrix B: */ - -/* N-K-L K L */ -/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */ -/* L ( 0 0 A23 ) */ -/* M-K-L ( 0 0 0 ) */ - -/* N-K-L K L */ -/* A = K ( 0 A12 A13 ) if M-K-L < 0; */ -/* M-K ( 0 0 A23 ) */ - -/* N-K-L K L */ -/* B = L ( 0 0 B13 ) */ -/* P-L ( 0 0 0 ) */ - -/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ -/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ -/* otherwise A23 is (M-K)-by-L upper trapezoidal. */ - -/* On exit, */ - -/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */ - -/* where U, V and Q are orthogonal matrices, Z' denotes the transpose */ -/* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are */ -/* ``diagonal'' matrices, which are of the following structures: */ - -/* If M-K-L >= 0, */ - -/* K L */ -/* D1 = K ( I 0 ) */ -/* L ( 0 C ) */ -/* M-K-L ( 0 0 ) */ - -/* K L */ -/* D2 = L ( 0 S ) */ -/* P-L ( 0 0 ) */ - -/* N-K-L K L */ -/* ( 0 R ) = K ( 0 R11 R12 ) K */ -/* L ( 0 0 R22 ) L */ - -/* where */ - -/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ -/* S = diag( BETA(K+1), ... , BETA(K+L) ), */ -/* C**2 + S**2 = I. */ - -/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */ - -/* If M-K-L < 0, */ - -/* K M-K K+L-M */ -/* D1 = K ( I 0 0 ) */ -/* M-K ( 0 C 0 ) */ - -/* K M-K K+L-M */ -/* D2 = M-K ( 0 S 0 ) */ -/* K+L-M ( 0 0 I ) */ -/* P-L ( 0 0 0 ) */ - -/* N-K-L K M-K K+L-M */ -/* ( 0 R ) = K ( 0 R11 R12 R13 ) */ -/* M-K ( 0 0 R22 R23 ) */ -/* K+L-M ( 0 0 0 R33 ) */ - -/* where */ -/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ -/* S = diag( BETA(K+1), ... , BETA(M) ), */ -/* C**2 + S**2 = I. */ - -/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */ -/* ( 0 R22 R23 ) */ -/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */ - -/* The computation of the orthogonal transformation matrices U, V or Q */ -/* is optional. These matrices may either be formed explicitly, or they */ -/* may be postmultiplied into input matrices U1, V1, or Q1. */ - -/* Arguments */ -/* ========= */ - -/* JOBU (input) CHARACTER*1 */ -/* = 'U': U must contain an orthogonal matrix U1 on entry, and */ -/* the product U1*U is returned; */ -/* = 'I': U is initialized to the unit matrix, and the */ -/* orthogonal matrix U is returned; */ -/* = 'N': U is not computed. */ - -/* JOBV (input) CHARACTER*1 */ -/* = 'V': V must contain an orthogonal matrix V1 on entry, and */ -/* the product V1*V is returned; */ -/* = 'I': V is initialized to the unit matrix, and the */ -/* orthogonal matrix V is returned; */ -/* = 'N': V is not computed. */ - -/* JOBQ (input) CHARACTER*1 */ -/* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */ -/* the product Q1*Q is returned; */ -/* = 'I': Q is initialized to the unit matrix, and the */ -/* orthogonal matrix Q is returned; */ -/* = 'N': Q is not computed. */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. */ - -/* P (input) INTEGER */ -/* The number of rows of the matrix B. P >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrices A and B. N >= 0. */ - -/* K (input) INTEGER */ -/* L (input) INTEGER */ -/* K and L specify the subblocks in the input matrices A and B: */ -/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */ -/* of A and B, whose GSVD is going to be computed by DTGSJA. */ -/* See Further details. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the M-by-N matrix A. */ -/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */ -/* matrix R or part of R. See Purpose for details. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ -/* On entry, the P-by-N matrix B. */ -/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */ -/* a part of R. See Purpose for details. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,P). */ - -/* TOLA (input) DOUBLE PRECISION */ -/* TOLB (input) DOUBLE PRECISION */ -/* TOLA and TOLB are the convergence criteria for the Jacobi- */ -/* Kogbetliantz iteration procedure. Generally, they are the */ -/* same as used in the preprocessing step, say */ -/* TOLA = max(M,N)*norm(A)*MAZHEPS, */ -/* TOLB = max(P,N)*norm(B)*MAZHEPS. */ - -/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */ -/* BETA (output) DOUBLE PRECISION array, dimension (N) */ -/* On exit, ALPHA and BETA contain the generalized singular */ -/* value pairs of A and B; */ -/* ALPHA(1:K) = 1, */ -/* BETA(1:K) = 0, */ -/* and if M-K-L >= 0, */ -/* ALPHA(K+1:K+L) = diag(C), */ -/* BETA(K+1:K+L) = diag(S), */ -/* or if M-K-L < 0, */ -/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */ -/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */ -/* Furthermore, if K+L < N, */ -/* ALPHA(K+L+1:N) = 0 and */ -/* BETA(K+L+1:N) = 0. */ - -/* U (input/output) DOUBLE PRECISION array, dimension (LDU,M) */ -/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */ -/* the orthogonal matrix returned by DGGSVP). */ -/* On exit, */ -/* if JOBU = 'I', U contains the orthogonal matrix U; */ -/* if JOBU = 'U', U contains the product U1*U. */ -/* If JOBU = 'N', U is not referenced. */ - -/* LDU (input) INTEGER */ -/* The leading dimension of the array U. LDU >= max(1,M) if */ -/* JOBU = 'U'; LDU >= 1 otherwise. */ - -/* V (input/output) DOUBLE PRECISION array, dimension (LDV,P) */ -/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */ -/* the orthogonal matrix returned by DGGSVP). */ -/* On exit, */ -/* if JOBV = 'I', V contains the orthogonal matrix V; */ -/* if JOBV = 'V', V contains the product V1*V. */ -/* If JOBV = 'N', V is not referenced. */ - -/* LDV (input) INTEGER */ -/* The leading dimension of the array V. LDV >= max(1,P) if */ -/* JOBV = 'V'; LDV >= 1 otherwise. */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */ -/* the orthogonal matrix returned by DGGSVP). */ -/* On exit, */ -/* if JOBQ = 'I', Q contains the orthogonal matrix Q; */ -/* if JOBQ = 'Q', Q contains the product Q1*Q. */ -/* If JOBQ = 'N', Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N) if */ -/* JOBQ = 'Q'; LDQ >= 1 otherwise. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ - -/* NCYCLE (output) INTEGER */ -/* The number of cycles required for convergence. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* = 1: the procedure does not converge after MAXIT cycles. */ - -/* Internal Parameters */ -/* =================== */ - -/* MAXIT INTEGER */ -/* MAXIT specifies the total loops that the iterative procedure */ -/* may take. If after MAXIT cycles, the routine fails to */ -/* converge, we return INFO = 1. */ - -/* Further Details */ -/* =============== */ - -/* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */ -/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */ -/* matrix B13 to the form: */ - -/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */ - -/* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose */ -/* of Z. C1 and S1 are diagonal matrices satisfying */ - -/* C1**2 + S1**2 = I, */ - -/* and R1 is an L-by-L nonsingular upper triangular matrix. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ - -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test the input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - --alpha; - --beta; - u_dim1 = *ldu; - u_offset = 1 + u_dim1; - u -= u_offset; - v_dim1 = *ldv; - v_offset = 1 + v_dim1; - v -= v_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --work; - - /* Function Body */ - initu = lsame_(jobu, "I"); - wantu = initu || lsame_(jobu, "U"); - - initv = lsame_(jobv, "I"); - wantv = initv || lsame_(jobv, "V"); - - initq = lsame_(jobq, "I"); - wantq = initq || lsame_(jobq, "Q"); - - *info = 0; - if (! (initu || wantu || lsame_(jobu, "N"))) { - *info = -1; - } else if (! (initv || wantv || lsame_(jobv, "N"))) - { - *info = -2; - } else if (! (initq || wantq || lsame_(jobq, "N"))) - { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*p < 0) { - *info = -5; - } else if (*n < 0) { - *info = -6; - } else if (*lda < std::max(1_integer,*m)) { - *info = -10; - } else if (*ldb < std::max(1_integer,*p)) { - *info = -12; - } else if (*ldu < 1 || wantu && *ldu < *m) { - *info = -18; - } else if (*ldv < 1 || wantv && *ldv < *p) { - *info = -20; - } else if (*ldq < 1 || wantq && *ldq < *n) { - *info = -22; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGSJA", &i__1); - return 0; - } - -/* Initialize U, V and Q, if necessary */ - - if (initu) { - dlaset_("Full", m, m, &c_b13, &c_b14, &u[u_offset], ldu); - } - if (initv) { - dlaset_("Full", p, p, &c_b13, &c_b14, &v[v_offset], ldv); - } - if (initq) { - dlaset_("Full", n, n, &c_b13, &c_b14, &q[q_offset], ldq); - } - -/* Loop until convergence */ - - upper = false; - for (kcycle = 1; kcycle <= 40; ++kcycle) { - - upper = ! upper; - - i__1 = *l - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *l; - for (j = i__ + 1; j <= i__2; ++j) { - - a1 = 0.; - a2 = 0.; - a3 = 0.; - if (*k + i__ <= *m) { - a1 = a[*k + i__ + (*n - *l + i__) * a_dim1]; - } - if (*k + j <= *m) { - a3 = a[*k + j + (*n - *l + j) * a_dim1]; - } - - b1 = b[i__ + (*n - *l + i__) * b_dim1]; - b3 = b[j + (*n - *l + j) * b_dim1]; - - if (upper) { - if (*k + i__ <= *m) { - a2 = a[*k + i__ + (*n - *l + j) * a_dim1]; - } - b2 = b[i__ + (*n - *l + j) * b_dim1]; - } else { - if (*k + j <= *m) { - a2 = a[*k + j + (*n - *l + i__) * a_dim1]; - } - b2 = b[j + (*n - *l + i__) * b_dim1]; - } - - dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, & - csv, &snv, &csq, &snq); - -/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */ - - if (*k + j <= *m) { - drot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k - + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu); - } - -/* Update I-th and J-th rows of matrix B: V'*B */ - - drot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - * - l + 1) * b_dim1], ldb, &csv, &snv); - -/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */ -/* A and B: A*Q and B*Q */ - -/* Computing MIN */ - i__4 = *k + *l; - i__3 = std::min(i__4,*m); - drot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - * - l + i__) * a_dim1 + 1], &c__1, &csq, &snq); - - drot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l + - i__) * b_dim1 + 1], &c__1, &csq, &snq); - - if (upper) { - if (*k + i__ <= *m) { - a[*k + i__ + (*n - *l + j) * a_dim1] = 0.; - } - b[i__ + (*n - *l + j) * b_dim1] = 0.; - } else { - if (*k + j <= *m) { - a[*k + j + (*n - *l + i__) * a_dim1] = 0.; - } - b[j + (*n - *l + i__) * b_dim1] = 0.; - } - -/* Update orthogonal matrices U, V, Q, if desired. */ - - if (wantu && *k + j <= *m) { - drot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) * - u_dim1 + 1], &c__1, &csu, &snu); - } - - if (wantv) { - drot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1], - &c__1, &csv, &snv); - } - - if (wantq) { - drot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - * - l + i__) * q_dim1 + 1], &c__1, &csq, &snq); - } - -/* L10: */ - } -/* L20: */ - } - - if (! upper) { - -/* The matrices A13 and B13 were lower triangular at the start */ -/* of the cycle, and are now upper triangular. */ - -/* Convergence test: test the parallelism of the corresponding */ -/* rows of A and B. */ - - error = 0.; -/* Computing MIN */ - i__2 = *l, i__3 = *m - *k; - i__1 = std::min(i__2,i__3); - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = *l - i__ + 1; - dcopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, & - work[1], &c__1); - i__2 = *l - i__ + 1; - dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[* - l + 1], &c__1); - i__2 = *l - i__ + 1; - dlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin); - error = std::max(error,ssmin); -/* L30: */ - } - - if (abs(error) <= std::min(*tola,*tolb)) { - goto L50; - } - } - -/* End of cycle loop */ - -/* L40: */ - } - -/* The algorithm has not converged after MAXIT cycles. */ - - *info = 1; - goto L100; - -L50: - -/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */ -/* Compute the generalized singular value pairs (ALPHA, BETA), and */ -/* set the triangular matrix R to array A. */ - - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - alpha[i__] = 1.; - beta[i__] = 0.; -/* L60: */ - } - -/* Computing MIN */ - i__2 = *l, i__3 = *m - *k; - i__1 = std::min(i__2,i__3); - for (i__ = 1; i__ <= i__1; ++i__) { - - a1 = a[*k + i__ + (*n - *l + i__) * a_dim1]; - b1 = b[i__ + (*n - *l + i__) * b_dim1]; - - if (a1 != 0.) { - gamma = b1 / a1; - -/* change sign if necessary */ - - if (gamma < 0.) { - i__2 = *l - i__ + 1; - dscal_(&i__2, &c_b43, &b[i__ + (*n - *l + i__) * b_dim1], ldb) - ; - if (wantv) { - dscal_(p, &c_b43, &v[i__ * v_dim1 + 1], &c__1); - } - } - - d__1 = abs(gamma); - dlartg_(&d__1, &c_b14, &beta[*k + i__], &alpha[*k + i__], &rwk); - - if (alpha[*k + i__] >= beta[*k + i__]) { - i__2 = *l - i__ + 1; - d__1 = 1. / alpha[*k + i__]; - dscal_(&i__2, &d__1, &a[*k + i__ + (*n - *l + i__) * a_dim1], - lda); - } else { - i__2 = *l - i__ + 1; - d__1 = 1. / beta[*k + i__]; - dscal_(&i__2, &d__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb); - i__2 = *l - i__ + 1; - dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k - + i__ + (*n - *l + i__) * a_dim1], lda); - } - - } else { - - alpha[*k + i__] = 0.; - beta[*k + i__] = 1.; - i__2 = *l - i__ + 1; - dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + - i__ + (*n - *l + i__) * a_dim1], lda); - - } - -/* L70: */ - } - -/* Post-assignment */ - - i__1 = *k + *l; - for (i__ = *m + 1; i__ <= i__1; ++i__) { - alpha[i__] = 0.; - beta[i__] = 1.; -/* L80: */ - } - - if (*k + *l < *n) { - i__1 = *n; - for (i__ = *k + *l + 1; i__ <= i__1; ++i__) { - alpha[i__] = 0.; - beta[i__] = 0.; -/* L90: */ - } - } - -L100: - *ncycle = kcycle; - return 0; - -/* End of DTGSJA */ - -} /* dtgsja_ */ diff --git a/external/clapack/lapack/dtgsna.cpp b/external/clapack/lapack/dtgsna.cpp deleted file mode 100644 index 1f1f5b8a..00000000 --- a/external/clapack/lapack/dtgsna.cpp +++ /dev/null @@ -1,657 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b19 = 1.; -static double c_b21 = 0.; -static integer c__2 = 2; -static bool c_false = false; -static integer c__3 = 3; - -/* Subroutine */ int dtgsna_(const char *job, const char *howmny, bool *select, - integer *n, double *a, integer *lda, double *b, integer *ldb, - double *vl, integer *ldvl, double *vr, integer *ldvr, - double *s, double *dif, integer *mm, integer *m, double * - work, integer *lwork, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, - vr_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, k; - double c1, c2; - integer n1, n2, ks, iz; - double eps, beta, cond; - bool pair; - integer ierr; - double uhav, uhbv; - integer ifst; - double lnrm; - integer ilst; - double rnrm; - double root1, root2, scale; - double uhavi, uhbvi, tmpii; - integer lwmin; - bool wants; - double tmpir, tmpri, dummy[1], tmprr; - double dummy1[1]; - double alphai, alphar; - bool wantbh, wantdf, somcon; - double alprqt; - double smlnum; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTGSNA estimates reciprocal condition numbers for specified */ -/* eigenvalues and/or eigenvectors of a matrix pair (A, B) in */ -/* generalized real Schur canonical form (or of any matrix pair */ -/* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where */ -/* Z' denotes the transpose of Z. */ - -/* (A, B) must be in generalized real Schur form (as returned by DGGES), */ -/* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal */ -/* blocks. B is upper triangular. */ - - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* Specifies whether condition numbers are required for */ -/* eigenvalues (S) or eigenvectors (DIF): */ -/* = 'E': for eigenvalues only (S); */ -/* = 'V': for eigenvectors only (DIF); */ -/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */ - -/* HOWMNY (input) CHARACTER*1 */ -/* = 'A': compute condition numbers for all eigenpairs; */ -/* = 'S': compute condition numbers for selected eigenpairs */ -/* specified by the array SELECT. */ - -/* SELECT (input) LOGICAL array, dimension (N) */ -/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ -/* condition numbers are required. To select condition numbers */ -/* for the eigenpair corresponding to a real eigenvalue w(j), */ -/* SELECT(j) must be set to .TRUE.. To select condition numbers */ -/* corresponding to a complex conjugate pair of eigenvalues w(j) */ -/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */ -/* set to .TRUE.. */ -/* If HOWMNY = 'A', SELECT is not referenced. */ - -/* N (input) INTEGER */ -/* The order of the square matrix pair (A, B). N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The upper quasi-triangular matrix A in the pair (A,B). */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */ -/* The upper triangular matrix B in the pair (A,B). */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* VL (input) DOUBLE PRECISION array, dimension (LDVL,M) */ -/* If JOB = 'E' or 'B', VL must contain left eigenvectors of */ -/* (A, B), corresponding to the eigenpairs specified by HOWMNY */ -/* and SELECT. The eigenvectors must be stored in consecutive */ -/* columns of VL, as returned by DTGEVC. */ -/* If JOB = 'V', VL is not referenced. */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the array VL. LDVL >= 1. */ -/* If JOB = 'E' or 'B', LDVL >= N. */ - -/* VR (input) DOUBLE PRECISION array, dimension (LDVR,M) */ -/* If JOB = 'E' or 'B', VR must contain right eigenvectors of */ -/* (A, B), corresponding to the eigenpairs specified by HOWMNY */ -/* and SELECT. The eigenvectors must be stored in consecutive */ -/* columns ov VR, as returned by DTGEVC. */ -/* If JOB = 'V', VR is not referenced. */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the array VR. LDVR >= 1. */ -/* If JOB = 'E' or 'B', LDVR >= N. */ - -/* S (output) DOUBLE PRECISION array, dimension (MM) */ -/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */ -/* selected eigenvalues, stored in consecutive elements of the */ -/* array. For a complex conjugate pair of eigenvalues two */ -/* consecutive elements of S are set to the same value. Thus */ -/* S(j), DIF(j), and the j-th columns of VL and VR all */ -/* correspond to the same eigenpair (but not in general the */ -/* j-th eigenpair, unless all eigenpairs are selected). */ -/* If JOB = 'V', S is not referenced. */ - -/* DIF (output) DOUBLE PRECISION array, dimension (MM) */ -/* If JOB = 'V' or 'B', the estimated reciprocal condition */ -/* numbers of the selected eigenvectors, stored in consecutive */ -/* elements of the array. For a complex eigenvector two */ -/* consecutive elements of DIF are set to the same value. If */ -/* the eigenvalues cannot be reordered to compute DIF(j), DIF(j) */ -/* is set to 0; this can only occur when the true value would be */ -/* very small anyway. */ -/* If JOB = 'E', DIF is not referenced. */ - -/* MM (input) INTEGER */ -/* The number of elements in the arrays S and DIF. MM >= M. */ - -/* M (output) INTEGER */ -/* The number of elements of the arrays S and DIF used to store */ -/* the specified condition numbers; for each selected real */ -/* eigenvalue one element is used, and for each selected complex */ -/* conjugate pair of eigenvalues, two elements are used. */ -/* If HOWMNY = 'A', M is set to N. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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). */ -/* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (N + 6) */ -/* If JOB = 'E', IWORK is not referenced. */ - -/* INFO (output) INTEGER */ -/* =0: Successful exit */ -/* <0: If INFO = -i, the i-th argument had an illegal value */ - - -/* Further Details */ -/* =============== */ - -/* The reciprocal of the condition number of a generalized eigenvalue */ -/* w = (a, b) is defined as */ - -/* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v)) */ - -/* where u and v are the left and right eigenvectors of (A, B) */ -/* corresponding to w; |z| denotes the absolute value of the complex */ -/* number, and norm(u) denotes the 2-norm of the vector u. */ -/* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv) */ -/* of the matrix pair (A, B). If both a and b equal zero, then (A B) is */ -/* singular and S(I) = -1 is returned. */ - -/* An approximate error bound on the chordal distance between the i-th */ -/* computed generalized eigenvalue w and the corresponding exact */ -/* eigenvalue lambda is */ - -/* chord(w, lambda) <= EPS * norm(A, B) / S(I) */ - -/* where EPS is the machine precision. */ - -/* The reciprocal of the condition number DIF(i) of right eigenvector u */ -/* and left eigenvector v corresponding to the generalized eigenvalue w */ -/* is defined as follows: */ - -/* a) If the i-th eigenvalue w = (a,b) is real */ - -/* Suppose U and V are orthogonal transformations such that */ - -/* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 */ -/* ( 0 S22 ),( 0 T22 ) n-1 */ -/* 1 n-1 1 n-1 */ - -/* Then the reciprocal condition number DIF(i) is */ - -/* Difl((a, b), (S22, T22)) = sigma-min( Zl ), */ - -/* where sigma-min(Zl) denotes the smallest singular value of the */ -/* 2(n-1)-by-2(n-1) matrix */ - -/* Zl = [ kron(a, In-1) -kron(1, S22) ] */ -/* [ kron(b, In-1) -kron(1, T22) ] . */ - -/* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the */ -/* Kronecker product between the matrices X and Y. */ - -/* Note that if the default method for computing DIF(i) is wanted */ -/* (see DLATDF), then the parameter DIFDRI (see below) should be */ -/* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). */ -/* See DTGSYL for more details. */ - -/* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, */ - -/* Suppose U and V are orthogonal transformations such that */ - -/* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 */ -/* ( 0 S22 ),( 0 T22) n-2 */ -/* 2 n-2 2 n-2 */ - -/* and (S11, T11) corresponds to the complex conjugate eigenvalue */ -/* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such */ -/* that */ - -/* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 ) */ -/* ( 0 s22 ) ( 0 t22 ) */ - -/* where the generalized eigenvalues w = s11/t11 and */ -/* conjg(w) = s22/t22. */ - -/* Then the reciprocal condition number DIF(i) is bounded by */ - -/* min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) */ - -/* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where */ -/* Z1 is the complex 2-by-2 matrix */ - -/* Z1 = [ s11 -s22 ] */ -/* [ t11 -t22 ], */ - -/* This is done by computing (using real arithmetic) the */ -/* roots of the characteristical polynomial det(Z1' * Z1 - lambda I), */ -/* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes */ -/* the determinant of X. */ - -/* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an */ -/* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) */ - -/* Z2 = [ kron(S11', In-2) -kron(I2, S22) ] */ -/* [ kron(T11', In-2) -kron(I2, T22) ] */ - -/* Note that if the default method for computing DIF is wanted (see */ -/* DLATDF), then the parameter DIFDRI (see below) should be changed */ -/* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL */ -/* for more details. */ - -/* For each eigenvalue/vector specified by SELECT, DIF stores a */ -/* Frobenius norm-based estimate of Difl. */ - -/* An approximate error bound for the i-th computed eigenvector VL(i) or */ -/* VR(i) is given by */ - -/* EPS * norm(A, B) / DIF(i). */ - -/* See ref. [2-3] for more details and further references. */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* References */ -/* ========== */ - -/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ -/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ -/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ -/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ - -/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ -/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ -/* Estimation: Theory, Algorithms and Software, */ -/* Report UMINF - 94.04, Department of Computing Science, Umea */ -/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ -/* Note 87. To appear in Numerical Algorithms, 1996. */ - -/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ -/* for Solving the Generalized Sylvester Equation and Estimating the */ -/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ -/* Department of Computing Science, Umea University, S-901 87 Umea, */ -/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ -/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ -/* No 1, 1996. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test the input parameters */ - - /* Parameter adjustments */ - --select; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --s; - --dif; - --work; - --iwork; - - /* Function Body */ - wantbh = lsame_(job, "B"); - wants = lsame_(job, "E") || wantbh; - wantdf = lsame_(job, "V") || wantbh; - - somcon = lsame_(howmny, "S"); - - *info = 0; - lquery = *lwork == -1; - - if (! wants && ! wantdf) { - *info = -1; - } else if (! lsame_(howmny, "A") && ! somcon) { - *info = -2; - } else if (*n < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } else if (wants && *ldvl < *n) { - *info = -10; - } else if (wants && *ldvr < *n) { - *info = -12; - } else { - -/* Set M to the number of eigenpairs for which condition numbers */ -/* are required, and test MM. */ - - if (somcon) { - *m = 0; - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (pair) { - pair = false; - } else { - if (k < *n) { - if (a[k + 1 + k * a_dim1] == 0.) { - if (select[k]) { - ++(*m); - } - } else { - pair = true; - if (select[k] || select[k + 1]) { - *m += 2; - } - } - } else { - if (select[*n]) { - ++(*m); - } - } - } -/* L10: */ - } - } else { - *m = *n; - } - - if (*n == 0) { - lwmin = 1; - } else if (lsame_(job, "V") || lsame_(job, - "B")) { - lwmin = (*n << 1) * (*n + 2) + 16; - } else { - lwmin = *n; - } - work[1] = (double) lwmin; - - if (*mm < *m) { - *info = -15; - } else if (*lwork < lwmin && ! lquery) { - *info = -18; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGSNA", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; - ks = 0; - pair = false; - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - -/* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. */ - - if (pair) { - pair = false; - goto L20; - } else { - if (k < *n) { - pair = a[k + 1 + k * a_dim1] != 0.; - } - } - -/* Determine whether condition numbers are required for the k-th */ -/* eigenpair. */ - - if (somcon) { - if (pair) { - if (! select[k] && ! select[k + 1]) { - goto L20; - } - } else { - if (! select[k]) { - goto L20; - } - } - } - - ++ks; - - if (wants) { - -/* Compute the reciprocal condition number of the k-th */ -/* eigenvalue. */ - - if (pair) { - -/* Complex eigenvalue pair. */ - - d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); - d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); - rnrm = dlapy2_(&d__1, &d__2); - d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); - d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); - lnrm = dlapy2_(&d__1, &d__2); - dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 - + 1], &c__1, &c_b21, &work[1], &c__1); - tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & - c__1); - tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], - &c__1); - dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[(ks + 1) * - vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1); - tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], - &c__1); - tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & - c__1); - uhav = tmprr + tmpii; - uhavi = tmpir - tmpri; - dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 - + 1], &c__1, &c_b21, &work[1], &c__1); - tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & - c__1); - tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], - &c__1); - dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[(ks + 1) * - vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1); - tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], - &c__1); - tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & - c__1); - uhbv = tmprr + tmpii; - uhbvi = tmpir - tmpri; - uhav = dlapy2_(&uhav, &uhavi); - uhbv = dlapy2_(&uhbv, &uhbvi); - cond = dlapy2_(&uhav, &uhbv); - s[ks] = cond / (rnrm * lnrm); - s[ks + 1] = s[ks]; - - } else { - -/* Real eigenvalue. */ - - rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); - lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); - dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 - + 1], &c__1, &c_b21, &work[1], &c__1); - uhav = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1) - ; - dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 - + 1], &c__1, &c_b21, &work[1], &c__1); - uhbv = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1) - ; - cond = dlapy2_(&uhav, &uhbv); - if (cond == 0.) { - s[ks] = -1.; - } else { - s[ks] = cond / (rnrm * lnrm); - } - } - } - - if (wantdf) { - if (*n == 1) { - dif[ks] = dlapy2_(&a[a_dim1 + 1], &b[b_dim1 + 1]); - goto L20; - } - -/* Estimate the reciprocal condition number of the k-th */ -/* eigenvectors. */ - if (pair) { - -/* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). */ -/* Compute the eigenvalue(s) at position K. */ - - work[1] = a[k + k * a_dim1]; - work[2] = a[k + 1 + k * a_dim1]; - work[3] = a[k + (k + 1) * a_dim1]; - work[4] = a[k + 1 + (k + 1) * a_dim1]; - work[5] = b[k + k * b_dim1]; - work[6] = b[k + 1 + k * b_dim1]; - work[7] = b[k + (k + 1) * b_dim1]; - work[8] = b[k + 1 + (k + 1) * b_dim1]; - d__1 = smlnum * eps; - dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta, dummy1, - &alphar, dummy, &alphai); - alprqt = 1.; - c1 = (alphar * alphar + alphai * alphai + beta * beta) * 2.; - c2 = beta * 4. * beta * alphai * alphai; - root1 = c1 + sqrt(c1 * c1 - c2 * 4.); - root2 = c2 / root1; - root1 /= 2.; -/* Computing MIN */ - d__1 = sqrt(root1), d__2 = sqrt(root2); - cond = std::min(d__1,d__2); - } - -/* Copy the matrix (A, B) to the array WORK and swap the */ -/* diagonal block beginning at A(k,k) to the (1,1) position. */ - - dlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n); - dlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n); - ifst = k; - ilst = 1; - - i__2 = *lwork - (*n << 1) * *n; - dtgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n, - dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &work[(*n * * - n << 1) + 1], &i__2, &ierr); - - if (ierr > 0) { - -/* Ill-conditioned problem - swap rejected. */ - - dif[ks] = 0.; - } else { - -/* Reordering successful, solve generalized Sylvester */ -/* equation for R and L, */ -/* A22 * R - L * A11 = A12 */ -/* B22 * R - L * B11 = B12, */ -/* and compute estimate of Difl((A11,B11), (A22, B22)). */ - - n1 = 1; - if (work[2] != 0.) { - n1 = 2; - } - n2 = *n - n1; - if (n2 == 0) { - dif[ks] = cond; - } else { - i__ = *n * *n + 1; - iz = (*n << 1) * *n + 1; - i__2 = *lwork - (*n << 1) * *n; - dtgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n, - &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1 - + i__], n, &work[i__], n, &work[n1 + i__], n, & - scale, &dif[ks], &work[iz + 1], &i__2, &iwork[1], - &ierr); - - if (pair) { -/* Computing MIN */ - d__1 = std::max(1.,alprqt) * dif[ks]; - dif[ks] = std::min(d__1,cond); - } - } - } - if (pair) { - dif[ks + 1] = dif[ks]; - } - } - if (pair) { - ++ks; - } - -L20: - ; - } - work[1] = (double) lwmin; - return 0; - -/* End of DTGSNA */ - -} /* dtgsna_ */ diff --git a/external/clapack/lapack/dtgsy2.cpp b/external/clapack/lapack/dtgsy2.cpp deleted file mode 100644 index acc5020b..00000000 --- a/external/clapack/lapack/dtgsy2.cpp +++ /dev/null @@ -1,1080 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__8 = 8; -static integer c__1 = 1; -static double c_b27 = -1.; -static double c_b42 = 1.; -static double c_b56 = 0.; - -/* Subroutine */ int dtgsy2_(const char *trans, integer *ijob, integer *m, integer * - n, double *a, integer *lda, double *b, integer *ldb, - double *c__, integer *ldc, double *d__, integer *ldd, - double *e, integer *lde, double *f, integer *ldf, double * - scale, double *rdsum, double *rdscal, integer *iwork, integer - *pq, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, - d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, p, q; - double z__[64] /* was [8][8] */; - integer ie, je, mb, nb, ii, jj, is, js; - double rhs[8]; - integer isp1, jsp1; - integer ierr, zdim, ipiv[8], jpiv[8]; - double alpha; - double scaloc; - bool notran; - - -/* -- LAPACK auxiliary routine (version 3.1.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* January 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTGSY2 solves the generalized Sylvester equation: */ - -/* A * R - L * B = scale * C (1) */ -/* D * R - L * E = scale * F, */ - -/* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, */ -/* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */ -/* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) */ -/* must be in generalized Schur canonical form, i.e. A, B are upper */ -/* quasi triangular and D, E are upper triangular. The solution (R, L) */ -/* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor */ -/* chosen to avoid overflow. */ - -/* In matrix notation solving equation (1) corresponds to solve */ -/* Z*x = scale*b, where Z is defined as */ - -/* Z = [ kron(In, A) -kron(B', Im) ] (2) */ -/* [ kron(In, D) -kron(E', Im) ], */ - -/* Ik is the identity matrix of size k and X' is the transpose of X. */ -/* kron(X, Y) is the Kronecker product between the matrices X and Y. */ -/* In the process of solving (1), we solve a number of such systems */ -/* where Dim(In), Dim(In) = 1 or 2. */ - -/* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, */ -/* which is equivalent to solve for R and L in */ - -/* A' * R + D' * L = scale * C (3) */ -/* R * B' + L * E' = scale * -F */ - -/* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */ -/* sigma_min(Z) using reverse communicaton with DLACON. */ - -/* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL */ -/* of an upper bound on the separation between to matrix pairs. Then */ -/* the input (A, D), (B, E) are sub-pencils of the matrix pair in */ -/* DTGSYL. See DTGSYL for details. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N', solve the generalized Sylvester equation (1). */ -/* = 'T': solve the 'transposed' system (3). */ - -/* IJOB (input) INTEGER */ -/* Specifies what kind of functionality to be performed. */ -/* = 0: solve (1) only. */ -/* = 1: A contribution from this subsystem to a Frobenius */ -/* norm-based estimate of the separation between two matrix */ -/* pairs is computed. (look ahead strategy is used). */ -/* = 2: A contribution from this subsystem to a Frobenius */ -/* norm-based estimate of the separation between two matrix */ -/* pairs is computed. (DGECON on sub-systems is used.) */ -/* Not referenced if TRANS = 'T'. */ - -/* M (input) INTEGER */ -/* On entry, M specifies the order of A and D, and the row */ -/* dimension of C, F, R and L. */ - -/* N (input) INTEGER */ -/* On entry, N specifies the order of B and E, and the column */ -/* dimension of C, F, R and L. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA, M) */ -/* On entry, A contains an upper quasi triangular matrix. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the matrix A. LDA >= max(1, M). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */ -/* On entry, B contains an upper quasi triangular matrix. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the matrix B. LDB >= max(1, N). */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */ -/* On entry, C contains the right-hand-side of the first matrix */ -/* equation in (1). */ -/* On exit, if IJOB = 0, C has been overwritten by the */ -/* solution R. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the matrix C. LDC >= max(1, M). */ - -/* D (input) DOUBLE PRECISION array, dimension (LDD, M) */ -/* On entry, D contains an upper triangular matrix. */ - -/* LDD (input) INTEGER */ -/* The leading dimension of the matrix D. LDD >= max(1, M). */ - -/* E (input) DOUBLE PRECISION array, dimension (LDE, N) */ -/* On entry, E contains an upper triangular matrix. */ - -/* LDE (input) INTEGER */ -/* The leading dimension of the matrix E. LDE >= max(1, N). */ - -/* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) */ -/* On entry, F contains the right-hand-side of the second matrix */ -/* equation in (1). */ -/* On exit, if IJOB = 0, F has been overwritten by the */ -/* solution L. */ - -/* LDF (input) INTEGER */ -/* The leading dimension of the matrix F. LDF >= max(1, M). */ - -/* SCALE (output) DOUBLE PRECISION */ -/* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */ -/* R and L (C and F on entry) will hold the solutions to a */ -/* slightly perturbed system but the input matrices A, B, D and */ -/* E have not been changed. If SCALE = 0, R and L will hold the */ -/* solutions to the homogeneous system with C = F = 0. Normally, */ -/* SCALE = 1. */ - -/* RDSUM (input/output) DOUBLE PRECISION */ -/* On entry, the sum of squares of computed contributions to */ -/* the Dif-estimate under computation by DTGSYL, where the */ -/* scaling factor RDSCAL (see below) has been factored out. */ -/* On exit, the corresponding sum of squares updated with the */ -/* contributions from the current sub-system. */ -/* If TRANS = 'T' RDSUM is not touched. */ -/* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. */ - -/* RDSCAL (input/output) DOUBLE PRECISION */ -/* On entry, scaling factor used to prevent overflow in RDSUM. */ -/* On exit, RDSCAL is updated w.r.t. the current contributions */ -/* in RDSUM. */ -/* If TRANS = 'T', RDSCAL is not touched. */ -/* NOTE: RDSCAL only makes sense when DTGSY2 is called by */ -/* DTGSYL. */ - -/* IWORK (workspace) INTEGER array, dimension (M+N+2) */ - -/* PQ (output) INTEGER */ -/* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and */ -/* 8-by-8) solved by this routine. */ - -/* INFO (output) INTEGER */ -/* On exit, if INFO is set to */ -/* =0: Successful exit */ -/* <0: If INFO = -i, the i-th argument had an illegal value. */ -/* >0: The matrix pairs (A, D) and (B, E) have common or very */ -/* close eigenvalues. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* ===================================================================== */ -/* Replaced various illegal calls to DCOPY by calls to DLASET. */ -/* Sven Hammarling, 27/5/02. */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - d_dim1 = *ldd; - d_offset = 1 + d_dim1; - d__ -= d_offset; - e_dim1 = *lde; - e_offset = 1 + e_dim1; - e -= e_offset; - f_dim1 = *ldf; - f_offset = 1 + f_dim1; - f -= f_offset; - --iwork; - - /* Function Body */ - *info = 0; - ierr = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T")) { - *info = -1; - } else if (notran) { - if (*ijob < 0 || *ijob > 2) { - *info = -2; - } - } - if (*info == 0) { - if (*m <= 0) { - *info = -3; - } else if (*n <= 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*m)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } else if (*ldd < std::max(1_integer,*m)) { - *info = -12; - } else if (*lde < std::max(1_integer,*n)) { - *info = -14; - } else if (*ldf < std::max(1_integer,*m)) { - *info = -16; - } - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGSY2", &i__1); - return 0; - } - -/* Determine block structure of A */ - - *pq = 0; - p = 0; - i__ = 1; -L10: - if (i__ > *m) { - goto L20; - } - ++p; - iwork[p] = i__; - if (i__ == *m) { - goto L20; - } - if (a[i__ + 1 + i__ * a_dim1] != 0.) { - i__ += 2; - } else { - ++i__; - } - goto L10; -L20: - iwork[p + 1] = *m + 1; - -/* Determine block structure of B */ - - q = p + 1; - j = 1; -L30: - if (j > *n) { - goto L40; - } - ++q; - iwork[q] = j; - if (j == *n) { - goto L40; - } - if (b[j + 1 + j * b_dim1] != 0.) { - j += 2; - } else { - ++j; - } - goto L30; -L40: - iwork[q + 1] = *n + 1; - *pq = p * (q - p - 1); - - if (notran) { - -/* Solve (I, J) - subsystem */ -/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ -/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ -/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */ - - *scale = 1.; - scaloc = 1.; - i__1 = q; - for (j = p + 2; j <= i__1; ++j) { - js = iwork[j]; - jsp1 = js + 1; - je = iwork[j + 1] - 1; - nb = je - js + 1; - for (i__ = p; i__ >= 1; --i__) { - - is = iwork[i__]; - isp1 = is + 1; - ie = iwork[i__ + 1] - 1; - mb = ie - is + 1; - zdim = mb * nb << 1; - - if (mb == 1 && nb == 1) { - -/* Build a 2-by-2 system Z * x = RHS */ - - z__[0] = a[is + is * a_dim1]; - z__[1] = d__[is + is * d_dim1]; - z__[8] = -b[js + js * b_dim1]; - z__[9] = -e[js + js * e_dim1]; - -/* Set up right hand side(s) */ - - rhs[0] = c__[is + js * c_dim1]; - rhs[1] = f[is + js * f_dim1]; - -/* Solve Z * x = RHS */ - - dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); - if (ierr > 0) { - *info = ierr; - } - - if (*ijob == 0) { - dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); - if (scaloc != 1.) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & - c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L50: */ - } - *scale *= scaloc; - } - } else { - dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, - ipiv, jpiv); - } - -/* Unpack solution vector(s) */ - - c__[is + js * c_dim1] = rhs[0]; - f[is + js * f_dim1] = rhs[1]; - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (i__ > 1) { - alpha = -rhs[0]; - i__2 = is - 1; - daxpy_(&i__2, &alpha, &a[is * a_dim1 + 1], &c__1, & - c__[js * c_dim1 + 1], &c__1); - i__2 = is - 1; - daxpy_(&i__2, &alpha, &d__[is * d_dim1 + 1], &c__1, & - f[js * f_dim1 + 1], &c__1); - } - if (j < q) { - i__2 = *n - je; - daxpy_(&i__2, &rhs[1], &b[js + (je + 1) * b_dim1], - ldb, &c__[is + (je + 1) * c_dim1], ldc); - i__2 = *n - je; - daxpy_(&i__2, &rhs[1], &e[js + (je + 1) * e_dim1], - lde, &f[is + (je + 1) * f_dim1], ldf); - } - - } else if (mb == 1 && nb == 2) { - -/* Build a 4-by-4 system Z * x = RHS */ - - z__[0] = a[is + is * a_dim1]; - z__[1] = 0.; - z__[2] = d__[is + is * d_dim1]; - z__[3] = 0.; - - z__[8] = 0.; - z__[9] = a[is + is * a_dim1]; - z__[10] = 0.; - z__[11] = d__[is + is * d_dim1]; - - z__[16] = -b[js + js * b_dim1]; - z__[17] = -b[js + jsp1 * b_dim1]; - z__[18] = -e[js + js * e_dim1]; - z__[19] = -e[js + jsp1 * e_dim1]; - - z__[24] = -b[jsp1 + js * b_dim1]; - z__[25] = -b[jsp1 + jsp1 * b_dim1]; - z__[26] = 0.; - z__[27] = -e[jsp1 + jsp1 * e_dim1]; - -/* Set up right hand side(s) */ - - rhs[0] = c__[is + js * c_dim1]; - rhs[1] = c__[is + jsp1 * c_dim1]; - rhs[2] = f[is + js * f_dim1]; - rhs[3] = f[is + jsp1 * f_dim1]; - -/* Solve Z * x = RHS */ - - dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); - if (ierr > 0) { - *info = ierr; - } - - if (*ijob == 0) { - dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); - if (scaloc != 1.) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & - c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L60: */ - } - *scale *= scaloc; - } - } else { - dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, - ipiv, jpiv); - } - -/* Unpack solution vector(s) */ - - c__[is + js * c_dim1] = rhs[0]; - c__[is + jsp1 * c_dim1] = rhs[1]; - f[is + js * f_dim1] = rhs[2]; - f[is + jsp1 * f_dim1] = rhs[3]; - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (i__ > 1) { - i__2 = is - 1; - dger_(&i__2, &nb, &c_b27, &a[is * a_dim1 + 1], &c__1, - rhs, &c__1, &c__[js * c_dim1 + 1], ldc); - i__2 = is - 1; - dger_(&i__2, &nb, &c_b27, &d__[is * d_dim1 + 1], & - c__1, rhs, &c__1, &f[js * f_dim1 + 1], ldf); - } - if (j < q) { - i__2 = *n - je; - daxpy_(&i__2, &rhs[2], &b[js + (je + 1) * b_dim1], - ldb, &c__[is + (je + 1) * c_dim1], ldc); - i__2 = *n - je; - daxpy_(&i__2, &rhs[2], &e[js + (je + 1) * e_dim1], - lde, &f[is + (je + 1) * f_dim1], ldf); - i__2 = *n - je; - daxpy_(&i__2, &rhs[3], &b[jsp1 + (je + 1) * b_dim1], - ldb, &c__[is + (je + 1) * c_dim1], ldc); - i__2 = *n - je; - daxpy_(&i__2, &rhs[3], &e[jsp1 + (je + 1) * e_dim1], - lde, &f[is + (je + 1) * f_dim1], ldf); - } - - } else if (mb == 2 && nb == 1) { - -/* Build a 4-by-4 system Z * x = RHS */ - - z__[0] = a[is + is * a_dim1]; - z__[1] = a[isp1 + is * a_dim1]; - z__[2] = d__[is + is * d_dim1]; - z__[3] = 0.; - - z__[8] = a[is + isp1 * a_dim1]; - z__[9] = a[isp1 + isp1 * a_dim1]; - z__[10] = d__[is + isp1 * d_dim1]; - z__[11] = d__[isp1 + isp1 * d_dim1]; - - z__[16] = -b[js + js * b_dim1]; - z__[17] = 0.; - z__[18] = -e[js + js * e_dim1]; - z__[19] = 0.; - - z__[24] = 0.; - z__[25] = -b[js + js * b_dim1]; - z__[26] = 0.; - z__[27] = -e[js + js * e_dim1]; - -/* Set up right hand side(s) */ - - rhs[0] = c__[is + js * c_dim1]; - rhs[1] = c__[isp1 + js * c_dim1]; - rhs[2] = f[is + js * f_dim1]; - rhs[3] = f[isp1 + js * f_dim1]; - -/* Solve Z * x = RHS */ - - dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); - if (ierr > 0) { - *info = ierr; - } - if (*ijob == 0) { - dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); - if (scaloc != 1.) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & - c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L70: */ - } - *scale *= scaloc; - } - } else { - dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, - ipiv, jpiv); - } - -/* Unpack solution vector(s) */ - - c__[is + js * c_dim1] = rhs[0]; - c__[isp1 + js * c_dim1] = rhs[1]; - f[is + js * f_dim1] = rhs[2]; - f[isp1 + js * f_dim1] = rhs[3]; - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (i__ > 1) { - i__2 = is - 1; - dgemv_("N", &i__2, &mb, &c_b27, &a[is * a_dim1 + 1], - lda, rhs, &c__1, &c_b42, &c__[js * c_dim1 + 1] -, &c__1); - i__2 = is - 1; - dgemv_("N", &i__2, &mb, &c_b27, &d__[is * d_dim1 + 1], - ldd, rhs, &c__1, &c_b42, &f[js * f_dim1 + 1], - &c__1); - } - if (j < q) { - i__2 = *n - je; - dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &b[js + (je - + 1) * b_dim1], ldb, &c__[is + (je + 1) * - c_dim1], ldc); - i__2 = *n - je; - dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &e[js + (je - + 1) * e_dim1], lde, &f[is + (je + 1) * - f_dim1], ldf); - } - - } else if (mb == 2 && nb == 2) { - -/* Build an 8-by-8 system Z * x = RHS */ - - dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8); - - z__[0] = a[is + is * a_dim1]; - z__[1] = a[isp1 + is * a_dim1]; - z__[4] = d__[is + is * d_dim1]; - - z__[8] = a[is + isp1 * a_dim1]; - z__[9] = a[isp1 + isp1 * a_dim1]; - z__[12] = d__[is + isp1 * d_dim1]; - z__[13] = d__[isp1 + isp1 * d_dim1]; - - z__[18] = a[is + is * a_dim1]; - z__[19] = a[isp1 + is * a_dim1]; - z__[22] = d__[is + is * d_dim1]; - - z__[26] = a[is + isp1 * a_dim1]; - z__[27] = a[isp1 + isp1 * a_dim1]; - z__[30] = d__[is + isp1 * d_dim1]; - z__[31] = d__[isp1 + isp1 * d_dim1]; - - z__[32] = -b[js + js * b_dim1]; - z__[34] = -b[js + jsp1 * b_dim1]; - z__[36] = -e[js + js * e_dim1]; - z__[38] = -e[js + jsp1 * e_dim1]; - - z__[41] = -b[js + js * b_dim1]; - z__[43] = -b[js + jsp1 * b_dim1]; - z__[45] = -e[js + js * e_dim1]; - z__[47] = -e[js + jsp1 * e_dim1]; - - z__[48] = -b[jsp1 + js * b_dim1]; - z__[50] = -b[jsp1 + jsp1 * b_dim1]; - z__[54] = -e[jsp1 + jsp1 * e_dim1]; - - z__[57] = -b[jsp1 + js * b_dim1]; - z__[59] = -b[jsp1 + jsp1 * b_dim1]; - z__[63] = -e[jsp1 + jsp1 * e_dim1]; - -/* Set up right hand side(s) */ - - k = 1; - ii = mb * nb + 1; - i__2 = nb - 1; - for (jj = 0; jj <= i__2; ++jj) { - dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, & - rhs[k - 1], &c__1); - dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[ - ii - 1], &c__1); - k += mb; - ii += mb; -/* L80: */ - } - -/* Solve Z * x = RHS */ - - dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); - if (ierr > 0) { - *info = ierr; - } - if (*ijob == 0) { - dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); - if (scaloc != 1.) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & - c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L90: */ - } - *scale *= scaloc; - } - } else { - dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, - ipiv, jpiv); - } - -/* Unpack solution vector(s) */ - - k = 1; - ii = mb * nb + 1; - i__2 = nb - 1; - for (jj = 0; jj <= i__2; ++jj) { - dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) * - c_dim1], &c__1); - dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) * - f_dim1], &c__1); - k += mb; - ii += mb; -/* L100: */ - } - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (i__ > 1) { - i__2 = is - 1; - dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &a[is * - a_dim1 + 1], lda, rhs, &mb, &c_b42, &c__[js * - c_dim1 + 1], ldc); - i__2 = is - 1; - dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &d__[is * - d_dim1 + 1], ldd, rhs, &mb, &c_b42, &f[js * - f_dim1 + 1], ldf); - } - if (j < q) { - k = mb * nb + 1; - i__2 = *n - je; - dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1], - &mb, &b[js + (je + 1) * b_dim1], ldb, &c_b42, - &c__[is + (je + 1) * c_dim1], ldc); - i__2 = *n - je; - dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1], - &mb, &e[js + (je + 1) * e_dim1], lde, &c_b42, - &f[is + (je + 1) * f_dim1], ldf); - } - - } - -/* L110: */ - } -/* L120: */ - } - } else { - -/* Solve (I, J) - subsystem */ -/* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */ -/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */ -/* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 */ - - *scale = 1.; - scaloc = 1.; - i__1 = p; - for (i__ = 1; i__ <= i__1; ++i__) { - - is = iwork[i__]; - isp1 = is + 1; - ie = i__; - mb = ie - is + 1; - i__2 = p + 2; - for (j = q; j >= i__2; --j) { - - js = iwork[j]; - jsp1 = js + 1; - je = iwork[j + 1] - 1; - nb = je - js + 1; - zdim = mb * nb << 1; - if (mb == 1 && nb == 1) { - -/* Build a 2-by-2 system Z' * x = RHS */ - - z__[0] = a[is + is * a_dim1]; - z__[1] = -b[js + js * b_dim1]; - z__[8] = d__[is + is * d_dim1]; - z__[9] = -e[js + js * e_dim1]; - -/* Set up right hand side(s) */ - - rhs[0] = c__[is + js * c_dim1]; - rhs[1] = f[is + js * f_dim1]; - -/* Solve Z' * x = RHS */ - - dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); - if (ierr > 0) { - *info = ierr; - } - - dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); - if (scaloc != 1.) { - i__3 = *n; - for (k = 1; k <= i__3; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L130: */ - } - *scale *= scaloc; - } - -/* Unpack solution vector(s) */ - - c__[is + js * c_dim1] = rhs[0]; - f[is + js * f_dim1] = rhs[1]; - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (j > p + 2) { - alpha = rhs[0]; - i__3 = js - 1; - daxpy_(&i__3, &alpha, &b[js * b_dim1 + 1], &c__1, &f[ - is + f_dim1], ldf); - alpha = rhs[1]; - i__3 = js - 1; - daxpy_(&i__3, &alpha, &e[js * e_dim1 + 1], &c__1, &f[ - is + f_dim1], ldf); - } - if (i__ < p) { - alpha = -rhs[0]; - i__3 = *m - ie; - daxpy_(&i__3, &alpha, &a[is + (ie + 1) * a_dim1], lda, - &c__[ie + 1 + js * c_dim1], &c__1); - alpha = -rhs[1]; - i__3 = *m - ie; - daxpy_(&i__3, &alpha, &d__[is + (ie + 1) * d_dim1], - ldd, &c__[ie + 1 + js * c_dim1], &c__1); - } - - } else if (mb == 1 && nb == 2) { - -/* Build a 4-by-4 system Z' * x = RHS */ - - z__[0] = a[is + is * a_dim1]; - z__[1] = 0.; - z__[2] = -b[js + js * b_dim1]; - z__[3] = -b[jsp1 + js * b_dim1]; - - z__[8] = 0.; - z__[9] = a[is + is * a_dim1]; - z__[10] = -b[js + jsp1 * b_dim1]; - z__[11] = -b[jsp1 + jsp1 * b_dim1]; - - z__[16] = d__[is + is * d_dim1]; - z__[17] = 0.; - z__[18] = -e[js + js * e_dim1]; - z__[19] = 0.; - - z__[24] = 0.; - z__[25] = d__[is + is * d_dim1]; - z__[26] = -e[js + jsp1 * e_dim1]; - z__[27] = -e[jsp1 + jsp1 * e_dim1]; - -/* Set up right hand side(s) */ - - rhs[0] = c__[is + js * c_dim1]; - rhs[1] = c__[is + jsp1 * c_dim1]; - rhs[2] = f[is + js * f_dim1]; - rhs[3] = f[is + jsp1 * f_dim1]; - -/* Solve Z' * x = RHS */ - - dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); - if (ierr > 0) { - *info = ierr; - } - dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); - if (scaloc != 1.) { - i__3 = *n; - for (k = 1; k <= i__3; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L140: */ - } - *scale *= scaloc; - } - -/* Unpack solution vector(s) */ - - c__[is + js * c_dim1] = rhs[0]; - c__[is + jsp1 * c_dim1] = rhs[1]; - f[is + js * f_dim1] = rhs[2]; - f[is + jsp1 * f_dim1] = rhs[3]; - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (j > p + 2) { - i__3 = js - 1; - daxpy_(&i__3, rhs, &b[js * b_dim1 + 1], &c__1, &f[is - + f_dim1], ldf); - i__3 = js - 1; - daxpy_(&i__3, &rhs[1], &b[jsp1 * b_dim1 + 1], &c__1, & - f[is + f_dim1], ldf); - i__3 = js - 1; - daxpy_(&i__3, &rhs[2], &e[js * e_dim1 + 1], &c__1, &f[ - is + f_dim1], ldf); - i__3 = js - 1; - daxpy_(&i__3, &rhs[3], &e[jsp1 * e_dim1 + 1], &c__1, & - f[is + f_dim1], ldf); - } - if (i__ < p) { - i__3 = *m - ie; - dger_(&i__3, &nb, &c_b27, &a[is + (ie + 1) * a_dim1], - lda, rhs, &c__1, &c__[ie + 1 + js * c_dim1], - ldc); - i__3 = *m - ie; - dger_(&i__3, &nb, &c_b27, &d__[is + (ie + 1) * d_dim1] -, ldd, &rhs[2], &c__1, &c__[ie + 1 + js * - c_dim1], ldc); - } - - } else if (mb == 2 && nb == 1) { - -/* Build a 4-by-4 system Z' * x = RHS */ - - z__[0] = a[is + is * a_dim1]; - z__[1] = a[is + isp1 * a_dim1]; - z__[2] = -b[js + js * b_dim1]; - z__[3] = 0.; - - z__[8] = a[isp1 + is * a_dim1]; - z__[9] = a[isp1 + isp1 * a_dim1]; - z__[10] = 0.; - z__[11] = -b[js + js * b_dim1]; - - z__[16] = d__[is + is * d_dim1]; - z__[17] = d__[is + isp1 * d_dim1]; - z__[18] = -e[js + js * e_dim1]; - z__[19] = 0.; - - z__[24] = 0.; - z__[25] = d__[isp1 + isp1 * d_dim1]; - z__[26] = 0.; - z__[27] = -e[js + js * e_dim1]; - -/* Set up right hand side(s) */ - - rhs[0] = c__[is + js * c_dim1]; - rhs[1] = c__[isp1 + js * c_dim1]; - rhs[2] = f[is + js * f_dim1]; - rhs[3] = f[isp1 + js * f_dim1]; - -/* Solve Z' * x = RHS */ - - dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); - if (ierr > 0) { - *info = ierr; - } - - dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); - if (scaloc != 1.) { - i__3 = *n; - for (k = 1; k <= i__3; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L150: */ - } - *scale *= scaloc; - } - -/* Unpack solution vector(s) */ - - c__[is + js * c_dim1] = rhs[0]; - c__[isp1 + js * c_dim1] = rhs[1]; - f[is + js * f_dim1] = rhs[2]; - f[isp1 + js * f_dim1] = rhs[3]; - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (j > p + 2) { - i__3 = js - 1; - dger_(&mb, &i__3, &c_b42, rhs, &c__1, &b[js * b_dim1 - + 1], &c__1, &f[is + f_dim1], ldf); - i__3 = js - 1; - dger_(&mb, &i__3, &c_b42, &rhs[2], &c__1, &e[js * - e_dim1 + 1], &c__1, &f[is + f_dim1], ldf); - } - if (i__ < p) { - i__3 = *m - ie; - dgemv_("T", &mb, &i__3, &c_b27, &a[is + (ie + 1) * - a_dim1], lda, rhs, &c__1, &c_b42, &c__[ie + 1 - + js * c_dim1], &c__1); - i__3 = *m - ie; - dgemv_("T", &mb, &i__3, &c_b27, &d__[is + (ie + 1) * - d_dim1], ldd, &rhs[2], &c__1, &c_b42, &c__[ie - + 1 + js * c_dim1], &c__1); - } - - } else if (mb == 2 && nb == 2) { - -/* Build an 8-by-8 system Z' * x = RHS */ - - dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8); - - z__[0] = a[is + is * a_dim1]; - z__[1] = a[is + isp1 * a_dim1]; - z__[4] = -b[js + js * b_dim1]; - z__[6] = -b[jsp1 + js * b_dim1]; - - z__[8] = a[isp1 + is * a_dim1]; - z__[9] = a[isp1 + isp1 * a_dim1]; - z__[13] = -b[js + js * b_dim1]; - z__[15] = -b[jsp1 + js * b_dim1]; - - z__[18] = a[is + is * a_dim1]; - z__[19] = a[is + isp1 * a_dim1]; - z__[20] = -b[js + jsp1 * b_dim1]; - z__[22] = -b[jsp1 + jsp1 * b_dim1]; - - z__[26] = a[isp1 + is * a_dim1]; - z__[27] = a[isp1 + isp1 * a_dim1]; - z__[29] = -b[js + jsp1 * b_dim1]; - z__[31] = -b[jsp1 + jsp1 * b_dim1]; - - z__[32] = d__[is + is * d_dim1]; - z__[33] = d__[is + isp1 * d_dim1]; - z__[36] = -e[js + js * e_dim1]; - - z__[41] = d__[isp1 + isp1 * d_dim1]; - z__[45] = -e[js + js * e_dim1]; - - z__[50] = d__[is + is * d_dim1]; - z__[51] = d__[is + isp1 * d_dim1]; - z__[52] = -e[js + jsp1 * e_dim1]; - z__[54] = -e[jsp1 + jsp1 * e_dim1]; - - z__[59] = d__[isp1 + isp1 * d_dim1]; - z__[61] = -e[js + jsp1 * e_dim1]; - z__[63] = -e[jsp1 + jsp1 * e_dim1]; - -/* Set up right hand side(s) */ - - k = 1; - ii = mb * nb + 1; - i__3 = nb - 1; - for (jj = 0; jj <= i__3; ++jj) { - dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, & - rhs[k - 1], &c__1); - dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[ - ii - 1], &c__1); - k += mb; - ii += mb; -/* L160: */ - } - - -/* Solve Z' * x = RHS */ - - dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); - if (ierr > 0) { - *info = ierr; - } - - dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); - if (scaloc != 1.) { - i__3 = *n; - for (k = 1; k <= i__3; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L170: */ - } - *scale *= scaloc; - } - -/* Unpack solution vector(s) */ - - k = 1; - ii = mb * nb + 1; - i__3 = nb - 1; - for (jj = 0; jj <= i__3; ++jj) { - dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) * - c_dim1], &c__1); - dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) * - f_dim1], &c__1); - k += mb; - ii += mb; -/* L180: */ - } - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (j > p + 2) { - i__3 = js - 1; - dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &c__[is + - js * c_dim1], ldc, &b[js * b_dim1 + 1], ldb, & - c_b42, &f[is + f_dim1], ldf); - i__3 = js - 1; - dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &f[is + js * - f_dim1], ldf, &e[js * e_dim1 + 1], lde, & - c_b42, &f[is + f_dim1], ldf); - } - if (i__ < p) { - i__3 = *m - ie; - dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &a[is + (ie - + 1) * a_dim1], lda, &c__[is + js * c_dim1], - ldc, &c_b42, &c__[ie + 1 + js * c_dim1], ldc); - i__3 = *m - ie; - dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &d__[is + ( - ie + 1) * d_dim1], ldd, &f[is + js * f_dim1], - ldf, &c_b42, &c__[ie + 1 + js * c_dim1], ldc); - } - - } - -/* L190: */ - } -/* L200: */ - } - - } - return 0; - -/* End of DTGSY2 */ - -} /* dtgsy2_ */ diff --git a/external/clapack/lapack/dtgsyl.cpp b/external/clapack/lapack/dtgsyl.cpp deleted file mode 100644 index cf717d4a..00000000 --- a/external/clapack/lapack/dtgsyl.cpp +++ /dev/null @@ -1,660 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__2 = 2; -static integer c_n1 = -1; -static integer c__5 = 5; -static double c_b14 = 0.; -static integer c__1 = 1; -static double c_b51 = -1.; -static double c_b52 = 1.; - -/* Subroutine */ int dtgsyl_(const char *trans, integer *ijob, integer *m, integer * - n, double *a, integer *lda, double *b, integer *ldb, - double *c__, integer *ldc, double *d__, integer *ldd, - double *e, integer *lde, double *f, integer *ldf, double * - scale, double *dif, double *work, integer *lwork, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, - d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3, - i__4; - - /* Local variables */ - integer i__, j, k, p, q, ie, je, mb, nb, is, js, pq; - double dsum; - integer ppqq; - integer ifunc, linfo, lwmin; - double scale2; - double dscale, scaloc; - integer iround; - bool notran; - integer isolve; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTGSYL solves the generalized Sylvester equation: */ - -/* A * R - L * B = scale * C (1) */ -/* D * R - L * E = scale * F */ - -/* where R and L are unknown m-by-n matrices, (A, D), (B, E) and */ -/* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */ -/* respectively, with real entries. (A, D) and (B, E) must be in */ -/* generalized (real) Schur canonical form, i.e. A, B are upper quasi */ -/* triangular and D, E are upper triangular. */ - -/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */ -/* scaling factor chosen to avoid overflow. */ - -/* In matrix notation (1) is equivalent to solve Zx = scale b, where */ -/* Z is defined as */ - -/* Z = [ kron(In, A) -kron(B', Im) ] (2) */ -/* [ kron(In, D) -kron(E', Im) ]. */ - -/* Here Ik is the identity matrix of size k and X' is the transpose of */ -/* X. kron(X, Y) is the Kronecker product between the matrices X and Y. */ - -/* If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b, */ -/* which is equivalent to solve for R and L in */ - -/* A' * R + D' * L = scale * C (3) */ -/* R * B' + L * E' = scale * (-F) */ - -/* This case (TRANS = 'T') is used to compute an one-norm-based estimate */ -/* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */ -/* and (B,E), using DLACON. */ - -/* If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate */ -/* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */ -/* reciprocal of the smallest singular value of Z. See [1-2] for more */ -/* information. */ - -/* This is a level 3 BLAS algorithm. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* = 'N', solve the generalized Sylvester equation (1). */ -/* = 'T', solve the 'transposed' system (3). */ - -/* IJOB (input) INTEGER */ -/* Specifies what kind of functionality to be performed. */ -/* =0: solve (1) only. */ -/* =1: The functionality of 0 and 3. */ -/* =2: The functionality of 0 and 4. */ -/* =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */ -/* (look ahead strategy IJOB = 1 is used). */ -/* =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */ -/* ( DGECON on sub-systems is used ). */ -/* Not referenced if TRANS = 'T'. */ - -/* M (input) INTEGER */ -/* The order of the matrices A and D, and the row dimension of */ -/* the matrices C, F, R and L. */ - -/* N (input) INTEGER */ -/* The order of the matrices B and E, and the column dimension */ -/* of the matrices C, F, R and L. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA, M) */ -/* The upper quasi triangular matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1, M). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */ -/* The upper quasi triangular matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1, N). */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */ -/* On entry, C contains the right-hand-side of the first matrix */ -/* equation in (1) or (3). */ -/* On exit, if IJOB = 0, 1 or 2, C has been overwritten by */ -/* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */ -/* the solution achieved during the computation of the */ -/* Dif-estimate. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1, M). */ - -/* D (input) DOUBLE PRECISION array, dimension (LDD, M) */ -/* The upper triangular matrix D. */ - -/* LDD (input) INTEGER */ -/* The leading dimension of the array D. LDD >= max(1, M). */ - -/* E (input) DOUBLE PRECISION array, dimension (LDE, N) */ -/* The upper triangular matrix E. */ - -/* LDE (input) INTEGER */ -/* The leading dimension of the array E. LDE >= max(1, N). */ - -/* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) */ -/* On entry, F contains the right-hand-side of the second matrix */ -/* equation in (1) or (3). */ -/* On exit, if IJOB = 0, 1 or 2, F has been overwritten by */ -/* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */ -/* the solution achieved during the computation of the */ -/* Dif-estimate. */ - -/* LDF (input) INTEGER */ -/* The leading dimension of the array F. LDF >= max(1, M). */ - -/* DIF (output) DOUBLE PRECISION */ -/* On exit DIF is the reciprocal of a lower bound of the */ -/* reciprocal of the Dif-function, i.e. DIF is an upper bound of */ -/* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). */ -/* IF IJOB = 0 or TRANS = 'T', DIF is not touched. */ - -/* SCALE (output) DOUBLE PRECISION */ -/* On exit SCALE is the scaling factor in (1) or (3). */ -/* If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */ -/* to a slightly perturbed system but the input matrices A, B, D */ -/* and E have not been changed. If SCALE = 0, C and F hold the */ -/* solutions R and L, respectively, to the homogeneous system */ -/* with C = F = 0. Normally, SCALE = 1. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK > = 1. */ -/* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (M+N+6) */ - -/* INFO (output) INTEGER */ -/* =0: successful exit */ -/* <0: If INFO = -i, the i-th argument had an illegal value. */ -/* >0: (A, D) and (B, E) have common or close eigenvalues. */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ -/* Umea University, S-901 87 Umea, Sweden. */ - -/* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ -/* for Solving the Generalized Sylvester Equation and Estimating the */ -/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ -/* Department of Computing Science, Umea University, S-901 87 Umea, */ -/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ -/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ -/* No 1, 1996. */ - -/* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */ -/* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */ -/* Appl., 15(4):1045-1060, 1994 */ - -/* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */ -/* Condition Estimators for Solving the Generalized Sylvester */ -/* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */ -/* July 1989, pp 745-751. */ - -/* ===================================================================== */ -/* Replaced various illegal calls to DCOPY by calls to DLASET. */ -/* Sven Hammarling, 1/5/02. */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - d_dim1 = *ldd; - d_offset = 1 + d_dim1; - d__ -= d_offset; - e_dim1 = *lde; - e_offset = 1 + e_dim1; - e -= e_offset; - f_dim1 = *ldf; - f_offset = 1 + f_dim1; - f -= f_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - - if (! notran && ! lsame_(trans, "T")) { - *info = -1; - } else if (notran) { - if (*ijob < 0 || *ijob > 4) { - *info = -2; - } - } - if (*info == 0) { - if (*m <= 0) { - *info = -3; - } else if (*n <= 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*m)) { - *info = -6; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -10; - } else if (*ldd < std::max(1_integer,*m)) { - *info = -12; - } else if (*lde < std::max(1_integer,*n)) { - *info = -14; - } else if (*ldf < std::max(1_integer,*m)) { - *info = -16; - } - } - - if (*info == 0) { - if (notran) { - if (*ijob == 1 || *ijob == 2) { -/* Computing MAX */ - i__1 = 1, i__2 = (*m << 1) * *n; - lwmin = std::max(i__1,i__2); - } else { - lwmin = 1; - } - } else { - lwmin = 1; - } - work[1] = (double) lwmin; - - if (*lwork < lwmin && ! lquery) { - *info = -20; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTGSYL", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - *scale = 1.; - if (notran) { - if (*ijob != 0) { - *dif = 0.; - } - } - return 0; - } - -/* Determine optimal block sizes MB and NB */ - - mb = ilaenv_(&c__2, "DTGSYL", trans, m, n, &c_n1, &c_n1); - nb = ilaenv_(&c__5, "DTGSYL", trans, m, n, &c_n1, &c_n1); - - isolve = 1; - ifunc = 0; - if (notran) { - if (*ijob >= 3) { - ifunc = *ijob - 2; - dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc) - ; - dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); - } else if (*ijob >= 1) { - isolve = 2; - } - } - - if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) { - - i__1 = isolve; - for (iround = 1; iround <= i__1; ++iround) { - -/* Use unblocked Level 2 solver */ - - dscale = 0.; - dsum = 1.; - pq = 0; - dtgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb, - &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset], - lde, &f[f_offset], ldf, scale, &dsum, &dscale, &iwork[1], - &pq, info); - if (dscale != 0.) { - if (*ijob == 1 || *ijob == 3) { - *dif = sqrt((double) ((*m << 1) * *n)) / (dscale * - sqrt(dsum)); - } else { - *dif = sqrt((double) pq) / (dscale * sqrt(dsum)); - } - } - - if (isolve == 2 && iround == 1) { - if (notran) { - ifunc = *ijob; - } - scale2 = *scale; - dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); - dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); - dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc); - dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); - } else if (isolve == 2 && iround == 2) { - dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); - dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); - *scale = scale2; - } -/* L30: */ - } - - return 0; - } - -/* Determine block structure of A */ - - p = 0; - i__ = 1; -L40: - if (i__ > *m) { - goto L50; - } - ++p; - iwork[p] = i__; - i__ += mb; - if (i__ >= *m) { - goto L50; - } - if (a[i__ + (i__ - 1) * a_dim1] != 0.) { - ++i__; - } - goto L40; -L50: - - iwork[p + 1] = *m + 1; - if (iwork[p] == iwork[p + 1]) { - --p; - } - -/* Determine block structure of B */ - - q = p + 1; - j = 1; -L60: - if (j > *n) { - goto L70; - } - ++q; - iwork[q] = j; - j += nb; - if (j >= *n) { - goto L70; - } - if (b[j + (j - 1) * b_dim1] != 0.) { - ++j; - } - goto L60; -L70: - - iwork[q + 1] = *n + 1; - if (iwork[q] == iwork[q + 1]) { - --q; - } - - if (notran) { - - i__1 = isolve; - for (iround = 1; iround <= i__1; ++iround) { - -/* Solve (I, J)-subsystem */ -/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ -/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ -/* for I = P, P - 1,..., 1; J = 1, 2,..., Q */ - - dscale = 0.; - dsum = 1.; - pq = 0; - *scale = 1.; - i__2 = q; - for (j = p + 2; j <= i__2; ++j) { - js = iwork[j]; - je = iwork[j + 1] - 1; - nb = je - js + 1; - for (i__ = p; i__ >= 1; --i__) { - is = iwork[i__]; - ie = iwork[i__ + 1] - 1; - mb = ie - is + 1; - ppqq = 0; - dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], - lda, &b[js + js * b_dim1], ldb, &c__[is + js * - c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js - + js * e_dim1], lde, &f[is + js * f_dim1], ldf, & - scaloc, &dsum, &dscale, &iwork[q + 2], &ppqq, & - linfo); - if (linfo > 0) { - *info = linfo; - } - - pq += ppqq; - if (scaloc != 1.) { - i__3 = js - 1; - for (k = 1; k <= i__3; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L80: */ - } - i__3 = je; - for (k = js; k <= i__3; ++k) { - i__4 = is - 1; - dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], & - c__1); - i__4 = is - 1; - dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L90: */ - } - i__3 = je; - for (k = js; k <= i__3; ++k) { - i__4 = *m - ie; - dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], - &c__1); - i__4 = *m - ie; - dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], & - c__1); -/* L100: */ - } - i__3 = *n; - for (k = je + 1; k <= i__3; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L110: */ - } - *scale *= scaloc; - } - -/* Substitute R(I, J) and L(I, J) into remaining */ -/* equation. */ - - if (i__ > 1) { - i__3 = is - 1; - dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &a[is * - a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc, - &c_b52, &c__[js * c_dim1 + 1], ldc); - i__3 = is - 1; - dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &d__[is * - d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc, - &c_b52, &f[js * f_dim1 + 1], ldf); - } - if (j < q) { - i__3 = *n - je; - dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js * - f_dim1], ldf, &b[js + (je + 1) * b_dim1], - ldb, &c_b52, &c__[is + (je + 1) * c_dim1], - ldc); - i__3 = *n - je; - dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js * - f_dim1], ldf, &e[js + (je + 1) * e_dim1], - lde, &c_b52, &f[is + (je + 1) * f_dim1], ldf); - } -/* L120: */ - } -/* L130: */ - } - if (dscale != 0.) { - if (*ijob == 1 || *ijob == 3) { - *dif = sqrt((double) ((*m << 1) * *n)) / (dscale * - sqrt(dsum)); - } else { - *dif = sqrt((double) pq) / (dscale * sqrt(dsum)); - } - } - if (isolve == 2 && iround == 1) { - if (notran) { - ifunc = *ijob; - } - scale2 = *scale; - dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); - dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); - dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc); - dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); - } else if (isolve == 2 && iround == 2) { - dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); - dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); - *scale = scale2; - } -/* L150: */ - } - - } else { - -/* Solve transposed (I, J)-subsystem */ -/* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) */ -/* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J) */ -/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */ - - *scale = 1.; - i__1 = p; - for (i__ = 1; i__ <= i__1; ++i__) { - is = iwork[i__]; - ie = iwork[i__ + 1] - 1; - mb = ie - is + 1; - i__2 = p + 2; - for (j = q; j >= i__2; --j) { - js = iwork[j]; - je = iwork[j + 1] - 1; - nb = je - js + 1; - dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, & - b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc, - &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1], - lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, & - dscale, &iwork[q + 2], &ppqq, &linfo); - if (linfo > 0) { - *info = linfo; - } - if (scaloc != 1.) { - i__3 = js - 1; - for (k = 1; k <= i__3; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L160: */ - } - i__3 = je; - for (k = js; k <= i__3; ++k) { - i__4 = is - 1; - dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &c__1); - i__4 = is - 1; - dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L170: */ - } - i__3 = je; - for (k = js; k <= i__3; ++k) { - i__4 = *m - ie; - dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], & - c__1); - i__4 = *m - ie; - dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &c__1) - ; -/* L180: */ - } - i__3 = *n; - for (k = je + 1; k <= i__3; ++k) { - dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); - dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); -/* L190: */ - } - *scale *= scaloc; - } - -/* Substitute R(I, J) and L(I, J) into remaining equation. */ - - if (j > p + 2) { - i__3 = js - 1; - dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &c__[is + js * - c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b52, & - f[is + f_dim1], ldf); - i__3 = js - 1; - dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &f[is + js * - f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b52, & - f[is + f_dim1], ldf); - } - if (i__ < p) { - i__3 = *m - ie; - dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &a[is + (ie + 1) - * a_dim1], lda, &c__[is + js * c_dim1], ldc, & - c_b52, &c__[ie + 1 + js * c_dim1], ldc); - i__3 = *m - ie; - dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &d__[is + (ie + - 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, & - c_b52, &c__[ie + 1 + js * c_dim1], ldc); - } -/* L200: */ - } -/* L210: */ - } - - } - - work[1] = (double) lwmin; - - return 0; - -/* End of DTGSYL */ - -} /* dtgsyl_ */ diff --git a/external/clapack/lapack/dtpcon.cpp b/external/clapack/lapack/dtpcon.cpp deleted file mode 100644 index ad26e8ec..00000000 --- a/external/clapack/lapack/dtpcon.cpp +++ /dev/null @@ -1,208 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dtpcon_(const char *norm, const char *uplo, const char *diag, integer *n, - double *ap, double *rcond, double *work, integer *iwork, - integer *info) -{ - /* System generated locals */ - integer i__1; - double d__1; - - /* Local variables */ - integer ix, kase, kase1; - double scale; - integer isave[3]; - double anorm; - bool upper; - double xnorm; - double ainvnm; - bool onenrm; - char normin[1]; - double smlnum; - bool nounit; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTPCON estimates the reciprocal of the condition number of a packed */ -/* triangular matrix A, in either the 1-norm or the infinity-norm. */ - -/* The norm of A is computed and an estimate is obtained for */ -/* norm(inv(A)), then the reciprocal of the condition number is */ -/* computed as */ -/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangular matrix A, packed columnwise in */ -/* a linear array. The j-th column of A is stored in the array */ -/* AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ -/* If DIAG = 'U', the diagonal elements of A are not referenced */ -/* and are assumed to be 1. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --iwork; - --work; - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); - nounit = lsame_(diag, "N"); - - if (! onenrm && ! lsame_(norm, "I")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTPCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *rcond = 1.; - return 0; - } - - *rcond = 0.; - smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n); - -/* Compute the norm of the triangular matrix A. */ - - anorm = dlantp_(norm, uplo, diag, n, &ap[1], &work[1]); - -/* Continue only if ANORM > 0. */ - - if (anorm > 0.) { - -/* Estimate the norm of the inverse of A. */ - - ainvnm = 0.; - *(unsigned char *)normin = 'N'; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kase = 0; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(A). */ - - dlatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ - 1], &scale, &work[(*n << 1) + 1], info); - } else { - -/* Multiply by inv(A'). */ - - dlatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1], - &scale, &work[(*n << 1) + 1], info); - } - *(unsigned char *)normin = 'Y'; - -/* Multiply by 1/SCALE if doing so will not cause overflow. */ - - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - xnorm = (d__1 = work[ix], abs(d__1)); - if (scale < xnorm * smlnum || scale == 0.) { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / anorm / ainvnm; - } - } - -L20: - return 0; - -/* End of DTPCON */ - -} /* dtpcon_ */ diff --git a/external/clapack/lapack/dtprfs.cpp b/external/clapack/lapack/dtprfs.cpp deleted file mode 100644 index 45b5c7f3..00000000 --- a/external/clapack/lapack/dtprfs.cpp +++ /dev/null @@ -1,473 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b19 = -1.; - -/* Subroutine */ int dtprfs_(const char *uplo, const char *trans, const char *diag, integer *n, - integer *nrhs, double *ap, double *b, integer *ldb, - double *x, integer *ldx, double *ferr, double *berr, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s; - integer kc; - double xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - bool upper; - double safmin; - bool notran; - char transt[1]; - bool nounit; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTPRFS provides error bounds and backward error estimates for the */ -/* solution to a system of linear equations with a triangular packed */ -/* coefficient matrix. */ - -/* The solution matrix X must be computed by DTPTRS or some other */ -/* means before entering this routine. DTPRFS does not do iterative */ -/* refinement because doing so cannot improve the backward error. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangular matrix A, packed columnwise in */ -/* a linear array. The j-th column of A is stored in the array */ -/* AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ -/* If DIAG = 'U', the diagonal elements of A are not referenced */ -/* and are assumed to be 1. */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* The solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - notran = lsame_(trans, "N"); - nounit = lsame_(diag, "N"); - - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTPRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *n + 1; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Compute residual R = B - op(A) * X, */ -/* where op(A) = A or A', depending on TRANS. */ - - dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dtpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); - daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L20: */ - } - - if (notran) { - -/* Compute abs(A)*abs(X) + abs(B). */ - - if (upper) { - kc = 1; - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = k; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1)) - * xk; -/* L30: */ - } - kc += k; -/* L40: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1)) - * xk; -/* L50: */ - } - work[k] += xk; - kc += k; -/* L60: */ - } - } - } else { - kc = 1; - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = *n; - for (i__ = k; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1)) - * xk; -/* L70: */ - } - kc = kc + *n - k + 1; -/* L80: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = *n; - for (i__ = k + 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1)) - * xk; -/* L90: */ - } - work[k] += xk; - kc = kc + *n - k + 1; -/* L100: */ - } - } - } - } else { - -/* Compute abs(A')*abs(X) + abs(B). */ - - if (upper) { - kc = 1; - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - i__3 = k; - for (i__ = 1; i__ <= i__3; ++i__) { - s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2 - = x[i__ + j * x_dim1], abs(d__2)); -/* L110: */ - } - work[k] += s; - kc += k; -/* L120: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2 - = x[i__ + j * x_dim1], abs(d__2)); -/* L130: */ - } - work[k] += s; - kc += k; -/* L140: */ - } - } - } else { - kc = 1; - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - i__3 = *n; - for (i__ = k; i__ <= i__3; ++i__) { - s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2 - = x[i__ + j * x_dim1], abs(d__2)); -/* L150: */ - } - work[k] += s; - kc = kc + *n - k + 1; -/* L160: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = *n; - for (i__ = k + 1; i__ <= i__3; ++i__) { - s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2 - = x[i__ + j * x_dim1], abs(d__2)); -/* L170: */ - } - work[k] += s; - kc = kc + *n - k + 1; -/* L180: */ - } - } - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L190: */ - } - berr[j] = s; - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(op(A)))* */ -/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(op(A)) is the inverse of op(A) */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(op(A)) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L200: */ - } - - kase = 0; -L210: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(op(A)'). */ - - dtpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L220: */ - } - } else { - -/* Multiply by inv(op(A))*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L230: */ - } - dtpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); - } - goto L210; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L240: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L250: */ - } - - return 0; - -/* End of DTPRFS */ - -} /* dtprfs_ */ diff --git a/external/clapack/lapack/dtptri.cpp b/external/clapack/lapack/dtptri.cpp deleted file mode 100644 index dff402b4..00000000 --- a/external/clapack/lapack/dtptri.cpp +++ /dev/null @@ -1,201 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dtptri_(const char *uplo, const char *diag, integer *n, double * - ap, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer j, jc, jj; - double ajj; - bool upper; - integer jclast; - bool nounit; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTPTRI computes the inverse of a real upper or lower triangular */ -/* matrix A stored in packed format. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* On entry, the upper or lower triangular matrix A, stored */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */ -/* See below for further details. */ -/* On exit, the (triangular) inverse of the original matrix, in */ -/* the same packed storage format. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ -/* matrix is singular and its inverse can not be computed. */ - -/* Further Details */ -/* =============== */ - -/* A triangular matrix A can be transferred to packed storage using one */ -/* of the following program segments: */ - -/* UPLO = 'U': UPLO = 'L': */ - -/* JC = 1 JC = 1 */ -/* DO 2 J = 1, N DO 2 J = 1, N */ -/* DO 1 I = 1, J DO 1 I = J, N */ -/* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */ -/* 1 CONTINUE 1 CONTINUE */ -/* JC = JC + J JC = JC + N - J + 1 */ -/* 2 CONTINUE 2 CONTINUE */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTPTRI", &i__1); - return 0; - } - -/* Check for singularity if non-unit. */ - - if (nounit) { - if (upper) { - jj = 0; - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - jj += *info; - if (ap[jj] == 0.) { - return 0; - } -/* L10: */ - } - } else { - jj = 1; - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (ap[jj] == 0.) { - return 0; - } - jj = jj + *n - *info + 1; -/* L20: */ - } - } - *info = 0; - } - - if (upper) { - -/* Compute inverse of upper triangular matrix. */ - - jc = 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (nounit) { - ap[jc + j - 1] = 1. / ap[jc + j - 1]; - ajj = -ap[jc + j - 1]; - } else { - ajj = -1.; - } - -/* Compute elements 1:j-1 of j-th column. */ - - i__2 = j - 1; - dtpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & - c__1); - i__2 = j - 1; - dscal_(&i__2, &ajj, &ap[jc], &c__1); - jc += j; -/* L30: */ - } - - } else { - -/* Compute inverse of lower triangular matrix. */ - - jc = *n * (*n + 1) / 2; - for (j = *n; j >= 1; --j) { - if (nounit) { - ap[jc] = 1. / ap[jc]; - ajj = -ap[jc]; - } else { - ajj = -1.; - } - if (j < *n) { - -/* Compute elements j+1:n of j-th column. */ - - i__1 = *n - j; - dtpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ - jc + 1], &c__1); - i__1 = *n - j; - dscal_(&i__1, &ajj, &ap[jc + 1], &c__1); - } - jclast = jc; - jc = jc - *n + j - 2; -/* L40: */ - } - } - - return 0; - -/* End of DTPTRI */ - -} /* dtptri_ */ diff --git a/external/clapack/lapack/dtptrs.cpp b/external/clapack/lapack/dtptrs.cpp deleted file mode 100644 index 7417679c..00000000 --- a/external/clapack/lapack/dtptrs.cpp +++ /dev/null @@ -1,177 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dtptrs_(const char *uplo, const char *trans, const char *diag, integer *n, - integer *nrhs, double *ap, double *b, integer *ldb, integer * - info) -{ - /* System generated locals */ - integer b_dim1, b_offset, i__1; - - /* Local variables */ - integer j, jc; - bool upper; - bool nounit; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTPTRS solves a triangular system of the form */ - -/* A * X = B or A**T * X = B, */ - -/* where A is a triangular matrix of order N stored in packed format, */ -/* and B is an N-by-NRHS matrix. A check is made to verify that A is */ -/* nonsingular. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ -/* The upper or lower triangular matrix A, packed columnwise in */ -/* a linear array. The j-th column of A is stored in the array */ -/* AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, if INFO = 0, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ -/* indicating that the matrix is singular and the */ -/* solutions X have not been computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTPTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity. */ - - if (nounit) { - if (upper) { - jc = 1; - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (ap[jc + *info - 1] == 0.) { - return 0; - } - jc += *info; -/* L10: */ - } - } else { - jc = 1; - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (ap[jc] == 0.) { - return 0; - } - jc = jc + *n - *info + 1; -/* L20: */ - } - } - } - *info = 0; - -/* Solve A * x = b or A' * x = b. */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - dtpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1); -/* L30: */ - } - - return 0; - -/* End of DTPTRS */ - -} /* dtptrs_ */ diff --git a/external/clapack/lapack/dtpttf.cpp b/external/clapack/lapack/dtpttf.cpp deleted file mode 100644 index 1de05fca..00000000 --- a/external/clapack/lapack/dtpttf.cpp +++ /dev/null @@ -1,482 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dtpttf_(const char *transr, const char *uplo, integer *n, double *ap, double *arf, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - - /* Local variables */ - integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp; - bool normaltransr, lower, nisodd; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ - -/* Purpose */ -/* ======= */ - -/* DTPTTF copies a triangular matrix A from standard packed format (TP) */ -/* to rectangular full packed format (TF). */ - -/* Arguments */ -/* ========= */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': ARF in Normal format is wanted; */ -/* = 'T': ARF in Conjugate-transpose format is wanted. */ - -/* UPLO (input) CHARACTER */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ -/* On entry, the upper or lower triangular matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ -/* On exit, the upper or lower triangular matrix A stored in */ -/* RFP format. For a further discussion see Notes below. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - *info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - if (! normaltransr && ! lsame_(transr, "T")) { - *info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTPTTF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (normaltransr) { - arf[0] = ap[0]; - } else { - arf[0] = ap[0]; - } - return 0; - } - -/* Size of array ARF(0:NT-1) */ - - nt = *n * (*n + 1) / 2; - -/* Set N1 and N2 depending on LOWER */ - - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - -/* If N is odd, set NISODD = .TRUE. */ -/* If N is even, set K = N/2 and NISODD = .FALSE. */ - -/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ -/* where noe = 0 if n is even, noe = 1 if n is odd */ - - if (*n % 2 == 0) { - k = *n / 2; - nisodd = false; - lda = *n + 1; - } else { - nisodd = true; - lda = *n; - } - -/* ARF^C has lda rows and n+1-noe cols */ - - if (! normaltransr) { - lda = (*n + 1) / 2; - } - -/* start execution: there are eight cases */ - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* N is odd, TRANSR = 'N', and UPLO = 'L' */ - - ijp = 0; - jp = 0; - i__1 = n2; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = j; i__ <= i__2; ++i__) { - ij = i__ + jp; - arf[ij] = ap[ijp]; - ++ijp; - } - jp += lda; - } - i__1 = n2 - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__2 = n2; - for (j = i__ + 1; j <= i__2; ++j) { - ij = i__ + j * lda; - arf[ij] = ap[ijp]; - ++ijp; - } - } - - } else { - -/* N is odd, TRANSR = 'N', and UPLO = 'U' */ - - ijp = 0; - i__1 = n1 - 1; - for (j = 0; j <= i__1; ++j) { - ij = n2 + j; - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = ap[ijp]; - ++ijp; - ij += lda; - } - } - js = 0; - i__1 = *n - 1; - for (j = n1; j <= i__1; ++j) { - ij = js; - i__2 = js + j; - for (ij = js; ij <= i__2; ++ij) { - arf[ij] = ap[ijp]; - ++ijp; - } - js += lda; - } - - } - - } else { - -/* N is odd and TRANSR = 'T' */ - - if (lower) { - -/* N is odd, TRANSR = 'T', and UPLO = 'L' */ - - ijp = 0; - i__1 = n2; - for (i__ = 0; i__ <= i__1; ++i__) { - i__2 = *n * lda - 1; - i__3 = lda; - for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= - i__2; ij += i__3) { - arf[ij] = ap[ijp]; - ++ijp; - } - } - js = 1; - i__1 = n2 - 1; - for (j = 0; j <= i__1; ++j) { - i__3 = js + n2 - j - 1; - for (ij = js; ij <= i__3; ++ij) { - arf[ij] = ap[ijp]; - ++ijp; - } - js = js + lda + 1; - } - - } else { - -/* N is odd, TRANSR = 'T', and UPLO = 'U' */ - - ijp = 0; - js = n2 * lda; - i__1 = n1 - 1; - for (j = 0; j <= i__1; ++j) { - i__3 = js + j; - for (ij = js; ij <= i__3; ++ij) { - arf[ij] = ap[ijp]; - ++ijp; - } - js += lda; - } - i__1 = n1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__3 = i__ + (n1 + i__) * lda; - i__2 = lda; - for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += - i__2) { - arf[ij] = ap[ijp]; - ++ijp; - } - } - - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* N is even, TRANSR = 'N', and UPLO = 'L' */ - - ijp = 0; - jp = 0; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = j; i__ <= i__2; ++i__) { - ij = i__ + 1 + jp; - arf[ij] = ap[ijp]; - ++ijp; - } - jp += lda; - } - i__1 = k - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__2 = k - 1; - for (j = i__; j <= i__2; ++j) { - ij = i__ + j * lda; - arf[ij] = ap[ijp]; - ++ijp; - } - } - - } else { - -/* N is even, TRANSR = 'N', and UPLO = 'U' */ - - ijp = 0; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - ij = k + 1 + j; - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = ap[ijp]; - ++ijp; - ij += lda; - } - } - js = 0; - i__1 = *n - 1; - for (j = k; j <= i__1; ++j) { - ij = js; - i__2 = js + j; - for (ij = js; ij <= i__2; ++ij) { - arf[ij] = ap[ijp]; - ++ijp; - } - js += lda; - } - - } - - } else { - -/* N is even and TRANSR = 'T' */ - - if (lower) { - -/* N is even, TRANSR = 'T', and UPLO = 'L' */ - - ijp = 0; - i__1 = k - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__2 = (*n + 1) * lda - 1; - i__3 = lda; - for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : - ij <= i__2; ij += i__3) { - arf[ij] = ap[ijp]; - ++ijp; - } - } - js = 0; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__3 = js + k - j - 1; - for (ij = js; ij <= i__3; ++ij) { - arf[ij] = ap[ijp]; - ++ijp; - } - js = js + lda + 1; - } - - } else { - -/* N is even, TRANSR = 'T', and UPLO = 'U' */ - - ijp = 0; - js = (k + 1) * lda; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__3 = js + j; - for (ij = js; ij <= i__3; ++ij) { - arf[ij] = ap[ijp]; - ++ijp; - } - js += lda; - } - i__1 = k - 1; - for (i__ = 0; i__ <= i__1; ++i__) { - i__3 = i__ + (k + i__) * lda; - i__2 = lda; - for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += - i__2) { - arf[ij] = ap[ijp]; - ++ijp; - } - } - - } - - } - - } - - return 0; - -/* End of DTPTTF */ - -} /* dtpttf_ */ diff --git a/external/clapack/lapack/dtpttr.cpp b/external/clapack/lapack/dtpttr.cpp deleted file mode 100644 index b8806af3..00000000 --- a/external/clapack/lapack/dtpttr.cpp +++ /dev/null @@ -1,128 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dtpttr_(const char *uplo, integer *n, double *ap, double *a, integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, k; - bool lower; - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTPTTR copies a triangular matrix A from standard packed format (TP) */ -/* to standard full format (TR). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER */ -/* = 'U': A is upper triangular. */ -/* = 'L': A is lower triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ -/* On entry, the upper or lower triangular matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* A (output) DOUBLE PRECISION array, dimension ( LDA, N ) */ -/* On exit, the triangular matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - --ap; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - lower = lsame_(uplo, "L"); - if (! lower && ! lsame_(uplo, "U")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTPTTR", &i__1); - return 0; - } - - if (lower) { - k = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - ++k; - a[i__ + j * a_dim1] = ap[k]; - } - } - } else { - k = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - ++k; - a[i__ + j * a_dim1] = ap[k]; - } - } - } - - - return 0; - -/* End of DTPTTR */ - -} /* dtpttr_ */ diff --git a/external/clapack/lapack/dtrcon.cpp b/external/clapack/lapack/dtrcon.cpp deleted file mode 100644 index 96f12975..00000000 --- a/external/clapack/lapack/dtrcon.cpp +++ /dev/null @@ -1,216 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dtrcon_(const char *norm, const char *uplo, const char *diag, integer *n, - double *a, integer *lda, double *rcond, double *work, - integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - double d__1; - - /* Local variables */ - integer ix, kase, kase1; - double scale; - integer isave[3]; - double anorm; - bool upper; - double xnorm; - double ainvnm; - bool onenrm; - char normin[1]; - double smlnum; - bool nounit; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRCON estimates the reciprocal of the condition number of a */ -/* triangular matrix A, in either the 1-norm or the infinity-norm. */ - -/* The norm of A is computed and an estimate is obtained for */ -/* norm(inv(A)), then the reciprocal of the condition number is */ -/* computed as */ -/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); - nounit = lsame_(diag, "N"); - - if (! onenrm && ! lsame_(norm, "I")) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < std::max(1_integer,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRCON", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *rcond = 1.; - return 0; - } - - *rcond = 0.; - smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n); - -/* Compute the norm of the triangular matrix A. */ - - anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]); - -/* Continue only if ANORM > 0. */ - - if (anorm > 0.) { - -/* Estimate the norm of the inverse of A. */ - - ainvnm = 0.; - *(unsigned char *)normin = 'N'; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kase = 0; -L10: - dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(A). */ - - dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], - lda, &work[1], &scale, &work[(*n << 1) + 1], info); - } else { - -/* Multiply by inv(A'). */ - - dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, - &work[1], &scale, &work[(*n << 1) + 1], info); - } - *(unsigned char *)normin = 'Y'; - -/* Multiply by 1/SCALE if doing so will not cause overflow. */ - - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - xnorm = (d__1 = work[ix], abs(d__1)); - if (scale < xnorm * smlnum || scale == 0.) { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / anorm / ainvnm; - } - } - -L20: - return 0; - -/* End of DTRCON */ - -} /* dtrcon_ */ diff --git a/external/clapack/lapack/dtrevc.cpp b/external/clapack/lapack/dtrevc.cpp deleted file mode 100644 index 25cc4d65..00000000 --- a/external/clapack/lapack/dtrevc.cpp +++ /dev/null @@ -1,1193 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static bool c_false = false; -static integer c__1 = 1; -static double c_b22 = 1.; -static double c_b25 = 0.; -static integer c__2 = 2; -static bool c_true = true; - -/* Subroutine */ int dtrevc_(const char *side, const char *howmny, bool *select, - integer *n, double *t, integer *ldt, double *vl, integer * - ldvl, double *vr, integer *ldvr, integer *mm, integer *m, - double *work, integer *info) -{ - /* System generated locals */ - integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, - i__2, i__3; - double d__1, d__2, d__3, d__4; - - /* Local variables */ - integer i__, j, k; - double x[4] /* was [2][2] */; - integer j1, j2, n2, ii, ki, ip, is; - double wi, wr, rec, ulp, beta, emax; - bool pair; - bool allv; - integer ierr; - double unfl, ovfl, smin; - bool over; - double vmax; - integer jnxt; - double scale; - double remax; - bool leftv, bothv; - double vcrit; - bool somev; - double xnorm; - double bignum; - bool rightv; - double smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTREVC computes some or all of the right and/or left eigenvectors of */ -/* a real upper quasi-triangular matrix T. */ -/* Matrices of this type are produced by the Schur factorization of */ -/* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. */ - -/* The right eigenvector x and the left eigenvector y of T corresponding */ -/* to an eigenvalue w are defined by: */ - -/* T*x = w*x, (y**H)*T = w*(y**H) */ - -/* where y**H denotes the conjugate transpose of y. */ -/* The eigenvalues are not input to this routine, but are read directly */ -/* from the diagonal blocks of T. */ - -/* This routine returns the matrices X and/or Y of right and left */ -/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ -/* input matrix. If Q is the orthogonal factor that reduces a matrix */ -/* A to Schur form T, then Q*X and Q*Y are the matrices of right and */ -/* left eigenvectors of A. */ - -/* Arguments */ -/* ========= */ - -/* SIDE (input) CHARACTER*1 */ -/* = 'R': compute right eigenvectors only; */ -/* = 'L': compute left eigenvectors only; */ -/* = 'B': compute both right and left eigenvectors. */ - -/* HOWMNY (input) CHARACTER*1 */ -/* = 'A': compute all right and/or left eigenvectors; */ -/* = 'B': compute all right and/or left eigenvectors, */ -/* backtransformed by the matrices in VR and/or VL; */ -/* = 'S': compute selected right and/or left eigenvectors, */ -/* as indicated by the logical array SELECT. */ - -/* SELECT (input/output) LOGICAL array, dimension (N) */ -/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ -/* computed. */ -/* If w(j) is a real eigenvalue, the corresponding real */ -/* eigenvector is computed if SELECT(j) is .TRUE.. */ -/* If w(j) and w(j+1) are the real and imaginary parts of a */ -/* complex eigenvalue, the corresponding complex eigenvector is */ -/* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */ -/* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */ -/* .FALSE.. */ -/* Not referenced if HOWMNY = 'A' or 'B'. */ - -/* N (input) INTEGER */ -/* The order of the matrix T. N >= 0. */ - -/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */ -/* The upper quasi-triangular matrix T in Schur canonical form. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= max(1,N). */ - -/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */ -/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ -/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ -/* of Schur vectors returned by DHSEQR). */ -/* On exit, if SIDE = 'L' or 'B', VL contains: */ -/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ -/* if HOWMNY = 'B', the matrix Q*Y; */ -/* if HOWMNY = 'S', the left eigenvectors of T specified by */ -/* SELECT, stored consecutively in the columns */ -/* of VL, in the same order as their */ -/* eigenvalues. */ -/* A complex eigenvector corresponding to a complex eigenvalue */ -/* is stored in two consecutive columns, the first holding the */ -/* real part, and the second the imaginary part. */ -/* Not referenced if SIDE = 'R'. */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the array VL. LDVL >= 1, and if */ -/* SIDE = 'L' or 'B', LDVL >= N. */ - -/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */ -/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ -/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ -/* of Schur vectors returned by DHSEQR). */ -/* On exit, if SIDE = 'R' or 'B', VR contains: */ -/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ -/* if HOWMNY = 'B', the matrix Q*X; */ -/* if HOWMNY = 'S', the right eigenvectors of T specified by */ -/* SELECT, stored consecutively in the columns */ -/* of VR, in the same order as their */ -/* eigenvalues. */ -/* A complex eigenvector corresponding to a complex eigenvalue */ -/* is stored in two consecutive columns, the first holding the */ -/* real part and the second the imaginary part. */ -/* Not referenced if SIDE = 'L'. */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the array VR. LDVR >= 1, and if */ -/* SIDE = 'R' or 'B', LDVR >= N. */ - -/* MM (input) INTEGER */ -/* The number of columns in the arrays VL and/or VR. MM >= M. */ - -/* M (output) INTEGER */ -/* The number of columns in the arrays VL and/or VR actually */ -/* used to store the eigenvectors. */ -/* If HOWMNY = 'A' or 'B', M is set to N. */ -/* Each selected real eigenvector occupies one column and each */ -/* selected complex eigenvector occupies two columns. */ - -/* 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 algorithm used in this program is basically backward (forward) */ -/* substitution, with scaling to make the the code robust against */ -/* possible overflow. */ - -/* Each eigenvector is normalized so that the element of largest */ -/* magnitude has magnitude 1; here the magnitude of a complex number */ -/* (x,y) is taken to be |x| + |y|. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test the input parameters */ - - /* Parameter adjustments */ - --select; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --work; - - /* Function Body */ - bothv = lsame_(side, "B"); - rightv = lsame_(side, "R") || bothv; - leftv = lsame_(side, "L") || bothv; - - allv = lsame_(howmny, "A"); - over = lsame_(howmny, "B"); - somev = lsame_(howmny, "S"); - - *info = 0; - if (! rightv && ! leftv) { - *info = -1; - } else if (! allv && ! over && ! somev) { - *info = -2; - } else if (*n < 0) { - *info = -4; - } else if (*ldt < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldvl < 1 || leftv && *ldvl < *n) { - *info = -8; - } else if (*ldvr < 1 || rightv && *ldvr < *n) { - *info = -10; - } else { - -/* Set M to the number of columns required to store the selected */ -/* eigenvectors, standardize the array SELECT if necessary, and */ -/* test MM. */ - - if (somev) { - *m = 0; - pair = false; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (pair) { - pair = false; - select[j] = false; - } else { - if (j < *n) { - if (t[j + 1 + j * t_dim1] == 0.) { - if (select[j]) { - ++(*m); - } - } else { - pair = true; - if (select[j] || select[j + 1]) { - select[j] = true; - *m += 2; - } - } - } else { - if (select[*n]) { - ++(*m); - } - } - } -/* L10: */ - } - } else { - *m = *n; - } - - if (*mm < *m) { - *info = -11; - } - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTREVC", &i__1); - return 0; - } - -/* Quick return if possible. */ - - if (*n == 0) { - return 0; - } - -/* Set the constants to control overflow. */ - - unfl = dlamch_("Safe minimum"); - ovfl = 1. / unfl; - dlabad_(&unfl, &ovfl); - ulp = dlamch_("Precision"); - smlnum = unfl * (*n / ulp); - bignum = (1. - ulp) / smlnum; - -/* Compute 1-norm of each column of strictly upper triangular */ -/* part of T to control overflow in triangular solver. */ - - work[1] = 0.; - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - work[j] = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1)); -/* L20: */ - } -/* L30: */ - } - -/* Index IP is used to specify the real or complex eigenvalue: */ -/* IP = 0, real eigenvalue, */ -/* 1, first of conjugate complex pair: (wr,wi) */ -/* -1, second of conjugate complex pair: (wr,wi) */ - - n2 = *n << 1; - - if (rightv) { - -/* Compute right eigenvectors. */ - - ip = 0; - is = *m; - for (ki = *n; ki >= 1; --ki) { - - if (ip == 1) { - goto L130; - } - if (ki == 1) { - goto L40; - } - if (t[ki + (ki - 1) * t_dim1] == 0.) { - goto L40; - } - ip = -1; - -L40: - if (somev) { - if (ip == 0) { - if (! select[ki]) { - goto L130; - } - } else { - if (! select[ki - 1]) { - goto L130; - } - } - } - -/* Compute the KI-th eigenvalue (WR,WI). */ - - wr = t[ki + ki * t_dim1]; - wi = 0.; - if (ip != 0) { - wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) * - sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2))); - } -/* Computing MAX */ - d__1 = ulp * (abs(wr) + abs(wi)); - smin = std::max(d__1,smlnum); - - if (ip == 0) { - -/* Real right eigenvector */ - - work[ki + *n] = 1.; - -/* Form right-hand side */ - - i__1 = ki - 1; - for (k = 1; k <= i__1; ++k) { - work[k + *n] = -t[k + ki * t_dim1]; -/* L50: */ - } - -/* Solve the upper quasi-triangular system: */ -/* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */ - - jnxt = ki - 1; - for (j = ki - 1; j >= 1; --j) { - if (j > jnxt) { - goto L60; - } - j1 = j; - j2 = j; - jnxt = j - 1; - if (j > 1) { - if (t[j + (j - 1) * t_dim1] != 0.) { - j1 = j - 1; - jnxt = j - 2; - } - } - - if (j1 == j2) { - -/* 1-by-1 diagonal block */ - - dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + - j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * - n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, - &ierr); - -/* Scale X(1,1) to avoid overflow when updating */ -/* the right-hand side. */ - - if (xnorm > 1.) { - if (work[j] > bignum / xnorm) { - x[0] /= xnorm; - scale /= xnorm; - } - } - -/* Scale if necessary */ - - if (scale != 1.) { - dscal_(&ki, &scale, &work[*n + 1], &c__1); - } - work[j + *n] = x[0]; - -/* Update right-hand side */ - - i__1 = j - 1; - d__1 = -x[0]; - daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ - *n + 1], &c__1); - - } else { - -/* 2-by-2 diagonal block */ - - dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b22, &t[j - - 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & - work[j - 1 + *n], n, &wr, &c_b25, x, &c__2, & - scale, &xnorm, &ierr); - -/* Scale X(1,1) and X(2,1) to avoid overflow when */ -/* updating the right-hand side. */ - - if (xnorm > 1.) { -/* Computing MAX */ - d__1 = work[j - 1], d__2 = work[j]; - beta = std::max(d__1,d__2); - if (beta > bignum / xnorm) { - x[0] /= xnorm; - x[1] /= xnorm; - scale /= xnorm; - } - } - -/* Scale if necessary */ - - if (scale != 1.) { - dscal_(&ki, &scale, &work[*n + 1], &c__1); - } - work[j - 1 + *n] = x[0]; - work[j + *n] = x[1]; - -/* Update right-hand side */ - - i__1 = j - 2; - d__1 = -x[0]; - daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, - &work[*n + 1], &c__1); - i__1 = j - 2; - d__1 = -x[1]; - daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ - *n + 1], &c__1); - } -L60: - ; - } - -/* Copy the vector x or Q*x to VR and normalize. */ - - if (! over) { - dcopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], & - c__1); - - ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); - remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1)); - dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); - - i__1 = *n; - for (k = ki + 1; k <= i__1; ++k) { - vr[k + is * vr_dim1] = 0.; -/* L70: */ - } - } else { - if (ki > 1) { - i__1 = ki - 1; - dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & - work[*n + 1], &c__1, &work[ki + *n], &vr[ki * - vr_dim1 + 1], &c__1); - } - - ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1); - remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1)); - dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); - } - - } else { - -/* Complex right eigenvector. */ - -/* Initial solve */ -/* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. */ -/* [ (T(KI,KI-1) T(KI,KI) ) ] */ - - if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >= (d__2 = t[ - ki + (ki - 1) * t_dim1], abs(d__2))) { - work[ki - 1 + *n] = 1.; - work[ki + n2] = wi / t[ki - 1 + ki * t_dim1]; - } else { - work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1]; - work[ki + n2] = 1.; - } - work[ki + *n] = 0.; - work[ki - 1 + n2] = 0.; - -/* Form right-hand side */ - - i__1 = ki - 2; - for (k = 1; k <= i__1; ++k) { - work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) * - t_dim1]; - work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1]; -/* L80: */ - } - -/* Solve upper quasi-triangular system: */ -/* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) */ - - jnxt = ki - 2; - for (j = ki - 2; j >= 1; --j) { - if (j > jnxt) { - goto L90; - } - j1 = j; - j2 = j; - jnxt = j - 1; - if (j > 1) { - if (t[j + (j - 1) * t_dim1] != 0.) { - j1 = j - 1; - jnxt = j - 2; - } - } - - if (j1 == j2) { - -/* 1-by-1 diagonal block */ - - dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + - j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * - n], n, &wr, &wi, x, &c__2, &scale, &xnorm, & - ierr); - -/* Scale X(1,1) and X(1,2) to avoid overflow when */ -/* updating the right-hand side. */ - - if (xnorm > 1.) { - if (work[j] > bignum / xnorm) { - x[0] /= xnorm; - x[2] /= xnorm; - scale /= xnorm; - } - } - -/* Scale if necessary */ - - if (scale != 1.) { - dscal_(&ki, &scale, &work[*n + 1], &c__1); - dscal_(&ki, &scale, &work[n2 + 1], &c__1); - } - work[j + *n] = x[0]; - work[j + n2] = x[2]; - -/* Update the right-hand side */ - - i__1 = j - 1; - d__1 = -x[0]; - daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ - *n + 1], &c__1); - i__1 = j - 1; - d__1 = -x[2]; - daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ - n2 + 1], &c__1); - - } else { - -/* 2-by-2 diagonal block */ - - dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b22, &t[j - - 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & - work[j - 1 + *n], n, &wr, &wi, x, &c__2, & - scale, &xnorm, &ierr); - -/* Scale X to avoid overflow when updating */ -/* the right-hand side. */ - - if (xnorm > 1.) { -/* Computing MAX */ - d__1 = work[j - 1], d__2 = work[j]; - beta = std::max(d__1,d__2); - if (beta > bignum / xnorm) { - rec = 1. / xnorm; - x[0] *= rec; - x[2] *= rec; - x[1] *= rec; - x[3] *= rec; - scale *= rec; - } - } - -/* Scale if necessary */ - - if (scale != 1.) { - dscal_(&ki, &scale, &work[*n + 1], &c__1); - dscal_(&ki, &scale, &work[n2 + 1], &c__1); - } - work[j - 1 + *n] = x[0]; - work[j + *n] = x[1]; - work[j - 1 + n2] = x[2]; - work[j + n2] = x[3]; - -/* Update the right-hand side */ - - i__1 = j - 2; - d__1 = -x[0]; - daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, - &work[*n + 1], &c__1); - i__1 = j - 2; - d__1 = -x[1]; - daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ - *n + 1], &c__1); - i__1 = j - 2; - d__1 = -x[2]; - daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, - &work[n2 + 1], &c__1); - i__1 = j - 2; - d__1 = -x[3]; - daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ - n2 + 1], &c__1); - } -L90: - ; - } - -/* Copy the vector x or Q*x to VR and normalize. */ - - if (! over) { - dcopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1 - + 1], &c__1); - dcopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], & - c__1); - - emax = 0.; - i__1 = ki; - for (k = 1; k <= i__1; ++k) { -/* Computing MAX */ - d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1] - , abs(d__1)) + (d__2 = vr[k + is * vr_dim1], - abs(d__2)); - emax = std::max(d__3,d__4); -/* L100: */ - } - - remax = 1. / emax; - dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1); - dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); - - i__1 = *n; - for (k = ki + 1; k <= i__1; ++k) { - vr[k + (is - 1) * vr_dim1] = 0.; - vr[k + is * vr_dim1] = 0.; -/* L110: */ - } - - } else { - - if (ki > 2) { - i__1 = ki - 2; - dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & - work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[( - ki - 1) * vr_dim1 + 1], &c__1); - i__1 = ki - 2; - dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & - work[n2 + 1], &c__1, &work[ki + n2], &vr[ki * - vr_dim1 + 1], &c__1); - } else { - dscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1 - + 1], &c__1); - dscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], & - c__1); - } - - emax = 0.; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { -/* Computing MAX */ - d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1] - , abs(d__1)) + (d__2 = vr[k + ki * vr_dim1], - abs(d__2)); - emax = std::max(d__3,d__4); -/* L120: */ - } - remax = 1. / emax; - dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1); - dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); - } - } - - --is; - if (ip != 0) { - --is; - } -L130: - if (ip == 1) { - ip = 0; - } - if (ip == -1) { - ip = 1; - } -/* L140: */ - } - } - - if (leftv) { - -/* Compute left eigenvectors. */ - - ip = 0; - is = 1; - i__1 = *n; - for (ki = 1; ki <= i__1; ++ki) { - - if (ip == -1) { - goto L250; - } - if (ki == *n) { - goto L150; - } - if (t[ki + 1 + ki * t_dim1] == 0.) { - goto L150; - } - ip = 1; - -L150: - if (somev) { - if (! select[ki]) { - goto L250; - } - } - -/* Compute the KI-th eigenvalue (WR,WI). */ - - wr = t[ki + ki * t_dim1]; - wi = 0.; - if (ip != 0) { - wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) * - sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2))); - } -/* Computing MAX */ - d__1 = ulp * (abs(wr) + abs(wi)); - smin = std::max(d__1,smlnum); - - if (ip == 0) { - -/* Real left eigenvector. */ - - work[ki + *n] = 1.; - -/* Form right-hand side */ - - i__2 = *n; - for (k = ki + 1; k <= i__2; ++k) { - work[k + *n] = -t[ki + k * t_dim1]; -/* L160: */ - } - -/* Solve the quasi-triangular system: */ -/* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK */ - - vmax = 1.; - vcrit = bignum; - - jnxt = ki + 1; - i__2 = *n; - for (j = ki + 1; j <= i__2; ++j) { - if (j < jnxt) { - goto L170; - } - j1 = j; - j2 = j; - jnxt = j + 1; - if (j < *n) { - if (t[j + 1 + j * t_dim1] != 0.) { - j2 = j + 1; - jnxt = j + 2; - } - } - - if (j1 == j2) { - -/* 1-by-1 diagonal block */ - -/* Scale if necessary to avoid overflow when forming */ -/* the right-hand side. */ - - if (work[j] > vcrit) { - rec = 1. / vmax; - i__3 = *n - ki + 1; - dscal_(&i__3, &rec, &work[ki + *n], &c__1); - vmax = 1.; - vcrit = bignum; - } - - i__3 = j - ki - 1; - work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1], - &c__1, &work[ki + 1 + *n], &c__1); - -/* Solve (T(J,J)-WR)'*X = WORK */ - - dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + - j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * - n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, - &ierr); - -/* Scale if necessary */ - - if (scale != 1.) { - i__3 = *n - ki + 1; - dscal_(&i__3, &scale, &work[ki + *n], &c__1); - } - work[j + *n] = x[0]; -/* Computing MAX */ - d__2 = (d__1 = work[j + *n], abs(d__1)); - vmax = std::max(d__2,vmax); - vcrit = bignum / vmax; - - } else { - -/* 2-by-2 diagonal block */ - -/* Scale if necessary to avoid overflow when forming */ -/* the right-hand side. */ - -/* Computing MAX */ - d__1 = work[j], d__2 = work[j + 1]; - beta = std::max(d__1,d__2); - if (beta > vcrit) { - rec = 1. / vmax; - i__3 = *n - ki + 1; - dscal_(&i__3, &rec, &work[ki + *n], &c__1); - vmax = 1.; - vcrit = bignum; - } - - i__3 = j - ki - 1; - work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1], - &c__1, &work[ki + 1 + *n], &c__1); - - i__3 = j - ki - 1; - work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 1 + (j + 1) * - t_dim1], &c__1, &work[ki + 1 + *n], &c__1); - -/* Solve */ -/* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) */ -/* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) */ - - dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b22, &t[j + - j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * - n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, - &ierr); - -/* Scale if necessary */ - - if (scale != 1.) { - i__3 = *n - ki + 1; - dscal_(&i__3, &scale, &work[ki + *n], &c__1); - } - work[j + *n] = x[0]; - work[j + 1 + *n] = x[1]; - -/* Computing MAX */ - d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2 - = work[j + 1 + *n], abs(d__2)), d__3 = std::max( - d__3,d__4); - vmax = std::max(d__3,vmax); - vcrit = bignum / vmax; - - } -L170: - ; - } - -/* Copy the vector x or Q*x to VL and normalize. */ - - if (! over) { - i__2 = *n - ki + 1; - dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * - vl_dim1], &c__1); - - i__2 = *n - ki + 1; - ii = idamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - - 1; - remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1)); - i__2 = *n - ki + 1; - dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); - - i__2 = ki - 1; - for (k = 1; k <= i__2; ++k) { - vl[k + is * vl_dim1] = 0.; -/* L180: */ - } - - } else { - - if (ki < *n) { - i__2 = *n - ki; - dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 1) * vl_dim1 - + 1], ldvl, &work[ki + 1 + *n], &c__1, &work[ - ki + *n], &vl[ki * vl_dim1 + 1], &c__1); - } - - ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1); - remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1)); - dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); - - } - - } else { - -/* Complex left eigenvector. */ - -/* Initial solve: */ -/* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. */ -/* ((T(KI+1,KI) T(KI+1,KI+1)) ) */ - - if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >= (d__2 = - t[ki + 1 + ki * t_dim1], abs(d__2))) { - work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1]; - work[ki + 1 + n2] = 1.; - } else { - work[ki + *n] = 1.; - work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1]; - } - work[ki + 1 + *n] = 0.; - work[ki + n2] = 0.; - -/* Form right-hand side */ - - i__2 = *n; - for (k = ki + 2; k <= i__2; ++k) { - work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1]; - work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1] - ; -/* L190: */ - } - -/* Solve complex quasi-triangular system: */ -/* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 */ - - vmax = 1.; - vcrit = bignum; - - jnxt = ki + 2; - i__2 = *n; - for (j = ki + 2; j <= i__2; ++j) { - if (j < jnxt) { - goto L200; - } - j1 = j; - j2 = j; - jnxt = j + 1; - if (j < *n) { - if (t[j + 1 + j * t_dim1] != 0.) { - j2 = j + 1; - jnxt = j + 2; - } - } - - if (j1 == j2) { - -/* 1-by-1 diagonal block */ - -/* Scale if necessary to avoid overflow when */ -/* forming the right-hand side elements. */ - - if (work[j] > vcrit) { - rec = 1. / vmax; - i__3 = *n - ki + 1; - dscal_(&i__3, &rec, &work[ki + *n], &c__1); - i__3 = *n - ki + 1; - dscal_(&i__3, &rec, &work[ki + n2], &c__1); - vmax = 1.; - vcrit = bignum; - } - - i__3 = j - ki - 2; - work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], - &c__1, &work[ki + 2 + *n], &c__1); - i__3 = j - ki - 2; - work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], - &c__1, &work[ki + 2 + n2], &c__1); - -/* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 */ - - d__1 = -wi; - dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + - j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * - n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, & - ierr); - -/* Scale if necessary */ - - if (scale != 1.) { - i__3 = *n - ki + 1; - dscal_(&i__3, &scale, &work[ki + *n], &c__1); - i__3 = *n - ki + 1; - dscal_(&i__3, &scale, &work[ki + n2], &c__1); - } - work[j + *n] = x[0]; - work[j + n2] = x[2]; -/* Computing MAX */ - d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2 - = work[j + n2], abs(d__2)), d__3 = std::max(d__3, - d__4); - vmax = std::max(d__3,vmax); - vcrit = bignum / vmax; - - } else { - -/* 2-by-2 diagonal block */ - -/* Scale if necessary to avoid overflow when forming */ -/* the right-hand side elements. */ - -/* Computing MAX */ - d__1 = work[j], d__2 = work[j + 1]; - beta = std::max(d__1,d__2); - if (beta > vcrit) { - rec = 1. / vmax; - i__3 = *n - ki + 1; - dscal_(&i__3, &rec, &work[ki + *n], &c__1); - i__3 = *n - ki + 1; - dscal_(&i__3, &rec, &work[ki + n2], &c__1); - vmax = 1.; - vcrit = bignum; - } - - i__3 = j - ki - 2; - work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], - &c__1, &work[ki + 2 + *n], &c__1); - - i__3 = j - ki - 2; - work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], - &c__1, &work[ki + 2 + n2], &c__1); - - i__3 = j - ki - 2; - work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 2 + (j + 1) * - t_dim1], &c__1, &work[ki + 2 + *n], &c__1); - - i__3 = j - ki - 2; - work[j + 1 + n2] -= ddot_(&i__3, &t[ki + 2 + (j + 1) * - t_dim1], &c__1, &work[ki + 2 + n2], &c__1); - -/* Solve 2-by-2 complex linear equation */ -/* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B */ -/* ([T(j+1,j) T(j+1,j+1)] ) */ - - d__1 = -wi; - dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b22, &t[j + - j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * - n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, & - ierr); - -/* Scale if necessary */ - - if (scale != 1.) { - i__3 = *n - ki + 1; - dscal_(&i__3, &scale, &work[ki + *n], &c__1); - i__3 = *n - ki + 1; - dscal_(&i__3, &scale, &work[ki + n2], &c__1); - } - work[j + *n] = x[0]; - work[j + n2] = x[2]; - work[j + 1 + *n] = x[1]; - work[j + 1 + n2] = x[3]; -/* Computing MAX */ - d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = std::max(d__1, - d__2), d__2 = abs(x[1]), d__1 = std::max(d__1,d__2) - , d__2 = abs(x[3]), d__1 = std::max(d__1,d__2); - vmax = std::max(d__1,vmax); - vcrit = bignum / vmax; - - } -L200: - ; - } - -/* Copy the vector x or Q*x to VL and normalize. */ - - if (! over) { - i__2 = *n - ki + 1; - dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * - vl_dim1], &c__1); - i__2 = *n - ki + 1; - dcopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) * - vl_dim1], &c__1); - - emax = 0.; - i__2 = *n; - for (k = ki; k <= i__2; ++k) { -/* Computing MAX */ - d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs( - d__1)) + (d__2 = vl[k + (is + 1) * vl_dim1], - abs(d__2)); - emax = std::max(d__3,d__4); -/* L220: */ - } - remax = 1. / emax; - i__2 = *n - ki + 1; - dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); - i__2 = *n - ki + 1; - dscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1) - ; - - i__2 = ki - 1; - for (k = 1; k <= i__2; ++k) { - vl[k + is * vl_dim1] = 0.; - vl[k + (is + 1) * vl_dim1] = 0.; -/* L230: */ - } - } else { - if (ki < *n - 1) { - i__2 = *n - ki - 1; - dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 - + 1], ldvl, &work[ki + 2 + *n], &c__1, &work[ - ki + *n], &vl[ki * vl_dim1 + 1], &c__1); - i__2 = *n - ki - 1; - dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 - + 1], ldvl, &work[ki + 2 + n2], &c__1, &work[ - ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], & - c__1); - } else { - dscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], & - c__1); - dscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1 - + 1], &c__1); - } - - emax = 0.; - i__2 = *n; - for (k = 1; k <= i__2; ++k) { -/* Computing MAX */ - d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs( - d__1)) + (d__2 = vl[k + (ki + 1) * vl_dim1], - abs(d__2)); - emax = std::max(d__3,d__4); -/* L240: */ - } - remax = 1. / emax; - dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); - dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1); - - } - - } - - ++is; - if (ip != 0) { - ++is; - } -L250: - if (ip == -1) { - ip = 0; - } - if (ip == 1) { - ip = -1; - } - -/* L260: */ - } - - } - - return 0; - -/* End of DTREVC */ - -} /* dtrevc_ */ diff --git a/external/clapack/lapack/dtrexc.cpp b/external/clapack/lapack/dtrexc.cpp deleted file mode 100644 index 17176321..00000000 --- a/external/clapack/lapack/dtrexc.cpp +++ /dev/null @@ -1,387 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__2 = 2; - -/* Subroutine */ int dtrexc_(const char *compq, integer *n, double *t, integer * - ldt, double *q, integer *ldq, integer *ifst, integer *ilst, - double *work, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, t_dim1, t_offset, i__1; - - /* Local variables */ - integer nbf, nbl, here; - bool wantq; - integer nbnext; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTREXC reorders the real Schur factorization of a real matrix */ -/* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is */ -/* moved to row ILST. */ - -/* The real Schur form T is reordered by an orthogonal similarity */ -/* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors */ -/* is updated by postmultiplying it with Z. */ - -/* T must be in Schur canonical form (as returned by DHSEQR), that is, */ -/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ -/* 2-by-2 diagonal block has its diagonal elements equal and its */ -/* off-diagonal elements of opposite sign. */ - -/* Arguments */ -/* ========= */ - -/* COMPQ (input) CHARACTER*1 */ -/* = 'V': update the matrix Q of Schur vectors; */ -/* = 'N': do not update Q. */ - -/* N (input) INTEGER */ -/* The order of the matrix T. N >= 0. */ - -/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */ -/* On entry, the upper quasi-triangular matrix T, in Schur */ -/* Schur canonical form. */ -/* On exit, the reordered upper quasi-triangular matrix, again */ -/* in Schur canonical form. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= max(1,N). */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ -/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */ -/* orthogonal transformation matrix Z which reorders T. */ -/* If COMPQ = 'N', Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. LDQ >= max(1,N). */ - -/* IFST (input/output) INTEGER */ -/* ILST (input/output) INTEGER */ -/* Specify the reordering of the diagonal blocks of T. */ -/* The block with row index IFST is moved to row ILST, by a */ -/* sequence of transpositions between adjacent blocks. */ -/* On exit, if IFST pointed on entry to the second row of a */ -/* 2-by-2 block, it is changed to point to the first row; ILST */ -/* always points to the first row of the block in its final */ -/* position (which may differ from its input value by +1 or -1). */ -/* 1 <= IFST <= N; 1 <= ILST <= N. */ - -/* 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 */ -/* = 1: two adjacent blocks were too close to swap (the problem */ -/* is very ill-conditioned); T may have been partially */ -/* reordered, and ILST points to the first row of the */ -/* current position of the block being moved. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test the input arguments. */ - - /* Parameter adjustments */ - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --work; - - /* Function Body */ - *info = 0; - wantq = lsame_(compq, "V"); - if (! wantq && ! lsame_(compq, "N")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ldt < std::max(1_integer,*n)) { - *info = -4; - } else if (*ldq < 1 || wantq && *ldq < std::max(1_integer,*n)) { - *info = -6; - } else if (*ifst < 1 || *ifst > *n) { - *info = -7; - } else if (*ilst < 1 || *ilst > *n) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTREXC", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 1) { - return 0; - } - -/* Determine the first row of specified block */ -/* and find out it is 1 by 1 or 2 by 2. */ - - if (*ifst > 1) { - if (t[*ifst + (*ifst - 1) * t_dim1] != 0.) { - --(*ifst); - } - } - nbf = 1; - if (*ifst < *n) { - if (t[*ifst + 1 + *ifst * t_dim1] != 0.) { - nbf = 2; - } - } - -/* Determine the first row of the final block */ -/* and find out it is 1 by 1 or 2 by 2. */ - - if (*ilst > 1) { - if (t[*ilst + (*ilst - 1) * t_dim1] != 0.) { - --(*ilst); - } - } - nbl = 1; - if (*ilst < *n) { - if (t[*ilst + 1 + *ilst * t_dim1] != 0.) { - nbl = 2; - } - } - - if (*ifst == *ilst) { - return 0; - } - - if (*ifst < *ilst) { - -/* Update ILST */ - - if (nbf == 2 && nbl == 1) { - --(*ilst); - } - if (nbf == 1 && nbl == 2) { - ++(*ilst); - } - - here = *ifst; - -L10: - -/* Swap block with next one below */ - - if (nbf == 1 || nbf == 2) { - -/* Current block either 1 by 1 or 2 by 2 */ - - nbnext = 1; - if (here + nbf + 1 <= *n) { - if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) { - nbnext = 2; - } - } - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, & - nbf, &nbnext, &work[1], info); - if (*info != 0) { - *ilst = here; - return 0; - } - here += nbnext; - -/* Test if 2 by 2 block breaks into two 1 by 1 blocks */ - - if (nbf == 2) { - if (t[here + 1 + here * t_dim1] == 0.) { - nbf = 3; - } - } - - } else { - -/* Current block consists of two 1 by 1 blocks each of which */ -/* must be swapped individually */ - - nbnext = 1; - if (here + 3 <= *n) { - if (t[here + 3 + (here + 2) * t_dim1] != 0.) { - nbnext = 2; - } - } - i__1 = here + 1; - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & - c__1, &nbnext, &work[1], info); - if (*info != 0) { - *ilst = here; - return 0; - } - if (nbnext == 1) { - -/* Swap two 1 by 1 blocks, no problems possible */ - - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - here, &c__1, &nbnext, &work[1], info); - ++here; - } else { - -/* Recompute NBNEXT in case 2 by 2 split */ - - if (t[here + 2 + (here + 1) * t_dim1] == 0.) { - nbnext = 1; - } - if (nbnext == 2) { - -/* 2 by 2 Block did not split */ - - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - here, &c__1, &nbnext, &work[1], info); - if (*info != 0) { - *ilst = here; - return 0; - } - here += 2; - } else { - -/* 2 by 2 Block did split */ - - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - here, &c__1, &c__1, &work[1], info); - i__1 = here + 1; - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - i__1, &c__1, &c__1, &work[1], info); - here += 2; - } - } - } - if (here < *ilst) { - goto L10; - } - - } else { - - here = *ifst; -L20: - -/* Swap block with next one above */ - - if (nbf == 1 || nbf == 2) { - -/* Current block either 1 by 1 or 2 by 2 */ - - nbnext = 1; - if (here >= 3) { - if (t[here - 1 + (here - 2) * t_dim1] != 0.) { - nbnext = 2; - } - } - i__1 = here - nbnext; - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & - nbnext, &nbf, &work[1], info); - if (*info != 0) { - *ilst = here; - return 0; - } - here -= nbnext; - -/* Test if 2 by 2 block breaks into two 1 by 1 blocks */ - - if (nbf == 2) { - if (t[here + 1 + here * t_dim1] == 0.) { - nbf = 3; - } - } - - } else { - -/* Current block consists of two 1 by 1 blocks each of which */ -/* must be swapped individually */ - - nbnext = 1; - if (here >= 3) { - if (t[here - 1 + (here - 2) * t_dim1] != 0.) { - nbnext = 2; - } - } - i__1 = here - nbnext; - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & - nbnext, &c__1, &work[1], info); - if (*info != 0) { - *ilst = here; - return 0; - } - if (nbnext == 1) { - -/* Swap two 1 by 1 blocks, no problems possible */ - - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - here, &nbnext, &c__1, &work[1], info); - --here; - } else { - -/* Recompute NBNEXT in case 2 by 2 split */ - - if (t[here + (here - 1) * t_dim1] == 0.) { - nbnext = 1; - } - if (nbnext == 2) { - -/* 2 by 2 Block did not split */ - - i__1 = here - 1; - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - i__1, &c__2, &c__1, &work[1], info); - if (*info != 0) { - *ilst = here; - return 0; - } - here += -2; - } else { - -/* 2 by 2 Block did split */ - - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - here, &c__1, &c__1, &work[1], info); - i__1 = here - 1; - dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - i__1, &c__1, &c__1, &work[1], info); - here += -2; - } - } - } - if (here > *ilst) { - goto L20; - } - } - *ilst = here; - - return 0; - -/* End of DTREXC */ - -} /* dtrexc_ */ diff --git a/external/clapack/lapack/dtrrfs.cpp b/external/clapack/lapack/dtrrfs.cpp deleted file mode 100644 index cd3d6bba..00000000 --- a/external/clapack/lapack/dtrrfs.cpp +++ /dev/null @@ -1,470 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b19 = -1.; - -/* Subroutine */ int dtrrfs_(const char *uplo, const char *trans, const char *diag, integer *n, - integer *nrhs, double *a, integer *lda, double *b, integer * - ldb, double *x, integer *ldx, double *ferr, double *berr, - double *work, integer *iwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, - i__3; - double d__1, d__2, d__3; - - /* Local variables */ - integer i__, j, k; - double s, xk; - integer nz; - double eps; - integer kase; - double safe1, safe2; - integer isave[3]; - bool upper; - double safmin; - bool notran; - char transt[1]; - bool nounit; - double lstres; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRRFS provides error bounds and backward error estimates for the */ -/* solution to a system of linear equations with a triangular */ -/* coefficient matrix. */ - -/* The solution matrix X must be computed by DTRTRS or some other */ -/* means before entering this routine. DTRRFS does not do iterative */ -/* refinement because doing so cannot improve the backward error. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* The solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - notran = lsame_(trans, "N"); - nounit = lsame_(diag, "N"); - - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T") && ! - lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldx < std::max(1_integer,*n)) { - *info = -11; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *n + 1; - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - -/* Compute residual R = B - op(A) * X, */ -/* where op(A) = A or A', depending on TRANS. */ - - dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1); - daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L20: */ - } - - if (notran) { - -/* Compute abs(A)*abs(X) + abs(B). */ - - if (upper) { - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = k; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs( - d__1)) * xk; -/* L30: */ - } -/* L40: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs( - d__1)) * xk; -/* L50: */ - } - work[k] += xk; -/* L60: */ - } - } - } else { - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = *n; - for (i__ = k; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs( - d__1)) * xk; -/* L70: */ - } -/* L80: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = *n; - for (i__ = k + 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs( - d__1)) * xk; -/* L90: */ - } - work[k] += xk; -/* L100: */ - } - } - } - } else { - -/* Compute abs(A')*abs(X) + abs(B). */ - - if (upper) { - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - i__3 = k; - for (i__ = 1; i__ <= i__3; ++i__) { - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( - d__2 = x[i__ + j * x_dim1], abs(d__2)); -/* L110: */ - } - work[k] += s; -/* L120: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( - d__2 = x[i__ + j * x_dim1], abs(d__2)); -/* L130: */ - } - work[k] += s; -/* L140: */ - } - } - } else { - if (nounit) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - i__3 = *n; - for (i__ = k; i__ <= i__3; ++i__) { - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( - d__2 = x[i__ + j * x_dim1], abs(d__2)); -/* L150: */ - } - work[k] += s; -/* L160: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = *n; - for (i__ = k + 1; i__ <= i__3; ++i__) { - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( - d__2 = x[i__ + j * x_dim1], abs(d__2)); -/* L170: */ - } - work[k] += s; -/* L180: */ - } - } - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = std::max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = std::max(d__2,d__3); - } -/* L190: */ - } - berr[j] = s; - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(op(A)))* */ -/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(op(A)) is the inverse of op(A) */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACN2 to estimate the infinity-norm of the matrix */ -/* inv(op(A)) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L200: */ - } - - kase = 0; -L210: - dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(op(A)'). */ - - dtrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1] -, &c__1); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L220: */ - } - } else { - -/* Multiply by inv(op(A))*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L230: */ - } - dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], - &c__1); - } - goto L210; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = std::max(d__2,d__3); -/* L240: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L250: */ - } - - return 0; - -/* End of DTRRFS */ - -} /* dtrrfs_ */ diff --git a/external/clapack/lapack/dtrsen.cpp b/external/clapack/lapack/dtrsen.cpp deleted file mode 100644 index 21f07276..00000000 --- a/external/clapack/lapack/dtrsen.cpp +++ /dev/null @@ -1,501 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c_n1 = -1; - -/* Subroutine */ int dtrsen_(const char *job, const char *compq, bool *select, integer - *n, double *t, integer *ldt, double *q, integer *ldq, - double *wr, double *wi, integer *m, double *s, double - *sep, double *work, integer *lwork, integer *iwork, integer * - liwork, integer *info) -{ - /* System generated locals */ - integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer k, n1, n2, kk, nn, ks; - double est; - integer kase; - bool pair; - integer ierr; - bool swap; - double scale; - integer isave[3], lwmin; - bool wantq, wants; - double rnorm; - bool wantbh; - integer liwmin; - bool wantsp, lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRSEN reorders the real Schur factorization of a real matrix */ -/* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */ -/* the leading diagonal blocks of the upper quasi-triangular matrix T, */ -/* and the leading columns of Q form an orthonormal basis of the */ -/* corresponding right invariant subspace. */ - -/* Optionally the routine computes the reciprocal condition numbers of */ -/* the cluster of eigenvalues and/or the invariant subspace. */ - -/* T must be in Schur canonical form (as returned by DHSEQR), that is, */ -/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ -/* 2-by-2 diagonal block has its diagonal elemnts equal and its */ -/* off-diagonal elements of opposite sign. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* Specifies whether condition numbers are required for the */ -/* cluster of eigenvalues (S) or the invariant subspace (SEP): */ -/* = 'N': none; */ -/* = 'E': for eigenvalues only (S); */ -/* = 'V': for invariant subspace only (SEP); */ -/* = 'B': for both eigenvalues and invariant subspace (S and */ -/* SEP). */ - -/* COMPQ (input) CHARACTER*1 */ -/* = 'V': update the matrix Q of Schur vectors; */ -/* = 'N': do not update Q. */ - -/* SELECT (input) LOGICAL array, dimension (N) */ -/* SELECT specifies the eigenvalues in the selected cluster. To */ -/* select a real eigenvalue w(j), SELECT(j) must be set to */ -/* .TRUE.. To select a complex conjugate pair of eigenvalues */ -/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ -/* either SELECT(j) or SELECT(j+1) or both must be set to */ -/* .TRUE.; a complex conjugate pair of eigenvalues must be */ -/* either both included in the cluster or both excluded. */ - -/* N (input) INTEGER */ -/* The order of the matrix T. N >= 0. */ - -/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */ -/* On entry, the upper quasi-triangular matrix T, in Schur */ -/* canonical form. */ -/* On exit, T is overwritten by the reordered matrix T, again in */ -/* Schur canonical form, with the selected eigenvalues in the */ -/* leading diagonal blocks. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= max(1,N). */ - -/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ -/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ -/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */ -/* orthogonal transformation matrix which reorders T; the */ -/* leading M columns of Q form an orthonormal basis for the */ -/* specified invariant subspace. */ -/* If COMPQ = 'N', Q is not referenced. */ - -/* LDQ (input) INTEGER */ -/* The leading dimension of the array Q. */ -/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */ - -/* WR (output) DOUBLE PRECISION array, dimension (N) */ -/* WI (output) DOUBLE PRECISION array, dimension (N) */ -/* The real and imaginary parts, respectively, of the reordered */ -/* eigenvalues of T. The eigenvalues are stored in the same */ -/* order as on the diagonal of T, with WR(i) = T(i,i) and, if */ -/* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */ -/* WI(i+1) = -WI(i). Note that if a complex eigenvalue is */ -/* sufficiently ill-conditioned, then its value may differ */ -/* significantly from its value before reordering. */ - -/* M (output) INTEGER */ -/* The dimension of the specified invariant subspace. */ -/* 0 < = M <= N. */ - -/* S (output) DOUBLE PRECISION */ -/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */ -/* condition number for the selected cluster of eigenvalues. */ -/* S cannot underestimate the true reciprocal condition number */ -/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */ -/* If JOB = 'N' or 'V', S is not referenced. */ - -/* SEP (output) DOUBLE PRECISION */ -/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */ -/* condition number of the specified invariant subspace. If */ -/* M = 0 or N, SEP = norm(T). */ -/* If JOB = 'N' or 'E', SEP is not referenced. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. */ -/* If JOB = 'N', LWORK >= max(1,N); */ -/* if JOB = 'E', LWORK >= max(1,M*(N-M)); */ -/* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */ -/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ - -/* LIWORK (input) INTEGER */ -/* The dimension of the array IWORK. */ -/* If JOB = 'N' or 'E', LIWORK >= 1; */ -/* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). */ - -/* If LIWORK = -1, then a workspace query is assumed; the */ -/* routine only calculates the optimal size of the IWORK array, */ -/* returns this value as the first entry of the IWORK array, and */ -/* no error message related to LIWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* = 1: reordering of T failed because some eigenvalues are too */ -/* close to separate (the problem is very ill-conditioned); */ -/* T may have been partially reordered, and WR and WI */ -/* contain the eigenvalues in the same order as in T; S and */ -/* SEP (if requested) are set to zero. */ - -/* Further Details */ -/* =============== */ - -/* DTRSEN first collects the selected eigenvalues by computing an */ -/* orthogonal transformation Z to move them to the top left corner of T. */ -/* In other words, the selected eigenvalues are the eigenvalues of T11 */ -/* in: */ - -/* Z'*T*Z = ( T11 T12 ) n1 */ -/* ( 0 T22 ) n2 */ -/* n1 n2 */ - -/* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns */ -/* of Z span the specified invariant subspace of T. */ - -/* If T has been obtained from the real Schur factorization of a matrix */ -/* A = Q*T*Q', then the reordered real Schur factorization of A is given */ -/* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span */ -/* the corresponding invariant subspace of A. */ - -/* The reciprocal condition number of the average of the eigenvalues of */ -/* T11 may be returned in S. S lies between 0 (very badly conditioned) */ -/* and 1 (very well conditioned). It is computed as follows. First we */ -/* compute R so that */ - -/* P = ( I R ) n1 */ -/* ( 0 0 ) n2 */ -/* n1 n2 */ - -/* is the projector on the invariant subspace associated with T11. */ -/* R is the solution of the Sylvester equation: */ - -/* T11*R - R*T22 = T12. */ - -/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */ -/* the two-norm of M. Then S is computed as the lower bound */ - -/* (1 + F-norm(R)**2)**(-1/2) */ - -/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */ -/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */ -/* sqrt(N). */ - -/* An approximate error bound for the computed average of the */ -/* eigenvalues of T11 is */ - -/* EPS * norm(T) / S */ - -/* where EPS is the machine precision. */ - -/* The reciprocal condition number of the right invariant subspace */ -/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */ -/* SEP is defined as the separation of T11 and T22: */ - -/* sep( T11, T22 ) = sigma-min( C ) */ - -/* where sigma-min(C) is the smallest singular value of the */ -/* n1*n2-by-n1*n2 matrix */ - -/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */ - -/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */ -/* product. We estimate sigma-min(C) by the reciprocal of an estimate of */ -/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */ -/* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */ - -/* When SEP is small, small changes in T can cause large changes in */ -/* the invariant subspace. An approximate bound on the maximum angular */ -/* error in the computed right invariant subspace is */ - -/* EPS * norm(T) / SEP */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test the input parameters */ - - /* Parameter adjustments */ - --select; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - q_dim1 = *ldq; - q_offset = 1 + q_dim1; - q -= q_offset; - --wr; - --wi; - --work; - --iwork; - - /* Function Body */ - wantbh = lsame_(job, "B"); - wants = lsame_(job, "E") || wantbh; - wantsp = lsame_(job, "V") || wantbh; - wantq = lsame_(compq, "V"); - - *info = 0; - lquery = *lwork == -1; - if (! lsame_(job, "N") && ! wants && ! wantsp) { - *info = -1; - } else if (! lsame_(compq, "N") && ! wantq) { - *info = -2; - } else if (*n < 0) { - *info = -4; - } else if (*ldt < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldq < 1 || wantq && *ldq < *n) { - *info = -8; - } else { - -/* Set M to the dimension of the specified invariant subspace, */ -/* and test LWORK and LIWORK. */ - - *m = 0; - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (pair) { - pair = false; - } else { - if (k < *n) { - if (t[k + 1 + k * t_dim1] == 0.) { - if (select[k]) { - ++(*m); - } - } else { - pair = true; - if (select[k] || select[k + 1]) { - *m += 2; - } - } - } else { - if (select[*n]) { - ++(*m); - } - } - } -/* L10: */ - } - - n1 = *m; - n2 = *n - *m; - nn = n1 * n2; - - if (wantsp) { -/* Computing MAX */ - i__1 = 1, i__2 = nn << 1; - lwmin = std::max(i__1,i__2); - liwmin = std::max(1_integer,nn); - } else if (lsame_(job, "N")) { - lwmin = std::max(1_integer,*n); - liwmin = 1; - } else if (lsame_(job, "E")) { - lwmin = std::max(1_integer,nn); - liwmin = 1; - } - - if (*lwork < lwmin && ! lquery) { - *info = -15; - } else if (*liwork < liwmin && ! lquery) { - *info = -17; - } - } - - if (*info == 0) { - work[1] = (double) lwmin; - iwork[1] = liwmin; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRSEN", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible. */ - - if (*m == *n || *m == 0) { - if (wants) { - *s = 1.; - } - if (wantsp) { - *sep = dlange_("1", n, n, &t[t_offset], ldt, &work[1]); - } - goto L40; - } - -/* Collect the selected blocks at the top-left corner of T. */ - - ks = 0; - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (pair) { - pair = false; - } else { - swap = select[k]; - if (k < *n) { - if (t[k + 1 + k * t_dim1] != 0.) { - pair = true; - swap = swap || select[k + 1]; - } - } - if (swap) { - ++ks; - -/* Swap the K-th block to position KS. */ - - ierr = 0; - kk = k; - if (k != ks) { - dtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, & - kk, &ks, &work[1], &ierr); - } - if (ierr == 1 || ierr == 2) { - -/* Blocks too close to swap: exit. */ - - *info = 1; - if (wants) { - *s = 0.; - } - if (wantsp) { - *sep = 0.; - } - goto L40; - } - if (pair) { - ++ks; - } - } - } -/* L20: */ - } - - if (wants) { - -/* Solve Sylvester equation for R: */ - -/* T11*R - R*T22 = scale*T12 */ - - dlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1); - dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 - + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr); - -/* Estimate the reciprocal of the condition number of the cluster */ -/* of eigenvalues. */ - - rnorm = dlange_("F", &n1, &n2, &work[1], &n1, &work[1]); - if (rnorm == 0.) { - *s = 1.; - } else { - *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm)); - } - } - - if (wantsp) { - -/* Estimate sep(T11,T22). */ - - est = 0.; - kase = 0; -L30: - dlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave); - if (kase != 0) { - if (kase == 1) { - -/* Solve T11*R - R*T22 = scale*X. */ - - dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + - 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & - ierr); - } else { - -/* Solve T11'*R - R*T22' = scale*X. */ - - dtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + - 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & - ierr); - } - goto L30; - } - - *sep = scale / est; - } - -L40: - -/* Store the output eigenvalues in WR and WI. */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - wr[k] = t[k + k * t_dim1]; - wi[k] = 0.; -/* L50: */ - } - i__1 = *n - 1; - for (k = 1; k <= i__1; ++k) { - if (t[k + 1 + k * t_dim1] != 0.) { - wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], abs(d__1))) * sqrt(( - d__2 = t[k + 1 + k * t_dim1], abs(d__2))); - wi[k + 1] = -wi[k]; - } -/* L60: */ - } - - work[1] = (double) lwmin; - iwork[1] = liwmin; - - return 0; - -/* End of DTRSEN */ - -} /* dtrsen_ */ diff --git a/external/clapack/lapack/dtrsna.cpp b/external/clapack/lapack/dtrsna.cpp deleted file mode 100644 index 20a154b7..00000000 --- a/external/clapack/lapack/dtrsna.cpp +++ /dev/null @@ -1,574 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static bool c_true = true; -static bool c_false = false; - -/* Subroutine */ int dtrsna_(const char *job, const char *howmny, bool *select, - integer *n, double *t, integer *ldt, double *vl, integer * - ldvl, double *vr, integer *ldvr, double *s, double *sep, - integer *mm, integer *m, double *work, integer *ldwork, integer * - iwork, integer *info) -{ - /* System generated locals */ - integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, - work_dim1, work_offset, i__1, i__2; - double d__1, d__2; - - /* Local variables */ - integer i__, j, k, n2; - double cs; - integer nn, ks; - double sn, mu, eps, est; - integer kase; - double cond; - bool pair; - integer ierr; - double dumm, prod; - integer ifst; - double lnrm; - integer ilst; - double rnrm; - double prod1, prod2, scale, delta; - integer isave[3]; - bool wants; - double dummy[1]; - double bignum; - bool wantbh; - bool somcon; - double smlnum; - bool wantsp; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRSNA estimates reciprocal condition numbers for specified */ -/* eigenvalues and/or right eigenvectors of a real upper */ -/* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q */ -/* orthogonal). */ - -/* T must be in Schur canonical form (as returned by DHSEQR), that is, */ -/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ -/* 2-by-2 diagonal block has its diagonal elements equal and its */ -/* off-diagonal elements of opposite sign. */ - -/* Arguments */ -/* ========= */ - -/* JOB (input) CHARACTER*1 */ -/* Specifies whether condition numbers are required for */ -/* eigenvalues (S) or eigenvectors (SEP): */ -/* = 'E': for eigenvalues only (S); */ -/* = 'V': for eigenvectors only (SEP); */ -/* = 'B': for both eigenvalues and eigenvectors (S and SEP). */ - -/* HOWMNY (input) CHARACTER*1 */ -/* = 'A': compute condition numbers for all eigenpairs; */ -/* = 'S': compute condition numbers for selected eigenpairs */ -/* specified by the array SELECT. */ - -/* SELECT (input) LOGICAL array, dimension (N) */ -/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ -/* condition numbers are required. To select condition numbers */ -/* for the eigenpair corresponding to a real eigenvalue w(j), */ -/* SELECT(j) must be set to .TRUE.. To select condition numbers */ -/* corresponding to a complex conjugate pair of eigenvalues w(j) */ -/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */ -/* set to .TRUE.. */ -/* If HOWMNY = 'A', SELECT is not referenced. */ - -/* N (input) INTEGER */ -/* The order of the matrix T. N >= 0. */ - -/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */ -/* The upper quasi-triangular matrix T, in Schur canonical form. */ - -/* LDT (input) INTEGER */ -/* The leading dimension of the array T. LDT >= max(1,N). */ - -/* VL (input) DOUBLE PRECISION array, dimension (LDVL,M) */ -/* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */ -/* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */ -/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ -/* must be stored in consecutive columns of VL, as returned by */ -/* DHSEIN or DTREVC. */ -/* If JOB = 'V', VL is not referenced. */ - -/* LDVL (input) INTEGER */ -/* The leading dimension of the array VL. */ -/* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */ - -/* VR (input) DOUBLE PRECISION array, dimension (LDVR,M) */ -/* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */ -/* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */ -/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ -/* must be stored in consecutive columns of VR, as returned by */ -/* DHSEIN or DTREVC. */ -/* If JOB = 'V', VR is not referenced. */ - -/* LDVR (input) INTEGER */ -/* The leading dimension of the array VR. */ -/* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */ - -/* S (output) DOUBLE PRECISION array, dimension (MM) */ -/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */ -/* selected eigenvalues, stored in consecutive elements of the */ -/* array. For a complex conjugate pair of eigenvalues two */ -/* consecutive elements of S are set to the same value. Thus */ -/* S(j), SEP(j), and the j-th columns of VL and VR all */ -/* correspond to the same eigenpair (but not in general the */ -/* j-th eigenpair, unless all eigenpairs are selected). */ -/* If JOB = 'V', S is not referenced. */ - -/* SEP (output) DOUBLE PRECISION array, dimension (MM) */ -/* If JOB = 'V' or 'B', the estimated reciprocal condition */ -/* numbers of the selected eigenvectors, stored in consecutive */ -/* elements of the array. For a complex eigenvector two */ -/* consecutive elements of SEP are set to the same value. If */ -/* the eigenvalues cannot be reordered to compute SEP(j), SEP(j) */ -/* is set to 0; this can only occur when the true value would be */ -/* very small anyway. */ -/* If JOB = 'E', SEP is not referenced. */ - -/* MM (input) INTEGER */ -/* The number of elements in the arrays S (if JOB = 'E' or 'B') */ -/* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */ - -/* M (output) INTEGER */ -/* The number of elements of the arrays S and/or SEP actually */ -/* used to store the estimated condition numbers. */ -/* If HOWMNY = 'A', M is set to N. */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6) */ -/* If JOB = 'E', WORK is not referenced. */ - -/* LDWORK (input) INTEGER */ -/* The leading dimension of the array WORK. */ -/* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */ - -/* IWORK (workspace) INTEGER array, dimension (2*(N-1)) */ -/* If JOB = 'E', IWORK is not referenced. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Further Details */ -/* =============== */ - -/* The reciprocal of the condition number of an eigenvalue lambda is */ -/* defined as */ - -/* S(lambda) = |v'*u| / (norm(u)*norm(v)) */ - -/* where u and v are the right and left eigenvectors of T corresponding */ -/* to lambda; v' denotes the conjugate-transpose of v, and norm(u) */ -/* denotes the Euclidean norm. These reciprocal condition numbers always */ -/* lie between zero (very badly conditioned) and one (very well */ -/* conditioned). If n = 1, S(lambda) is defined to be 1. */ - -/* An approximate error bound for a computed eigenvalue W(i) is given by */ - -/* EPS * norm(T) / S(i) */ - -/* where EPS is the machine precision. */ - -/* The reciprocal of the condition number of the right eigenvector u */ -/* corresponding to lambda is defined as follows. Suppose */ - -/* T = ( lambda c ) */ -/* ( 0 T22 ) */ - -/* Then the reciprocal condition number is */ - -/* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */ - -/* where sigma-min denotes the smallest singular value. We approximate */ -/* the smallest singular value by the reciprocal of an estimate of the */ -/* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */ -/* defined to be abs(T(1,1)). */ - -/* An approximate error bound for a computed right eigenvector VR(i) */ -/* is given by */ - -/* EPS * norm(T) / SEP(i) */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and test the input parameters */ - - /* Parameter adjustments */ - --select; - t_dim1 = *ldt; - t_offset = 1 + t_dim1; - t -= t_offset; - vl_dim1 = *ldvl; - vl_offset = 1 + vl_dim1; - vl -= vl_offset; - vr_dim1 = *ldvr; - vr_offset = 1 + vr_dim1; - vr -= vr_offset; - --s; - --sep; - work_dim1 = *ldwork; - work_offset = 1 + work_dim1; - work -= work_offset; - --iwork; - - /* Function Body */ - wantbh = lsame_(job, "B"); - wants = lsame_(job, "E") || wantbh; - wantsp = lsame_(job, "V") || wantbh; - - somcon = lsame_(howmny, "S"); - - *info = 0; - if (! wants && ! wantsp) { - *info = -1; - } else if (! lsame_(howmny, "A") && ! somcon) { - *info = -2; - } else if (*n < 0) { - *info = -4; - } else if (*ldt < std::max(1_integer,*n)) { - *info = -6; - } else if (*ldvl < 1 || wants && *ldvl < *n) { - *info = -8; - } else if (*ldvr < 1 || wants && *ldvr < *n) { - *info = -10; - } else { - -/* Set M to the number of eigenpairs for which condition numbers */ -/* are required, and test MM. */ - - if (somcon) { - *m = 0; - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (pair) { - pair = false; - } else { - if (k < *n) { - if (t[k + 1 + k * t_dim1] == 0.) { - if (select[k]) { - ++(*m); - } - } else { - pair = true; - if (select[k] || select[k + 1]) { - *m += 2; - } - } - } else { - if (select[*n]) { - ++(*m); - } - } - } -/* L10: */ - } - } else { - *m = *n; - } - - if (*mm < *m) { - *info = -13; - } else if (*ldwork < 1 || wantsp && *ldwork < *n) { - *info = -16; - } - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRSNA", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (*n == 1) { - if (somcon) { - if (! select[1]) { - return 0; - } - } - if (wants) { - s[1] = 1.; - } - if (wantsp) { - sep[1] = (d__1 = t[t_dim1 + 1], abs(d__1)); - } - return 0; - } - -/* Get machine constants */ - - eps = dlamch_("P"); - smlnum = dlamch_("S") / eps; - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - - ks = 0; - pair = false; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - -/* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */ - - if (pair) { - pair = false; - goto L60; - } else { - if (k < *n) { - pair = t[k + 1 + k * t_dim1] != 0.; - } - } - -/* Determine whether condition numbers are required for the k-th */ -/* eigenpair. */ - - if (somcon) { - if (pair) { - if (! select[k] && ! select[k + 1]) { - goto L60; - } - } else { - if (! select[k]) { - goto L60; - } - } - } - - ++ks; - - if (wants) { - -/* Compute the reciprocal condition number of the k-th */ -/* eigenvalue. */ - - if (! pair) { - -/* Real eigenvalue. */ - - prod = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * - vl_dim1 + 1], &c__1); - rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); - lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); - s[ks] = abs(prod) / (rnrm * lnrm); - } else { - -/* Complex eigenvalue. */ - - prod1 = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * - vl_dim1 + 1], &c__1); - prod1 += ddot_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1, &vl[(ks - + 1) * vl_dim1 + 1], &c__1); - prod2 = ddot_(n, &vl[ks * vl_dim1 + 1], &c__1, &vr[(ks + 1) * - vr_dim1 + 1], &c__1); - prod2 -= ddot_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1, &vr[ks * - vr_dim1 + 1], &c__1); - d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); - d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); - rnrm = dlapy2_(&d__1, &d__2); - d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); - d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); - lnrm = dlapy2_(&d__1, &d__2); - cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm); - s[ks] = cond; - s[ks + 1] = cond; - } - } - - if (wantsp) { - -/* Estimate the reciprocal condition number of the k-th */ -/* eigenvector. */ - -/* Copy the matrix T to the array WORK and swap the diagonal */ -/* block beginning at T(k,k) to the (1,1) position. */ - - dlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], - ldwork); - ifst = k; - ilst = 1; - dtrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, & - ifst, &ilst, &work[(*n + 1) * work_dim1 + 1], &ierr); - - if (ierr == 1 || ierr == 2) { - -/* Could not swap because blocks not well separated */ - - scale = 1.; - est = bignum; - } else { - -/* Reordering successful */ - - if (work[work_dim1 + 2] == 0.) { - -/* Form C = T22 - lambda*I in WORK(2:N,2:N). */ - - i__2 = *n; - for (i__ = 2; i__ <= i__2; ++i__) { - work[i__ + i__ * work_dim1] -= work[work_dim1 + 1]; -/* L20: */ - } - n2 = 1; - nn = *n - 1; - } else { - -/* Triangularize the 2 by 2 block by unitary */ -/* transformation U = [ cs i*ss ] */ -/* [ i*ss cs ]. */ -/* such that the (1,1) position of WORK is complex */ -/* eigenvalue lambda with positive imaginary part. (2,2) */ -/* position of WORK is the complex eigenvalue lambda */ -/* with negative imaginary part. */ - - mu = sqrt((d__1 = work[(work_dim1 << 1) + 1], abs(d__1))) - * sqrt((d__2 = work[work_dim1 + 2], abs(d__2))); - delta = dlapy2_(&mu, &work[work_dim1 + 2]); - cs = mu / delta; - sn = -work[work_dim1 + 2] / delta; - -/* Form */ - -/* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] */ -/* [ mu ] */ -/* [ .. ] */ -/* [ .. ] */ -/* [ mu ] */ -/* where C' is conjugate transpose of complex matrix C, */ -/* and RWORK is stored starting in the N+1-st column of */ -/* WORK. */ - - i__2 = *n; - for (j = 3; j <= i__2; ++j) { - work[j * work_dim1 + 2] = cs * work[j * work_dim1 + 2] - ; - work[j + j * work_dim1] -= work[work_dim1 + 1]; -/* L30: */ - } - work[(work_dim1 << 1) + 2] = 0.; - - work[(*n + 1) * work_dim1 + 1] = mu * 2.; - i__2 = *n - 1; - for (i__ = 2; i__ <= i__2; ++i__) { - work[i__ + (*n + 1) * work_dim1] = sn * work[(i__ + 1) - * work_dim1 + 1]; -/* L40: */ - } - n2 = 2; - nn = *n - 1 << 1; - } - -/* Estimate norm(inv(C')) */ - - est = 0.; - kase = 0; -L50: - dlacn2_(&nn, &work[(*n + 2) * work_dim1 + 1], &work[(*n + 4) * - work_dim1 + 1], &iwork[1], &est, &kase, isave); - if (kase != 0) { - if (kase == 1) { - if (n2 == 1) { - -/* Real eigenvalue: solve C'*x = scale*c. */ - - i__2 = *n - 1; - dlaqtr_(&c_true, &c_true, &i__2, &work[(work_dim1 - << 1) + 2], ldwork, dummy, &dumm, &scale, - &work[(*n + 4) * work_dim1 + 1], &work[(* - n + 6) * work_dim1 + 1], &ierr); - } else { - -/* Complex eigenvalue: solve */ -/* C'*(p+iq) = scale*(c+id) in real arithmetic. */ - - i__2 = *n - 1; - dlaqtr_(&c_true, &c_false, &i__2, &work[( - work_dim1 << 1) + 2], ldwork, &work[(*n + - 1) * work_dim1 + 1], &mu, &scale, &work[(* - n + 4) * work_dim1 + 1], &work[(*n + 6) * - work_dim1 + 1], &ierr); - } - } else { - if (n2 == 1) { - -/* Real eigenvalue: solve C*x = scale*c. */ - - i__2 = *n - 1; - dlaqtr_(&c_false, &c_true, &i__2, &work[( - work_dim1 << 1) + 2], ldwork, dummy, & - dumm, &scale, &work[(*n + 4) * work_dim1 - + 1], &work[(*n + 6) * work_dim1 + 1], & - ierr); - } else { - -/* Complex eigenvalue: solve */ -/* C*(p+iq) = scale*(c+id) in real arithmetic. */ - - i__2 = *n - 1; - dlaqtr_(&c_false, &c_false, &i__2, &work[( - work_dim1 << 1) + 2], ldwork, &work[(*n + - 1) * work_dim1 + 1], &mu, &scale, &work[(* - n + 4) * work_dim1 + 1], &work[(*n + 6) * - work_dim1 + 1], &ierr); - - } - } - - goto L50; - } - } - - sep[ks] = scale / std::max(est,smlnum); - if (pair) { - sep[ks + 1] = sep[ks]; - } - } - - if (pair) { - ++ks; - } - -L60: - ; - } - return 0; - -/* End of DTRSNA */ - -} /* dtrsna_ */ diff --git a/external/clapack/lapack/dtrsyl.cpp b/external/clapack/lapack/dtrsyl.cpp deleted file mode 100644 index 1639d3f3..00000000 --- a/external/clapack/lapack/dtrsyl.cpp +++ /dev/null @@ -1,1290 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static bool c_false = false; -static integer c__2 = 2; -static double c_b26 = 1.; -static double c_b30 = 0.; -static bool c_true = true; - -/* Subroutine */ int dtrsyl_(const char *trana, const char *tranb, integer *isgn, integer - *m, integer *n, double *a, integer *lda, double *b, integer * - ldb, double *c__, integer *ldc, double *scale, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4; - double d__1, d__2; - - /* Local variables */ - integer j, k, l; - double x[4] /* was [2][2] */; - integer k1, k2, l1, l2; - double a11, db, da11, vec[4] /* was [2][2] */, dum[1], eps, sgn; - integer ierr; - double smin, suml, sumr; - integer knext, lnext; - double xnorm; - double scaloc; - double bignum; - bool notrna, notrnb; - double smlnum; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRSYL solves the real Sylvester matrix equation: */ - -/* op(A)*X + X*op(B) = scale*C or */ -/* op(A)*X - X*op(B) = scale*C, */ - -/* where op(A) = A or A**T, and A and B are both upper quasi- */ -/* triangular. A is M-by-M and B is N-by-N; the right hand side C and */ -/* the solution X are M-by-N; and scale is an output scale factor, set */ -/* <= 1 to avoid overflow in X. */ - -/* A and B must be in Schur canonical form (as returned by DHSEQR), that */ -/* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; */ -/* each 2-by-2 diagonal block has its diagonal elements equal and its */ -/* off-diagonal elements of opposite sign. */ - -/* Arguments */ -/* ========= */ - -/* TRANA (input) CHARACTER*1 */ -/* Specifies the option op(A): */ -/* = 'N': op(A) = A (No transpose) */ -/* = 'T': op(A) = A**T (Transpose) */ -/* = 'C': op(A) = A**H (Conjugate transpose = Transpose) */ - -/* TRANB (input) CHARACTER*1 */ -/* Specifies the option op(B): */ -/* = 'N': op(B) = B (No transpose) */ -/* = 'T': op(B) = B**T (Transpose) */ -/* = 'C': op(B) = B**H (Conjugate transpose = Transpose) */ - -/* ISGN (input) INTEGER */ -/* Specifies the sign in the equation: */ -/* = +1: solve op(A)*X + X*op(B) = scale*C */ -/* = -1: solve op(A)*X - X*op(B) = scale*C */ - -/* M (input) INTEGER */ -/* The order of the matrix A, and the number of rows in the */ -/* matrices X and C. M >= 0. */ - -/* N (input) INTEGER */ -/* The order of the matrix B, and the number of columns in the */ -/* matrices X and C. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,M) */ -/* The upper quasi-triangular matrix A, in Schur canonical form. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */ -/* The upper quasi-triangular matrix B, in Schur canonical form. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ -/* On entry, the M-by-N right hand side matrix C. */ -/* On exit, C is overwritten by the solution matrix X. */ - -/* LDC (input) INTEGER */ -/* The leading dimension of the array C. LDC >= max(1,M) */ - -/* SCALE (output) DOUBLE PRECISION */ -/* The scale factor, scale, set <= 1 to avoid overflow in X. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* = 1: A and B have common or very close eigenvalues; perturbed */ -/* values were used to solve the equation (but the matrices */ -/* A and B are unchanged). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Local Arrays .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Decode and Test input parameters */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1; - c__ -= c_offset; - - /* Function Body */ - notrna = lsame_(trana, "N"); - notrnb = lsame_(tranb, "N"); - - *info = 0; - if (! notrna && ! lsame_(trana, "T") && ! lsame_( - trana, "C")) { - *info = -1; - } else if (! notrnb && ! lsame_(tranb, "T") && ! - lsame_(tranb, "C")) { - *info = -2; - } else if (*isgn != 1 && *isgn != -1) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*m)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } else if (*ldc < std::max(1_integer,*m)) { - *info = -11; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRSYL", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Set constants to control overflow */ - - eps = dlamch_("P"); - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - smlnum = smlnum * (double) (*m * *n) / eps; - bignum = 1. / smlnum; - -/* Computing MAX */ - d__1 = smlnum, d__2 = eps * dlange_("M", m, m, &a[a_offset], lda, dum), d__1 = std::max(d__1,d__2), d__2 = eps * dlange_("M", n, n, - &b[b_offset], ldb, dum); - smin = std::max(d__1,d__2); - - *scale = 1.; - sgn = (double) (*isgn); - - if (notrna && notrnb) { - -/* Solve A*X + ISGN*X*B = scale*C. */ - -/* The (K,L)th block of X is determined starting from */ -/* bottom-left corner column by column by */ - -/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ - -/* Where */ -/* M L-1 */ -/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. */ -/* I=K+1 J=1 */ - -/* Start column loop (index = L) */ -/* L1 (L2) : column index of the first (first) row of X(K,L). */ - - lnext = 1; - i__1 = *n; - for (l = 1; l <= i__1; ++l) { - if (l < lnext) { - goto L60; - } - if (l == *n) { - l1 = l; - l2 = l; - } else { - if (b[l + 1 + l * b_dim1] != 0.) { - l1 = l; - l2 = l + 1; - lnext = l + 2; - } else { - l1 = l; - l2 = l; - lnext = l + 1; - } - } - -/* Start row loop (index = K) */ -/* K1 (K2): row index of the first (last) row of X(K,L). */ - - knext = *m; - for (k = *m; k >= 1; --k) { - if (k > knext) { - goto L50; - } - if (k == 1) { - k1 = k; - k2 = k; - } else { - if (a[k + (k - 1) * a_dim1] != 0.) { - k1 = k - 1; - k2 = k; - knext = k - 2; - } else { - k1 = k; - k2 = k; - knext = k - 1; - } - } - - if (l1 == l2 && k1 == k2) { - i__2 = *m - k1; -/* Computing MIN */ - i__3 = k1 + 1; -/* Computing MIN */ - i__4 = k1 + 1; - suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - scaloc = 1.; - - a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; - da11 = abs(a11); - if (da11 <= smin) { - a11 = smin; - da11 = smin; - *info = 1; - } - db = abs(vec[0]); - if (da11 < 1. && db > 1.) { - if (db > bignum * da11) { - scaloc = 1. / db; - } - } - x[0] = vec[0] * scaloc / a11; - - if (scaloc != 1.) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L10: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - - } else if (l1 == l2 && k1 != k2) { - - i__2 = *m - k2; -/* Computing MIN */ - i__3 = k2 + 1; -/* Computing MIN */ - i__4 = k2 + 1; - suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - - i__2 = *m - k2; -/* Computing MIN */ - i__3 = k2 + 1; -/* Computing MIN */ - i__4 = k2 + 1; - suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); - - d__1 = -sgn * b[l1 + l1 * b_dim1]; - dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 - * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, - &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L20: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k2 + l1 * c_dim1] = x[1]; - - } else if (l1 != l2 && k1 == k2) { - - i__2 = *m - k1; -/* Computing MIN */ - i__3 = k1 + 1; -/* Computing MIN */ - i__4 = k1 + 1; - suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * - sumr)); - - i__2 = *m - k1; -/* Computing MIN */ - i__3 = k1 + 1; -/* Computing MIN */ - i__4 = k1 + 1; - suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * - b_dim1 + 1], &c__1); - vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * - sumr)); - - d__1 = -sgn * a[k1 + k1 * a_dim1]; - dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * - b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, - &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L30: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k1 + l2 * c_dim1] = x[1]; - - } else if (l1 != l2 && k1 != k2) { - - i__2 = *m - k2; -/* Computing MIN */ - i__3 = k2 + 1; -/* Computing MIN */ - i__4 = k2 + 1; - suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - - i__2 = *m - k2; -/* Computing MIN */ - i__3 = k2 + 1; -/* Computing MIN */ - i__4 = k2 + 1; - suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * - b_dim1 + 1], &c__1); - vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); - - i__2 = *m - k2; -/* Computing MIN */ - i__3 = k2 + 1; -/* Computing MIN */ - i__4 = k2 + 1; - suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); - - i__2 = *m - k2; -/* Computing MIN */ - i__3 = k2 + 1; -/* Computing MIN */ - i__4 = k2 + 1; - suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, & - c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1); - i__2 = l1 - 1; - sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 * - b_dim1 + 1], &c__1); - vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); - - dlasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 + - k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, - &c__2, &scaloc, x, &c__2, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L40: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k1 + l2 * c_dim1] = x[2]; - c__[k2 + l1 * c_dim1] = x[1]; - c__[k2 + l2 * c_dim1] = x[3]; - } - -L50: - ; - } - -L60: - ; - } - - } else if (! notrna && notrnb) { - -/* Solve A' *X + ISGN*X*B = scale*C. */ - -/* The (K,L)th block of X is determined starting from */ -/* upper-left corner column by column by */ - -/* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ - -/* Where */ -/* K-1 L-1 */ -/* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] */ -/* I=1 J=1 */ - -/* Start column loop (index = L) */ -/* L1 (L2): column index of the first (last) row of X(K,L) */ - - lnext = 1; - i__1 = *n; - for (l = 1; l <= i__1; ++l) { - if (l < lnext) { - goto L120; - } - if (l == *n) { - l1 = l; - l2 = l; - } else { - if (b[l + 1 + l * b_dim1] != 0.) { - l1 = l; - l2 = l + 1; - lnext = l + 2; - } else { - l1 = l; - l2 = l; - lnext = l + 1; - } - } - -/* Start row loop (index = K) */ -/* K1 (K2): row index of the first (last) row of X(K,L) */ - - knext = 1; - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (k < knext) { - goto L110; - } - if (k == *m) { - k1 = k; - k2 = k; - } else { - if (a[k + 1 + k * a_dim1] != 0.) { - k1 = k; - k2 = k + 1; - knext = k + 2; - } else { - k1 = k; - k2 = k; - knext = k + 1; - } - } - - if (l1 == l2 && k1 == k2) { - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - scaloc = 1.; - - a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; - da11 = abs(a11); - if (da11 <= smin) { - a11 = smin; - da11 = smin; - *info = 1; - } - db = abs(vec[0]); - if (da11 < 1. && db > 1.) { - if (db > bignum * da11) { - scaloc = 1. / db; - } - } - x[0] = vec[0] * scaloc / a11; - - if (scaloc != 1.) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L70: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - - } else if (l1 == l2 && k1 != k2) { - - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); - - d__1 = -sgn * b[l1 + l1 * b_dim1]; - dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * - a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, - &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L80: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k2 + l1 * c_dim1] = x[1]; - - } else if (l1 != l2 && k1 == k2) { - - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * - sumr)); - - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * - b_dim1 + 1], &c__1); - vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * - sumr)); - - d__1 = -sgn * a[k1 + k1 * a_dim1]; - dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * - b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, - &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L90: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k1 + l2 * c_dim1] = x[1]; - - } else if (l1 != l2 && k1 != k2) { - - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * - b_dim1 + 1], &c__1); - vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); - - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * - b_dim1 + 1], &c__1); - vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); - - i__3 = k1 - 1; - suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * - c_dim1 + 1], &c__1); - i__3 = l1 - 1; - sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 * - b_dim1 + 1], &c__1); - vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); - - dlasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1 - * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & - c__2, &scaloc, x, &c__2, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L100: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k1 + l2 * c_dim1] = x[2]; - c__[k2 + l1 * c_dim1] = x[1]; - c__[k2 + l2 * c_dim1] = x[3]; - } - -L110: - ; - } -L120: - ; - } - - } else if (! notrna && ! notrnb) { - -/* Solve A'*X + ISGN*X*B' = scale*C. */ - -/* The (K,L)th block of X is determined starting from */ -/* top-right corner column by column by */ - -/* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */ - -/* Where */ -/* K-1 N */ -/* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */ -/* I=1 J=L+1 */ - -/* Start column loop (index = L) */ -/* L1 (L2): column index of the first (last) row of X(K,L) */ - - lnext = *n; - for (l = *n; l >= 1; --l) { - if (l > lnext) { - goto L180; - } - if (l == 1) { - l1 = l; - l2 = l; - } else { - if (b[l + (l - 1) * b_dim1] != 0.) { - l1 = l - 1; - l2 = l; - lnext = l - 2; - } else { - l1 = l; - l2 = l; - lnext = l - 1; - } - } - -/* Start row loop (index = K) */ -/* K1 (K2): row index of the first (last) row of X(K,L) */ - - knext = 1; - i__1 = *m; - for (k = 1; k <= i__1; ++k) { - if (k < knext) { - goto L170; - } - if (k == *m) { - k1 = k; - k2 = k; - } else { - if (a[k + 1 + k * a_dim1] != 0.) { - k1 = k; - k2 = k + 1; - knext = k + 2; - } else { - k1 = k; - k2 = k; - knext = k + 1; - } - } - - if (l1 == l2 && k1 == k2) { - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__2 = *n - l1; -/* Computing MIN */ - i__3 = l1 + 1; -/* Computing MIN */ - i__4 = l1 + 1; - sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, - &b[l1 + std::min(i__4, *n)* b_dim1], ldb); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - scaloc = 1.; - - a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; - da11 = abs(a11); - if (da11 <= smin) { - a11 = smin; - da11 = smin; - *info = 1; - } - db = abs(vec[0]); - if (da11 < 1. && db > 1.) { - if (db > bignum * da11) { - scaloc = 1. / db; - } - } - x[0] = vec[0] * scaloc / a11; - - if (scaloc != 1.) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L130: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - - } else if (l1 == l2 && k1 != k2) { - - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__2 = *n - l2; -/* Computing MIN */ - i__3 = l2 + 1; -/* Computing MIN */ - i__4 = l2 + 1; - sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, - &b[l1 + std::min(i__4, *n)* b_dim1], ldb); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__2 = *n - l2; -/* Computing MIN */ - i__3 = l2 + 1; -/* Computing MIN */ - i__4 = l2 + 1; - sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc, - &b[l1 + std::min(i__4, *n)* b_dim1], ldb); - vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); - - d__1 = -sgn * b[l1 + l1 * b_dim1]; - dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * - a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, - &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L140: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k2 + l1 * c_dim1] = x[1]; - - } else if (l1 != l2 && k1 == k2) { - - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__2 = *n - l2; -/* Computing MIN */ - i__3 = l2 + 1; -/* Computing MIN */ - i__4 = l2 + 1; - sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, - &b[l1 + std::min(i__4, *n)* b_dim1], ldb); - vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * - sumr)); - - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * - c_dim1 + 1], &c__1); - i__2 = *n - l2; -/* Computing MIN */ - i__3 = l2 + 1; -/* Computing MIN */ - i__4 = l2 + 1; - sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, - &b[l2 + std::min(i__4, *n)* b_dim1], ldb); - vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * - sumr)); - - d__1 = -sgn * a[k1 + k1 * a_dim1]; - dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 - * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, - &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L150: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k1 + l2 * c_dim1] = x[1]; - - } else if (l1 != l2 && k1 != k2) { - - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__2 = *n - l2; -/* Computing MIN */ - i__3 = l2 + 1; -/* Computing MIN */ - i__4 = l2 + 1; - sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, - &b[l1 + std::min(i__4, *n)* b_dim1], ldb); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * - c_dim1 + 1], &c__1); - i__2 = *n - l2; -/* Computing MIN */ - i__3 = l2 + 1; -/* Computing MIN */ - i__4 = l2 + 1; - sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, - &b[l2 + std::min(i__4, *n)* b_dim1], ldb); - vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); - - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * - c_dim1 + 1], &c__1); - i__2 = *n - l2; -/* Computing MIN */ - i__3 = l2 + 1; -/* Computing MIN */ - i__4 = l2 + 1; - sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc, - &b[l1 + std::min(i__4, *n)* b_dim1], ldb); - vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); - - i__2 = k1 - 1; - suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * - c_dim1 + 1], &c__1); - i__2 = *n - l2; -/* Computing MIN */ - i__3 = l2 + 1; -/* Computing MIN */ - i__4 = l2 + 1; - sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc, - &b[l2 + std::min(i__4, *n)* b_dim1], ldb); - vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); - - dlasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 * - a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & - c__2, &scaloc, x, &c__2, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__2 = *n; - for (j = 1; j <= i__2; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L160: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k1 + l2 * c_dim1] = x[2]; - c__[k2 + l1 * c_dim1] = x[1]; - c__[k2 + l2 * c_dim1] = x[3]; - } - -L170: - ; - } -L180: - ; - } - - } else if (notrna && ! notrnb) { - -/* Solve A*X + ISGN*X*B' = scale*C. */ - -/* The (K,L)th block of X is determined starting from */ -/* bottom-right corner column by column by */ - -/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */ - -/* Where */ -/* M N */ -/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */ -/* I=K+1 J=L+1 */ - -/* Start column loop (index = L) */ -/* L1 (L2): column index of the first (last) row of X(K,L) */ - - lnext = *n; - for (l = *n; l >= 1; --l) { - if (l > lnext) { - goto L240; - } - if (l == 1) { - l1 = l; - l2 = l; - } else { - if (b[l + (l - 1) * b_dim1] != 0.) { - l1 = l - 1; - l2 = l; - lnext = l - 2; - } else { - l1 = l; - l2 = l; - lnext = l - 1; - } - } - -/* Start row loop (index = K) */ -/* K1 (K2): row index of the first (last) row of X(K,L) */ - - knext = *m; - for (k = *m; k >= 1; --k) { - if (k > knext) { - goto L230; - } - if (k == 1) { - k1 = k; - k2 = k; - } else { - if (a[k + (k - 1) * a_dim1] != 0.) { - k1 = k - 1; - k2 = k; - knext = k - 2; - } else { - k1 = k; - k2 = k; - knext = k - 1; - } - } - - if (l1 == l2 && k1 == k2) { - i__1 = *m - k1; -/* Computing MIN */ - i__2 = k1 + 1; -/* Computing MIN */ - i__3 = k1 + 1; - suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); - i__1 = *n - l1; -/* Computing MIN */ - i__2 = l1 + 1; -/* Computing MIN */ - i__3 = l1 + 1; - sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, - &b[l1 + std::min(i__3, *n)* b_dim1], ldb); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - scaloc = 1.; - - a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; - da11 = abs(a11); - if (da11 <= smin) { - a11 = smin; - da11 = smin; - *info = 1; - } - db = abs(vec[0]); - if (da11 < 1. && db > 1.) { - if (db > bignum * da11) { - scaloc = 1. / db; - } - } - x[0] = vec[0] * scaloc / a11; - - if (scaloc != 1.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L190: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - - } else if (l1 == l2 && k1 != k2) { - - i__1 = *m - k2; -/* Computing MIN */ - i__2 = k2 + 1; -/* Computing MIN */ - i__3 = k2 + 1; - suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); - i__1 = *n - l2; -/* Computing MIN */ - i__2 = l2 + 1; -/* Computing MIN */ - i__3 = l2 + 1; - sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, - &b[l1 + std::min(i__3, *n)* b_dim1], ldb); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - - i__1 = *m - k2; -/* Computing MIN */ - i__2 = k2 + 1; -/* Computing MIN */ - i__3 = k2 + 1; - suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); - i__1 = *n - l2; -/* Computing MIN */ - i__2 = l2 + 1; -/* Computing MIN */ - i__3 = l2 + 1; - sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc, - &b[l1 + std::min(i__3, *n)* b_dim1], ldb); - vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); - - d__1 = -sgn * b[l1 + l1 * b_dim1]; - dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 - * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, - &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L200: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k2 + l1 * c_dim1] = x[1]; - - } else if (l1 != l2 && k1 == k2) { - - i__1 = *m - k1; -/* Computing MIN */ - i__2 = k1 + 1; -/* Computing MIN */ - i__3 = k1 + 1; - suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); - i__1 = *n - l2; -/* Computing MIN */ - i__2 = l2 + 1; -/* Computing MIN */ - i__3 = l2 + 1; - sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, - &b[l1 + std::min(i__3, *n)* b_dim1], ldb); - vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * - sumr)); - - i__1 = *m - k1; -/* Computing MIN */ - i__2 = k1 + 1; -/* Computing MIN */ - i__3 = k1 + 1; - suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1); - i__1 = *n - l2; -/* Computing MIN */ - i__2 = l2 + 1; -/* Computing MIN */ - i__3 = l2 + 1; - sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, - &b[l2 + std::min(i__3, *n)* b_dim1], ldb); - vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * - sumr)); - - d__1 = -sgn * a[k1 + k1 * a_dim1]; - dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 - * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, - &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L210: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k1 + l2 * c_dim1] = x[1]; - - } else if (l1 != l2 && k1 != k2) { - - i__1 = *m - k2; -/* Computing MIN */ - i__2 = k2 + 1; -/* Computing MIN */ - i__3 = k2 + 1; - suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); - i__1 = *n - l2; -/* Computing MIN */ - i__2 = l2 + 1; -/* Computing MIN */ - i__3 = l2 + 1; - sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, - &b[l1 + std::min(i__3, *n)* b_dim1], ldb); - vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); - - i__1 = *m - k2; -/* Computing MIN */ - i__2 = k2 + 1; -/* Computing MIN */ - i__3 = k2 + 1; - suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1); - i__1 = *n - l2; -/* Computing MIN */ - i__2 = l2 + 1; -/* Computing MIN */ - i__3 = l2 + 1; - sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, - &b[l2 + std::min(i__3, *n)* b_dim1], ldb); - vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); - - i__1 = *m - k2; -/* Computing MIN */ - i__2 = k2 + 1; -/* Computing MIN */ - i__3 = k2 + 1; - suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); - i__1 = *n - l2; -/* Computing MIN */ - i__2 = l2 + 1; -/* Computing MIN */ - i__3 = l2 + 1; - sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc, - &b[l1 + std::min(i__3, *n)* b_dim1], ldb); - vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); - - i__1 = *m - k2; -/* Computing MIN */ - i__2 = k2 + 1; -/* Computing MIN */ - i__3 = k2 + 1; - suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, & - c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1); - i__1 = *n - l2; -/* Computing MIN */ - i__2 = l2 + 1; -/* Computing MIN */ - i__3 = l2 + 1; - sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc, - &b[l2 + std::min(i__3, *n)* b_dim1], ldb); - vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); - - dlasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 - * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & - c__2, &scaloc, x, &c__2, &xnorm, &ierr); - if (ierr != 0) { - *info = 1; - } - - if (scaloc != 1.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); -/* L220: */ - } - *scale *= scaloc; - } - c__[k1 + l1 * c_dim1] = x[0]; - c__[k1 + l2 * c_dim1] = x[2]; - c__[k2 + l1 * c_dim1] = x[1]; - c__[k2 + l2 * c_dim1] = x[3]; - } - -L230: - ; - } -L240: - ; - } - - } - - return 0; - -/* End of DTRSYL */ - -} /* dtrsyl_ */ diff --git a/external/clapack/lapack/dtrti2.cpp b/external/clapack/lapack/dtrti2.cpp deleted file mode 100644 index ab8f5956..00000000 --- a/external/clapack/lapack/dtrti2.cpp +++ /dev/null @@ -1,165 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dtrti2_(const char *uplo, const char *diag, integer *n, double * - a, integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer j; - double ajj; - bool upper; - bool nounit; - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTI2 computes the inverse of a real upper or lower triangular */ -/* matrix. */ - -/* This is the Level 2 BLAS version of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular matrix A. If UPLO = 'U', the */ -/* leading n by n upper triangular part of the array A contains */ -/* the upper triangular matrix, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of the array A contains */ -/* the lower triangular matrix, and the strictly upper */ -/* triangular part of A is not referenced. If DIAG = 'U', the */ -/* diagonal elements of A are also not referenced and are */ -/* assumed to be 1. */ - -/* On exit, the (triangular) inverse of the original matrix, in */ -/* the same storage format. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTI2", &i__1); - return 0; - } - - if (upper) { - -/* Compute inverse of upper triangular matrix. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (nounit) { - a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; - ajj = -a[j + j * a_dim1]; - } else { - ajj = -1.; - } - -/* Compute elements 1:j-1 of j-th column. */ - - i__2 = j - 1; - dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, & - a[j * a_dim1 + 1], &c__1); - i__2 = j - 1; - dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); -/* L10: */ - } - } else { - -/* Compute inverse of lower triangular matrix. */ - - for (j = *n; j >= 1; --j) { - if (nounit) { - a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; - ajj = -a[j + j * a_dim1]; - } else { - ajj = -1.; - } - if (j < *n) { - -/* Compute elements j+1:n of j-th column. */ - - i__1 = *n - j; - dtrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j + - 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1); - i__1 = *n - j; - dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); - } -/* L20: */ - } - } - - return 0; - -/* End of DTRTI2 */ - -} /* dtrti2_ */ diff --git a/external/clapack/lapack/dtrtri.cpp b/external/clapack/lapack/dtrtri.cpp deleted file mode 100644 index 6fa85f1d..00000000 --- a/external/clapack/lapack/dtrtri.cpp +++ /dev/null @@ -1,216 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__2 = 2; -static double c_b18 = 1.; -static double c_b22 = -1.; - -/* Subroutine */ int dtrtri_(const char *uplo, const char *diag, integer *n, double * - a, integer *lda, integer *info) -{ - /* System generated locals */ - char * a__1[2]; - integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5; - char ch__1[3] = { 0 }; - - /* Local variables */ - integer j, jb, nb, nn; - bool upper; - bool nounit; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTRI computes the inverse of a real upper or lower triangular */ -/* matrix A. */ - -/* This is the Level 3 BLAS version of the algorithm. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the triangular matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of the array A contains */ -/* the upper triangular matrix, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of the array A contains */ -/* the lower triangular matrix, and the strictly upper */ -/* triangular part of A is not referenced. If DIAG = 'U', the */ -/* diagonal elements of A are also not referenced and are */ -/* assumed to be 1. */ -/* On exit, the (triangular) inverse of the original matrix, in */ -/* the same storage format. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ -/* matrix is singular and its inverse can not be computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity if non-unit. */ - - if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L10: */ - } - *info = 0; - } - -/* Determine the block size for this environment. */ - -/* Writing concatenation */ - i__2[0] = 1, a__1[0] = const_cast (uplo); - i__2[1] = 1, a__1[1] = const_cast (diag); - s_cat(ch__1, a__1, i__2, &c__2, 2_integer); - nb = ilaenv_(&c__1, "DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - dtrti2_(uplo, diag, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute inverse of upper triangular matrix */ - - i__1 = *n; - i__3 = nb; - for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { -/* Computing MIN */ - i__4 = nb, i__5 = *n - j + 1; - jb = std::min(i__4,i__5); - -/* Compute rows 1:j-1 of current block column */ - - i__4 = j - 1; - dtrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, & - c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda); - i__4 = j - 1; - dtrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, & - c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], - lda); - -/* Compute inverse of current diagonal block */ - - dtrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info); -/* L20: */ - } - } else { - -/* Compute inverse of lower triangular matrix */ - - nn = (*n - 1) / nb * nb + 1; - i__3 = -nb; - for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { -/* Computing MIN */ - i__1 = nb, i__4 = *n - j + 1; - jb = std::min(i__1,i__4); - if (j + jb <= *n) { - -/* Compute rows j+jb:n of current block column */ - - i__1 = *n - j - jb + 1; - dtrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb, - &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j - + jb + j * a_dim1], lda); - i__1 = *n - j - jb + 1; - dtrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb, - &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j * - a_dim1], lda); - } - -/* Compute inverse of current diagonal block */ - - dtrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info); -/* L30: */ - } - } - } - - return 0; - -/* End of DTRTRI */ - -} /* dtrtri_ */ diff --git a/external/clapack/lapack/dtrtrs.cpp b/external/clapack/lapack/dtrtrs.cpp deleted file mode 100644 index 8bd89740..00000000 --- a/external/clapack/lapack/dtrtrs.cpp +++ /dev/null @@ -1,166 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static double c_b12 = 1.; - -/* Subroutine */ int dtrtrs_(const char *uplo, const char *trans, const char *diag, integer *n, - integer *nrhs, double *a, integer *lda, double *b, integer * - ldb, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - bool nounit; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTRS solves a triangular system of the form */ - -/* A * X = B or A**T * X = B, */ - -/* where A is a triangular matrix of order N, and B is an N-by-NRHS */ -/* matrix. A check is made to verify that A is nonsingular. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, if INFO = 0, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ -/* indicating that the matrix is singular and the solutions */ -/* X have not been computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - nounit = lsame_(diag, "N"); - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*lda < std::max(1_integer,*n)) { - *info = -7; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity. */ - - if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L10: */ - } - } - *info = 0; - -/* Solve A * x = b or A' * x = b. */ - - dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[ - b_offset], ldb); - - return 0; - -/* End of DTRTRS */ - -} /* dtrtrs_ */ diff --git a/external/clapack/lapack/dtrttf.cpp b/external/clapack/lapack/dtrttf.cpp deleted file mode 100644 index e124b7c4..00000000 --- a/external/clapack/lapack/dtrttf.cpp +++ /dev/null @@ -1,472 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dtrttf_(const char *transr, const char *uplo, integer *n, double *a, integer *lda, double *arf, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2; - bool normaltransr, lower, nisodd; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTTF copies a triangular matrix A from standard full format (TR) */ -/* to rectangular full packed format (TF) . */ - -/* Arguments */ -/* ========= */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': ARF in Normal form is wanted; */ -/* = 'T': ARF in Transpose form is wanted. */ - -/* UPLO (input) CHARACTER */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N). */ -/* On entry, the triangular matrix A. If UPLO = 'U', the */ -/* leading N-by-N upper triangular part of the array A contains */ -/* the upper triangular matrix, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of the array A contains */ -/* the lower triangular matrix, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the matrix A. LDA >= max(1,N). */ - -/* ARF (output) DOUBLE PRECISION array, dimension (NT). */ -/* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Notes */ -/* ===== */ - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* even. We give an example where N = 6. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 05 00 */ -/* 11 12 13 14 15 10 11 */ -/* 22 23 24 25 20 21 22 */ -/* 33 34 35 30 31 32 33 */ -/* 44 45 40 41 42 43 44 */ -/* 55 50 51 52 53 54 55 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ -/* the transpose of the first three columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ -/* the transpose of the last three columns of AP lower. */ -/* This covers the case N even and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 03 04 05 33 43 53 */ -/* 13 14 15 00 44 54 */ -/* 23 24 25 10 11 55 */ -/* 33 34 35 20 21 22 */ -/* 00 44 45 30 31 32 */ -/* 01 11 55 40 41 42 */ -/* 02 12 22 50 51 52 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - - -/* RFP A RFP A */ - -/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ -/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ -/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ - - -/* We first consider Rectangular Full Packed (RFP) Format when N is */ -/* odd. We give an example where N = 5. */ - -/* AP is Upper AP is Lower */ - -/* 00 01 02 03 04 00 */ -/* 11 12 13 14 10 11 */ -/* 22 23 24 20 21 22 */ -/* 33 34 30 31 32 33 */ -/* 44 40 41 42 43 44 */ - - -/* Let TRANSR = 'N'. RFP holds AP as follows: */ -/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ -/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ -/* the transpose of the first two columns of AP upper. */ -/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ -/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ -/* the transpose of the last two columns of AP lower. */ -/* This covers the case N odd and TRANSR = 'N'. */ - -/* RFP A RFP A */ - -/* 02 03 04 00 33 43 */ -/* 12 13 14 10 11 44 */ -/* 22 23 24 20 21 22 */ -/* 00 33 34 30 31 32 */ -/* 01 11 44 40 41 42 */ - -/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ -/* transpose of RFP A above. One therefore gets: */ - -/* RFP A RFP A */ - -/* 02 12 22 00 01 00 10 20 30 40 50 */ -/* 03 13 23 33 11 33 11 21 31 41 51 */ -/* 04 14 24 34 44 43 44 22 32 42 52 */ - -/* Reference */ -/* ========= */ - -/* ===================================================================== */ - -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda - 1 - 0 + 1; - a_offset = 0 + a_dim1 * 0; - a -= a_offset; - - /* Function Body */ - *info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - if (! normaltransr && ! lsame_(transr, "T")) { - *info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTTF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 1) { - if (*n == 1) { - arf[0] = a[0]; - } - return 0; - } - -/* Size of array ARF(0:nt-1) */ - - nt = *n * (*n + 1) / 2; - -/* Set N1 and N2 depending on LOWER: for N even N1=N2=K */ - - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - -/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ -/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ -/* N--by--(N+1)/2. */ - - if (*n % 2 == 0) { - k = *n / 2; - nisodd = false; - if (! lower) { - np1x2 = *n + *n + 2; - } - } else { - nisodd = true; - if (! lower) { - nx2 = *n + *n; - } - } - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* N is odd, TRANSR = 'N', and UPLO = 'L' */ - - ij = 0; - i__1 = n2; - for (j = 0; j <= i__1; ++j) { - i__2 = n2 + j; - for (i__ = n1; i__ <= i__2; ++i__) { - arf[ij] = a[n2 + j + i__ * a_dim1]; - ++ij; - } - i__2 = *n - 1; - for (i__ = j; i__ <= i__2; ++i__) { - arf[ij] = a[i__ + j * a_dim1]; - ++ij; - } - } - - } else { - -/* N is odd, TRANSR = 'N', and UPLO = 'U' */ - - ij = nt - *n; - i__1 = n1; - for (j = *n - 1; j >= i__1; --j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = a[i__ + j * a_dim1]; - ++ij; - } - i__2 = n1 - 1; - for (l = j - n1; l <= i__2; ++l) { - arf[ij] = a[j - n1 + l * a_dim1]; - ++ij; - } - ij -= nx2; - } - - } - - } else { - -/* N is odd and TRANSR = 'T' */ - - if (lower) { - -/* N is odd, TRANSR = 'T', and UPLO = 'L' */ - - ij = 0; - i__1 = n2 - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = a[j + i__ * a_dim1]; - ++ij; - } - i__2 = *n - 1; - for (i__ = n1 + j; i__ <= i__2; ++i__) { - arf[ij] = a[i__ + (n1 + j) * a_dim1]; - ++ij; - } - } - i__1 = *n - 1; - for (j = n2; j <= i__1; ++j) { - i__2 = n1 - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = a[j + i__ * a_dim1]; - ++ij; - } - } - - } else { - -/* N is odd, TRANSR = 'T', and UPLO = 'U' */ - - ij = 0; - i__1 = n1; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = n1; i__ <= i__2; ++i__) { - arf[ij] = a[j + i__ * a_dim1]; - ++ij; - } - } - i__1 = n1 - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = a[i__ + j * a_dim1]; - ++ij; - } - i__2 = *n - 1; - for (l = n2 + j; l <= i__2; ++l) { - arf[ij] = a[n2 + j + l * a_dim1]; - ++ij; - } - } - - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* N is even, TRANSR = 'N', and UPLO = 'L' */ - - ij = 0; - i__1 = k - 1; - for (j = 0; j <= i__1; ++j) { - i__2 = k + j; - for (i__ = k; i__ <= i__2; ++i__) { - arf[ij] = a[k + j + i__ * a_dim1]; - ++ij; - } - i__2 = *n - 1; - for (i__ = j; i__ <= i__2; ++i__) { - arf[ij] = a[i__ + j * a_dim1]; - ++ij; - } - } - - } else { - -/* N is even, TRANSR = 'N', and UPLO = 'U' */ - - ij = nt - *n - 1; - i__1 = k; - for (j = *n - 1; j >= i__1; --j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = a[i__ + j * a_dim1]; - ++ij; - } - i__2 = k - 1; - for (l = j - k; l <= i__2; ++l) { - arf[ij] = a[j - k + l * a_dim1]; - ++ij; - } - ij -= np1x2; - } - - } - - } else { - -/* N is even and TRANSR = 'T' */ - - if (lower) { - -/* N is even, TRANSR = 'T', and UPLO = 'L' */ - - ij = 0; - j = k; - i__1 = *n - 1; - for (i__ = k; i__ <= i__1; ++i__) { - arf[ij] = a[i__ + j * a_dim1]; - ++ij; - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = a[j + i__ * a_dim1]; - ++ij; - } - i__2 = *n - 1; - for (i__ = k + 1 + j; i__ <= i__2; ++i__) { - arf[ij] = a[i__ + (k + 1 + j) * a_dim1]; - ++ij; - } - } - i__1 = *n - 1; - for (j = k - 1; j <= i__1; ++j) { - i__2 = k - 1; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = a[j + i__ * a_dim1]; - ++ij; - } - } - - } else { - -/* N is even, TRANSR = 'T', and UPLO = 'U' */ - - ij = 0; - i__1 = k; - for (j = 0; j <= i__1; ++j) { - i__2 = *n - 1; - for (i__ = k; i__ <= i__2; ++i__) { - arf[ij] = a[j + i__ * a_dim1]; - ++ij; - } - } - i__1 = k - 2; - for (j = 0; j <= i__1; ++j) { - i__2 = j; - for (i__ = 0; i__ <= i__2; ++i__) { - arf[ij] = a[i__ + j * a_dim1]; - ++ij; - } - i__2 = *n - 1; - for (l = k + 1 + j; l <= i__2; ++l) { - arf[ij] = a[k + 1 + j + l * a_dim1]; - ++ij; - } - } -/* Note that here, on exit of the loop, J = K-1 */ - i__1 = j; - for (i__ = 0; i__ <= i__1; ++i__) { - arf[ij] = a[i__ + j * a_dim1]; - ++ij; - } - - } - - } - - } - - return 0; - -/* End of DTRTTF */ - -} /* dtrttf_ */ diff --git a/external/clapack/lapack/dtrttp.cpp b/external/clapack/lapack/dtrttp.cpp deleted file mode 100644 index ef4cc71f..00000000 --- a/external/clapack/lapack/dtrttp.cpp +++ /dev/null @@ -1,129 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int dtrttp_(const char *uplo, integer *n, double *a, integer *lda, double *ap, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, k; - bool lower; - - -/* -- LAPACK routine (version 3.2) -- */ -/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ -/* -- and Julien Langou of the Univ. of Colorado Denver -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTTP copies a triangular matrix A from full format (TR) to standard */ -/* packed format (TP). */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER */ -/* = 'U': A is upper triangular. */ -/* = 'L': A is lower triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrices AP and A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On exit, the triangular matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2 */ -/* On exit, the upper or lower triangular matrix A, packed */ -/* columnwise in a linear array. The j-th column of A is stored */ -/* in the array AP as follows: */ -/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ -/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ap; - - /* Function Body */ - *info = 0; - lower = lsame_(uplo, "L"); - if (! lower && ! lsame_(uplo, "U")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTTP", &i__1); - return 0; - } - - if (lower) { - k = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - ++k; - ap[k] = a[i__ + j * a_dim1]; - } - } - } else { - k = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - ++k; - ap[k] = a[i__ + j * a_dim1]; - } - } - } - - - return 0; - -/* End of DTRTTP */ - -} /* dtrttp_ */ diff --git a/external/clapack/lapack/dtzrqf.cpp b/external/clapack/lapack/dtzrqf.cpp deleted file mode 100644 index 5a53cd6a..00000000 --- a/external/clapack/lapack/dtzrqf.cpp +++ /dev/null @@ -1,198 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static double c_b8 = 1.; - -int dtzrqf_(integer *m, integer *n, double *a, integer *lda, double *tau, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - double d__1; - - /* Local variables */ - integer i__, k, m1; - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This routine is deprecated and has been replaced by routine DTZRZF. */ - -/* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */ -/* to upper triangular form by means of orthogonal transformations. */ - -/* The upper trapezoidal matrix A is factored as */ - -/* A = ( R 0 ) * Z, */ - -/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ -/* triangular matrix. */ - -/* 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 >= M. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the leading M-by-N upper trapezoidal part of the */ -/* array A must contain the matrix to be factorized. */ -/* On exit, the leading M-by-M upper triangular part of A */ -/* contains the upper triangular matrix R, and elements M+1 to */ -/* N of the first M rows of A, with the array TAU, represent the */ -/* orthogonal matrix Z as a product of M elementary reflectors. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* TAU (output) DOUBLE PRECISION array, dimension (M) */ -/* The scalar factors of the elementary reflectors. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Further Details */ -/* =============== */ - -/* The factorization is obtained by Householder's method. The kth */ -/* transformation matrix, Z( k ), which is used to introduce zeros into */ -/* the ( m - k + 1 )th row of A, is given in the form */ - -/* Z( k ) = ( I 0 ), */ -/* ( 0 T( k ) ) */ - -/* where */ - -/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */ -/* ( 0 ) */ -/* ( z( k ) ) */ - -/* tau is a scalar and z( k ) is an ( n - m ) element vector. */ -/* tau and z( k ) are chosen to annihilate the elements of the kth row */ -/* of X. */ - -/* The scalar tau is returned in the kth element of TAU and the vector */ -/* u( k ) in the kth row of A, such that the elements of z( k ) are */ -/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ -/* the upper triangular part of A. */ - -/* Z is given by */ - -/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTZRQF", &i__1); - return 0; - } - -/* Perform the factorization. */ - - if (*m == 0) { - return 0; - } - if (*m == *n) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - tau[i__] = 0.; -/* L10: */ - } - } else { -/* Computing MIN */ - i__1 = *m + 1; - m1 = std::min(i__1,*n); - for (k = *m; k >= 1; --k) { - -/* Use a Householder reflection to zero the kth row of A. */ -/* First set up the reflection. */ - - i__1 = *n - *m + 1; - dlarfp_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[ - k]); - - if (tau[k] != 0. && k > 1) { - -/* We now perform the operation A := A*P( k ). */ - -/* Use the first ( k - 1 ) elements of TAU to store a( k ), */ -/* where a( k ) consists of the first ( k - 1 ) elements of */ -/* the kth column of A. Also let B denote the first */ -/* ( k - 1 ) rows of the last ( n - m ) columns of A. */ - - i__1 = k - 1; - dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1); - -/* Form w = a( k ) + B*z( k ) in TAU. */ - - i__1 = k - 1; - i__2 = *n - *m; - dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 + - 1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], & - c__1); - -/* Now form a( k ) := a( k ) - tau*w */ -/* and B := B - tau*w*z( k )'. */ - - i__1 = k - 1; - d__1 = -tau[k]; - daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], & - c__1); - i__1 = k - 1; - i__2 = *n - *m; - d__1 = -tau[k]; - dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1] -, lda, &a[m1 * a_dim1 + 1], lda); - } -/* L20: */ - } - } - - return 0; - -/* End of DTZRQF */ - -} /* dtzrqf_ */ diff --git a/external/clapack/lapack/dtzrzf.cpp b/external/clapack/lapack/dtzrzf.cpp deleted file mode 100644 index a3c6fabe..00000000 --- a/external/clapack/lapack/dtzrzf.cpp +++ /dev/null @@ -1,287 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static integer c__3 = 3; -static integer c__2 = 2; - -/* Subroutine */ int dtzrzf_(integer *m, integer *n, double *a, integer * - lda, double *tau, double *work, integer *lwork, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - - /* Local variables */ - integer i__, m1, ib, nb, ki, kk, mu, nx, iws, nbmin; - integer ldwork, lwkopt; - bool lquery; - - -/* -- LAPACK routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */ -/* to upper triangular form by means of orthogonal transformations. */ - -/* The upper trapezoidal matrix A is factored as */ - -/* A = ( R 0 ) * Z, */ - -/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ -/* triangular matrix. */ - -/* 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 >= M. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the leading M-by-N upper trapezoidal part of the */ -/* array A must contain the matrix to be factorized. */ -/* On exit, the leading M-by-M upper triangular part of A */ -/* contains the upper triangular matrix R, and elements M+1 to */ -/* N of the first M rows of A, with the array TAU, represent the */ -/* orthogonal matrix Z as a product of M elementary reflectors. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1_integer,M). */ - -/* TAU (output) DOUBLE PRECISION array, dimension (M) */ -/* The scalar factors of the elementary reflectors. */ - -/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ - -/* LWORK (input) INTEGER */ -/* The dimension of the array WORK. LWORK >= max(1_integer,M). */ -/* For optimum performance LWORK >= M*NB, where NB is */ -/* the optimal blocksize. */ - -/* If LWORK = -1, then a workspace query is assumed; the routine */ -/* only calculates the optimal size of the WORK array, returns */ -/* this value as the first entry of the WORK array, and no error */ -/* message related to LWORK is issued by XERBLA. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Further Details */ -/* =============== */ - -/* Based on contributions by */ -/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ - -/* The factorization is obtained by Householder's method. The kth */ -/* transformation matrix, Z( k ), which is used to introduce zeros into */ -/* the ( m - k + 1 )th row of A, is given in the form */ - -/* Z( k ) = ( I 0 ), */ -/* ( 0 T( k ) ) */ - -/* where */ - -/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */ -/* ( 0 ) */ -/* ( z( k ) ) */ - -/* tau is a scalar and z( k ) is an ( n - m ) element vector. */ -/* tau and z( k ) are chosen to annihilate the elements of the kth row */ -/* of X. */ - -/* The scalar tau is returned in the kth element of TAU and the vector */ -/* u( k ) in the kth row of A, such that the elements of z( k ) are */ -/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ -/* the upper triangular part of A. */ - -/* Z is given by */ - -/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input arguments */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*lda < std::max(1_integer,*m)) { - *info = -4; - } - - if (*info == 0) { - if (*m == 0 || *m == *n) { - lwkopt = 1; - } else { - -/* Determine the block size. */ - - nb = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); - lwkopt = *m * nb; - } - work[1] = (double) lwkopt; - - if (*lwork < std::max(1_integer,*m) && ! lquery) { - *info = -7; - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTZRZF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0) { - return 0; - } else if (*m == *n) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - tau[i__] = 0.; -/* L10: */ - } - return 0; - } - - nbmin = 2; - nx = 1; - iws = *m; - if (nb > 1 && nb < *m) { - -/* Determine when to cross over from blocked to unblocked code. */ - -/* Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DGERQF", " ", m, n, &c_n1, &c_n1); - nx = std::max(i__1,i__2); - if (nx < *m) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and */ -/* determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGERQF", " ", m, n, &c_n1, & - c_n1); - nbmin = std::max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *m && nx < *m) { - -/* Use blocked code initially. */ -/* The last kk rows are handled by the block method. */ - -/* Computing MIN */ - i__1 = *m + 1; - m1 = std::min(i__1,*n); - ki = (*m - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *m, i__2 = ki + nb; - kk = std::min(i__1,i__2); - - i__1 = *m - kk + 1; - i__2 = -nb; - for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; - i__ += i__2) { -/* Computing MIN */ - i__3 = *m - i__ + 1; - ib = std::min(i__3,nb); - -/* Compute the TZ factorization of the current block */ -/* A(i:i+ib-1,i:n) */ - - i__3 = *n - i__ + 1; - i__4 = *n - *m; - dlatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__], - &work[1]); - if (i__ > 1) { - -/* Form the triangular factor of the block reflector */ -/* H = H(i+ib-1) . . . H(i+1) H(i) */ - - i__3 = *n - *m; - dlarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 * - a_dim1], lda, &tau[i__], &work[1], &ldwork); - -/* Apply H to A(1:i-1,i:n) from the right */ - - i__3 = i__ - 1; - i__4 = *n - i__ + 1; - i__5 = *n - *m; - dlarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3, - &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[ - 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1], - &ldwork) - ; - } -/* L20: */ - } - mu = i__ + nb - 1; - } else { - mu = *m; - } - -/* Use unblocked code to factor the last or only block */ - - if (mu > 0) { - i__2 = *n - *m; - dlatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]); - } - - work[1] = (double) lwkopt; - - return 0; - -/* End of DTZRZF */ - -} /* dtzrzf_ */ diff --git a/external/clapack/lapack/ieeeck.cpp b/external/clapack/lapack/ieeeck.cpp deleted file mode 100644 index ee6f8f81..00000000 --- a/external/clapack/lapack/ieeeck.cpp +++ /dev/null @@ -1,154 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -integer ieeeck_(integer *ispec, float *zero, float *one) -{ - /* System generated locals */ - integer ret_val; - - /* Local variables */ - float nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* IEEECK is called from the ILAENV to verify that Infinity and */ -/* possibly NaN arithmetic is safe (i.e. will not trap). */ - -/* Arguments */ -/* ========= */ - -/* ISPEC (input) INTEGER */ -/* Specifies whether to test just for inifinity arithmetic */ -/* or whether to test for infinity and NaN arithmetic. */ -/* = 0: Verify infinity arithmetic only. */ -/* = 1: Verify infinity and NaN arithmetic. */ - -/* ZERO (input) REAL */ -/* Must contain the value 0.0 */ -/* This is passed to prevent the compiler from optimizing */ -/* away this code. */ - -/* ONE (input) REAL */ -/* Must contain the value 1.0 */ -/* This is passed to prevent the compiler from optimizing */ -/* away this code. */ - -/* RETURN VALUE: INTEGER */ -/* = 0: Arithmetic failed to produce the correct answers */ -/* = 1: Arithmetic produced the correct answers */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - ret_val = 1; - - posinf = *one / *zero; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - neginf = -(*one) / *zero; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - negzro = *one / (neginf + *one); - if (negzro != *zero) { - ret_val = 0; - return ret_val; - } - - neginf = *one / negzro; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - newzro = negzro + *zero; - if (newzro != *zero) { - ret_val = 0; - return ret_val; - } - - posinf = *one / newzro; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - neginf *= posinf; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - posinf *= posinf; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - - - -/* Return if we were only asked to check infinity arithmetic */ - - if (*ispec == 0) { - return ret_val; - } - - nan1 = posinf + neginf; - - nan2 = posinf / neginf; - - nan3 = posinf / posinf; - - nan4 = posinf * *zero; - - nan5 = neginf * negzro; - - nan6 = nan5 * 0.f; - - if (nan1 == nan1) { - ret_val = 0; - return ret_val; - } - - if (nan2 == nan2) { - ret_val = 0; - return ret_val; - } - - if (nan3 == nan3) { - ret_val = 0; - return ret_val; - } - - if (nan4 == nan4) { - ret_val = 0; - return ret_val; - } - - if (nan5 == nan5) { - ret_val = 0; - return ret_val; - } - - if (nan6 == nan6) { - ret_val = 0; - return ret_val; - } - - return ret_val; -} /* ieeeck_ */ diff --git a/external/clapack/lapack/iladlc.cpp b/external/clapack/lapack/iladlc.cpp deleted file mode 100644 index 1ca88261..00000000 --- a/external/clapack/lapack/iladlc.cpp +++ /dev/null @@ -1,76 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -integer iladlc_(integer *m, integer *n, double *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, ret_val, i__1; - - /* Local variables */ - integer i__; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ - -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* ILADLC scans A for its last non-zero column. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The m by n matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick test for the common case where one corner is non-zero. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - if (*n == 0) { - ret_val = *n; - } else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) { - ret_val = *n; - } else { -/* Now scan each column from the end, returning with the first non-zero. */ - for (ret_val = *n; ret_val >= 1; --ret_val) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (a[i__ + ret_val * a_dim1] != 0.) { - return ret_val; - } - } - } - } - return ret_val; -} /* iladlc_ */ diff --git a/external/clapack/lapack/iladlr.cpp b/external/clapack/lapack/iladlr.cpp deleted file mode 100644 index 134a3719..00000000 --- a/external/clapack/lapack/iladlr.cpp +++ /dev/null @@ -1,78 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -integer iladlr_(integer *m, integer *n, double *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, ret_val, i__1; - - /* Local variables */ - integer i__, j; - - -/* -- LAPACK auxiliary routine (version 3.2.1) -- */ - -/* -- April 2009 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* ILADLR scans A for its last non-zero row. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The m by n matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Quick test for the common case where one corner is non-zero. */ - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - if (*m == 0) { - ret_val = *m; - } else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) { - ret_val = *m; - } else { -/* Scan up each column tracking the last zero row seen. */ - ret_val = 0; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - if (a[i__ + j * a_dim1] != 0.) { - break; - } - } - ret_val = std::max(ret_val,i__); - } - } - return ret_val; -} /* iladlr_ */ diff --git a/external/clapack/lapack/ilaenv.cpp b/external/clapack/lapack/ilaenv.cpp deleted file mode 100644 index 2222b9ac..00000000 --- a/external/clapack/lapack/ilaenv.cpp +++ /dev/null @@ -1,643 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - - -/* Table of constant values */ - -static integer c__1 = 1; -static float c_b163 = 0.f; -static float c_b164 = 1.f; -static integer c__0 = 0; - -integer ilaenv_(integer *ispec, const char *name__, const char *opts, integer *n1, - integer *n2, integer *n3, integer *n4) -{ - /* System generated locals */ - integer ret_val; - - /* Local variables */ - integer i__; - char c1[1], c2[1], c3[1], c4[1]; - integer ic, nb, iz, nx; - bool cname; - integer nbmin; - bool sname; - char subnam[1]; - integer name_len, opts_len; - - name_len = strlen (name__); - opts_len = strlen (opts); - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* January 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* 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. */ - -/* ILAENV returns an INTEGER */ -/* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC */ -/* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. */ - -/* 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 (DEPRECATED) */ -/* = 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 method */ -/* for nonsymmetric eigenvalue problems (DEPRECATED) */ -/* = 9: maximum size of the subproblems at the bottom of the */ -/* computation tree in the divide-and-conquer algorithm */ -/* (used by xGELSD and xGESDD) */ -/* =10: ieee NaN arithmetic can be trusted not to trap */ -/* =11: infinity arithmetic can be trusted not to trap */ -/* 12 <= ISPEC <= 16: */ -/* xHSEQR or one of its subroutines, */ -/* see IPARMQ for detailed explanation */ - -/* 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. */ - -/* 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 .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - switch (*ispec) { - case 1: goto L10; - case 2: goto L10; - case 3: goto L10; - case 4: goto L80; - case 5: goto L90; - case 6: goto L100; - case 7: goto L110; - case 8: goto L120; - case 9: goto L130; - case 10: goto L140; - case 11: goto L150; - case 12: goto L160; - case 13: goto L160; - case 14: goto L160; - case 15: goto L160; - case 16: goto L160; - } - -/* Invalid value for ISPEC */ - - ret_val = -1; - return ret_val; - -L10: - -/* Convert NAME to upper case if the first character is lower case. */ - - ret_val = 1; - s_copy(subnam, name__, 1_integer, name_len); - ic = *(unsigned char *)subnam; - iz = 'Z'; - if (iz == 90 || iz == 122) { - -/* ASCII character set */ - - if (ic >= 97 && ic <= 122) { - *(unsigned char *)subnam = (char) (ic - 32); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 97 && ic <= 122) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); - } -/* L20: */ - } - } - - } else if (iz == 233 || iz == 169) { - -/* EBCDIC character set */ - - if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && - ic <= 169) { - *(unsigned char *)subnam = (char) (ic + 64); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= - 162 && ic <= 169) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); - } -/* L30: */ - } - } - - } else if (iz == 218 || iz == 250) { - -/* Prime machines: ASCII+128 */ - - if (ic >= 225 && ic <= 250) { - *(unsigned char *)subnam = (char) (ic - 32); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 225 && ic <= 250) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); - } -/* L40: */ - } - } - } - - *(unsigned char *)c1 = *(unsigned char *)subnam; - sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D'; - cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z'; - if (! (cname || sname)) { - return ret_val; - } - s_copy(c2, subnam + 1, 1_integer, 2_integer); - s_copy(c3, subnam + 3, 1_integer, 3_integer); - s_copy(c4, c3 + 1, 1_integer, 2_integer); - - switch (*ispec) { - case 1: goto L50; - case 2: goto L60; - case 3: goto L70; - } - -L50: - -/* 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 (s_cmp(c2, "GE", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } else if (s_cmp(c3, "QRF", 1_integer, 3_integer) == 0 || s_cmp(c3, - "RQF", 1_integer, 3_integer) == 0 || s_cmp(c3, "LQF", 1_integer, - 3_integer) == 0 || s_cmp(c3, "QLF", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, "HRD", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, "BRD", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, "TRI", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } - } else if (s_cmp(c2, "PO", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } - } else if (s_cmp(c2, "SY", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } else if (sname && s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { - nb = 32; - } else if (sname && s_cmp(c3, "GST", 1_integer, 3_integer) == 0) { - nb = 64; - } - } else if (cname && s_cmp(c2, "HE", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { - nb = 64; - } else if (s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { - nb = 32; - } else if (s_cmp(c3, "GST", 1_integer, 3_integer) == 0) { - nb = 64; - } - } else if (sname && s_cmp(c2, "OR", 1_integer, 2_integer) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nb = 32; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nb = 32; - } - } - } else if (cname && s_cmp(c2, "UN", 1_integer, 2_integer) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nb = 32; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nb = 32; - } - } - } else if (s_cmp(c2, "GB", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { - if (sname) { - if (*n4 <= 64) { - nb = 1; - } else { - nb = 32; - } - } else { - if (*n4 <= 64) { - nb = 1; - } else { - nb = 32; - } - } - } - } else if (s_cmp(c2, "PB", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { - if (sname) { - if (*n2 <= 64) { - nb = 1; - } else { - nb = 32; - } - } else { - if (*n2 <= 64) { - nb = 1; - } else { - nb = 32; - } - } - } - } else if (s_cmp(c2, "TR", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRI", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } - } else if (s_cmp(c2, "LA", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "UUM", 1_integer, 3_integer) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } - } else if (sname && s_cmp(c2, "ST", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "EBZ", 1_integer, 3_integer) == 0) { - nb = 1; - } - } - ret_val = nb; - return ret_val; - -L60: - -/* ISPEC = 2: minimum block size */ - - nbmin = 2; - if (s_cmp(c2, "GE", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "QRF", 1_integer, 3_integer) == 0 || - s_cmp(c3, "RQF", 1_integer, 3_integer) == 0 || - s_cmp(c3, "LQF", 1_integer, 3_integer) == 0 || - s_cmp(c3, "QLF", 1_integer, 3_integer) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, "HRD", 1_integer, 3_integer) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, "BRD", 1_integer, 3_integer) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, "TRI", 1_integer, 3_integer) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } - } else if (s_cmp(c2, "SY", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRF", 1_integer, 3_integer) == 0) { - if (sname) { - nbmin = 8; - } else { - nbmin = 8; - } - } else if (sname && s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { - nbmin = 2; - } - } else if (cname && s_cmp(c2, "HE", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { - nbmin = 2; - } - } else if (sname && s_cmp(c2, "OR", 1_integer, 2_integer) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nbmin = 2; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nbmin = 2; - } - } - } else if (cname && s_cmp(c2, "UN", 1_integer, 2_integer) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nbmin = 2; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nbmin = 2; - } - } - } - ret_val = nbmin; - return ret_val; - -L70: - -/* ISPEC = 3: crossover point */ - - nx = 0; - if (s_cmp(c2, "GE", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "QRF", 1_integer, 3_integer) == 0 || - s_cmp(c3, "RQF", 1_integer, 3_integer) == 0 || - s_cmp(c3, "LQF", 1_integer, 3_integer) == 0 || - s_cmp(c3, "QLF", 1_integer, 3_integer) == 0) { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } else if (s_cmp(c3, "HRD", 1_integer, 3_integer) == 0) { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } else if (s_cmp(c3, "BRD", 1_integer, 3_integer) == 0) { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } - } else if (s_cmp(c2, "SY", 1_integer, 2_integer) == 0) { - if (sname && s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { - nx = 32; - } - } else if (cname && s_cmp(c2, "HE", 1_integer, 2_integer) == 0) { - if (s_cmp(c3, "TRD", 1_integer, 3_integer) == 0) { - nx = 32; - } - } else if (sname && s_cmp(c2, "OR", 1_integer, 2_integer) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nx = 128; - } - } - } else if (cname && s_cmp(c2, "UN", 1_integer, 2_integer) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "RQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "LQ", 1_integer, 2_integer) == 0 || - s_cmp(c4, "QL", 1_integer, 2_integer) == 0 || - s_cmp(c4, "HR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "TR", 1_integer, 2_integer) == 0 || - s_cmp(c4, "BR", 1_integer, 2_integer) == 0) { - nx = 128; - } - } - } - ret_val = nx; - return ret_val; - -L80: - -/* ISPEC = 4: number of shifts (used by xHSEQR) */ - - ret_val = 6; - return ret_val; - -L90: - -/* ISPEC = 5: minimum column dimension (not used) */ - - ret_val = 2; - return ret_val; - -L100: - -/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */ - - ret_val = (integer) ((float) std::min(*n1,*n2) * 1.6f); - return ret_val; - -L110: - -/* ISPEC = 7: number of processors (not used) */ - - ret_val = 1; - return ret_val; - -L120: - -/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */ - - ret_val = 50; - return ret_val; - -L130: - -/* ISPEC = 9: maximum size of the subproblems at the bottom of the */ -/* computation tree in the divide-and-conquer algorithm */ -/* (used by xGELSD and xGESDD) */ - - ret_val = 25; - return ret_val; - -L140: - -/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */ - -/* ILAENV = 0 */ - ret_val = 1; - if (ret_val == 1) { - ret_val = ieeeck_(&c__1, &c_b163, &c_b164); - } - return ret_val; - -L150: - -/* ISPEC = 11: infinity arithmetic can be trusted not to trap */ - -/* ILAENV = 0 */ - ret_val = 1; - if (ret_val == 1) { - ret_val = ieeeck_(&c__0, &c_b163, &c_b164); - } - return ret_val; - -L160: - -/* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. */ - - ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4) - ; - return ret_val; - -/* End of ILAENV */ - -} /* ilaenv_ */ diff --git a/external/clapack/lapack/ilaprec.cpp b/external/clapack/lapack/ilaprec.cpp deleted file mode 100644 index 638f9b21..00000000 --- a/external/clapack/lapack/ilaprec.cpp +++ /dev/null @@ -1,57 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -integer ilaprec_(const char *prec) -{ - /* System generated locals */ - integer ret_val; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* October 2008 */ -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This subroutine translated from a character string specifying an */ -/* intermediate precision to the relevant BLAST-specified integer */ -/* constant. */ - -/* ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a */ -/* character indicating a supported intermediate precision. Otherwise */ -/* ILAPREC returns the constant value corresponding to PREC. */ - -/* Arguments */ -/* ========= */ -/* PREC (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'S': Single */ -/* = 'D': Double */ -/* = 'I': Indigenous */ -/* = 'X', 'E': Extra */ -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - if (lsame_(prec, "S")) { - ret_val = 211; - } else if (lsame_(prec, "D")) { - ret_val = 212; - } else if (lsame_(prec, "I")) { - ret_val = 213; - } else if (lsame_(prec, "X") || lsame_(prec, "E")) { - ret_val = 214; - } else { - ret_val = -1; - } - return ret_val; - -/* End of ILAPREC */ - -} /* ilaprec_ */ diff --git a/external/clapack/lapack/ilatrans.cpp b/external/clapack/lapack/ilatrans.cpp deleted file mode 100644 index f9477d10..00000000 --- a/external/clapack/lapack/ilatrans.cpp +++ /dev/null @@ -1,53 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -integer ilatrans_(const char *trans) -{ - /* System generated locals */ - integer ret_val; - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* October 2008 */ -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This subroutine translates from a character string specifying a */ -/* transposition operation to the relevant BLAST-specified integer */ -/* constant. */ - -/* ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not */ -/* a character indicating a transposition operator. Otherwise ILATRANS */ -/* returns the constant value corresponding to TRANS. */ - -/* Arguments */ -/* ========= */ -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': No transpose */ -/* = 'T': Transpose */ -/* = 'C': Conjugate transpose */ -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - if (lsame_(trans, "N")) { - ret_val = 111; - } else if (lsame_(trans, "T")) { - ret_val = 112; - } else if (lsame_(trans, "C")) { - ret_val = 113; - } else { - ret_val = -1; - } - return ret_val; - -/* End of ILATRANS */ - -} /* ilatrans_ */ diff --git a/external/clapack/lapack/ilaver.cpp b/external/clapack/lapack/ilaver.cpp deleted file mode 100644 index c399a761..00000000 --- a/external/clapack/lapack/ilaver.cpp +++ /dev/null @@ -1,38 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Subroutine */ int ilaver_(integer *vers_major__, integer *vers_minor__, - integer *vers_patch__) -{ - -/* -- LAPACK routine (version 3.1.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* January 2007 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This subroutine return the Lapack version. */ - -/* Arguments */ -/* ========= */ - -/* VERS_MAJOR (output) INTEGER */ -/* return the lapack major version */ -/* VERS_MINOR (output) INTEGER */ -/* return the lapack minor version from the major version */ -/* VERS_PATCH (output) INTEGER */ -/* return the lapack patch version from the minor version */ - -/* .. Executable Statements .. */ - - *vers_major__ = 3; - *vers_minor__ = 1; - *vers_patch__ = 1; -/* ===================================================================== */ - - return 0; -} /* ilaver_ */ diff --git a/external/clapack/lapack/iparmq.cpp b/external/clapack/lapack/iparmq.cpp deleted file mode 100644 index 6f68fbb2..00000000 --- a/external/clapack/lapack/iparmq.cpp +++ /dev/null @@ -1,266 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -integer iparmq_(integer *ispec, const char *name__, const char *opts, integer *n, integer - *ilo, integer *ihi, integer *lwork) -{ - /* System generated locals */ - integer ret_val, i__1, i__2; - float r__1; - - /* Local variables */ - integer nh, ns; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ - -/* Purpose */ -/* ======= */ - -/* This program sets problem and machine dependent parameters */ -/* useful for xHSEQR and its subroutines. It is called whenever */ -/* ILAENV is called with 12 <= ISPEC <= 16 */ - -/* Arguments */ -/* ========= */ - -/* ISPEC (input) integer scalar */ -/* ISPEC specifies which tunable parameter IPARMQ should */ -/* return. */ - -/* ISPEC=12: (INMIN) Matrices of order nmin or less */ -/* are sent directly to xLAHQR, the implicit */ -/* double shift QR algorithm. NMIN must be */ -/* at least 11. */ - -/* ISPEC=13: (INWIN) Size of the deflation window. */ -/* This is best set greater than or equal to */ -/* the number of simultaneous shifts NS. */ -/* Larger matrices benefit from larger deflation */ -/* windows. */ - -/* ISPEC=14: (INIBL) Determines when to stop nibbling and */ -/* invest in an (expensive) multi-shift QR sweep. */ -/* If the aggressive early deflation subroutine */ -/* finds LD converged eigenvalues from an order */ -/* NW deflation window and LD.GT.(NW*NIBBLE)/100, */ -/* then the next QR sweep is skipped and early */ -/* deflation is applied immediately to the */ -/* remaining active diagonal block. Setting */ -/* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a */ -/* multi-shift QR sweep whenever early deflation */ -/* finds a converged eigenvalue. Setting */ -/* IPARMQ(ISPEC=14) greater than or equal to 100 */ -/* prevents TTQRE from skipping a multi-shift */ -/* QR sweep. */ - -/* ISPEC=15: (NSHFTS) The number of simultaneous shifts in */ -/* a multi-shift QR iteration. */ - -/* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the */ -/* following meanings. */ -/* 0: During the multi-shift QR sweep, */ -/* xLAQR5 does not accumulate reflections and */ -/* does not use matrix-matrix multiply to */ -/* update the far-from-diagonal matrix */ -/* entries. */ -/* 1: During the multi-shift QR sweep, */ -/* xLAQR5 and/or xLAQRaccumulates reflections and uses */ -/* matrix-matrix multiply to update the */ -/* far-from-diagonal matrix entries. */ -/* 2: During the multi-shift QR sweep. */ -/* xLAQR5 accumulates reflections and takes */ -/* advantage of 2-by-2 block structure during */ -/* matrix-matrix multiplies. */ -/* (If xTRMM is slower than xGEMM, then */ -/* IPARMQ(ISPEC=16)=1 may be more efficient than */ -/* IPARMQ(ISPEC=16)=2 despite the greater level of */ -/* arithmetic work implied by the latter choice.) */ - -/* NAME (input) character string */ -/* Name of the calling subroutine */ - -/* OPTS (input) character string */ -/* This is a concatenation of the string arguments to */ -/* TTQRE. */ - -/* N (input) integer scalar */ -/* N is the order of the Hessenberg matrix H. */ - -/* ILO (input) INTEGER */ -/* IHI (input) INTEGER */ -/* It is assumed that H is already upper triangular */ -/* in rows and columns 1:ILO-1 and IHI+1:N. */ - -/* LWORK (input) integer scalar */ -/* The amount of workspace available. */ - -/* Further Details */ -/* =============== */ - -/* Little is known about how best to choose these parameters. */ -/* It is possible to use different values of the parameters */ -/* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. */ - -/* It is probably best to choose different parameters for */ -/* different matrices and different parameters at different */ -/* times during the iteration, but this has not been */ -/* implemented --- yet. */ - - -/* The best choices of most of the parameters depend */ -/* in an ill-understood way on the relative execution */ -/* rate of xLAQR3 and xLAQR5 and on the nature of each */ -/* particular eigenvalue problem. Experiment may be the */ -/* only practical way to determine which choices are most */ -/* effective. */ - -/* Following is a list of default values supplied by IPARMQ. */ -/* These defaults may be adjusted in order to attain better */ -/* performance in any particular computational environment. */ - -/* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. */ -/* Default: 75. (Must be at least 11.) */ - -/* IPARMQ(ISPEC=13) Recommended deflation window size. */ -/* This depends on ILO, IHI and NS, the */ -/* number of simultaneous shifts returned */ -/* by IPARMQ(ISPEC=15). The default for */ -/* (IHI-ILO+1).LE.500 is NS. The default */ -/* for (IHI-ILO+1).GT.500 is 3*NS/2. */ - -/* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. */ - -/* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. */ -/* a multi-shift QR iteration. */ - -/* If IHI-ILO+1 is ... */ - -/* greater than ...but less ... the */ -/* or equal to ... than default is */ - -/* 0 30 NS = 2+ */ -/* 30 60 NS = 4+ */ -/* 60 150 NS = 10 */ -/* 150 590 NS = ** */ -/* 590 3000 NS = 64 */ -/* 3000 6000 NS = 128 */ -/* 6000 infinity NS = 256 */ - -/* (+) By default matrices of this order are */ -/* passed to the implicit double shift routine */ -/* xLAHQR. See IPARMQ(ISPEC=12) above. These */ -/* values of NS are used only in case of a rare */ -/* xLAHQR failure. */ - -/* (**) The asterisks (**) indicate an ad-hoc */ -/* function increasing from 10 to 64. */ - -/* IPARMQ(ISPEC=16) Select structured matrix multiply. */ -/* (See ISPEC=16 above for details.) */ -/* Default: 3. */ - -/* ================================================================ */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - if (*ispec == 15 || *ispec == 13 || *ispec == 16) { - -/* ==== Set the number simultaneous shifts ==== */ - - nh = *ihi - *ilo + 1; - ns = 2; - if (nh >= 30) { - ns = 4; - } - if (nh >= 60) { - ns = 10; - } - if (nh >= 150) { -/* Computing MAX */ - r__1 = log((float) nh) / log(2.f); - i__1 = 10, i__2 = nh / i_nint(&r__1); - ns = std::max(i__1,i__2); - } - if (nh >= 590) { - ns = 64; - } - if (nh >= 3000) { - ns = 128; - } - if (nh >= 6000) { - ns = 256; - } -/* Computing MAX */ - i__1 = 2, i__2 = ns - ns % 2; - ns = std::max(i__1,i__2); - } - - if (*ispec == 12) { - - -/* ===== Matrices of order smaller than NMIN get sent */ -/* . to xLAHQR, the classic double shift algorithm. */ -/* . This must be at least 11. ==== */ - - ret_val = 75; - - } else if (*ispec == 14) { - -/* ==== INIBL: skip a multi-shift qr iteration and */ -/* . whenever aggressive early deflation finds */ -/* . at least (NIBBLE*(window size)/100) deflations. ==== */ - - ret_val = 14; - - } else if (*ispec == 15) { - -/* ==== NSHFTS: The number of simultaneous shifts ===== */ - - ret_val = ns; - - } else if (*ispec == 13) { - -/* ==== NW: deflation window size. ==== */ - - if (nh <= 500) { - ret_val = ns; - } else { - ret_val = ns * 3 / 2; - } - - } else if (*ispec == 16) { - -/* ==== IACC22: Whether to accumulate reflections */ -/* . before updating the far-from-diagonal elements */ -/* . and whether to use 2-by-2 block structure while */ -/* . doing it. A small amount of work could be saved */ -/* . by making this choice dependent also upon the */ -/* . NH=IHI-ILO+1. */ - - ret_val = 0; - if (ns >= 14) { - ret_val = 1; - } - if (ns >= 14) { - ret_val = 2; - } - - } else { -/* ===== invalid value of ispec ===== */ - ret_val = -1; - - } - -/* ==== End of IPARMQ ==== */ - - return ret_val; -} /* iparmq_ */ diff --git a/external/clapack/lapack/lsame.cpp b/external/clapack/lapack/lsame.cpp deleted file mode 100644 index e4efa88c..00000000 --- a/external/clapack/lapack/lsame.cpp +++ /dev/null @@ -1,105 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -bool lsame_(const char *ca, const char *cb) -{ - /* System generated locals */ - bool ret_val; - - /* Local variables */ - integer inta, intb, zcode; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* LSAME returns .TRUE. if CA is the same letter as CB regardless of */ -/* case. */ - -/* Arguments */ -/* ========= */ - -/* CA (input) CHARACTER*1 */ -/* CB (input) CHARACTER*1 */ -/* CA and CB specify the single characters to be compared. */ - -/* ===================================================================== */ - -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test if the characters are equal */ - - ret_val = *(unsigned char *)ca == *(unsigned char *)cb; - if (ret_val) { - return ret_val; - } - -/* Now test for equivalence if both characters are alphabetic. */ - - zcode = 'Z'; - -/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */ -/* machines, on which ICHAR returns a value with bit 8 set. */ -/* ICHAR('A') on Prime machines returns 193 which is the same as */ -/* ICHAR('A') on an EBCDIC machine. */ - - inta = *(unsigned char *)ca; - intb = *(unsigned char *)cb; - - if (zcode == 90 || zcode == 122) { - -/* ASCII is assumed - ZCODE is the ASCII code of either lower or */ -/* upper case 'Z'. */ - - if (inta >= 97 && inta <= 122) { - inta += -32; - } - if (intb >= 97 && intb <= 122) { - intb += -32; - } - - } else if (zcode == 233 || zcode == 169) { - -/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */ -/* upper case 'Z'. */ - - if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta - >= 162 && inta <= 169) { - inta += 64; - } - if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb - >= 162 && intb <= 169) { - intb += 64; - } - - } else if (zcode == 218 || zcode == 250) { - -/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */ -/* plus 128 of either lower or upper case 'Z'. */ - - if (inta >= 225 && inta <= 250) { - inta += -32; - } - if (intb >= 225 && intb <= 250) { - intb += -32; - } - } - ret_val = inta == intb; - -/* RETURN */ - -/* End of LSAME */ - - return ret_val; -} /* lsame_ */ diff --git a/external/clapack/lapack/lsamen.cpp b/external/clapack/lapack/lsamen.cpp deleted file mode 100644 index 01cbfefa..00000000 --- a/external/clapack/lapack/lsamen.cpp +++ /dev/null @@ -1,76 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" -#include "string.h" - -bool lsamen_(integer *n, const char *ca, const char *cb) -{ - /* System generated locals */ - integer i__1; - bool ret_val; - - /* Local variables */ - integer i__; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* LSAMEN tests if the first N letters of CA are the same as the */ -/* first N letters of CB, regardless of case. */ -/* LSAMEN returns .TRUE. if CA and CB are equivalent except for case */ -/* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) */ -/* or LEN( CB ) is less than N. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The number of characters in CA and CB to be compared. */ - -/* CA (input) CHARACTER*(*) */ -/* CB (input) CHARACTER*(*) */ -/* CA and CB specify two character strings of length at least N. */ -/* Only the first N characters of each string will be accessed. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - ret_val = false; - if (strlen(ca) < *n || strlen(cb) < *n) { - goto L20; - } - -/* Do for each character in the two strings. */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Test if the characters are equal using LSAME. */ - - if (! lsame_(ca + (i__ - 1), cb + (i__ - 1))) { - goto L20; - } - -/* L10: */ - } - ret_val = true; - -L20: - return ret_val; - -/* End of LSAMEN */ - -} /* lsamen_ */ diff --git a/external/clapack/lapack/sisnan.cpp b/external/clapack/lapack/sisnan.cpp deleted file mode 100644 index 6ebfbb59..00000000 --- a/external/clapack/lapack/sisnan.cpp +++ /dev/null @@ -1,36 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -bool sisnan_(float *sin__) -{ - /* System generated locals */ - bool ret_val; - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SISNAN returns .TRUE. if its argument is NaN, and .FALSE. */ -/* otherwise. To be replaced by the Fortran 2003 intrinsic in the */ -/* future. */ - -/* Arguments */ -/* ========= */ - -/* SIN (input) REAL */ -/* Input to test for NaN. */ - -/* ===================================================================== */ - -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - ret_val = slaisnan_(sin__, sin__); - return ret_val; -} /* sisnan_ */ diff --git a/external/clapack/lapack/slaisnan.cpp b/external/clapack/lapack/slaisnan.cpp deleted file mode 100644 index d610098b..00000000 --- a/external/clapack/lapack/slaisnan.cpp +++ /dev/null @@ -1,46 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -bool slaisnan_(float *sin1, float *sin2) -{ - /* System generated locals */ - bool ret_val; - - -/* -- LAPACK auxiliary routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* This routine is not for general use. It exists solely to avoid */ -/* over-optimization in SISNAN. */ - -/* SLAISNAN checks for NaNs by comparing its two arguments for */ -/* inequality. NaN is the only floating-point value where NaN != NaN */ -/* returns .TRUE. To check for NaNs, pass the same variable as both */ -/* arguments. */ - -/* A compiler must assume that the two arguments are */ -/* not the same variable, and the test will not be optimized away. */ -/* Interprocedural or whole-program optimization may delete this */ -/* test. The ISNAN functions will be replaced by the correct */ -/* Fortran 03 intrinsic once the intrinsic is widely available. */ - -/* Arguments */ -/* ========= */ - -/* SIN1 (input) REAL */ -/* SIN2 (input) REAL */ -/* Two numbers to compare for inequality. */ - -/* ===================================================================== */ - -/* .. Executable Statements .. */ - ret_val = *sin1 != *sin2; - return ret_val; -} /* slaisnan_ */ diff --git a/external/clapack/lapack/slamch.cpp b/external/clapack/lapack/slamch.cpp deleted file mode 100644 index 5f210b12..00000000 --- a/external/clapack/lapack/slamch.cpp +++ /dev/null @@ -1,967 +0,0 @@ -#include "clapack.h" -#include "melder.h" -#include "f2cP.h" - -/* Table of constant values */ - -static float c_b32 = 0.f; - -int slamc1_(integer *beta, integer *t, bool *rnd, bool *ieee1); -int slamc2_(integer *beta, integer *t, bool *rnd, float * - eps, integer *emin, float *rmin, integer *emax, float *rmax); -double slamc3_(float *a, float *b); -int slamc4_(integer *emin, float *start, integer *base); -int slamc5_(integer *beta, integer *p, integer *emin, - bool *ieee, integer *emax, float *rmax); - -double slamch_(const char *cmach) -{ - /* Initialized data */ - - static bool first = true; - - /* System generated locals */ - integer i__1; - float ret_val; - - /* Local variables */ - static float t; - integer it; - static float rnd, eps, base; - integer beta; - static float emin, prec, emax; - integer imin, imax; - bool lrnd; - static float rmin, rmax; - float rmach; - float small; - static float sfmin; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAMCH determines single precision machine parameters. */ - -/* Arguments */ -/* ========= */ - -/* CMACH (input) CHARACTER*1 */ -/* Specifies the value to be returned by SLAMCH: */ -/* = 'E' or 'e', SLAMCH := eps */ -/* = 'S' or 's , SLAMCH := sfmin */ -/* = 'B' or 'b', SLAMCH := base */ -/* = 'P' or 'p', SLAMCH := eps*base */ -/* = 'N' or 'n', SLAMCH := t */ -/* = 'R' or 'r', SLAMCH := rnd */ -/* = 'M' or 'm', SLAMCH := emin */ -/* = 'U' or 'u', SLAMCH := rmin */ -/* = 'L' or 'l', SLAMCH := emax */ -/* = 'O' or 'o', SLAMCH := 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 .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (first) { - slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); - base = (float) beta; - t = (float) it; - if (lrnd) { - rnd = 1.f; - i__1 = 1 - it; - eps = pow_ri(&base, &i__1) / 2; - } else { - rnd = 0.f; - i__1 = 1 - it; - eps = pow_ri(&base, &i__1); - } - prec = eps * base; - emin = (float) imin; - emax = (float) imax; - sfmin = rmin; - small = 1.f / rmax; - if (small >= sfmin) { - -/* Use SMALL plus a bit, to avoid the possibility of rounding */ -/* causing overflow when computing 1/sfmin. */ - - sfmin = small * (eps + 1.f); - } - } - - if (lsame_(cmach, "E")) { - rmach = eps; - } else if (lsame_(cmach, "S")) { - rmach = sfmin; - } else if (lsame_(cmach, "B")) { - rmach = base; - } else if (lsame_(cmach, "P")) { - rmach = prec; - } else if (lsame_(cmach, "N")) { - rmach = t; - } else if (lsame_(cmach, "R")) { - rmach = rnd; - } else if (lsame_(cmach, "M")) { - rmach = emin; - } else if (lsame_(cmach, "U")) { - rmach = rmin; - } else if (lsame_(cmach, "L")) { - rmach = emax; - } else if (lsame_(cmach, "O")) { - rmach = rmax; - } - - ret_val = rmach; - first = false; - return ret_val; - -/* End of SLAMCH */ - -} /* slamch_ */ - - -/* *********************************************************************** */ - -/* Subroutine */ int slamc1_(integer *beta, integer *t, bool *rnd, bool - *ieee1) -{ - /* Initialized data */ - - static bool first = true; - - /* System generated locals */ - float r__1, r__2; - - /* Local variables */ - float a, b, c__, f, t1, t2; - static integer lt; - float one, qtr; - static bool lrnd; - static integer lbeta; - float savec; - static bool lieee1; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAMC1 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 .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (first) { - one = 1.f; - -/* LBETA, LIEEE1, LT and LRND are the local values of BETA, */ -/* IEEE1, T and RND. */ - -/* Throughout this routine we use the function SLAMC3 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.f; - c__ = 1.f; - -/* + WHILE( C.EQ.ONE )LOOP */ -L10: - if (c__ == one) { - a *= 2; - c__ = slamc3_(&a, &one); - r__1 = -a; - c__ = slamc3_(&c__, &r__1); - goto L10; - } -/* + END WHILE */ - -/* Now compute b = 2.0**m with the smallest positive integer m */ -/* such that */ - -/* fl( a + b ) .gt. a. */ - - b = 1.f; - c__ = slamc3_(&a, &b); - -/* + WHILE( C.EQ.A )LOOP */ -L20: - if (c__ == a) { - b *= 2; - c__ = slamc3_(&a, &b); - goto L20; - } -/* + 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__; - r__1 = -a; - c__ = slamc3_(&c__, &r__1); - 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 = (float) lbeta; - r__1 = b / 2; - r__2 = -b / 100; - f = slamc3_(&r__1, &r__2); - c__ = slamc3_(&f, &a); - if (c__ == a) { - lrnd = true; - } else { - lrnd = false; - } - r__1 = b / 2; - r__2 = b / 100; - f = slamc3_(&r__1, &r__2); - c__ = slamc3_(&f, &a); - if (lrnd && c__ == 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. */ - - r__1 = b / 2; - t1 = slamc3_(&r__1, &a); - r__1 = b / 2; - t2 = slamc3_(&r__1, &savec); - lieee1 = t1 == a && t2 > savec && 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.f; - c__ = 1.f; - -/* + WHILE( C.EQ.ONE )LOOP */ -L30: - if (c__ == one) { - ++lt; - a *= lbeta; - c__ = slamc3_(&a, &one); - r__1 = -a; - c__ = slamc3_(&c__, &r__1); - goto L30; - } -/* + END WHILE */ - - } - - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *ieee1 = lieee1; - first = false; - return 0; - -/* End of SLAMC1 */ - -} /* slamc1_ */ - - -/* *********************************************************************** */ - -/* Subroutine */ int slamc2_(integer *beta, integer *t, bool *rnd, float * - eps, integer *emin, float *rmin, integer *emax, float *rmax) -{ - /* Initialized data */ - - static bool first = true; - static bool iwarn = false; - - /* System generated locals */ - integer i__1; - float r__1, r__2, r__3, r__4, r__5; - - /* Local variables */ - float a, b, c__; - integer i__; - static integer lt; - float one, two; - bool ieee; - float half; - bool lrnd; - static float leps; - float zero; - static integer lbeta; - float rbase; - static integer lemin, lemax; - integer gnmin; - float small; - integer gpmin; - float third; - static float lrmin, lrmax; - float sixth; - bool lieee1; - integer ngnmin, ngpmin; - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAMC2 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) REAL */ -/* 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) REAL */ -/* 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) REAL */ -/* 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 .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Data statements .. */ -/* .. */ -/* .. Executable Statements .. */ - - if (first) { - zero = 0.f; - one = 1.f; - two = 2.f; - -/* 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 SLAMC3 to ensure */ -/* that relevant values are stored and not held in registers, or */ -/* are not affected by optimizers. */ - -/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */ - - slamc1_(&lbeta, <, &lrnd, &lieee1); - -/* Start to find EPS. */ - - b = (float) lbeta; - i__1 = -lt; - a = pow_ri(&b, &i__1); - leps = a; - -/* Try some tricks to see whether or not this is the correct EPS. */ - - b = two / 3; - half = one / 2; - r__1 = -half; - sixth = slamc3_(&b, &r__1); - third = slamc3_(&sixth, &sixth); - r__1 = -half; - b = slamc3_(&third, &r__1); - b = slamc3_(&b, &sixth); - b = abs(b); - if (b < leps) { - b = leps; - } - - leps = 1.f; - -/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ -L10: - if (leps > b && b > zero) { - leps = b; - r__1 = half * leps; -/* Computing 5th power */ - r__3 = two, r__4 = r__3, r__3 *= r__3; -/* Computing 2nd power */ - r__5 = leps; - r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5); - c__ = slamc3_(&r__1, &r__2); - r__1 = -c__; - c__ = slamc3_(&half, &r__1); - b = slamc3_(&half, &c__); - r__1 = -b; - c__ = slamc3_(&half, &r__1); - b = slamc3_(&half, &c__); - goto L10; - } -/* + END WHILE */ - - if (a < 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; - for (i__ = 1; i__ <= 3; ++i__) { - r__1 = small * rbase; - small = slamc3_(&r__1, &zero); -/* L20: */ - } - a = slamc3_(&one, &small); - slamc4_(&ngpmin, &one, &lbeta); - r__1 = -one; - slamc4_(&ngnmin, &r__1, &lbeta); - slamc4_(&gpmin, &a, &lbeta); - r__1 = -a; - slamc4_(&gnmin, &r__1, &lbeta); - ieee = false; - - if (ngpmin == ngnmin && gpmin == gnmin) { - if (ngpmin == gpmin) { - lemin = ngpmin; -/* ( Non twos-complement machines, no gradual underflow; */ -/* e.g., VAX ) */ - } else if (gpmin - ngpmin == 3) { - lemin = ngpmin - 1 + lt; - ieee = true; -/* ( Non twos-complement machines, with gradual underflow; */ -/* e.g., IEEE standard followers ) */ - } else { - lemin = std::min(ngpmin,gpmin); -/* ( A guess; no known machine ) */ - iwarn = true; - } - - } else if (ngpmin == gpmin && ngnmin == gnmin) { - if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { - lemin = std::max(ngpmin,ngnmin); -/* ( Twos-complement machines, no gradual underflow; */ -/* e.g., CYBER 205 ) */ - } else { - lemin = std::min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = true; - } - - } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) - { - if (gpmin - std::min(ngpmin,ngnmin) == 3) { - lemin = std::max(ngpmin,ngnmin) - 1 + lt; -/* ( Twos-complement machines with gradual underflow; */ -/* no known machine ) */ - } else { - lemin = std::min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = true; - } - - } else { -/* Computing MIN */ - i__1 = std::min(ngpmin,ngnmin), i__1 = std::min(i__1,gpmin); - lemin = std::min(i__1,gnmin); -/* ( A guess; no known machine ) */ - iwarn = true; - } - first = false; -/* ** */ -/* Comment out this if block if EMIN is ok */ - if (iwarn) { - first = true; - Melder_warning (U"WARNING. The value EMIN may be incorrect:- \n" - "EMIN = ",lemin, - U"If, after inspection, the value EMIN looks acceptable please comment out \n" - "the IF block as marked within the code of routine SLAMC2, \n " - "otherwise supply EMIN explicitly.\n"); - } -/* ** */ - -/* Assume IEEE arithmetic if we found denormalised numbers above, */ -/* or if arithmetic seems to round in the IEEE style, determined */ -/* in routine SLAMC1. A true IEEE machine should have both things */ -/* true; however, faulty machines may have one or the other. */ - - ieee = ieee || 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.f; - i__1 = 1 - lemin; - for (i__ = 1; i__ <= i__1; ++i__) { - r__1 = lrmin * rbase; - lrmin = slamc3_(&r__1, &zero); -/* L30: */ - } - -/* Finally, call SLAMC5 to compute EMAX and RMAX. */ - - slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); - } - - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *eps = leps; - *emin = lemin; - *rmin = lrmin; - *emax = lemax; - *rmax = lrmax; - - return 0; - - -/* End of SLAMC2 */ - -} /* slamc2_ */ - - -/* *********************************************************************** */ - -double slamc3_(float *a, float *b) -{ - /* System generated locals */ - volatile float ret_val; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAMC3 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 (input) REAL */ -/* B (input) REAL */ -/* The values A and B. */ - -/* ===================================================================== */ - -/* .. Executable Statements .. */ - - ret_val = *a + *b; - - return ret_val; - -/* End of SLAMC3 */ - -} /* slamc3_ */ - - -/* *********************************************************************** */ - -/* Subroutine */ int slamc4_(integer *emin, float *start, integer *base) -{ - /* System generated locals */ - integer i__1; - float r__1; - - /* Local variables */ - float a; - integer i__; - float b1, b2, c1, c2, d1, d2, one, zero, rbase; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAMC4 is a service routine for SLAMC2. */ - -/* Arguments */ -/* ========= */ - -/* EMIN (output) INTEGER */ -/* 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) REAL */ -/* The starting point for determining EMIN. */ - -/* BASE (input) INTEGER */ -/* The base of the machine. */ - -/* ===================================================================== */ - -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - a = *start; - one = 1.f; - rbase = one / *base; - zero = 0.f; - *emin = 1; - r__1 = a * rbase; - b1 = slamc3_(&r__1, &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 */ -L10: - if (c1 == a && c2 == a && d1 == a && d2 == a) { - --(*emin); - a = b1; - r__1 = a / *base; - b1 = slamc3_(&r__1, &zero); - r__1 = b1 * *base; - c1 = slamc3_(&r__1, &zero); - d1 = zero; - i__1 = *base; - for (i__ = 1; i__ <= i__1; ++i__) { - d1 += b1; -/* L20: */ - } - r__1 = a * rbase; - b2 = slamc3_(&r__1, &zero); - r__1 = b2 / rbase; - c2 = slamc3_(&r__1, &zero); - d2 = zero; - i__1 = *base; - for (i__ = 1; i__ <= i__1; ++i__) { - d2 += b2; -/* L30: */ - } - goto L10; - } -/* + END WHILE */ - - return 0; - -/* End of SLAMC4 */ - -} /* slamc4_ */ - - -/* *********************************************************************** */ - -/* Subroutine */ int slamc5_(integer *beta, integer *p, integer *emin, - bool *ieee, integer *emax, float *rmax) -{ - /* System generated locals */ - integer i__1; - float r__1; - - /* Local variables */ - integer i__; - float y, z__; - integer try__, lexp; - float oldy; - integer uexp, nbits; - float recbas; - integer exbits, expsum; - - -/* -- LAPACK auxiliary routine (version 3.1) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SLAMC5 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) REAL */ -/* The largest machine floating-point number. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. 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; -L10: - try__ = lexp << 1; - if (try__ <= -(*emin)) { - lexp = try__; - ++exbits; - goto L10; - } - if (lexp == -(*emin)) { - uexp = lexp; - } else { - uexp = try__; - ++exbits; - } - -/* 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 > -lexp - *emin) { - expsum = lexp << 1; - } else { - expsum = uexp << 1; - } - -/* EXPSUM is the exponent range, approximately equal to */ -/* EMAX - EMIN + 1 . */ - - *emax = expsum + *emin - 1; - nbits = exbits + 1 + *p; - -/* NBITS is the total number of bits needed to store a */ -/* floating-point number. */ - - if (nbits % 2 == 1 && *beta == 2) { - -/* 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); - } - - if (*ieee) { - -/* Assume we are on an IEEE machine which reserves one exponent */ -/* for infinity and NaN. */ - - --(*emax); - } - -/* 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 = 1.f / *beta; - z__ = *beta - 1.f; - y = 0.f; - i__1 = *p; - for (i__ = 1; i__ <= i__1; ++i__) { - z__ *= recbas; - if (y < 1.f) { - oldy = y; - } - y = slamc3_(&y, &z__); -/* L20: */ - } - if (y >= 1.f) { - y = oldy; - } - -/* Now multiply by BETA**EMAX to get RMAX. */ - - i__1 = *emax; - for (i__ = 1; i__ <= i__1; ++i__) { - r__1 = y * *beta; - y = slamc3_(&r__1, &c_b32); -/* L30: */ - } - - *rmax = y; - return 0; - -/* End of SLAMC5 */ - -} /* slamc5_ */ diff --git a/external/clapack/lapack/spotf2.cpp b/external/clapack/lapack/spotf2.cpp deleted file mode 100644 index af8c17a7..00000000 --- a/external/clapack/lapack/spotf2.cpp +++ /dev/null @@ -1,197 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static float c_b10 = -1.f; -static float c_b12 = 1.f; - -int spotf2_(const char *uplo, integer *n, float *a, integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - float r__1; - - /* Local variables */ - integer j; - float ajj; - bool upper; - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SPOTF2 computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U' * U , if UPLO = 'U', or */ -/* A = L * L', if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n by n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U'*U or A = L*L'. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, the leading minor of order k is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SPOTF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute U(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j * a_dim1 + 1], &c__1, - &a[j * a_dim1 + 1], &c__1); - if (ajj <= 0.f || sisnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of row J. */ - - if (j < *n) { - i__2 = j - 1; - i__3 = *n - j; - sgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 - + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( - j + 1) * a_dim1], lda); - i__2 = *n - j; - r__1 = 1.f / ajj; - sscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute L(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j + a_dim1], lda, &a[j - + a_dim1], lda); - if (ajj <= 0.f || sisnan_(&ajj)) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of column J. */ - - if (j < *n) { - i__2 = *n - j; - i__3 = j - 1; - sgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + - a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + - j * a_dim1], &c__1); - i__2 = *n - j; - r__1 = 1.f / ajj; - sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1); - } -/* L20: */ - } - } - goto L40; - -L30: - *info = j; - -L40: - return 0; - -/* End of SPOTF2 */ - -} /* spotf2_ */ diff --git a/external/clapack/lapack/spotrf.cpp b/external/clapack/lapack/spotrf.cpp deleted file mode 100644 index 466999e3..00000000 --- a/external/clapack/lapack/spotrf.cpp +++ /dev/null @@ -1,218 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static float c_b13 = -1.f; -static float c_b14 = 1.f; - -int spotrf_(const char *uplo, integer *n, float *a, integer *lda, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer j, jb, nb; - float upper; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SPOTRF computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the block version of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) REAL array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < std::max(1_integer,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SPOTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "SPOTRF", uplo, n, &c_n1, &c_n1, &c_n1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code. */ - - spotf2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code. */ - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = std::min(i__3,i__4); - i__3 = j - 1; - ssyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j * - a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda); - spotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block row. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - sgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, & - c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) * - a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) * - a_dim1], lda); - i__3 = *n - j - jb + 1; - strsm_("Left", "Upper", "Transpose", "Non-unit", &jb, & - i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j - + jb) * a_dim1], lda); - } -/* L10: */ - } - - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__2 = *n; - i__1 = nb; - for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = std::min(i__3,i__4); - i__3 = j - 1; - ssyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j + - a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda); - spotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block column. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, & - c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1], - lda, &c_b14, &a[j + jb + j * a_dim1], lda); - i__3 = *n - j - jb + 1; - strsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, & - jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb + - j * a_dim1], lda); - } -/* L20: */ - } - } - } - goto L40; - -L30: - *info = *info + j - 1; - -L40: - return 0; - -/* End of SPOTRF */ - -} /* spotrf_ */ diff --git a/external/clapack/lapack/spotrs.cpp b/external/clapack/lapack/spotrs.cpp deleted file mode 100644 index 4ac133a2..00000000 --- a/external/clapack/lapack/spotrs.cpp +++ /dev/null @@ -1,147 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -/* Table of constant values */ - -static float c_b9 = 1.f; - -int spotrs_(const char *uplo, integer *n, integer *nrhs, float *a, - integer *lda, float *b, integer *ldb, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - - bool upper; - - -/* -- LAPACK routine (version 3.2) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ -/* November 2006 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* SPOTRS solves a system of linear equations A*X = B with a symmetric */ -/* positive definite matrix A using the Cholesky factorization */ -/* A = U**T*U or A = L*L**T computed by SPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input) REAL array, dimension (LDA,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) REAL array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < std::max(1_integer,*n)) { - *info = -5; - } else if (*ldb < std::max(1_integer,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("SPOTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B where A = U'*U. */ - -/* Solve U'*X = B, overwriting B with X. */ - - strsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Solve U*X = B, overwriting B with X. */ - - strsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb); - } else { - -/* Solve A*X = B where A = L*L'. */ - -/* Solve L*X = B, overwriting B with X. */ - - strsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb); - -/* Solve L'*X = B, overwriting B with X. */ - - strsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb); - } - - return 0; - -/* End of SPOTRS */ - -} /* spotrs_ */ diff --git a/external/clapack/lapack/ssfrk.cpp b/external/clapack/lapack/ssfrk.cpp deleted file mode 100644 index d13d5b8e..00000000 --- a/external/clapack/lapack/ssfrk.cpp +++ /dev/null @@ -1,496 +0,0 @@ -#include "clapack.h" -#include "f2cP.h" - -int ssfrk_(const char *transr, const char *uplo, const char *trans, integer *n, - integer *k, float *alpha, float *a, integer *lda, float *beta, float *c__) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - - /* Local variables */ - integer j, n1, n2, nk, info; - bool normaltransr; - integer nrowa; - bool lower, nisodd, notrans; - - -/* -- LAPACK routine (version 3.2) -- */ - -/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */ -/* -- November 2008 -- */ - -/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ -/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ - -/* .. */ -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* Level 3 BLAS like routine for C in RFP Format. */ - -/* SSFRK performs one of the symmetric rank--k operations */ - -/* C := alpha*A*A' + beta*C, */ - -/* or */ - -/* C := alpha*A'*A + beta*C, */ - -/* where alpha and beta are real scalars, C is an n--by--n symmetric */ -/* matrix and A is an n--by--k matrix in the first case and a k--by--n */ -/* matrix in the second case. */ - -/* Arguments */ -/* ========== */ - -/* TRANSR (input) CHARACTER */ -/* = 'N': The Normal Form of RFP A is stored; */ -/* = 'T': The Transpose Form of RFP A is stored. */ - -/* UPLO - (input) CHARACTER */ -/* On entry, UPLO specifies whether the upper or lower */ -/* triangular part of the array C is to be referenced as */ -/* follows: */ - -/* UPLO = 'U' or 'u' Only the upper triangular part of C */ -/* is to be referenced. */ - -/* UPLO = 'L' or 'l' Only the lower triangular part of C */ -/* is to be referenced. */ - -/* Unchanged on exit. */ - -/* TRANS - (input) CHARACTER */ -/* On entry, TRANS specifies the operation to be performed as */ -/* follows: */ - -/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ - -/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ - -/* Unchanged on exit. */ - -/* N - (input) INTEGER. */ -/* On entry, N specifies the order of the matrix C. N must be */ -/* at least zero. */ -/* Unchanged on exit. */ - -/* K - (input) INTEGER. */ -/* On entry with TRANS = 'N' or 'n', K specifies the number */ -/* of columns of the matrix A, and on entry with TRANS = 'T' */ -/* or 't', K specifies the number of rows of the matrix A. K */ -/* must be at least zero. */ -/* Unchanged on exit. */ - -/* ALPHA - (input) REAL. */ -/* On entry, ALPHA specifies the scalar alpha. */ -/* Unchanged on exit. */ - -/* A - (input) REAL array of DIMENSION ( LDA, ka ), where KA */ -/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */ -/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */ -/* the array A must contain the matrix A, otherwise the leading */ -/* K--by--N part of the array A must contain the matrix A. */ -/* Unchanged on exit. */ - -/* LDA - (input) INTEGER. */ -/* On entry, LDA specifies the first dimension of A as declared */ -/* in the calling (sub) program. When TRANS = 'N' or 'n' */ -/* then LDA must be at least max( 1, n ), otherwise LDA must */ -/* be at least max( 1, k ). */ -/* Unchanged on exit. */ - -/* BETA - (input) REAL. */ -/* On entry, BETA specifies the scalar beta. */ -/* Unchanged on exit. */ - - -/* C - (input/output) REAL array, dimension ( NT ); */ -/* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP */ -/* Format. RFP Format is described by TRANSR, UPLO and N. */ - -/* Arguments */ -/* ========== */ - -/* .. */ -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --c__; - - /* Function Body */ - info = 0; - normaltransr = lsame_(transr, "N"); - lower = lsame_(uplo, "L"); - notrans = lsame_(trans, "N"); - - if (notrans) { - nrowa = *n; - } else { - nrowa = *k; - } - - if (! normaltransr && ! lsame_(transr, "T")) { - info = -1; - } else if (! lower && ! lsame_(uplo, "U")) { - info = -2; - } else if (! notrans && ! lsame_(trans, "T")) { - info = -3; - } else if (*n < 0) { - info = -4; - } else if (*k < 0) { - info = -5; - } else if (*lda < std::max(1_integer,nrowa)) { - info = -8; - } - if (info != 0) { - i__1 = -info; - xerbla_("SSFRK ", &i__1); - return 0; - } - -/* Quick return if possible. */ - -/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */ -/* done (it is in SSYRK for example) and left in the general case. */ - - if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) { - return 0; - } - - if (*alpha == 0.f && *beta == 0.f) { - i__1 = *n * (*n + 1) / 2; - for (j = 1; j <= i__1; ++j) { - c__[j] = 0.f; - } - return 0; - } - -/* C is N-by-N. */ -/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ -/* If N is even, NISODD = .FALSE., and NK. */ - - if (*n % 2 == 0) { - nisodd = false; - nk = *n / 2; - } else { - nisodd = true; - if (lower) { - n2 = *n / 2; - n1 = *n - n2; - } else { - n1 = *n / 2; - n2 = *n - n1; - } - } - - if (nisodd) { - -/* N is odd */ - - if (normaltransr) { - -/* N is odd and TRANSR = 'N' */ - - if (lower) { - -/* N is odd, TRANSR = 'N', and UPLO = 'L' */ - - if (notrans) { - -/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */ - - ssyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[1], n); - ssyrk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, - beta, &c__[*n + 1], n); - sgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1], - lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1], n); - - } else { - -/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */ - - ssyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[1], n); - ssyrk_("U", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], - lda, beta, &c__[*n + 1], n) - ; - sgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1 - + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1] -, n); - - } - - } else { - -/* N is odd, TRANSR = 'N', and UPLO = 'U' */ - - if (notrans) { - -/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */ - - ssyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[n2 + 1], n); - ssyrk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda, - beta, &c__[n1 + 1], n); - sgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, - &a[n2 + a_dim1], lda, beta, &c__[1], n); - - } else { - -/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */ - - ssyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[n2 + 1], n); - ssyrk_("U", "T", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda, - beta, &c__[n1 + 1], n); - sgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, - &a[n2 * a_dim1 + 1], lda, beta, &c__[1], n); - - } - - } - - } else { - -/* N is odd, and TRANSR = 'T' */ - - if (lower) { - -/* N is odd, TRANSR = 'T', and UPLO = 'L' */ - - if (notrans) { - -/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */ - - ssyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[1], &n1); - ssyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, - beta, &c__[2], &n1); - sgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, - &a[n1 + 1 + a_dim1], lda, beta, &c__[n1 * n1 + 1], - &n1); - - } else { - -/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */ - - ssyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[1], &n1); - ssyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], - lda, beta, &c__[2], &n1); - sgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, - &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[n1 * - n1 + 1], &n1); - - } - - } else { - -/* N is odd, TRANSR = 'T', and UPLO = 'U' */ - - if (notrans) { - -/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */ - - ssyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[n2 * n2 + 1], &n2); - ssyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, - beta, &c__[n1 * n2 + 1], &n2); - sgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1], - lda, &a[a_dim1 + 1], lda, beta, &c__[1], &n2); - - } else { - -/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */ - - ssyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[n2 * n2 + 1], &n2); - ssyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], - lda, beta, &c__[n1 * n2 + 1], &n2); - sgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1 - + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], & - n2); - - } - - } - - } - - } else { - -/* N is even */ - - if (normaltransr) { - -/* N is even and TRANSR = 'N' */ - - if (lower) { - -/* N is even, TRANSR = 'N', and UPLO = 'L' */ - - if (notrans) { - -/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */ - - i__1 = *n + 1; - ssyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[2], &i__1); - i__1 = *n + 1; - ssyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, - beta, &c__[1], &i__1); - i__1 = *n + 1; - sgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1], - lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], & - i__1); - - } else { - -/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */ - - i__1 = *n + 1; - ssyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[2], &i__1); - i__1 = *n + 1; - ssyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], - lda, beta, &c__[1], &i__1); - i__1 = *n + 1; - sgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1 - + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2] -, &i__1); - - } - - } else { - -/* N is even, TRANSR = 'N', and UPLO = 'U' */ - - if (notrans) { - -/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */ - - i__1 = *n + 1; - ssyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk + 2], &i__1); - i__1 = *n + 1; - ssyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, - beta, &c__[nk + 1], &i__1); - i__1 = *n + 1; - sgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, - &a[nk + 1 + a_dim1], lda, beta, &c__[1], &i__1); - - } else { - -/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */ - - i__1 = *n + 1; - ssyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk + 2], &i__1); - i__1 = *n + 1; - ssyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], - lda, beta, &c__[nk + 1], &i__1); - i__1 = *n + 1; - sgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, - &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[1], & - i__1); - - } - - } - - } else { - -/* N is even, and TRANSR = 'T' */ - - if (lower) { - -/* N is even, TRANSR = 'T', and UPLO = 'L' */ - - if (notrans) { - -/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */ - - ssyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk + 1], &nk); - ssyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, - beta, &c__[1], &nk); - sgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, - &a[nk + 1 + a_dim1], lda, beta, &c__[(nk + 1) * - nk + 1], &nk); - - } else { - -/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */ - - ssyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk + 1], &nk); - ssyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], - lda, beta, &c__[1], &nk); - sgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, - &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[(nk + - 1) * nk + 1], &nk); - - } - - } else { - -/* N is even, TRANSR = 'T', and UPLO = 'U' */ - - if (notrans) { - -/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */ - - ssyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk * (nk + 1) + 1], &nk); - ssyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, - beta, &c__[nk * nk + 1], &nk); - sgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1], - lda, &a[a_dim1 + 1], lda, beta, &c__[1], &nk); - - } else { - -/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */ - - ssyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, - &c__[nk * (nk + 1) + 1], &nk); - ssyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], - lda, beta, &c__[nk * nk + 1], &nk); - sgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1 - + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], & - nk); - - } - - } - - } - - } - - return 0; - -/* End of SSFRK */ - -} /* ssfrk_ */ diff --git a/external/clapack/lapack_dg.cpp b/external/clapack/lapack_dg.cpp new file mode 100644 index 00000000..b969c695 --- /dev/null +++ b/external/clapack/lapack_dg.cpp @@ -0,0 +1,31320 @@ +#include "clapack.h" +#include "f2cP.h" + +/* Subroutine */ int dgbbrd_(const char *vect, integer *m, integer *n, integer *ncc, + integer *kl, integer *ku, double *ab, integer *ldab, double * + d__, double *e, double *q, integer *ldq, double *pt, + integer *ldpt, double *c__, integer *ldc, double *work, + integer *info) +{ + /* Table of constant values */ + static double c_b8 = 0.; + static double c_b9 = 1.; + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1, + q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + + /* Local variables */ + integer i__, j, l, j1, j2, kb; + double ra, rb, rc; + integer kk, ml, mn, nr, mu; + double rs; + integer kb1, ml0, mu0, klm, kun, nrt, klu1, inca; + bool wantb, wantc; + integer minmn; + bool wantq; + bool wantpt; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBBRD reduces a real general m-by-n band matrix A to upper */ +/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */ + +/* The routine computes B, and optionally forms Q or P', or computes */ +/* Q'*C for a given matrix C. */ + +/* Arguments */ +/* ========= */ + +/* VECT (input) CHARACTER*1 */ +/* Specifies whether or not the matrices Q and P' are to be */ +/* formed. */ +/* = 'N': do not form Q or P'; */ +/* = 'Q': form Q only; */ +/* = 'P': form P' only; */ +/* = 'B': form both. */ + +/* 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. */ + +/* NCC (input) INTEGER */ +/* The number of columns of the matrix C. NCC >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals of the matrix A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals of the matrix A. KU >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the m-by-n band matrix A, stored in rows 1 to */ +/* KL+KU+1. The j-th column of A is stored in the j-th column of */ +/* the array AB as follows: */ +/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */ +/* On exit, A is overwritten by values generated during the */ +/* reduction. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array A. LDAB >= KL+KU+1. */ + +/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The diagonal elements of the bidiagonal matrix B. */ + +/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */ +/* The superdiagonal elements of the bidiagonal matrix B. */ + +/* Q (output) DOUBLE PRECISION array, dimension (LDQ,M) */ +/* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. */ +/* If VECT = 'N' or 'P', the array Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. */ +/* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */ + +/* PT (output) DOUBLE PRECISION array, dimension (LDPT,N) */ +/* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. */ +/* If VECT = 'N' or 'Q', the array PT is not referenced. */ + +/* LDPT (input) INTEGER */ +/* The leading dimension of the array PT. */ +/* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */ + +/* C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC) */ +/* On entry, an m-by-ncc matrix C. */ +/* On exit, C is overwritten by Q'*C. */ +/* C is not referenced if NCC = 0. */ + +/* LDC (input) INTEGER */ +/* The leading dimension of the array C. */ +/* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N)) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + pt_dim1 = *ldpt; + pt_offset = 1 + pt_dim1; + pt -= pt_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + wantb = lsame_(vect, "B"); + wantq = lsame_(vect, "Q") || wantb; + wantpt = lsame_(vect, "P") || wantb; + wantc = *ncc > 0; + klu1 = *kl + *ku + 1; + *info = 0; + if (! wantq && ! wantpt && ! lsame_(vect, "N")) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ncc < 0) { + *info = -4; + } else if (*kl < 0) { + *info = -5; + } else if (*ku < 0) { + *info = -6; + } else if (*ldab < klu1) { + *info = -8; + } else if (*ldq < 1 || wantq && *ldq < std::max(1_integer,*m)) { + *info = -12; + } else if (*ldpt < 1 || wantpt && *ldpt < std::max(1_integer,*n)) { + *info = -14; + } else if (*ldc < 1 || wantc && *ldc < std::max(1_integer,*m)) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBBRD", &i__1); + return 0; + } + +/* Initialize Q and P' to the unit matrix, if needed */ + + if (wantq) { + dlaset_("Full", m, m, &c_b8, &c_b9, &q[q_offset], ldq); + } + if (wantpt) { + dlaset_("Full", n, n, &c_b8, &c_b9, &pt[pt_offset], ldpt); + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + + minmn = std::min(*m,*n); + + if (*kl + *ku > 1) { + +/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */ +/* first to lower bidiagonal form and then transform to upper */ +/* bidiagonal */ + + if (*ku > 0) { + ml0 = 1; + mu0 = 2; + } else { + ml0 = 2; + mu0 = 1; + } + +/* Wherever possible, plane rotations are generated and applied in */ +/* vector operations of length NR over the index set J1:J2:KLU1. */ + +/* The sines of the plane rotations are stored in WORK(1:max(m,n)) */ +/* and the cosines in WORK(max(m,n)+1:2*max(m,n)). */ + + mn = std::max(*m,*n); +/* Computing MIN */ + i__1 = *m - 1; + klm = std::min(i__1,*kl); +/* Computing MIN */ + i__1 = *n - 1; + kun = std::min(i__1,*ku); + kb = klm + kun; + kb1 = kb + 1; + inca = kb1 * *ldab; + nr = 0; + j1 = klm + 2; + j2 = 1 - kun; + + i__1 = minmn; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Reduce i-th column and i-th row of matrix to bidiagonal form */ + + ml = klm + 1; + mu = kun + 1; + i__2 = kb; + for (kk = 1; kk <= i__2; ++kk) { + j1 += kb; + j2 += kb; + +/* generate plane rotations to annihilate nonzero elements */ +/* which have been created below the band */ + + if (nr > 0) { + dlargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca, + &work[j1], &kb1, &work[mn + j1], &kb1); + } + +/* apply plane rotations from the left */ + + i__3 = kb; + for (l = 1; l <= i__3; ++l) { + if (j2 - klm + l - 1 > *n) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + dlartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) * + ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm + + l - 1) * ab_dim1], &inca, &work[mn + j1], & + work[j1], &kb1); + } +/* L10: */ + } + + if (ml > ml0) { + if (ml <= *m - i__ + 1) { + +/* generate plane rotation to annihilate a(i+ml-1,i) */ +/* within the band, and apply rotation from the left */ + + dlartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku + + ml + i__ * ab_dim1], &work[mn + i__ + ml - 1], + &work[i__ + ml - 1], &ra); + ab[*ku + ml - 1 + i__ * ab_dim1] = ra; + if (i__ < *n) { +/* Computing MIN */ + i__4 = *ku + ml - 2, i__5 = *n - i__; + i__3 = std::min(i__4,i__5); + i__6 = *ldab - 1; + i__7 = *ldab - 1; + drot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) * + ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__ + + 1) * ab_dim1], &i__7, &work[mn + i__ + + ml - 1], &work[i__ + ml - 1]); + } + } + ++nr; + j1 -= kb1; + } + + if (wantq) { + +/* accumulate product of plane rotations in Q */ + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) + { + drot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j * + q_dim1 + 1], &c__1, &work[mn + j], &work[j]); +/* L20: */ + } + } + + if (wantc) { + +/* apply plane rotations to C */ + + i__4 = j2; + i__3 = kb1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) + { + drot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1] +, ldc, &work[mn + j], &work[j]); +/* L30: */ + } + } + + if (j2 + kun > *n) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 -= kb1; + } + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j-1,j+ku) above the band */ +/* and store it in WORK(n+1:2*n) */ + + work[j + kun] = work[j] * ab[(j + kun) * ab_dim1 + 1]; + ab[(j + kun) * ab_dim1 + 1] = work[mn + j] * ab[(j + kun) + * ab_dim1 + 1]; +/* L40: */ + } + +/* generate plane rotations to annihilate nonzero elements */ +/* which have been generated above the band */ + + if (nr > 0) { + dlargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, & + work[j1 + kun], &kb1, &work[mn + j1 + kun], &kb1); + } + +/* apply plane rotations from the right */ + + i__4 = kb; + for (l = 1; l <= i__4; ++l) { + if (j2 + l - 1 > *m) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + dlartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], & + inca, &ab[l + (j1 + kun) * ab_dim1], &inca, & + work[mn + j1 + kun], &work[j1 + kun], &kb1); + } +/* L50: */ + } + + if (ml == ml0 && mu > mu0) { + if (mu <= *n - i__ + 1) { + +/* generate plane rotation to annihilate a(i,i+mu-1) */ +/* within the band, and apply rotation from the right */ + + dlartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1], + &ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1], + &work[mn + i__ + mu - 1], &work[i__ + mu - 1], + &ra); + ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1] = ra; +/* Computing MIN */ + i__3 = *kl + mu - 2, i__5 = *m - i__; + i__4 = std::min(i__3,i__5); + drot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) * + ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu + - 1) * ab_dim1], &c__1, &work[mn + i__ + mu - + 1], &work[i__ + mu - 1]); + } + ++nr; + j1 -= kb1; + } + + if (wantpt) { + +/* accumulate product of plane rotations in P' */ + + i__4 = j2; + i__3 = kb1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) + { + drot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j + + kun + pt_dim1], ldpt, &work[mn + j + kun], & + work[j + kun]); +/* L60: */ + } + } + + if (j2 + kb > *m) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 -= kb1; + } + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j+kl+ku,j+ku-1) below the */ +/* band and store it in WORK(1:n) */ + + work[j + kb] = work[j + kun] * ab[klu1 + (j + kun) * + ab_dim1]; + ab[klu1 + (j + kun) * ab_dim1] = work[mn + j + kun] * ab[ + klu1 + (j + kun) * ab_dim1]; +/* L70: */ + } + + if (ml > ml0) { + --ml; + } else { + --mu; + } +/* L80: */ + } +/* L90: */ + } + } + + if (*ku == 0 && *kl > 0) { + +/* A has been reduced to lower bidiagonal form */ + +/* Transform lower bidiagonal form to upper bidiagonal by applying */ +/* plane rotations from the left, storing diagonal elements in D */ +/* and off-diagonal elements in E */ + +/* Computing MIN */ + i__2 = *m - 1; + i__1 = std::min(i__2,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs, + &ra); + d__[i__] = ra; + if (i__ < *n) { + e[i__] = rs * ab[(i__ + 1) * ab_dim1 + 1]; + ab[(i__ + 1) * ab_dim1 + 1] = rc * ab[(i__ + 1) * ab_dim1 + 1] + ; + } + if (wantq) { + drot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 + + 1], &c__1, &rc, &rs); + } + if (wantc) { + drot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1], + ldc, &rc, &rs); + } +/* L100: */ + } + if (*m <= *n) { + d__[*m] = ab[*m * ab_dim1 + 1]; + } + } else if (*ku > 0) { + +/* A has been reduced to upper bidiagonal form */ + + if (*m < *n) { + +/* Annihilate a(m,m+1) by applying plane rotations from the */ +/* right, storing diagonal elements in D and off-diagonal */ +/* elements in E */ + + rb = ab[*ku + (*m + 1) * ab_dim1]; + for (i__ = *m; i__ >= 1; --i__) { + dlartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra); + d__[i__] = ra; + if (i__ > 1) { + rb = -rs * ab[*ku + i__ * ab_dim1]; + e[i__ - 1] = rc * ab[*ku + i__ * ab_dim1]; + } + if (wantpt) { + drot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1], + ldpt, &rc, &rs); + } +/* L110: */ + } + } else { + +/* Copy off-diagonal elements to E and diagonal elements to D */ + + i__1 = minmn - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = ab[*ku + (i__ + 1) * ab_dim1]; +/* L120: */ + } + i__1 = minmn; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[*ku + 1 + i__ * ab_dim1]; +/* L130: */ + } + } + } else { + +/* A is diagonal. Set elements of E to zero and copy diagonal */ +/* elements to D. */ + + i__1 = minmn - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = 0.; +/* L140: */ + } + i__1 = minmn; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[i__ * ab_dim1 + 1]; +/* L150: */ + } + } + return 0; + +/* End of DGBBRD */ + +} /* dgbbrd_ */ + +/* Subroutine */ int dgbcon_(const char *norm, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, integer *ipiv, double *anorm, + double *rcond, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer j; + double t; + integer kd, lm, jp, ix, kase; + integer kase1; + double scale; + integer isave[3]; + bool lnoti; + double ainvnm; + bool onenrm; + char normin[1]; + double smlnum; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBCON estimates the reciprocal of the condition number of a real */ +/* general band matrix A, in either the 1-norm or the infinity-norm, */ +/* using the LU factorization computed by DGBTRF. */ + +/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* condition number is computed as */ +/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies whether the 1-norm condition number or the */ +/* infinity-norm condition number is required: */ +/* = '1' or 'O': 1-norm; */ +/* = 'I': Infinity-norm. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* Details of the LU factorization of the band matrix A, as */ +/* computed by DGBTRF. U is stored as an upper triangular band */ +/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* the multipliers used during the factorization are stored in */ +/* rows KL+KU+2 to 2*KL+KU+1. */ +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices; for 1 <= i <= N, row i of the matrix was */ +/* interchanged with row IPIV(i). */ + +/* ANORM (input) DOUBLE PRECISION */ +/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ +/* If NORM = 'I', the infinity-norm of the original matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --ipiv; + --work; + --iwork; + + /* Function Body */ + *info = 0; + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < (*kl << 1) + *ku + 1) { + *info = -6; + } else if (*anorm < 0.) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + + smlnum = dlamch_("Safe minimum"); + +/* Estimate the norm of inv(A). */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kd = *kl + *ku + 1; + lnoti = *kl > 0; + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(L). */ + + if (lnoti) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kl, i__3 = *n - j; + lm = std::min(i__2,i__3); + jp = ipiv[j]; + t = work[jp]; + if (jp != j) { + work[jp] = work[j]; + work[j] = t; + } + d__1 = -t; + daxpy_(&lm, &d__1, &ab[kd + 1 + j * ab_dim1], &c__1, & + work[j + 1], &c__1); +/* L20: */ + } + } + +/* Multiply by inv(U). */ + + i__1 = *kl + *ku; + dlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, & + ab[ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + + 1], info); + } else { + +/* Multiply by inv(U'). */ + + i__1 = *kl + *ku; + dlatbs_("Upper", "Transpose", "Non-unit", normin, n, &i__1, &ab[ + ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 1], + info); + +/* Multiply by inv(L'). */ + + if (lnoti) { + for (j = *n - 1; j >= 1; --j) { +/* Computing MIN */ + i__1 = *kl, i__2 = *n - j; + lm = std::min(i__1,i__2); + work[j] -= ddot_(&lm, &ab[kd + 1 + j * ab_dim1], &c__1, & + work[j + 1], &c__1); + jp = ipiv[j]; + if (jp != j) { + t = work[jp]; + work[jp] = work[j]; + work[j] = t; + } +/* L30: */ + } + } + } + +/* Divide X by 1/SCALE if doing so will not cause overflow. */ + + *(unsigned char *)normin = 'Y'; + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) + { + goto L40; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + +L40: + return 0; + +/* End of DGBCON */ + +} /* dgbcon_ */ + +/* Subroutine */ int dgbequ_(integer *m, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, double *r__, double *c__, + double *rowcnd, double *colcnd, double *amax, integer * + info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, kd; + double rcmin, rcmax; + double bignum, smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBEQU computes row and column scalings intended to equilibrate an */ +/* M-by-N band matrix A and reduce its condition number. R returns the */ +/* row scale factors and C the column scale factors, chosen to try to */ +/* make the largest element in each row and column of the matrix B with */ +/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ + +/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ +/* number and BIGNUM = largest safe number. Use of these scaling */ +/* factors is not guaranteed to reduce the condition number of A but */ +/* works well in practice. */ + +/* 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. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ +/* column of A is stored in the j-th column of the array AB as */ +/* follows: */ +/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ + +/* R (output) DOUBLE PRECISION array, dimension (M) */ +/* If INFO = 0, or INFO > M, R contains the row scale factors */ +/* for A. */ + +/* C (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, C contains the column scale factors for A. */ + +/* ROWCND (output) DOUBLE PRECISION */ +/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* AMAX is neither too large nor too small, it is not worth */ +/* scaling by R. */ + +/* COLCND (output) DOUBLE PRECISION */ +/* If INFO = 0, COLCND contains the ratio of the smallest */ +/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* worth scaling by C. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= M: the i-th row of A is exactly zero */ +/* > M: the (i-M)-th column of A is exactly zero */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBEQU", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.; + *colcnd = 1.; + *amax = 0.; + return 0; + } + +/* Get machine constants. */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = std::min(i__4,*m); + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = r__[i__], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], + abs(d__1)); + r__[i__] = std::max(d__2,d__3); +/* L20: */ + } +/* L30: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[i__]; + rcmax = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[i__]; + rcmin = std::min(d__1,d__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = r__[i__]; + d__1 = std::max(d__2,smlnum); + r__[i__] = 1. / std::min(d__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = min(R(I)) / max(R(I)) */ + + *rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } + +/* Compute column scale factors */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__2 = std::min(i__4,*m); + for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = c__[j], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs( + d__1)) * r__[i__]; + c__[j] = std::max(d__2,d__3); +/* L80: */ + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = std::max(d__1,d__2); +/* L100: */ + } + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = c__[j]; + d__1 = std::max(d__2,smlnum); + c__[j] = 1. / std::min(d__1,bignum); +/* L120: */ + } + +/* Compute COLCND = min(C(J)) / max(C(J)) */ + + *colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } + + return 0; + +/* End of DGBEQU */ + +} /* dgbequ_ */ + +/* Subroutine */ int dgbequb_(integer *m, integer *n, integer *kl, integer * + ku, double *ab, integer *ldab, double *r__, double *c__, + double *rowcnd, double *colcnd, double *amax, integer * + info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, kd; + double radix, rcmin, rcmax; + double bignum, logrdx, smlnum; + + +/* -- LAPACK routine (version 3.2) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBEQUB computes row and column scalings intended to equilibrate an */ +/* M-by-N matrix A and reduce its condition number. R returns the row */ +/* scale factors and C the column scale factors, chosen to try to make */ +/* the largest element in each row and column of the matrix B with */ +/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */ +/* the radix. */ + +/* R(i) and C(j) are restricted to be a power of the radix between */ +/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */ +/* of these scaling factors is not guaranteed to reduce the condition */ +/* number of A but works well in practice. */ + +/* This routine differs from DGEEQU by restricting the scaling factors */ +/* to a power of the radix. Baring over- and underflow, scaling by */ +/* these factors introduces no additional rounding errors. However, the */ +/* scaled entries' magnitured are no longer approximately 1 but lie */ +/* between sqrt(radix) and 1/sqrt(radix). */ + +/* 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. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array A. LDAB >= max(1,M). */ + +/* R (output) DOUBLE PRECISION array, dimension (M) */ +/* If INFO = 0 or INFO > M, R contains the row scale factors */ +/* for A. */ + +/* C (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, C contains the column scale factors for A. */ + +/* ROWCND (output) DOUBLE PRECISION */ +/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* AMAX is neither too large nor too small, it is not worth */ +/* scaling by R. */ + +/* COLCND (output) DOUBLE PRECISION */ +/* If INFO = 0, COLCND contains the ratio of the smallest */ +/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* worth scaling by C. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= M: the i-th row of A is exactly zero */ +/* > M: the (i-M)-th column of A is exactly zero */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBEQUB", &i__1); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.; + *colcnd = 1.; + *amax = 0.; + return 0; + } + +/* Get machine constants. Assume SMLNUM is a power of the radix. */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + radix = dlamch_("B"); + logrdx = log(radix); + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = std::min(i__4,*m); + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = r__[i__], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], + abs(d__1)); + r__[i__] = std::max(d__2,d__3); +/* L20: */ + } +/* L30: */ + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] > 0.) { + i__3 = (integer) (log(r__[i__]) / logrdx); + r__[i__] = pow_di(&radix, &i__3); + } + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[i__]; + rcmax = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[i__]; + rcmin = std::min(d__1,d__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = r__[i__]; + d__1 = std::max(d__2,smlnum); + r__[i__] = 1. / std::min(d__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = min(R(I)) / max(R(I)). */ + + *rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } + +/* Compute column scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__2 = std::min(i__4,*m); + for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = c__[j], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs( + d__1)) * r__[i__]; + c__[j] = std::max(d__2,d__3); +/* L80: */ + } + if (c__[j] > 0.) { + i__2 = (integer) (log(c__[j]) / logrdx); + c__[j] = pow_di(&radix, &i__2); + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = std::max(d__1,d__2); +/* L100: */ + } + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = c__[j]; + d__1 = std::max(d__2,smlnum); + c__[j] = 1. / std::min(d__1,bignum); +/* L120: */ + } + +/* Compute COLCND = min(C(J)) / max(C(J)). */ + + *colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } + + return 0; + +/* End of DGBEQUB */ + +} /* dgbequb_ */ + +/* Subroutine */ int dgbrfs_(const char *trans, integer *n, integer *kl, integer * + ku, integer *nrhs, double *ab, integer *ldab, double *afb, + integer *ldafb, integer *ipiv, double *b, integer *ldb, + double *x, integer *ldx, double *ferr, double *berr, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b15 = -1.; + static double c_b17 = 1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s; + integer kk; + double xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + integer count; + double safmin; + bool notran; + char transt[1]; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBRFS improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is banded, and provides */ +/* error bounds and backward error estimates for the solution. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The original band matrix A, stored in rows 1 to KL+KU+1. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ + +/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* Details of the LU factorization of the band matrix A, as */ +/* computed by DGBTRF. U is stored as an upper triangular band */ +/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* the multipliers used during the factorization are stored in */ +/* rows KL+KU+2 to 2*KL+KU+1. */ + +/* LDAFB (input) INTEGER */ +/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices from DGBTRF; for 1<=i<=N, row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DGBTRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldab < *kl + *ku + 1) { + *info = -7; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -9; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -12; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + +/* Computing MIN */ + i__1 = *kl + *ku + 2, i__2 = *n + 1; + nz = std::min(i__1,i__2); + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dgbmv_(trans, n, n, kl, ku, &c_b15, &ab[ab_offset], ldab, &x[j * + x_dim1 + 1], &c__1, &c_b17, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(op(A))*abs(X) + abs(B). */ + + if (notran) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + kk = *ku + 1 - k; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *ku; +/* Computing MIN */ + i__6 = *n, i__7 = k + *kl; + i__5 = std::min(i__6,i__7); + for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) { + work[i__] += (d__1 = ab[kk + i__ + k * ab_dim1], abs(d__1) + ) * xk; +/* L40: */ + } +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + kk = *ku + 1 - k; +/* Computing MAX */ + i__5 = 1, i__3 = k - *ku; +/* Computing MIN */ + i__6 = *n, i__7 = k + *kl; + i__4 = std::min(i__6,i__7); + for (i__ = std::max(i__5,i__3); i__ <= i__4; ++i__) { + s += (d__1 = ab[kk + i__ + k * ab_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L60: */ + } + work[k] += s; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] +, &work[*n + 1], n, info); + daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + dgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & + ipiv[1], &work[*n + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] *= work[i__]; +/* L110: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] *= work[i__]; +/* L120: */ + } + dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & + ipiv[1], &work[*n + 1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DGBRFS */ + +} /* dgbrfs_ */ + +#if 0 +/* Subroutine */ int dgbrfsx_(const char *trans, const char *equed, integer *n, integer * + kl, integer *ku, integer *nrhs, double *ab, integer *ldab, + double *afb, integer *ldafb, integer *ipiv, double *r__, + double *c__, double *b, integer *ldb, double *x, integer * + ldx, double *rcond, double *berr, integer *n_err_bnds__, + double *err_bnds_norm__, double *err_bnds_comp__, integer * + nparams, double *params, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c_n1 = -1; + static integer c__0 = 0; + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + double d__1, d__2; + + /* Local variables */ + double illrcond_thresh__, unstable_thresh__, err_lbnd__; + integer ref_type__; + integer j; + double rcond_tmp__; + integer prec_type__, trans_type__; + double cwise_wrong__; + char norm[1]; + bool ignore_cwise__; + double anorm; + bool colequ, notran, rowequ; + integer ithresh, n_norms__; + double rthresh; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBRFSX improves the computed solution to a system of linear */ +/* equations and provides error bounds and backward error estimates */ +/* for the solution. In addition to normwise error bound, the code */ +/* provides maximum componentwise error bound if possible. See */ +/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */ +/* error bounds. */ + +/* The original system of linear equations may have been equilibrated */ +/* before calling this routine, as described by arguments EQUED, R */ +/* and C below. In this case, the solution and error bounds returned */ +/* are for the original unequilibrated system. */ + +/* Arguments */ +/* ========= */ + +/* Some optional parameters are bundled in the PARAMS array. These */ +/* settings determine how refinement is performed, but often the */ +/* defaults are acceptable. If the defaults are acceptable, users */ +/* can pass NPARAMS = 0 which prevents the source code from accessing */ +/* the PARAMS argument. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* EQUED (input) CHARACTER*1 */ +/* Specifies the form of equilibration that was done to A */ +/* before calling this routine. This is needed to compute */ +/* the solution and error bounds correctly. */ +/* = 'N': No equilibration */ +/* = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* diag(R). */ +/* = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* by diag(C). */ +/* = 'B': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(R) * A * diag(C). */ +/* The right hand side B has been changed accordingly. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The original band matrix A, stored in rows 1 to KL+KU+1. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ + +/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* Details of the LU factorization of the band matrix A, as */ +/* computed by DGBTRF. U is stored as an upper triangular band */ +/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* the multipliers used during the factorization are stored in */ +/* rows KL+KU+2 to 2*KL+KU+1. */ + +/* LDAFB (input) INTEGER */ +/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* R (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* is not accessed. R is an input argument if FACT = 'F'; */ +/* otherwise, R is an output argument. If FACT = 'F' and */ +/* EQUED = 'R' or 'B', each element of R must be positive. */ +/* If R is output, each element of R is a power of the radix. */ +/* If R is input, each element of R should be a power of the radix */ +/* to ensure a reliable solution and error estimates. Scaling by */ +/* powers of the radix does not cause rounding errors unless the */ +/* result underflows or overflows. Rounding errors during scaling */ +/* lead to refining with a matrix that is not equivalent to the */ +/* input matrix, producing error estimates that may not be */ +/* reliable. */ + +/* C (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* is not accessed. C is an input argument if FACT = 'F'; */ +/* otherwise, C is an output argument. If FACT = 'F' and */ +/* EQUED = 'C' or 'B', each element of C must be positive. */ +/* If C is output, each element of C is a power of the radix. */ +/* If C is input, each element of C should be a power of the radix */ +/* to ensure a reliable solution and error estimates. Scaling by */ +/* powers of the radix does not cause rounding errors unless the */ +/* result underflows or overflows. Rounding errors during scaling */ +/* lead to refining with a matrix that is not equivalent to the */ +/* input matrix, producing error estimates that may not be */ +/* reliable. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DGETRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* Reciprocal scaled condition number. This is an estimate of the */ +/* reciprocal Skeel condition number of the matrix A after */ +/* equilibration (if done). If this is less than the machine */ +/* precision (in particular, if it is zero), the matrix is singular */ +/* to working precision. Note that the error may still be small even */ +/* if this number is very small and the matrix appears ill- */ +/* conditioned. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* Componentwise relative backward error. This is the */ +/* componentwise relative backward error of each solution vector X(j) */ +/* (i.e., the smallest relative change in any element of A or B that */ +/* makes X(j) an exact solution). */ + +/* N_ERR_BNDS (input) INTEGER */ +/* Number of error bounds to return for each right hand side */ +/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* ERR_BNDS_COMP below. */ + +/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* For each right-hand side, this array contains information about */ +/* various error bounds and condition numbers corresponding to the */ +/* normwise relative error, which is defined as follows: */ + +/* Normwise relative error in the ith solution vector: */ +/* max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* ------------------------------ */ +/* max_j abs(X(j,i)) */ + +/* The array is indexed by the type of error information as described */ +/* below. There currently are up to three pieces of information */ +/* returned. */ + +/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* right-hand side. */ + +/* The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* three fields: */ +/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* reciprocal condition number is less than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). */ + +/* err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* almost certainly within a factor of 10 of the true error */ +/* so long as the next entry is greater than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* be trusted if the previous boolean is true. */ + +/* err = 3 Reciprocal condition number: Estimated normwise */ +/* reciprocal condition number. Compared with the threshold */ +/* sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* estimate is "guaranteed". These reciprocal condition */ +/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* appropriately scaled matrix Z. */ +/* Let Z = S*A, where S scales each row by a power of the */ +/* radix so all absolute row sums of Z are approximately 1. */ + +/* See Lapack Working Note 165 for further details and extra */ +/* cautions. */ + +/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* For each right-hand side, this array contains information about */ +/* various error bounds and condition numbers corresponding to the */ +/* componentwise relative error, which is defined as follows: */ + +/* Componentwise relative error in the ith solution vector: */ +/* abs(XTRUE(j,i) - X(j,i)) */ +/* max_j ---------------------- */ +/* abs(X(j,i)) */ + +/* The array is indexed by the right-hand side i (on which the */ +/* componentwise relative error depends), and the type of error */ +/* information as described below. There currently are up to three */ +/* pieces of information returned for each right-hand side. If */ +/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ +/* the first (:,N_ERR_BNDS) entries are returned. */ + +/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* right-hand side. */ + +/* The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* three fields: */ +/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* reciprocal condition number is less than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). */ + +/* err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* almost certainly within a factor of 10 of the true error */ +/* so long as the next entry is greater than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* be trusted if the previous boolean is true. */ + +/* err = 3 Reciprocal condition number: Estimated componentwise */ +/* reciprocal condition number. Compared with the threshold */ +/* sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* estimate is "guaranteed". These reciprocal condition */ +/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* appropriately scaled matrix Z. */ +/* Let Z = S*(A*diag(x)), where x is the solution for the */ +/* current right-hand side and S scales each row of */ +/* A*diag(x) by a power of the radix so all absolute row */ +/* sums of Z are approximately 1. */ + +/* See Lapack Working Note 165 for further details and extra */ +/* cautions. */ + +/* NPARAMS (input) INTEGER */ +/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */ +/* PARAMS array is never referenced and default values are used. */ + +/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */ +/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */ +/* that entry will be filled with default value used for that */ +/* parameter. Only positions up to NPARAMS are accessed; defaults */ +/* are used for higher-numbered parameters. */ + +/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* refinement or not. */ +/* Default: 1.0D+0 */ +/* = 0.0 : No refinement is performed, and no error bounds are */ +/* computed. */ +/* = 1.0 : Use the double-precision refinement algorithm, */ +/* possibly with doubled-single computations if the */ +/* compilation environment does not support DOUBLE */ +/* PRECISION. */ +/* (other values are reserved for future use) */ + +/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* computations allowed for refinement. */ +/* Default: 10 */ +/* Aggressive: Set to 100 to permit convergence using approximate */ +/* factorizations or factorizations other than LU. If */ +/* the factorization uses a technique other than */ +/* Gaussian elimination, the guarantees in */ +/* err_bnds_norm and err_bnds_comp may no longer be */ +/* trustworthy. */ + +/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* will attempt to find a solution with small componentwise */ +/* relative error in the double-precision algorithm. Positive */ +/* is true, 0.0 is false. */ +/* Default: 1.0 (attempt componentwise convergence) */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: Successful exit. The solution to every right-hand side is */ +/* guaranteed. */ +/* < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly singular, so */ +/* the solution and error bounds could not be computed. RCOND = 0 */ +/* is returned. */ +/* = N+J: The solution corresponding to the Jth right-hand side is */ +/* not guaranteed. The solutions corresponding to other right- */ +/* hand sides K with K > J may not be guaranteed as well, but */ +/* only the first such right-hand side is reported. If a small */ +/* componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* the Jth right-hand side is the first with a normwise error */ +/* bound that is not guaranteed (the smallest J such */ +/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* the Jth right-hand side is the first with either a normwise or */ +/* componentwise error bound that is not guaranteed (the smallest */ +/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* about all of the right-hand sides check ERR_BNDS_NORM or */ +/* ERR_BNDS_COMP. */ + +/* ================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Check the input parameters. */ + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1; + err_bnds_norm__ -= err_bnds_norm_offset; + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + trans_type__ = ilatrans_(trans); + ref_type__ = 1; + if (*nparams >= 1) { + if (params[1] < 0.) { + params[1] = 1.; + } else { + ref_type__ = (integer) params[1]; + } + } + +/* Set default parameters. */ + + illrcond_thresh__ = (double) (*n) * dlamch_("Epsilon"); + ithresh = 10; + rthresh = .5; + unstable_thresh__ = .25; + ignore_cwise__ = false; + + if (*nparams >= 2) { + if (params[2] < 0.) { + params[2] = (double) ithresh; + } else { + ithresh = (integer) params[2]; + } + } + if (*nparams >= 3) { + if (params[3] < 0.) { + if (ignore_cwise__) { + params[3] = 0.; + } else { + params[3] = 1.; + } + } else { + ignore_cwise__ = params[3] == 0.; + } + } + if (ref_type__ == 0 || *n_err_bnds__ == 0) { + n_norms__ = 0; + } else if (ignore_cwise__) { + n_norms__ = 1; + } else { + n_norms__ = 2; + } + + notran = lsame_(trans, "N"); + rowequ = lsame_(equed, "R") || lsame_(equed, "B"); + colequ = lsame_(equed, "C") || lsame_(equed, "B"); + +/* Test input parameters. */ + + if (trans_type__ == -1) { + *info = -1; + } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kl < 0) { + *info = -4; + } else if (*ku < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kl + *ku + 1) { + *info = -8; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -10; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -13; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBRFSX", &i__1); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *nrhs == 0) { + *rcond = 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 0.; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } else if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.; + } else if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.; + } + } + return 0; + } + +/* Default to failure. */ + + *rcond = 0.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 1.; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } else if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + } else if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.; + } + } + +/* Compute the norm of A and the reciprocal of the condition */ +/* number of A. */ + + if (notran) { + *(unsigned char *)norm = 'I'; + } else { + *(unsigned char *)norm = '1'; + } + anorm = dlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]); + dgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, + &work[1], &iwork[1], info); + +/* Perform refinement on each right-hand side */ + + if (ref_type__ != 0) { + prec_type__ = ilaprec_("E"); + if (notran) { + dla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku, + nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, & + ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset] + , ldx, &berr[1], &n_norms__, &err_bnds_norm__[ + err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n + << 1) + 1], &work[1], rcond, &ithresh, &rthresh, & + unstable_thresh__, &ignore_cwise__, info); + } else { + dla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku, + nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, & + ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset] + , ldx, &berr[1], &n_norms__, &err_bnds_norm__[ + err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n + << 1) + 1], &work[1], rcond, &ithresh, &rthresh, & + unstable_thresh__, &ignore_cwise__, info); + } + } +/* Computing MAX */ + d__1 = 10., d__2 = sqrt((double) (*n)); + err_lbnd__ = std::max(d__1,d__2) * dlamch_("Epsilon"); + if (*n_err_bnds__ >= 1 && n_norms__ >= 1) { + +/* Compute scaled normwise condition number cond(A*C). */ + + if (colequ && notran) { + rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset], + ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &c__[1], + info, &work[1], &iwork[1], 1_integer); + } else if (rowequ && ! notran) { + rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset], + ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &r__[1], + info, &work[1], &iwork[1], 1_integer); + } else { + rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset], + ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__0, &r__[1], + info, &work[1], &iwork[1], 1_integer); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 + << 1)] > 1.) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + err_bnds_norm__[j + err_bnds_norm_dim1] = 0.; + if (*info <= *n) { + *info = *n + j; + } + } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < + err_lbnd__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__; + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__; + } + } + } + if (*n_err_bnds__ >= 1 && n_norms__ >= 2) { + +/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */ +/* each right-hand side using the current solution as an estimate of */ +/* the true solution. If the componentwise error estimate is too */ +/* large, then the solution is a lousy estimate of truth and the */ +/* estimated RCOND may be too optimistic. To avoid misleading users, */ +/* the inverse condition number is set to 0.0 when the estimated */ +/* cwise error is at least CWISE_WRONG. */ + + cwise_wrong__ = sqrt(dlamch_("Epsilon")); + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + cwise_wrong__) { + rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset], + ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__1, &x[j * + x_dim1 + 1], info, &work[1], &iwork[1], 1_integer); + } else { + rcond_tmp__ = 0.; + } + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 + << 1)] > 1.) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 0.; + if (params[3] == 1. && *info < *n + j) { + *info = *n + j; + } + } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + err_lbnd__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__; + } + } + } + + return 0; + +/* End of DGBRFSX */ + +} /* dgbrfsx_ */ +#endif + +/* Subroutine */ int dgbsv_(integer *n, integer *kl, integer *ku, integer * + nrhs, double *ab, integer *ldab, integer *ipiv, double *b, + integer *ldb, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBSV computes the solution to a real system of linear equations */ +/* A * X = B, where A is a band matrix of order N with KL subdiagonals */ +/* and KU superdiagonals, and X and B are N-by-NRHS matrices. */ + +/* The LU decomposition with partial pivoting and row interchanges is */ +/* used to factor A as A = L * U, where L is a product of permutation */ +/* and unit lower triangular matrices with KL subdiagonals, and U is */ +/* upper triangular with KL+KU superdiagonals. The factored form of A */ +/* is then used to solve the system of equations A * X = B. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows KL+1 to */ +/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) */ +/* On exit, details of the factorization: U is stored as an */ +/* upper triangular band matrix with KL+KU superdiagonals in */ +/* rows 1 to KL+KU+1, and the multipliers used during the */ +/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* See below for further details. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* The pivot indices that define the permutation matrix P; */ +/* row i of the matrix was interchanged with row IPIV(i). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly */ +/* singular, and the solution has not been computed. */ + +/* Further Details */ +/* =============== */ + +/* The band storage scheme is illustrated by the following example, when */ +/* M = N = 6, KL = 2, KU = 1: */ + +/* On entry: On exit: */ + +/* * * * + + + * * * u14 u25 u36 */ +/* * * + + + + * * u13 u24 u35 u46 */ +/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ + +/* Array elements marked * are not used by the routine; elements marked */ +/* + need not be set on entry, but are required by the routine to store */ +/* elements of U because of fill-in resulting from the row interchanges. */ + +/* ===================================================================== */ + +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*kl < 0) { + *info = -2; + } else if (*ku < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < (*kl << 1) + *ku + 1) { + *info = -6; + } else if (*ldb < std::max(*n,1_integer)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBSV ", &i__1); + return 0; + } + +/* Compute the LU factorization of the band matrix A. */ + + dgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[ + 1], &b[b_offset], ldb, info); + } + return 0; + +/* End of DGBSV */ + +} /* dgbsv_ */ + +/* Subroutine */ int dgbsvx_(const char *fact, const char *trans, integer *n, integer *kl, + integer *ku, integer *nrhs, double *ab, integer *ldab, + double *afb, integer *ldafb, integer *ipiv, char *equed, + double *r__, double *c__, double *b, integer *ldb, + double *x, integer *ldx, double *rcond, double *ferr, + double *berr, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, j1, j2; + double amax; + char norm[1]; + double rcmin, rcmax, anorm; + bool equil; + double colcnd; + bool nofact; + double bignum; + integer infequ; + bool colequ; + double rowcnd; + bool notran; + double smlnum; + bool rowequ; + double rpvgrw; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBSVX uses the LU factorization to compute the solution to a real */ +/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */ +/* where A is a band matrix of order N with KL subdiagonals and KU */ +/* superdiagonals, and X and B are N-by-NRHS matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed by this subroutine: */ + +/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* the system: */ +/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ +/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ +/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ +/* Whether or not the system will be equilibrated depends on the */ +/* scaling of the matrix A, but if equilibration is used, A is */ +/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ +/* or diag(C)*B (if TRANS = 'T' or 'C'). */ + +/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */ +/* matrix A (after equilibration if FACT = 'E') as */ +/* A = L * U, */ +/* where L is a product of permutation and unit lower triangular */ +/* matrices with KL subdiagonals, and U is upper triangular with */ +/* KL+KU superdiagonals. */ + +/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */ +/* returns with INFO = i. Otherwise, the factored form of A is used */ +/* to estimate the condition number of the matrix A. If the */ +/* reciprocal of the condition number is less than machine precision, */ +/* INFO = N+1 is returned as a warning, but the routine still goes on */ +/* to solve for X and compute error bounds as described below. */ + +/* 4. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 5. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* 6. If equilibration was used, the matrix X is premultiplied by */ +/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ +/* that it solves the original system before equilibration. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of the matrix A is */ +/* supplied on entry, and if not, whether the matrix A should be */ +/* equilibrated before it is factored. */ +/* = 'F': On entry, AFB and IPIV contain the factored form of */ +/* A. If EQUED is not 'N', the matrix A has been */ +/* equilibrated with scaling factors given by R and C. */ +/* AB, AFB, and IPIV are not modified. */ +/* = 'N': The matrix A will be copied to AFB and factored. */ +/* = 'E': The matrix A will be equilibrated if necessary, then */ +/* copied to AFB and factored. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations. */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Transpose) */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ + +/* If FACT = 'F' and EQUED is not 'N', then A must have been */ +/* equilibrated by the scaling factors in R and/or C. AB is not */ +/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */ +/* EQUED = 'N' on exit. */ + +/* On exit, if EQUED .ne. 'N', A is scaled as follows: */ +/* EQUED = 'R': A := diag(R) * A */ +/* EQUED = 'C': A := A * diag(C) */ +/* EQUED = 'B': A := diag(R) * A * diag(C). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ + +/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* If FACT = 'F', then AFB is an input argument and on entry */ +/* contains details of the LU factorization of the band matrix */ +/* A, as computed by DGBTRF. U is stored as an upper triangular */ +/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* and the multipliers used during the factorization are stored */ +/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */ +/* the factored form of the equilibrated matrix A. */ + +/* If FACT = 'N', then AFB is an output argument and on exit */ +/* returns details of the LU factorization of A. */ + +/* If FACT = 'E', then AFB is an output argument and on exit */ +/* returns details of the LU factorization of the equilibrated */ +/* matrix A (see the description of AB for the form of the */ +/* equilibrated matrix). */ + +/* LDAFB (input) INTEGER */ +/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ + +/* IPIV (input or output) INTEGER array, dimension (N) */ +/* If FACT = 'F', then IPIV is an input argument and on entry */ +/* contains the pivot indices from the factorization A = L*U */ +/* as computed by DGBTRF; row i of the matrix was interchanged */ +/* with row IPIV(i). */ + +/* If FACT = 'N', then IPIV is an output argument and on exit */ +/* contains the pivot indices from the factorization A = L*U */ +/* of the original matrix A. */ + +/* If FACT = 'E', then IPIV is an output argument and on exit */ +/* contains the pivot indices from the factorization A = L*U */ +/* of the equilibrated matrix A. */ + +/* EQUED (input or output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration (always true if FACT = 'N'). */ +/* = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* diag(R). */ +/* = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* by diag(C). */ +/* = 'B': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(R) * A * diag(C). */ +/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* output argument. */ + +/* R (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* is not accessed. R is an input argument if FACT = 'F'; */ +/* otherwise, R is an output argument. If FACT = 'F' and */ +/* EQUED = 'R' or 'B', each element of R must be positive. */ + +/* C (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* is not accessed. C is an input argument if FACT = 'F'; */ +/* otherwise, C is an output argument. If FACT = 'F' and */ +/* EQUED = 'C' or 'B', each element of C must be positive. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, */ +/* if EQUED = 'N', B is not modified; */ +/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ +/* diag(R)*B; */ +/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ +/* overwritten by diag(C)*B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */ +/* to the original system of equations. Note that A and B are */ +/* modified on exit if EQUED .ne. 'N', and the solution to the */ +/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */ +/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */ +/* and EQUED = 'R' or 'B'. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The estimate of the reciprocal condition number of the matrix */ +/* A after equilibration (if done). If RCOND is less than the */ +/* machine precision (in particular, if RCOND = 0), the matrix */ +/* is singular to working precision. This condition is */ +/* indicated by a return code of INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (3*N) */ +/* On exit, WORK(1) contains the reciprocal pivot growth */ +/* factor norm(A)/norm(U). The "max absolute element" norm is */ +/* used. If WORK(1) is much less than 1, then the stability */ +/* of the LU factorization of the (equilibrated) matrix A */ +/* could be poor. This also means that the solution X, condition */ +/* estimator RCOND, and forward error bound FERR could be */ +/* unreliable. If factorization fails with 0 0: if INFO = i, and i is */ +/* <= N: U(i,i) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly */ +/* singular, so the solution and error bounds */ +/* could not be computed. RCOND = 0 is returned. */ +/* = N+1: U is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + notran = lsame_(trans, "N"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rowequ = false; + colequ = false; + } else { + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kl < 0) { + *info = -4; + } else if (*ku < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kl + *ku + 1) { + *info = -8; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -10; + } else if (lsame_(fact, "F") && ! (rowequ || colequ + || lsame_(equed, "N"))) { + *info = -12; + } else { + if (rowequ) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[j]; + rcmax = std::max(d__1,d__2); +/* L10: */ + } + if (rcmin <= 0.) { + *info = -13; + } else if (*n > 0) { + rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } else { + rowcnd = 1.; + } + } + if (colequ && *info == 0) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = std::max(d__1,d__2); +/* L20: */ + } + if (rcmin <= 0.) { + *info = -14; + } else if (*n > 0) { + colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } else { + colcnd = 1.; + } + } + if (*info == 0) { + if (*ldb < std::max(1_integer,*n)) { + *info = -16; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -18; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBSVX", &i__1); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd, + &colcnd, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, equed); + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + } + +/* Scale the right hand side. */ + + if (notran) { + if (rowequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else if (colequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1]; +/* L50: */ + } +/* L60: */ + } + } + + if (nofact || equil) { + +/* Compute the LU factorization of the band matrix A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; + j1 = std::max(i__2,1_integer); +/* Computing MIN */ + i__2 = j + *kl; + j2 = std::min(i__2,*n); + i__2 = j2 - j1 + 1; + dcopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[* + kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1); +/* L70: */ + } + + dgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + anorm = 0.; + i__1 = *info; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *ku + 2 - j; +/* Computing MIN */ + i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; + i__3 = std::min(i__4,i__5); + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = anorm, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs( + d__1)); + anorm = std::max(d__2,d__3); +/* L80: */ + } +/* L90: */ + } +/* Computing MIN */ + i__3 = *info - 1, i__2 = *kl + *ku; + i__1 = std::min(i__3,i__2); +/* Computing MAX */ + i__4 = 1, i__5 = *kl + *ku + 2 - *info; + rpvgrw = dlantb_("M", "U", "N", info, &i__1, &afb[std::max(i__4, i__5) + + afb_dim1], ldafb, &work[1]); + if (rpvgrw == 0.) { + rpvgrw = 1.; + } else { + rpvgrw = anorm / rpvgrw; + } + work[1] = rpvgrw; + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A and the */ +/* reciprocal pivot growth factor RPVGRW. */ + + if (notran) { + *(unsigned char *)norm = '1'; + } else { + *(unsigned char *)norm = 'I'; + } + anorm = dlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]); + i__1 = *kl + *ku; + rpvgrw = dlantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &work[ + 1]); + if (rpvgrw == 0.) { + rpvgrw = 1.; + } else { + rpvgrw = dlangb_("M", n, kl, ku, &ab[ab_offset], ldab, &work[1]) / rpvgrw; + } + +/* Compute the reciprocal of the condition number of A. */ + + dgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, + &work[1], &iwork[1], info); + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ + x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], + ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], & + berr[1], &work[1], &iwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (notran) { + if (colequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1]; +/* L100: */ + } +/* L110: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= colcnd; +/* L120: */ + } + } + } else if (rowequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1]; +/* L130: */ + } +/* L140: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= rowcnd; +/* L150: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + work[1] = rpvgrw; + return 0; + +/* End of DGBSVX */ + +} /* dgbsvx_ */ + +#if 0 +/* Subroutine */ int dgbsvxx_(const char *fact, const char *trans, integer *n, integer * + kl, integer *ku, integer *nrhs, double *ab, integer *ldab, + double *afb, integer *ldafb, integer *ipiv, char *equed, + double *r__, double *c__, double *b, integer *ldb, + double *x, integer *ldx, double *rcond, double *rpvgrw, + double *berr, integer *n_err_bnds__, double *err_bnds_norm__, + double *err_bnds_comp__, integer *nparams, double *params, + double *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double amax; + double rcmin, rcmax; + bool equil; + double colcnd; + bool nofact; + double bignum; + integer infequ; + bool colequ; + double rowcnd; + bool notran; + double smlnum; + bool rowequ; + +/* -- LAPACK driver routine (version 3.2) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBSVXX uses the LU factorization to compute the solution to a */ +/* double precision system of linear equations A * X = B, where A is an */ +/* N-by-N matrix and X and B are N-by-NRHS matrices. */ + +/* If requested, both normwise and maximum componentwise error bounds */ +/* are returned. DGBSVXX will return a solution with a tiny */ +/* guaranteed error (O(eps) where eps is the working machine */ +/* precision) unless the matrix is very ill-conditioned, in which */ +/* case a warning is returned. Relevant condition numbers also are */ +/* calculated and returned. */ + +/* DGBSVXX accepts user-provided factorizations and equilibration */ +/* factors; see the definitions of the FACT and EQUED options. */ +/* Solving with refinement and using a factorization from a previous */ +/* DGBSVXX call will also produce a solution with either O(eps) */ +/* errors or warnings, but we cannot make that claim for general */ +/* user-provided factorizations and equilibration factors if they */ +/* differ from what DGBSVXX would itself produce. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */ +/* the system: */ + +/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ +/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ +/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ + +/* Whether or not the system will be equilibrated depends on the */ +/* scaling of the matrix A, but if equilibration is used, A is */ +/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ +/* or diag(C)*B (if TRANS = 'T' or 'C'). */ + +/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */ +/* the matrix A (after equilibration if FACT = 'E') as */ + +/* A = P * L * U, */ + +/* where P is a permutation matrix, L is a unit lower triangular */ +/* matrix, and U is upper triangular. */ + +/* 3. If some U(i,i)=0, so that U is exactly singular, then the */ +/* routine returns with INFO = i. Otherwise, the factored form of A */ +/* is used to estimate the condition number of the matrix A (see */ +/* argument RCOND). If the reciprocal of the condition number is less */ +/* than machine precision, the routine still goes on to solve for X */ +/* and compute error bounds as described below. */ + +/* 4. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ +/* the routine will use iterative refinement to try to get a small */ +/* error and error bounds. Refinement calculates the residual to at */ +/* least twice the working precision. */ + +/* 6. If equilibration was used, the matrix X is premultiplied by */ +/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ +/* that it solves the original system before equilibration. */ + +/* Arguments */ +/* ========= */ + +/* Some optional parameters are bundled in the PARAMS array. These */ +/* settings determine how refinement is performed, but often the */ +/* defaults are acceptable. If the defaults are acceptable, users */ +/* can pass NPARAMS = 0 which prevents the source code from accessing */ +/* the PARAMS argument. */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of the matrix A is */ +/* supplied on entry, and if not, whether the matrix A should be */ +/* equilibrated before it is factored. */ +/* = 'F': On entry, AF and IPIV contain the factored form of A. */ +/* If EQUED is not 'N', the matrix A has been */ +/* equilibrated with scaling factors given by R and C. */ +/* A, AF, and IPIV are not modified. */ +/* = 'N': The matrix A will be copied to AF and factored. */ +/* = 'E': The matrix A will be equilibrated if necessary, then */ +/* copied to AF and factored. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ + +/* If FACT = 'F' and EQUED is not 'N', then AB must have been */ +/* equilibrated by the scaling factors in R and/or C. AB is not */ +/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */ +/* EQUED = 'N' on exit. */ + +/* On exit, if EQUED .ne. 'N', A is scaled as follows: */ +/* EQUED = 'R': A := diag(R) * A */ +/* EQUED = 'C': A := A * diag(C) */ +/* EQUED = 'B': A := diag(R) * A * diag(C). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ + +/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* If FACT = 'F', then AFB is an input argument and on entry */ +/* contains details of the LU factorization of the band matrix */ +/* A, as computed by DGBTRF. U is stored as an upper triangular */ +/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* and the multipliers used during the factorization are stored */ +/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */ +/* the factored form of the equilibrated matrix A. */ + +/* If FACT = 'N', then AF is an output argument and on exit */ +/* returns the factors L and U from the factorization A = P*L*U */ +/* of the original matrix A. */ + +/* If FACT = 'E', then AF is an output argument and on exit */ +/* returns the factors L and U from the factorization A = P*L*U */ +/* of the equilibrated matrix A (see the description of A for */ +/* the form of the equilibrated matrix). */ + +/* LDAFB (input) INTEGER */ +/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ + +/* IPIV (input or output) INTEGER array, dimension (N) */ +/* If FACT = 'F', then IPIV is an input argument and on entry */ +/* contains the pivot indices from the factorization A = P*L*U */ +/* as computed by DGETRF; row i of the matrix was interchanged */ +/* with row IPIV(i). */ + +/* If FACT = 'N', then IPIV is an output argument and on exit */ +/* contains the pivot indices from the factorization A = P*L*U */ +/* of the original matrix A. */ + +/* If FACT = 'E', then IPIV is an output argument and on exit */ +/* contains the pivot indices from the factorization A = P*L*U */ +/* of the equilibrated matrix A. */ + +/* EQUED (input or output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration (always true if FACT = 'N'). */ +/* = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* diag(R). */ +/* = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* by diag(C). */ +/* = 'B': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(R) * A * diag(C). */ +/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* output argument. */ + +/* R (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* is not accessed. R is an input argument if FACT = 'F'; */ +/* otherwise, R is an output argument. If FACT = 'F' and */ +/* EQUED = 'R' or 'B', each element of R must be positive. */ +/* If R is output, each element of R is a power of the radix. */ +/* If R is input, each element of R should be a power of the radix */ +/* to ensure a reliable solution and error estimates. Scaling by */ +/* powers of the radix does not cause rounding errors unless the */ +/* result underflows or overflows. Rounding errors during scaling */ +/* lead to refining with a matrix that is not equivalent to the */ +/* input matrix, producing error estimates that may not be */ +/* reliable. */ + +/* C (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* is not accessed. C is an input argument if FACT = 'F'; */ +/* otherwise, C is an output argument. If FACT = 'F' and */ +/* EQUED = 'C' or 'B', each element of C must be positive. */ +/* If C is output, each element of C is a power of the radix. */ +/* If C is input, each element of C should be a power of the radix */ +/* to ensure a reliable solution and error estimates. Scaling by */ +/* powers of the radix does not cause rounding errors unless the */ +/* result underflows or overflows. Rounding errors during scaling */ +/* lead to refining with a matrix that is not equivalent to the */ +/* input matrix, producing error estimates that may not be */ +/* reliable. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, */ +/* if EQUED = 'N', B is not modified; */ +/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ +/* diag(R)*B; */ +/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ +/* overwritten by diag(C)*B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0, the N-by-NRHS solution matrix X to the original */ +/* system of equations. Note that A and B are modified on exit */ +/* if EQUED .ne. 'N', and the solution to the equilibrated system is */ +/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */ +/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* Reciprocal scaled condition number. This is an estimate of the */ +/* reciprocal Skeel condition number of the matrix A after */ +/* equilibration (if done). If this is less than the machine */ +/* precision (in particular, if it is zero), the matrix is singular */ +/* to working precision. Note that the error may still be small even */ +/* if this number is very small and the matrix appears ill- */ +/* conditioned. */ + +/* RPVGRW (output) DOUBLE PRECISION */ +/* Reciprocal pivot growth. On exit, this contains the reciprocal */ +/* pivot growth factor norm(A)/norm(U). The "max absolute element" */ +/* norm is used. If this is much less than 1, then the stability of */ +/* the LU factorization of the (equilibrated) matrix A could be poor. */ +/* This also means that the solution X, estimated condition numbers, */ +/* and error bounds could be unreliable. If factorization fails with */ +/* 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly singular, so */ +/* the solution and error bounds could not be computed. RCOND = 0 */ +/* is returned. */ +/* = N+J: The solution corresponding to the Jth right-hand side is */ +/* not guaranteed. The solutions corresponding to other right- */ +/* hand sides K with K > J may not be guaranteed as well, but */ +/* only the first such right-hand side is reported. If a small */ +/* componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* the Jth right-hand side is the first with a normwise error */ +/* bound that is not guaranteed (the smallest J such */ +/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* the Jth right-hand side is the first with either a normwise or */ +/* componentwise error bound that is not guaranteed (the smallest */ +/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* about all of the right-hand sides check ERR_BNDS_NORM or */ +/* ERR_BNDS_COMP. */ + +/* ================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1; + err_bnds_norm__ -= err_bnds_norm_offset; + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + notran = lsame_(trans, "N"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rowequ = false; + colequ = false; + } else { + rowequ = lsame_(equed, "R") || lsame_(equed, "B"); + colequ = lsame_(equed, "C") || lsame_(equed, "B"); + } + +/* Default is failure. If an input parameter is wrong or */ +/* factorization fails, make everything look horrible. Only the */ +/* pivot growth is set here, the rest is initialized in DGBRFSX. */ + + *rpvgrw = 0.; + +/* Test the input parameters. PARAMS is not tested until DGBRFSX. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kl < 0) { + *info = -4; + } else if (*ku < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kl + *ku + 1) { + *info = -8; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -10; + } else if (lsame_(fact, "F") && ! (rowequ || colequ + || lsame_(equed, "N"))) { + *info = -12; + } else { + if (rowequ) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[j]; + rcmax = std::max(d__1,d__2); +/* L10: */ + } + if (rcmin <= 0.) { + *info = -13; + } else if (*n > 0) { + rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } else { + rowcnd = 1.; + } + } + if (colequ && *info == 0) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = std::max(d__1,d__2); +/* L20: */ + } + if (rcmin <= 0.) { + *info = -14; + } else if (*n > 0) { + colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } else { + colcnd = 1.; + } + } + if (*info == 0) { + if (*ldb < std::max(1_integer,*n)) { + *info = -15; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -16; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBSVXX", &i__1); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dgbequb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, equed); + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + +/* If the scaling factors are not applied, set them to 1.0. */ + + if (! rowequ) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + r__[j] = 1.; + } + } + if (! colequ) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 1.; + } + } + } + +/* Scale the right hand side. */ + + if (notran) { + if (rowequ) { + dlascl2_(n, nrhs, &r__[1], &b[b_offset], ldb); + } + } else { + if (colequ) { + dlascl2_(n, nrhs, &c__[1], &b[b_offset], ldb); + } + } + + if (nofact || equil) { + +/* Compute the LU factorization of A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = (*kl << 1) + *ku + 1; + for (i__ = *kl + 1; i__ <= i__2; ++i__) { + afb[i__ + j * afb_dim1] = ab[i__ - *kl + j * ab_dim1]; +/* L30: */ + } +/* L40: */ + } + dgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Pivot in column INFO is exactly 0 */ +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + *rpvgrw = dla_gbrpvgrw__(n, kl, ku, info, &ab[ab_offset], ldab, & + afb[afb_offset], ldafb); + return 0; + } + } + +/* Compute the reciprocal pivot growth factor RPVGRW. */ + + *rpvgrw = dla_gbrpvgrw__(n, kl, ku, n, &ab[ab_offset], ldab, &afb[ + afb_offset], ldafb); + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ + x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dgbrfsx_(trans, equed, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[ + afb_offset], ldafb, &ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, + &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, & + err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], nparams, ¶ms[1], &work[1], &iwork[1], + info); + +/* Scale solutions. */ + + if (colequ && notran) { + dlascl2_(n, nrhs, &c__[1], &x[x_offset], ldx); + } else if (rowequ && ! notran) { + dlascl2_(n, nrhs, &r__[1], &x[x_offset], ldx); + } + + return 0; + +/* End of DGBSVXX */ + +} /* dgbsvxx_ */ +#endif + +/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, integer *ipiv, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b9 = -1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + double d__1; + + /* Local variables */ + integer i__, j, km, jp, ju, kv; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBTF2 computes an LU factorization of a real m-by-n band matrix A */ +/* using partial pivoting with row interchanges. */ + +/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ + +/* 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. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows KL+1 to */ +/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */ + +/* On exit, details of the factorization: U is stored as an */ +/* upper triangular band matrix with KL+KU superdiagonals in */ +/* rows 1 to KL+KU+1, and the multipliers used during the */ +/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* See below for further details. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ + +/* IPIV (output) INTEGER array, dimension (min(M,N)) */ +/* The pivot indices; for 1 <= i <= min(M,N), row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly */ +/* singular, and division by zero will occur if it is used */ +/* to solve a system of equations. */ + +/* Further Details */ +/* =============== */ + +/* The band storage scheme is illustrated by the following example, when */ +/* M = N = 6, KL = 2, KU = 1: */ + +/* On entry: On exit: */ + +/* * * * + + + * * * u14 u25 u36 */ +/* * * + + + + * * u13 u24 u35 u46 */ +/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ + +/* Array elements marked * are not used by the routine; elements marked */ +/* + need not be set on entry, but are required by the routine to store */ +/* elements of U, because of fill-in resulting from the row */ +/* interchanges. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* KV is the number of superdiagonals in the factor U, allowing for */ +/* fill-in. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --ipiv; + + /* Function Body */ + kv = *ku + *kl; + +/* Test the input parameters. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + kv + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBTF2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Gaussian elimination with partial pivoting */ + +/* Set fill-in elements in columns KU+2 to KV to zero. */ + + i__1 = std::min(kv,*n); + for (j = *ku + 2; j <= i__1; ++j) { + i__2 = *kl; + for (i__ = kv - j + 2; i__ <= i__2; ++i__) { + ab[i__ + j * ab_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + +/* JU is the index of the last column affected by the current stage */ +/* of the factorization. */ + + ju = 1; + + i__1 = std::min(*m,*n); + for (j = 1; j <= i__1; ++j) { + +/* Set fill-in elements in column J+KV to zero. */ + + if (j + kv <= *n) { + i__2 = *kl; + for (i__ = 1; i__ <= i__2; ++i__) { + ab[i__ + (j + kv) * ab_dim1] = 0.; +/* L30: */ + } + } + +/* Find pivot and test for singularity. KM is the number of */ +/* subdiagonal elements in the current column. */ + +/* Computing MIN */ + i__2 = *kl, i__3 = *m - j; + km = std::min(i__2,i__3); + i__2 = km + 1; + jp = idamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1); + ipiv[j] = jp + j - 1; + if (ab[kv + jp + j * ab_dim1] != 0.) { +/* Computing MAX */ +/* Computing MIN */ + i__4 = j + *ku + jp - 1; + i__2 = ju, i__3 = std::min(i__4,*n); + ju = std::max(i__2,i__3); + +/* Apply interchange to columns J to JU. */ + + if (jp != 1) { + i__2 = ju - j + 1; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 + + j * ab_dim1], &i__4); + } + + if (km > 0) { + +/* Compute multipliers. */ + + d__1 = 1. / ab[kv + 1 + j * ab_dim1]; + dscal_(&km, &d__1, &ab[kv + 2 + j * ab_dim1], &c__1); + +/* Update trailing submatrix within the band. */ + + if (ju > j) { + i__2 = ju - j; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dger_(&km, &i__2, &c_b9, &ab[kv + 2 + j * ab_dim1], &c__1, + &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 + + (j + 1) * ab_dim1], &i__4); + } + } + } else { + +/* If pivot is zero, set INFO to the index of the pivot */ +/* unless a zero pivot has already been found. */ + + if (*info == 0) { + *info = j; + } + } +/* L40: */ + } + return 0; + +/* End of DGBTF2 */ + +} /* dgbtf2_ */ + +/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, integer *ipiv, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__65 = 65; + static double c_b18 = -1.; + static double c_b31 = 1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + double d__1; + + /* Local variables */ + integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju, + kv, nw; + double temp; + double work13[4160] /* was [65][64] */, work31[4160] /* + was [65][64] */; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBTRF computes an LU factorization of a real m-by-n band matrix A */ +/* using partial pivoting with row interchanges. */ + +/* This is the blocked version of the algorithm, calling Level 3 BLAS. */ + +/* 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. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows KL+1 to */ +/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */ + +/* On exit, details of the factorization: U is stored as an */ +/* upper triangular band matrix with KL+KU superdiagonals in */ +/* rows 1 to KL+KU+1, and the multipliers used during the */ +/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* See below for further details. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ + +/* IPIV (output) INTEGER array, dimension (min(M,N)) */ +/* The pivot indices; for 1 <= i <= min(M,N), row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly */ +/* singular, and division by zero will occur if it is used */ +/* to solve a system of equations. */ + +/* Further Details */ +/* =============== */ + +/* The band storage scheme is illustrated by the following example, when */ +/* M = N = 6, KL = 2, KU = 1: */ + +/* On entry: On exit: */ + +/* * * * + + + * * * u14 u25 u36 */ +/* * * + + + + * * u13 u24 u35 u46 */ +/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ + +/* Array elements marked * are not used by the routine; elements marked */ +/* + need not be set on entry, but are required by the routine to store */ +/* elements of U because of fill-in resulting from the row interchanges. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* KV is the number of superdiagonals in the factor U, allowing for */ +/* fill-in */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --ipiv; + + /* Function Body */ + kv = *ku + *kl; + +/* Test the input parameters. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + kv + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBTRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Determine the block size for this environment */ + + nb = ilaenv_(&c__1, "DGBTRF", " ", m, n, kl, ku); + +/* The block size must not exceed the limit set by the size of the */ +/* local arrays WORK13 and WORK31. */ + + nb = std::min(nb,64_integer); + + if (nb <= 1 || nb > *kl) { + +/* Use unblocked code */ + + dgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); + } else { + +/* Use blocked code */ + +/* Zero the superdiagonal elements of the work array WORK13 */ + + i__1 = nb; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work13[i__ + j * 65 - 66] = 0.; +/* L10: */ + } +/* L20: */ + } + +/* Zero the subdiagonal elements of the work array WORK31 */ + + i__1 = nb; + for (j = 1; j <= i__1; ++j) { + i__2 = nb; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work31[i__ + j * 65 - 66] = 0.; +/* L30: */ + } +/* L40: */ + } + +/* Gaussian elimination with partial pivoting */ + +/* Set fill-in elements in columns KU+2 to KV to zero */ + + i__1 = std::min(kv,*n); + for (j = *ku + 2; j <= i__1; ++j) { + i__2 = *kl; + for (i__ = kv - j + 2; i__ <= i__2; ++i__) { + ab[i__ + j * ab_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + +/* JU is the index of the last column affected by the current */ +/* stage of the factorization */ + + ju = 1; + + i__1 = std::min(*m,*n); + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = std::min(*m,*n) - j + 1; + jb = std::min(i__3,i__4); + +/* The active part of the matrix is partitioned */ + +/* A11 A12 A13 */ +/* A21 A22 A23 */ +/* A31 A32 A33 */ + +/* Here A11, A21 and A31 denote the current block of JB columns */ +/* which is about to be factorized. The number of rows in the */ +/* partitioning are JB, I2, I3 respectively, and the numbers */ +/* of columns are JB, J2, J3. The superdiagonal elements of A13 */ +/* and the subdiagonal elements of A31 lie outside the band. */ + +/* Computing MIN */ + i__3 = *kl - jb, i__4 = *m - j - jb + 1; + i2 = std::min(i__3,i__4); +/* Computing MIN */ + i__3 = jb, i__4 = *m - j - *kl + 1; + i3 = std::min(i__3,i__4); + +/* J2 and J3 are computed after JU has been updated. */ + +/* Factorize the current block of JB columns */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + +/* Set fill-in elements in column JJ+KV to zero */ + + if (jj + kv <= *n) { + i__4 = *kl; + for (i__ = 1; i__ <= i__4; ++i__) { + ab[i__ + (jj + kv) * ab_dim1] = 0.; +/* L70: */ + } + } + +/* Find pivot and test for singularity. KM is the number of */ +/* subdiagonal elements in the current column. */ + +/* Computing MIN */ + i__4 = *kl, i__5 = *m - jj; + km = std::min(i__4,i__5); + i__4 = km + 1; + jp = idamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1); + ipiv[jj] = jp + jj - j; + if (ab[kv + jp + jj * ab_dim1] != 0.) { +/* Computing MAX */ +/* Computing MIN */ + i__6 = jj + *ku + jp - 1; + i__4 = ju, i__5 = std::min(i__6,*n); + ju = std::max(i__4,i__5); + if (jp != 1) { + +/* Apply interchange to columns J to J+JB-1 */ + + if (jp + jj - 1 < j + *kl) { + + i__4 = *ldab - 1; + i__5 = *ldab - 1; + dswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__4, &ab[kv + jp + jj - j + j * ab_dim1], + &i__5); + } else { + +/* The interchange affects columns J to JJ-1 of A31 */ +/* which are stored in the work array WORK31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], + &i__5, &work31[jp + jj - j - *kl - 1], & + c__65); + i__4 = j + jb - jj; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + dswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, & + ab[kv + jp + jj * ab_dim1], &i__6); + } + } + +/* Compute multipliers */ + + d__1 = 1. / ab[kv + 1 + jj * ab_dim1]; + dscal_(&km, &d__1, &ab[kv + 2 + jj * ab_dim1], &c__1); + +/* Update trailing submatrix within the band and within */ +/* the current block. JM is the index of the last column */ +/* which needs to be updated. */ + +/* Computing MIN */ + i__4 = ju, i__5 = j + jb - 1; + jm = std::min(i__4,i__5); + if (jm > jj) { + i__4 = jm - jj; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + dger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1], + &c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, & + ab[kv + 1 + (jj + 1) * ab_dim1], &i__6); + } + } else { + +/* If pivot is zero, set INFO to the index of the pivot */ +/* unless a zero pivot has already been found. */ + + if (*info == 0) { + *info = jj; + } + } + +/* Copy current column of A31 into the work array WORK31 */ + +/* Computing MIN */ + i__4 = jj - j + 1; + nw = std::min(i__4,i3); + if (nw > 0) { + dcopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], & + c__1, &work31[(jj - j + 1) * 65 - 65], &c__1); + } +/* L80: */ + } + if (j + jb <= *n) { + +/* Apply the row interchanges to the other blocks. */ + +/* Computing MIN */ + i__3 = ju - j + 1; + j2 = std::min(i__3,kv) - jb; +/* Computing MAX */ + i__3 = 0, i__4 = ju - j - kv + 1; + j3 = std::max(i__3,i__4); + +/* Use DLASWP to apply the row interchanges to A12, A22, and */ +/* A32. */ + + i__3 = *ldab - 1; + dlaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, & + c__1, &jb, &ipiv[j], &c__1); + +/* Adjust the pivot indices. */ + + i__3 = j + jb - 1; + for (i__ = j; i__ <= i__3; ++i__) { + ipiv[i__] = ipiv[i__] + j - 1; +/* L90: */ + } + +/* Apply the row interchanges to A13, A23, and A33 */ +/* columnwise. */ + + k2 = j - 1 + jb + j2; + i__3 = j3; + for (i__ = 1; i__ <= i__3; ++i__) { + jj = k2 + i__; + i__4 = j + jb - 1; + for (ii = j + i__ - 1; ii <= i__4; ++ii) { + ip = ipiv[ii]; + if (ip != ii) { + temp = ab[kv + 1 + ii - jj + jj * ab_dim1]; + ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 + + ip - jj + jj * ab_dim1]; + ab[kv + 1 + ip - jj + jj * ab_dim1] = temp; + } +/* L100: */ + } +/* L110: */ + } + +/* Update the relevant part of the trailing submatrix */ + + if (j2 > 0) { + +/* Update A12 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2, + &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv + + 1 - jb + (j + jb) * ab_dim1], &i__4); + + if (i2 > 0) { + +/* Update A22 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + i__5 = *ldab - 1; + dgemm_("No transpose", "No transpose", &i2, &j2, &jb, + &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3, + &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4, + &c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], & + i__5); + } + + if (i3 > 0) { + +/* Update A32 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dgemm_("No transpose", "No transpose", &i3, &j2, &jb, + &c_b18, work31, &c__65, &ab[kv + 1 - jb + (j + + jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl + + 1 - jb + (j + jb) * ab_dim1], &i__4); + } + } + + if (j3 > 0) { + +/* Copy the lower triangle of A13 into the work array */ +/* WORK13 */ + + i__3 = j3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = jb; + for (ii = jj; ii <= i__4; ++ii) { + work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj + + j + kv - 1) * ab_dim1]; +/* L120: */ + } +/* L130: */ + } + +/* Update A13 in the work array */ + + i__3 = *ldab - 1; + dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3, + &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13, + &c__65); + + if (i2 > 0) { + +/* Update A23 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + dgemm_("No transpose", "No transpose", &i2, &j3, &jb, + &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3, + work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv) + * ab_dim1], &i__4); + } + + if (i3 > 0) { + +/* Update A33 */ + + i__3 = *ldab - 1; + dgemm_("No transpose", "No transpose", &i3, &j3, &jb, + &c_b18, work31, &c__65, work13, &c__65, & + c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], & + i__3); + } + +/* Copy the lower triangle of A13 back into place */ + + i__3 = j3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = jb; + for (ii = jj; ii <= i__4; ++ii) { + ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] = + work13[ii + jj * 65 - 66]; +/* L140: */ + } +/* L150: */ + } + } + } else { + +/* Adjust the pivot indices. */ + + i__3 = j + jb - 1; + for (i__ = j; i__ <= i__3; ++i__) { + ipiv[i__] = ipiv[i__] + j - 1; +/* L160: */ + } + } + +/* Partially undo the interchanges in the current block to */ +/* restore the upper triangular form of A31 and copy the upper */ +/* triangle of A31 back into place */ + + i__3 = j; + for (jj = j + jb - 1; jj >= i__3; --jj) { + jp = ipiv[jj] - jj + 1; + if (jp != 1) { + +/* Apply interchange to columns J to JJ-1 */ + + if (jp + jj - 1 < j + *kl) { + +/* The interchange does not affect A31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__5, &ab[kv + jp + jj - j + j * ab_dim1], & + i__6); + } else { + +/* The interchange does affect A31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__5, &work31[jp + jj - j - *kl - 1], &c__65); + } + } + +/* Copy the current column of A31 back into place */ + +/* Computing MIN */ + i__4 = i3, i__5 = jj - j + 1; + nw = std::min(i__4,i__5); + if (nw > 0) { + dcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[ + kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1); + } +/* L170: */ + } +/* L180: */ + } + } + + return 0; + +/* End of DGBTRF */ + +} /* dgbtrf_ */ + +/* Subroutine */ int dgbtrs_(const char *trans, integer *n, integer *kl, integer * + ku, integer *nrhs, double *ab, integer *ldab, integer *ipiv, + double *b, integer *ldb, integer *info) +{ + /* Table of constant values */ + static double c_b7 = -1.; + static integer c__1 = 1; + static double c_b23 = 1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, l, kd, lm; + bool lnoti; + bool notran; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGBTRS solves a system of linear equations */ +/* A * X = B or A' * X = B */ +/* with a general band matrix A using the LU factorization computed */ +/* by DGBTRF. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations. */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A'* X = B (Transpose) */ +/* = 'C': A'* X = B (Conjugate transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* Details of the LU factorization of the band matrix A, as */ +/* computed by DGBTRF. U is stored as an upper triangular band */ +/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* the multipliers used during the factorization are stored in */ +/* rows KL+KU+2 to 2*KL+KU+1. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices; for 1 <= i <= N, row i of the matrix was */ +/* interchanged with row IPIV(i). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldab < (*kl << 1) + *ku + 1) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGBTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + kd = *ku + *kl + 1; + lnoti = *kl > 0; + + if (notran) { + +/* Solve A*X = B. */ + +/* Solve L*X = B, overwriting B with X. */ + +/* L is represented as a product of permutations and unit lower */ +/* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), */ +/* where each transformation L(i) is a rank-one modification of */ +/* the identity matrix. */ + + if (lnoti) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kl, i__3 = *n - j; + lm = std::min(i__2,i__3); + l = ipiv[j]; + if (l != j) { + dswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); + } + dger_(&lm, nrhs, &c_b7, &ab[kd + 1 + j * ab_dim1], &c__1, &b[ + j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb); +/* L10: */ + } + } + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve U*X = B, overwriting B with X. */ + + i__2 = *kl + *ku; + dtbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[ + ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1); +/* L20: */ + } + + } else { + +/* Solve A'*X = B. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve U'*X = B, overwriting B with X. */ + + i__2 = *kl + *ku; + dtbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset], + ldab, &b[i__ * b_dim1 + 1], &c__1); +/* L30: */ + } + +/* Solve L'*X = B, overwriting B with X. */ + + if (lnoti) { + for (j = *n - 1; j >= 1; --j) { +/* Computing MIN */ + i__1 = *kl, i__2 = *n - j; + lm = std::min(i__1,i__2); + dgemv_("Transpose", &lm, nrhs, &c_b7, &b[j + 1 + b_dim1], ldb, + &ab[kd + 1 + j * ab_dim1], &c__1, &c_b23, &b[j + + b_dim1], ldb); + l = ipiv[j]; + if (l != j) { + dswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); + } +/* L40: */ + } + } + } + return 0; + +/* End of DGBTRS */ + +} /* dgbtrs_ */ + +/* Subroutine */ int dgebak_(const char *job, const char *side, integer *n, integer *ilo, + integer *ihi, double *scale, integer *m, double *v, integer * + ldv, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, i__1; + + /* Local variables */ + integer i__, k; + double s; + integer ii; + bool leftv; + bool rightv; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEBAK forms the right or left eigenvectors of a real general matrix */ +/* by backward transformation on the computed eigenvectors of the */ +/* balanced matrix output by DGEBAL. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* Specifies the type of backward transformation required: */ +/* = 'N', do nothing, return immediately; */ +/* = 'P', do backward transformation for permutation only; */ +/* = 'S', do backward transformation for scaling only; */ +/* = 'B', do backward transformations for both permutation and */ +/* scaling. */ +/* JOB must be the same as the argument JOB supplied to DGEBAL. */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'R': V contains right eigenvectors; */ +/* = 'L': V contains left eigenvectors. */ + +/* N (input) INTEGER */ +/* The number of rows of the matrix V. N >= 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* The integers ILO and IHI determined by DGEBAL. */ +/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ + +/* SCALE (input) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutation and scaling factors, as returned */ +/* by DGEBAL. */ + +/* M (input) INTEGER */ +/* The number of columns of the matrix V. M >= 0. */ + +/* V (input/output) DOUBLE PRECISION array, dimension (LDV,M) */ +/* On entry, the matrix of right or left eigenvectors to be */ +/* transformed, as returned by DHSEIN or DTREVC. */ +/* On exit, V is overwritten by the transformed eigenvectors. */ + +/* LDV (input) INTEGER */ +/* The leading dimension of the array V. LDV >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and Test the input parameters */ + + /* Parameter adjustments */ + --scale; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + + /* Function Body */ + rightv = lsame_(side, "R"); + leftv = lsame_(side, "L"); + + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") + && ! lsame_(job, "B")) { + *info = -1; + } else if (! rightv && ! leftv) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1 || *ilo > std::max(1_integer,*n)) { + *info = -4; + } else if (*ihi < std::min(*ilo,*n) || *ihi > *n) { + *info = -5; + } else if (*m < 0) { + *info = -7; + } else if (*ldv < std::max(1_integer,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEBAK", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*m == 0) { + return 0; + } + if (lsame_(job, "N")) { + return 0; + } + + if (*ilo == *ihi) { + goto L30; + } + +/* Backward balance */ + + if (lsame_(job, "S") || lsame_(job, "B")) { + + if (rightv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + s = scale[i__]; + dscal_(m, &s, &v[i__ + v_dim1], ldv); +/* L10: */ + } + } + + if (leftv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + s = 1. / scale[i__]; + dscal_(m, &s, &v[i__ + v_dim1], ldv); +/* L20: */ + } + } + + } + +/* Backward permutation */ + +/* For I = ILO-1 step -1 until 1, */ +/* IHI+1 step 1 until N do -- */ + +L30: + if (lsame_(job, "P") || lsame_(job, "B")) { + if (rightv) { + i__1 = *n; + for (ii = 1; ii <= i__1; ++ii) { + i__ = ii; + if (i__ >= *ilo && i__ <= *ihi) { + goto L40; + } + if (i__ < *ilo) { + i__ = *ilo - ii; + } + k = (integer) scale[i__]; + if (k == i__) { + goto L40; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L40: + ; + } + } + + if (leftv) { + i__1 = *n; + for (ii = 1; ii <= i__1; ++ii) { + i__ = ii; + if (i__ >= *ilo && i__ <= *ihi) { + goto L50; + } + if (i__ < *ilo) { + i__ = *ilo - ii; + } + k = (integer) scale[i__]; + if (k == i__) { + goto L50; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L50: + ; + } + } + } + + return 0; + +/* End of DGEBAK */ + +} /* dgebak_ */ + +/* Subroutine */ int dgebal_(const char *job, integer *n, double *a, integer * + lda, integer *ilo, integer *ihi, double *scale, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + double c__, f, g; + integer i__, j, k, l, m; + double r__, s, ca, ra; + integer ica, ira, iexc; + double sfmin1, sfmin2, sfmax1, sfmax2; + bool noconv; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEBAL balances a general real matrix A. This involves, first, */ +/* permuting A by a similarity transformation to isolate eigenvalues */ +/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */ +/* diagonal; and second, applying a diagonal similarity transformation */ +/* to rows and columns ILO to IHI to make the rows and columns as */ +/* close in norm as possible. Both steps are optional. */ + +/* Balancing may reduce the 1-norm of the matrix, and improve the */ +/* accuracy of the computed eigenvalues and/or eigenvectors. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* Specifies the operations to be performed on A: */ +/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */ +/* for i = 1,...,N; */ +/* = 'P': permute only; */ +/* = 'S': scale only; */ +/* = 'B': both permute and scale. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the input matrix A. */ +/* On exit, A is overwritten by the balanced matrix. */ +/* If JOB = 'N', A is not referenced. */ +/* See Further Details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* ILO (output) INTEGER */ +/* IHI (output) INTEGER */ +/* ILO and IHI are set to integers such that on exit */ +/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */ +/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */ + +/* SCALE (output) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutations and scaling factors applied to */ +/* A. If P(j) is the index of the row and column interchanged */ +/* with row and column j and D(j) is the scaling factor */ +/* applied to row and column j, then */ +/* SCALE(j) = P(j) for j = 1,...,ILO-1 */ +/* = D(j) for j = ILO,...,IHI */ +/* = P(j) for j = IHI+1,...,N. */ +/* The order in which the interchanges are made is N to IHI+1, */ +/* then 1 to ILO-1. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* The permutations consist of row and column interchanges which put */ +/* the matrix in the form */ + +/* ( T1 X Y ) */ +/* P A P = ( 0 B Z ) */ +/* ( 0 0 T2 ) */ + +/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */ +/* along the diagonal. The column indices ILO and IHI mark the starting */ +/* and ending columns of the submatrix B. Balancing consists of applying */ +/* a diagonal similarity transformation inv(D) * B * D to make the */ +/* 1-norms of each row of B and its corresponding column nearly equal. */ +/* The output matrix is */ + +/* ( T1 X*D Y ) */ +/* ( 0 inv(D)*B*D inv(D)*Z ). */ +/* ( 0 0 T2 ) */ + +/* Information about the permutations P and the diagonal matrix D is */ +/* returned in the vector SCALE. */ + +/* This subroutine is based on the EISPACK routine BALANC. */ + +/* Modified by Tzu-Yi Chen, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --scale; + + /* Function Body */ + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") + && ! lsame_(job, "B")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEBAL", &i__1); + return 0; + } + + k = 1; + l = *n; + + if (*n == 0) { + goto L210; + } + + if (lsame_(job, "N")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scale[i__] = 1.; +/* L10: */ + } + goto L210; + } + + if (lsame_(job, "S")) { + goto L120; + } + +/* Permutation to isolate eigenvalues if possible */ + + goto L50; + +/* Row and column exchange. */ + +L20: + scale[m] = (double) j; + if (j == m) { + goto L30; + } + + dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1); + i__1 = *n - k + 1; + dswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda); + +L30: + switch (iexc) { + case 1: goto L40; + case 2: goto L80; + } + +/* Search for rows isolating an eigenvalue and push them down. */ + +L40: + if (l == 1) { + goto L210; + } + --l; + +L50: + for (j = l; j >= 1; --j) { + + i__1 = l; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ == j) { + goto L60; + } + if (a[j + i__ * a_dim1] != 0.) { + goto L70; + } +L60: + ; + } + + m = l; + iexc = 1; + goto L20; +L70: + ; + } + + goto L90; + +/* Search for columns isolating an eigenvalue and push them left. */ + +L80: + ++k; + +L90: + i__1 = l; + for (j = k; j <= i__1; ++j) { + + i__2 = l; + for (i__ = k; i__ <= i__2; ++i__) { + if (i__ == j) { + goto L100; + } + if (a[i__ + j * a_dim1] != 0.) { + goto L110; + } +L100: + ; + } + + m = k; + iexc = 2; + goto L20; +L110: + ; + } + +L120: + i__1 = l; + for (i__ = k; i__ <= i__1; ++i__) { + scale[i__] = 1.; +/* L130: */ + } + + if (lsame_(job, "P")) { + goto L210; + } + +/* Balance the submatrix in rows K to L. */ + +/* Iterative loop for norm reduction */ + + sfmin1 = dlamch_("S") / dlamch_("P"); + sfmax1 = 1. / sfmin1; + sfmin2 = sfmin1 * 2.; + sfmax2 = 1. / sfmin2; +L140: + noconv = false; + + i__1 = l; + for (i__ = k; i__ <= i__1; ++i__) { + c__ = 0.; + r__ = 0.; + + i__2 = l; + for (j = k; j <= i__2; ++j) { + if (j == i__) { + goto L150; + } + c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1)); + r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +L150: + ; + } + ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1); + ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1)); + i__2 = *n - k + 1; + ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda); + ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1)); + +/* Guard against zero C or R due to underflow. */ + + if (c__ == 0. || r__ == 0.) { + goto L200; + } + g = r__ / 2.; + f = 1.; + s = c__ + r__; +L160: +/* Computing MAX */ + d__1 = std::max(f,c__); +/* Computing MIN */ + d__2 = std::min(r__,g); + if (c__ >= g || std::max(d__1,ca) >= sfmax2 || std::min(d__2,ra) <= sfmin2) { + goto L170; + } + f *= 2.; + c__ *= 2.; + ca *= 2.; + r__ /= 2.; + g /= 2.; + ra /= 2.; + goto L160; + +L170: + g = c__ / 2.; +L180: +/* Computing MIN */ + d__1 = std::min(f,c__), d__1 = std::min(d__1,g); + if (g < r__ || std::max(r__,ra) >= sfmax2 || std::min(d__1,ca) <= sfmin2) { + goto L190; + } + f /= 2.; + c__ /= 2.; + g /= 2.; + ca /= 2.; + r__ *= 2.; + ra *= 2.; + goto L180; + +/* Now balance. */ + +L190: + if (c__ + r__ >= s * .95) { + goto L200; + } + if (f < 1. && scale[i__] < 1.) { + if (f * scale[i__] <= sfmin1) { + goto L200; + } + } + if (f > 1. && scale[i__] > 1.) { + if (scale[i__] >= sfmax1 / f) { + goto L200; + } + } + g = 1. / f; + scale[i__] *= f; + noconv = true; + + i__2 = *n - k + 1; + dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda); + dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1); + +L200: + ; + } + + if (noconv) { + goto L140; + } + +L210: + *ilo = k; + *ihi = l; + + return 0; + +/* End of DGEBAL */ + +} /* dgebal_ */ + +/* Subroutine */ int dgebd2_(integer *m, integer *n, double *a, integer * + lda, double *d__, double *e, double *tauq, double * + taup, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEBD2 reduces a real general m by n matrix A to upper or lower */ +/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */ + +/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows in the matrix A. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns in the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the m by n general matrix to be reduced. */ +/* On exit, */ +/* if m >= n, the diagonal and the first superdiagonal are */ +/* overwritten with the upper bidiagonal matrix B; the */ +/* elements below the diagonal, with the array TAUQ, represent */ +/* the orthogonal matrix Q as a product of elementary */ +/* reflectors, and the elements above the first superdiagonal, */ +/* with the array TAUP, represent the orthogonal matrix P as */ +/* a product of elementary reflectors; */ +/* if m < n, the diagonal and the first subdiagonal are */ +/* overwritten with the lower bidiagonal matrix B; the */ +/* elements below the first subdiagonal, with the array TAUQ, */ +/* represent the orthogonal matrix Q as a product of */ +/* elementary reflectors, and the elements above the diagonal, */ +/* with the array TAUP, represent the orthogonal matrix P as */ +/* a product of elementary reflectors. */ +/* See Further Details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The diagonal elements of the bidiagonal matrix B: */ +/* D(i) = A(i,i). */ + +/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */ +/* The off-diagonal elements of the bidiagonal matrix B: */ +/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */ +/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */ + +/* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix Q. See Further Details. */ + +/* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix P. See Further Details. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* The matrices Q and P are represented as products of elementary */ +/* reflectors: */ + +/* If m >= n, */ + +/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */ + +/* Each H(i) and G(i) has the form: */ + +/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ + +/* where tauq and taup are real scalars, and v and u are real vectors; */ +/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */ +/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */ +/* tauq is stored in TAUQ(i) and taup in TAUP(i). */ + +/* If m < n, */ + +/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */ + +/* Each H(i) and G(i) has the form: */ + +/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ + +/* where tauq and taup are real scalars, and v and u are real vectors; */ +/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */ +/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */ +/* tauq is stored in TAUQ(i) and taup in TAUP(i). */ + +/* The contents of A on exit are illustrated by the following examples: */ + +/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ + +/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */ +/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */ +/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */ +/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */ +/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */ +/* ( v1 v2 v3 v4 v5 ) */ + +/* where d and e denote diagonal and off-diagonal elements of B, vi */ +/* denotes an element of the vector defining H(i), and ui an element of */ +/* the vector defining G(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("DGEBD2", &i__1); + return 0; + } + + if (*m >= *n) { + +/* Reduce to upper bidiagonal form */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ + + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[std::min(i__3, *m)+ i__ * + a_dim1], &c__1, &tauq[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + +/* Apply H(i) to A(i:m,i+1:n) from the left */ + + if (i__ < *n) { + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & + tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1] +); + } + a[i__ + i__ * a_dim1] = d__[i__]; + + if (i__ < *n) { + +/* Generate elementary reflector G(i) to annihilate */ +/* A(i,i+2:n) */ + + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + std::min( + i__3, *n)* a_dim1], lda, &taup[i__]); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + a[i__ + (i__ + 1) * a_dim1] = 1.; + +/* Apply G(i) to A(i+1:m,i+1:n) from the right */ + + i__2 = *m - i__; + i__3 = *n - i__; + dlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], + lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &work[1]); + a[i__ + (i__ + 1) * a_dim1] = e[i__]; + } else { + taup[i__] = 0.; + } +/* L10: */ + } + } else { + +/* Reduce to lower bidiagonal form */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */ + + i__2 = *n - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + std::min(i__3, *n)* + a_dim1], lda, &taup[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + +/* Apply G(i) to A(i+1:m,i:n) from the right */ + + if (i__ < *m) { + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, & + taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); + } + a[i__ + i__ * a_dim1] = d__[i__]; + + if (i__ < *m) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(i+2:m,i) */ + + i__2 = *m - i__; +/* Computing MIN */ + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *m)+ + i__ * a_dim1], &c__1, &tauq[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; + +/* Apply H(i) to A(i+1:m,i+1:n) from the left */ + + i__2 = *m - i__; + i__3 = *n - i__; + dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], & + c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &work[1]); + a[i__ + 1 + i__ * a_dim1] = e[i__]; + } else { + tauq[i__] = 0.; + } +/* L20: */ + } + } + return 0; + +/* End of DGEBD2 */ + +} /* dgebd2_ */ + +/* Subroutine */ int dgebrd_(integer *m, integer *n, double *a, integer * + lda, double *d__, double *e, double *tauq, double * + taup, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + static double c_b21 = -1.; + static double c_b22 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, nb, nx; + double ws; + integer nbmin, iinfo, minmn; + integer ldwrkx, ldwrky, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEBRD reduces a general real M-by-N matrix A to upper or lower */ +/* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. */ + +/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows in the matrix A. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns in the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N general matrix to be reduced. */ +/* On exit, */ +/* if m >= n, the diagonal and the first superdiagonal are */ +/* overwritten with the upper bidiagonal matrix B; the */ +/* elements below the diagonal, with the array TAUQ, represent */ +/* the orthogonal matrix Q as a product of elementary */ +/* reflectors, and the elements above the first superdiagonal, */ +/* with the array TAUP, represent the orthogonal matrix P as */ +/* a product of elementary reflectors; */ +/* if m < n, the diagonal and the first subdiagonal are */ +/* overwritten with the lower bidiagonal matrix B; the */ +/* elements below the first subdiagonal, with the array TAUQ, */ +/* represent the orthogonal matrix Q as a product of */ +/* elementary reflectors, and the elements above the diagonal, */ +/* with the array TAUP, represent the orthogonal matrix P as */ +/* a product of elementary reflectors. */ +/* See Further Details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The diagonal elements of the bidiagonal matrix B: */ +/* D(i) = A(i,i). */ + +/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */ +/* The off-diagonal elements of the bidiagonal matrix B: */ +/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */ +/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */ + +/* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix Q. See Further Details. */ + +/* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix P. See Further Details. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of the array WORK. LWORK >= max(1,M,N). */ +/* For optimum performance LWORK >= (M+N)*NB, where NB */ +/* is the optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* The matrices Q and P are represented as products of elementary */ +/* reflectors: */ + +/* If m >= n, */ + +/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */ + +/* Each H(i) and G(i) has the form: */ + +/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ + +/* where tauq and taup are real scalars, and v and u are real vectors; */ +/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */ +/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */ +/* tauq is stored in TAUQ(i) and taup in TAUP(i). */ + +/* If m < n, */ + +/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */ + +/* Each H(i) and G(i) has the form: */ + +/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ + +/* where tauq and taup are real scalars, and v and u are real vectors; */ +/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */ +/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */ +/* tauq is stored in TAUQ(i) and taup in TAUP(i). */ + +/* The contents of A on exit are illustrated by the following examples: */ + +/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ + +/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */ +/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */ +/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */ +/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */ +/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */ +/* ( v1 v2 v3 v4 v5 ) */ + +/* where d and e denote diagonal and off-diagonal elements of B, vi */ +/* denotes an element of the vector defining H(i), and ui an element of */ +/* the vector defining G(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + --work; + + /* Function Body */ + *info = 0; +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "DGEBRD", " ", m, n, &c_n1, &c_n1); + nb = std::max(i__1,i__2); + lwkopt = (*m + *n) * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = std::max(1_integer,*m); + if (*lwork < std::max(i__1,*n) && ! lquery) { + *info = -10; + } + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("DGEBRD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + minmn = std::min(*m,*n); + if (minmn == 0) { + work[1] = 1.; + return 0; + } + + ws = (double) std::max(*m,*n); + ldwrkx = *m; + ldwrky = *n; + + if (nb > 1 && nb < minmn) { + +/* Set the crossover point NX. */ + +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__3, "DGEBRD", " ", m, n, &c_n1, &c_n1); + nx = std::max(i__1,i__2); + +/* Determine when to switch from blocked to unblocked code. */ + + if (nx < minmn) { + ws = (double) ((*m + *n) * nb); + if ((double) (*lwork) < ws) { + +/* Not enough work space for the optimal NB, consider using */ +/* a smaller block size. */ + + nbmin = ilaenv_(&c__2, "DGEBRD", " ", m, n, &c_n1, &c_n1); + if (*lwork >= (*m + *n) * nbmin) { + nb = *lwork / (*m + *n); + } else { + nb = 1; + nx = minmn; + } + } + } + } else { + nx = minmn; + } + + i__1 = minmn - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Reduce rows and columns i:i+nb-1 to bidiagonal form and return */ +/* the matrices X and Y which are needed to update the unreduced */ +/* part of the matrix */ + + i__3 = *m - i__ + 1; + i__4 = *n - i__ + 1; + dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[ + i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx + * nb + 1], &ldwrky); + +/* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update */ +/* of the form A := A - V*Y' - X*U' */ + + i__3 = *m - i__ - nb + 1; + i__4 = *n - i__ - nb + 1; + dgemm_("No transpose", "Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__ + + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], & + ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda); + i__3 = *m - i__ - nb + 1; + i__4 = *n - i__ - nb + 1; + dgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &c_b21, & + work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, & + c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda); + +/* Copy diagonal and off-diagonal elements of B back into A */ + + if (*m >= *n) { + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + j * a_dim1] = d__[j]; + a[j + (j + 1) * a_dim1] = e[j]; +/* L10: */ + } + } else { + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + j * a_dim1] = d__[j]; + a[j + 1 + j * a_dim1] = e[j]; +/* L20: */ + } + } +/* L30: */ + } + +/* Use unblocked code to reduce the remainder of the matrix */ + + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], & + tauq[i__], &taup[i__], &work[1], &iinfo); + work[1] = ws; + return 0; + +/* End of DGEBRD */ + +} /* dgebrd_ */ + +/* Subroutine */ int dgecon_(const char *norm, integer *n, double *a, integer * + lda, double *anorm, double *rcond, double *work, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1; + double d__1; + + /* Local variables */ + double sl; + integer ix; + double su; + integer kase, kase1; + double scale; + integer isave[3]; + double ainvnm; + bool onenrm; + char normin[1]; + double smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGECON estimates the reciprocal of the condition number of a general */ +/* real matrix A, in either the 1-norm or the infinity-norm, using */ +/* the LU factorization computed by DGETRF. */ + +/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* condition number is computed as */ +/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies whether the 1-norm condition number or the */ +/* infinity-norm condition number is required: */ +/* = '1' or 'O': 1-norm; */ +/* = 'I': Infinity-norm. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The factors L and U from the factorization A = P*L*U */ +/* as computed by DGETRF. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* ANORM (input) DOUBLE PRECISION */ +/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ +/* If NORM = 'I', the infinity-norm of the original matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else if (*anorm < 0.) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGECON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + + smlnum = dlamch_("Safe minimum"); + +/* Estimate the norm of inv(A). */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(L). */ + + dlatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], + lda, &work[1], &sl, &work[(*n << 1) + 1], info); + +/* Multiply by inv(U). */ + + dlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info); + } else { + +/* Multiply by inv(U'). */ + + dlatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset], + lda, &work[1], &su, &work[*n * 3 + 1], info); + +/* Multiply by inv(L'). */ + + dlatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset], + lda, &work[1], &sl, &work[(*n << 1) + 1], info); + } + +/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ + + scale = sl * su; + *(unsigned char *)normin = 'Y'; + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) + { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + +L20: + return 0; + +/* End of DGECON */ + +} /* dgecon_ */ + +/* Subroutine */ int dgeequ_(integer *m, integer *n, double *a, integer * + lda, double *r__, double *c__, double *rowcnd, double + *colcnd, double *amax, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j; + double rcmin, rcmax; + double bignum, smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEEQU computes row and column scalings intended to equilibrate an */ +/* M-by-N matrix A and reduce its condition number. R returns the row */ +/* scale factors and C the column scale factors, chosen to try to make */ +/* the largest element in each row and column of the matrix B with */ +/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ + +/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ +/* number and BIGNUM = largest safe number. Use of these scaling */ +/* factors is not guaranteed to reduce the condition number of A but */ +/* works well in practice. */ + +/* 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) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The M-by-N matrix whose equilibration factors are */ +/* to be computed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* R (output) DOUBLE PRECISION array, dimension (M) */ +/* If INFO = 0 or INFO > M, R contains the row scale factors */ +/* for A. */ + +/* C (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, C contains the column scale factors for A. */ + +/* ROWCND (output) DOUBLE PRECISION */ +/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* AMAX is neither too large nor too small, it is not worth */ +/* scaling by R. */ + +/* COLCND (output) DOUBLE PRECISION */ +/* If INFO = 0, COLCND contains the ratio of the smallest */ +/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* worth scaling by C. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= M: the i-th row of A is exactly zero */ +/* > M: the (i-M)-th column of A is exactly zero */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEEQU", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.; + *colcnd = 1.; + *amax = 0.; + return 0; + } + +/* Get machine constants. */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = r__[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + r__[i__] = std::max(d__2,d__3); +/* L20: */ + } +/* L30: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[i__]; + rcmax = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[i__]; + rcmin = std::min(d__1,d__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = r__[i__]; + d__1 = std::max(d__2,smlnum); + r__[i__] = 1. / std::min(d__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = min(R(I)) / max(R(I)) */ + + *rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } + +/* Compute column scale factors */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = c__[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) * + r__[i__]; + c__[j] = std::max(d__2,d__3); +/* L80: */ + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = std::max(d__1,d__2); +/* L100: */ + } + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = c__[j]; + d__1 = std::max(d__2,smlnum); + c__[j] = 1. / std::min(d__1,bignum); +/* L120: */ + } + +/* Compute COLCND = min(C(J)) / max(C(J)) */ + + *colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } + + return 0; + +/* End of DGEEQU */ + +} /* dgeequ_ */ + +/* Subroutine */ int dgeequb_(integer *m, integer *n, double *a, integer * + lda, double *r__, double *c__, double *rowcnd, double + *colcnd, double *amax, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j; + double radix, rcmin, rcmax; + double bignum, logrdx, smlnum; + + +/* -- LAPACK routine (version 3.2) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEEQUB computes row and column scalings intended to equilibrate an */ +/* M-by-N matrix A and reduce its condition number. R returns the row */ +/* scale factors and C the column scale factors, chosen to try to make */ +/* the largest element in each row and column of the matrix B with */ +/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */ +/* the radix. */ + +/* R(i) and C(j) are restricted to be a power of the radix between */ +/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */ +/* of these scaling factors is not guaranteed to reduce the condition */ +/* number of A but works well in practice. */ + +/* This routine differs from DGEEQU by restricting the scaling factors */ +/* to a power of the radix. Baring over- and underflow, scaling by */ +/* these factors introduces no additional rounding errors. However, the */ +/* scaled entries' magnitured are no longer approximately 1 but lie */ +/* between sqrt(radix) and 1/sqrt(radix). */ + +/* 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) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The M-by-N matrix whose equilibration factors are */ +/* to be computed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* R (output) DOUBLE PRECISION array, dimension (M) */ +/* If INFO = 0 or INFO > M, R contains the row scale factors */ +/* for A. */ + +/* C (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, C contains the column scale factors for A. */ + +/* ROWCND (output) DOUBLE PRECISION */ +/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* AMAX is neither too large nor too small, it is not worth */ +/* scaling by R. */ + +/* COLCND (output) DOUBLE PRECISION */ +/* If INFO = 0, COLCND contains the ratio of the smallest */ +/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* worth scaling by C. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= M: the i-th row of A is exactly zero */ +/* > M: the (i-M)-th column of A is exactly zero */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEEQUB", &i__1); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.; + *colcnd = 1.; + *amax = 0.; + return 0; + } + +/* Get machine constants. Assume SMLNUM is a power of the radix. */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + radix = dlamch_("B"); + logrdx = log(radix); + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = r__[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + r__[i__] = std::max(d__2,d__3); +/* L20: */ + } +/* L30: */ + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] > 0.) { + i__2 = (integer) (log(r__[i__]) / logrdx); + r__[i__] = pow_di(&radix, &i__2); + } + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[i__]; + rcmax = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[i__]; + rcmin = std::min(d__1,d__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = r__[i__]; + d__1 = std::max(d__2,smlnum); + r__[i__] = 1. / std::min(d__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = min(R(I)) / max(R(I)). */ + + *rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } + +/* Compute column scale factors */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = c__[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) * + r__[i__]; + c__[j] = std::max(d__2,d__3); +/* L80: */ + } + if (c__[j] > 0.) { + i__2 = (integer) (log(c__[j]) / logrdx); + c__[j] = pow_di(&radix, &i__2); + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = std::max(d__1,d__2); +/* L100: */ + } + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = c__[j]; + d__1 = std::max(d__2,smlnum); + c__[j] = 1. / std::min(d__1,bignum); +/* L120: */ + } + +/* Compute COLCND = min(C(J)) / max(C(J)). */ + + *colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } + + return 0; + +/* End of DGEEQUB */ + +} /* dgeequb_ */ + +/* Subroutine */ int dgees_(const char *jobvs, const char *sort, bool (*select)(const double *, const double *), + integer *n, double *a, integer *lda, integer *sdim, double *wr, + double *wi, double *vs, integer *ldvs, double *work, + integer *lwork, bool *bwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3; + + /* Builtin functions + double sqrt(double);*/ + + /* Local variables */ + integer i__; + double s; + integer i1, i2, ip, ihi, ilo; + double dum[1], eps, sep; + integer ibal; + double anrm; + integer idum[1], ierr, itau, iwrk, inxt, icond, ieval; + bool cursl; + bool lst2sl, scalea; + double cscale; + double bignum; + bool lastsl; + integer minwrk, maxwrk; + double smlnum; + integer hswork; + bool wantst, lquery, wantvs; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ +/* .. Function Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEES computes for an N-by-N real nonsymmetric matrix A, the */ +/* eigenvalues, the real Schur form T, and, optionally, the matrix of */ +/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */ + +/* Optionally, it also orders the eigenvalues on the diagonal of the */ +/* real Schur form so that selected eigenvalues are at the top left. */ +/* The leading columns of Z then form an orthonormal basis for the */ +/* invariant subspace corresponding to the selected eigenvalues. */ + +/* A matrix is in real Schur form if it is upper quasi-triangular with */ +/* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the */ +/* form */ +/* [ a b ] */ +/* [ c a ] */ + +/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */ + +/* Arguments */ +/* ========= */ + +/* JOBVS (input) CHARACTER*1 */ +/* = 'N': Schur vectors are not computed; */ +/* = 'V': Schur vectors are computed. */ + +/* SORT (input) CHARACTER*1 */ +/* Specifies whether or not to order the eigenvalues on the */ +/* diagonal of the Schur form. */ +/* = 'N': Eigenvalues are not ordered; */ +/* = 'S': Eigenvalues are ordered (see SELECT). */ + +/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */ +/* SELECT must be declared EXTERNAL in the calling subroutine. */ +/* If SORT = 'S', SELECT is used to select eigenvalues to sort */ +/* to the top left of the Schur form. */ +/* If SORT = 'N', SELECT is not referenced. */ +/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */ +/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex */ +/* conjugate pair of eigenvalues is selected, then both complex */ +/* eigenvalues are selected. */ +/* Note that a selected complex eigenvalue may no longer */ +/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */ +/* ordering may change the value of complex eigenvalues */ +/* (especially if the eigenvalue is ill-conditioned); in this */ +/* case INFO is set to N+2 (see INFO below). */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the N-by-N matrix A. */ +/* On exit, A has been overwritten by its real Schur form T. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* SDIM (output) INTEGER */ +/* If SORT = 'N', SDIM = 0. */ +/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ +/* for which SELECT is true. (Complex conjugate */ +/* pairs for which SELECT is true for either */ +/* eigenvalue count as 2.) */ + +/* WR (output) DOUBLE PRECISION array, dimension (N) */ +/* WI (output) DOUBLE PRECISION array, dimension (N) */ +/* WR and WI contain the real and imaginary parts, */ +/* respectively, of the computed eigenvalues in the same order */ +/* that they appear on the diagonal of the output Schur form T. */ +/* Complex conjugate pairs of eigenvalues will appear */ +/* consecutively with the eigenvalue having the positive */ +/* imaginary part first. */ + +/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */ +/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */ +/* vectors. */ +/* If JOBVS = 'N', VS is not referenced. */ + +/* LDVS (input) INTEGER */ +/* The leading dimension of the array VS. LDVS >= 1; if */ +/* JOBVS = 'V', LDVS >= N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,3*N). */ +/* For good performance, LWORK must generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* BWORK (workspace) LOGICAL array, dimension (N) */ +/* Not referenced if SORT = 'N'. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = i, and i is */ +/* <= N: the QR algorithm failed to compute all the */ +/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */ +/* contain those eigenvalues which have converged; if */ +/* JOBVS = 'V', VS contains the matrix which reduces A */ +/* to its partially converged Schur form. */ +/* = N+1: the eigenvalues could not be reordered because some */ +/* eigenvalues were too close to separate (the problem */ +/* is very ill-conditioned); */ +/* = N+2: after reordering, roundoff changed values of some */ +/* complex eigenvalues so that leading eigenvalues in */ +/* the Schur form no longer satisfy SELECT=.TRUE. This */ +/* could also be caused by underflow due to scaling. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --wr; + --wi; + vs_dim1 = *ldvs; + vs_offset = 1 + vs_dim1; + vs -= vs_offset; + --work; + --bwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + wantvs = lsame_(jobvs, "V"); + wantst = lsame_(sort, "S"); + if (! wantvs && ! lsame_(jobvs, "N")) { + *info = -1; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldvs < 1 || wantvs && *ldvs < *n) { + *info = -11; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV. */ +/* HSWORK refers to the workspace preferred by DHSEQR, as */ +/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ +/* the worst case.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, + n, &c__0); + minwrk = *n * 3; + + dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1] +, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval); + hswork = (integer) work[1]; + + if (! wantvs) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + hswork; + maxwrk = std::max(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, + "DORGHR", " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + hswork; + maxwrk = std::max(i__1,i__2); + } + } + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEES ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, dum); + scalea = false; + if (anrm > 0. && anrm < smlnum) { + scalea = true; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = true; + cscale = bignum; + } + if (scalea) { + dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + +/* Permute the matrix to make it more nearly triangular */ +/* (Workspace: need N) */ + + ibal = 1; + dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr); + +/* Reduce to upper Hessenberg form */ +/* (Workspace: need 3*N, prefer 2*N+N*NB) */ + + itau = *n + ibal; + iwrk = *n + itau; + i__1 = *lwork - iwrk + 1; + dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, + &ierr); + + if (wantvs) { + +/* Copy Householder vectors to VS */ + + dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs) + ; + +/* Generate orthogonal matrix in VS */ +/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ + + i__1 = *lwork - iwrk + 1; + dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk], + &i__1, &ierr); + } + + *sdim = 0; + +/* Perform QR iteration, accumulating Schur vectors in VS if desired */ +/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[ + vs_offset], ldvs, &work[iwrk], &i__1, &ieval); + if (ieval > 0) { + *info = ieval; + } + +/* Sort eigenvalues if desired */ + + if (wantst && *info == 0) { + if (scalea) { + dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, & + ierr); + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*select)(&wr[i__], &wi[i__]); +/* L10: */ + } + +/* Reorder eigenvalues and transform Schur vectors */ +/* (Workspace: none needed) */ + + i__1 = *lwork - iwrk + 1; + dtrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset], + ldvs, &wr[1], &wi[1], sdim, &s, &sep, &work[iwrk], &i__1, + idum, &c__1, &icond); + if (icond > 0) { + *info = *n + icond; + } + } + + if (wantvs) { + +/* Undo balancing */ +/* (Workspace: need N) */ + + dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs, + &ierr); + } + + if (scalea) { + +/* Undo scaling for the Schur form of A */ + + dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, & + ierr); + i__1 = *lda + 1; + dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1); + if (cscale == smlnum) { + +/* If scaling back towards underflow, adjust WI if an */ +/* offdiagonal element of a 2-by-2 block in the Schur form */ +/* underflows. */ + + if (ieval > 0) { + i1 = ieval + 1; + i2 = ihi - 1; + i__1 = ilo - 1; +/* Computing MAX */ + i__3 = ilo - 1; + i__2 = std::max(i__3,1_integer); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ + 1], &i__2, &ierr); + } else if (wantst) { + i1 = 1; + i2 = *n - 1; + } else { + i1 = ilo; + i2 = ihi - 1; + } + inxt = i1 - 1; + i__1 = i2; + for (i__ = i1; i__ <= i__1; ++i__) { + if (i__ < inxt) { + goto L20; + } + if (wi[i__] == 0.) { + inxt = i__ + 1; + } else { + if (a[i__ + 1 + i__ * a_dim1] == 0.) { + wi[i__] = 0.; + wi[i__ + 1] = 0.; + } else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + ( + i__ + 1) * a_dim1] == 0.) { + wi[i__] = 0.; + wi[i__ + 1] = 0.; + if (i__ > 1) { + i__2 = i__ - 1; + dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[( + i__ + 1) * a_dim1 + 1], &c__1); + } + if (*n > i__ + 1) { + i__2 = *n - i__ - 1; + dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, & + a[i__ + 1 + (i__ + 2) * a_dim1], lda); + } + if (wantvs) { + dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + + 1) * vs_dim1 + 1], &c__1); + } + a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ * + a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 0.; + } + inxt = i__ + 2; + } +L20: + ; + } + } + +/* Undo scaling for the imaginary part of the eigenvalues */ + + i__1 = *n - ieval; +/* Computing MAX */ + i__3 = *n - ieval; + i__2 = std::max(i__3,1_integer); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval + + 1], &i__2, &ierr); + } + + if (wantst && *info == 0) { + +/* Check if reordering successful */ + + lastsl = true; + lst2sl = true; + *sdim = 0; + ip = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cursl = (*select)(&wr[i__], &wi[i__]); + if (wi[i__] == 0.) { + if (cursl) { + ++(*sdim); + } + ip = 0; + if (cursl && ! lastsl) { + *info = *n + 2; + } + } else { + if (ip == 1) { + +/* Last eigenvalue of conjugate pair */ + + cursl = cursl || lastsl; + lastsl = cursl; + if (cursl) { + *sdim += 2; + } + ip = -1; + if (cursl && ! lst2sl) { + *info = *n + 2; + } + } else { + +/* First eigenvalue of conjugate pair */ + + ip = 1; + } + } + lst2sl = lastsl; + lastsl = cursl; +/* L30: */ + } + } + + work[1] = (double) maxwrk; + return 0; + +/* End of DGEES */ + +} /* dgees_ */ + +/* Subroutine */ int dgeesx_(const char *jobvs, const char *sort, bool (*select)(const double *, const double *), + const char *sense, integer *n, double *a, integer *lda, integer *sdim, + double *wr, double *wi, double *vs, integer *ldvs, + double *rconde, double *rcondv, double *work, integer * + lwork, integer *iwork, integer *liwork, bool *bwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, i1, i2, ip, ihi, ilo; + double dum[1], eps; + integer ibal; + double anrm; + integer ierr, itau, iwrk, lwrk, inxt, icond, ieval; + bool cursl; + integer liwrk; + bool lst2sl, scalea; + double cscale; + double bignum; + bool wantsb; + bool wantse, lastsl; + integer minwrk, maxwrk; + bool wantsn; + double smlnum; + integer hswork; + bool wantst, lquery, wantsv, wantvs; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ +/* .. Function Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEESX computes for an N-by-N real nonsymmetric matrix A, the */ +/* eigenvalues, the real Schur form T, and, optionally, the matrix of */ +/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */ + +/* Optionally, it also orders the eigenvalues on the diagonal of the */ +/* real Schur form so that selected eigenvalues are at the top left; */ +/* computes a reciprocal condition number for the average of the */ +/* selected eigenvalues (RCONDE); and computes a reciprocal condition */ +/* number for the right invariant subspace corresponding to the */ +/* selected eigenvalues (RCONDV). The leading columns of Z form an */ +/* orthonormal basis for this invariant subspace. */ + +/* For further explanation of the reciprocal condition numbers RCONDE */ +/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */ +/* these quantities are called s and sep respectively). */ + +/* A real matrix is in real Schur form if it is upper quasi-triangular */ +/* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in */ +/* the form */ +/* [ a b ] */ +/* [ c a ] */ + +/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */ + +/* Arguments */ +/* ========= */ + +/* JOBVS (input) CHARACTER*1 */ +/* = 'N': Schur vectors are not computed; */ +/* = 'V': Schur vectors are computed. */ + +/* SORT (input) CHARACTER*1 */ +/* Specifies whether or not to order the eigenvalues on the */ +/* diagonal of the Schur form. */ +/* = 'N': Eigenvalues are not ordered; */ +/* = 'S': Eigenvalues are ordered (see SELECT). */ + +/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */ +/* SELECT must be declared EXTERNAL in the calling subroutine. */ +/* If SORT = 'S', SELECT is used to select eigenvalues to sort */ +/* to the top left of the Schur form. */ +/* If SORT = 'N', SELECT is not referenced. */ +/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */ +/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a */ +/* complex conjugate pair of eigenvalues is selected, then both */ +/* are. Note that a selected complex eigenvalue may no longer */ +/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */ +/* ordering may change the value of complex eigenvalues */ +/* (especially if the eigenvalue is ill-conditioned); in this */ +/* case INFO may be set to N+3 (see INFO below). */ + +/* SENSE (input) CHARACTER*1 */ +/* Determines which reciprocal condition numbers are computed. */ +/* = 'N': None are computed; */ +/* = 'E': Computed for average of selected eigenvalues only; */ +/* = 'V': Computed for selected right invariant subspace only; */ +/* = 'B': Computed for both. */ +/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the N-by-N matrix A. */ +/* On exit, A is overwritten by its real Schur form T. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* SDIM (output) INTEGER */ +/* If SORT = 'N', SDIM = 0. */ +/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ +/* for which SELECT is true. (Complex conjugate */ +/* pairs for which SELECT is true for either */ +/* eigenvalue count as 2.) */ + +/* WR (output) DOUBLE PRECISION array, dimension (N) */ +/* WI (output) DOUBLE PRECISION array, dimension (N) */ +/* WR and WI contain the real and imaginary parts, respectively, */ +/* of the computed eigenvalues, in the same order that they */ +/* appear on the diagonal of the output Schur form T. Complex */ +/* conjugate pairs of eigenvalues appear consecutively with the */ +/* eigenvalue having the positive imaginary part first. */ + +/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */ +/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */ +/* vectors. */ +/* If JOBVS = 'N', VS is not referenced. */ + +/* LDVS (input) INTEGER */ +/* The leading dimension of the array VS. LDVS >= 1, and if */ +/* JOBVS = 'V', LDVS >= N. */ + +/* RCONDE (output) DOUBLE PRECISION */ +/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */ +/* condition number for the average of the selected eigenvalues. */ +/* Not referenced if SENSE = 'N' or 'V'. */ + +/* RCONDV (output) DOUBLE PRECISION */ +/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */ +/* condition number for the selected right invariant subspace. */ +/* Not referenced if SENSE = 'N' or 'E'. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,3*N). */ +/* Also, if SENSE = 'E' or 'V' or 'B', */ +/* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of */ +/* selected eigenvalues computed by this routine. Note that */ +/* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only */ +/* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or */ +/* 'B' this may not be large enough. */ +/* For good performance, LWORK must generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates upper bounds on the optimal sizes of the */ +/* arrays WORK and IWORK, returns these values as the first */ +/* entries of the WORK and IWORK arrays, and no error messages */ +/* related to LWORK or LIWORK are issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). */ +/* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is */ +/* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this */ +/* may not be large enough. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates upper bounds on the optimal sizes of */ +/* the arrays WORK and IWORK, returns these values as the first */ +/* entries of the WORK and IWORK arrays, and no error messages */ +/* related to LWORK or LIWORK are issued by XERBLA. */ + +/* BWORK (workspace) LOGICAL array, dimension (N) */ +/* Not referenced if SORT = 'N'. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = i, and i is */ +/* <= N: the QR algorithm failed to compute all the */ +/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */ +/* contain those eigenvalues which have converged; if */ +/* JOBVS = 'V', VS contains the transformation which */ +/* reduces A to its partially converged Schur form. */ +/* = N+1: the eigenvalues could not be reordered because some */ +/* eigenvalues were too close to separate (the problem */ +/* is very ill-conditioned); */ +/* = N+2: after reordering, roundoff changed values of some */ +/* complex eigenvalues so that leading eigenvalues in */ +/* the Schur form no longer satisfy SELECT=.TRUE. This */ +/* could also be caused by underflow due to scaling. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --wr; + --wi; + vs_dim1 = *ldvs; + vs_offset = 1 + vs_dim1; + vs -= vs_offset; + --work; + --iwork; + --bwork; + + /* Function Body */ + *info = 0; + wantvs = lsame_(jobvs, "V"); + wantst = lsame_(sort, "S"); + wantsn = lsame_(sense, "N"); + wantse = lsame_(sense, "E"); + wantsv = lsame_(sense, "V"); + wantsb = lsame_(sense, "B"); + lquery = *lwork == -1 || *liwork == -1; + if (! wantvs && ! lsame_(jobvs, "N")) { + *info = -1; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -2; + } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && ! + wantsn) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldvs < 1 || wantvs && *ldvs < *n) { + *info = -12; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "RWorkspace:" describe the */ +/* minimal amount of real workspace needed at that point in the */ +/* code, as well as the preferred amount for good performance. */ +/* IWorkspace refers to integer workspace. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV. */ +/* HSWORK refers to the workspace preferred by DHSEQR, as */ +/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ +/* the worst case. */ +/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */ +/* depends on SDIM, which is computed by the routine DTRSEN later */ +/* in the code.) */ + + if (*info == 0) { + liwrk = 1; + if (*n == 0) { + minwrk = 1; + lwrk = 1; + } else { + maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, + n, &c__0); + minwrk = *n * 3; + + dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1] +, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval); + hswork = (integer) work[1]; + + if (! wantvs) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + hswork; + maxwrk = std::max(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, + "DORGHR", " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + hswork; + maxwrk = std::max(i__1,i__2); + } + lwrk = maxwrk; + if (! wantsn) { +/* Computing MAX */ + i__1 = lwrk, i__2 = *n + *n * *n / 2; + lwrk = std::max(i__1,i__2); + } + if (wantsv || wantsb) { + liwrk = *n * *n / 4; + } + } + iwork[1] = liwrk; + work[1] = (double) lwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -16; + } else if (*liwork < 1 && ! lquery) { + *info = -18; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEESX", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, dum); + scalea = false; + if (anrm > 0. && anrm < smlnum) { + scalea = true; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = true; + cscale = bignum; + } + if (scalea) { + dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + +/* Permute the matrix to make it more nearly triangular */ +/* (RWorkspace: need N) */ + + ibal = 1; + dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr); + +/* Reduce to upper Hessenberg form */ +/* (RWorkspace: need 3*N, prefer 2*N+N*NB) */ + + itau = *n + ibal; + iwrk = *n + itau; + i__1 = *lwork - iwrk + 1; + dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, + &ierr); + + if (wantvs) { + +/* Copy Householder vectors to VS */ + + dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs) + ; + +/* Generate orthogonal matrix in VS */ +/* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ + + i__1 = *lwork - iwrk + 1; + dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk], + &i__1, &ierr); + } + + *sdim = 0; + +/* Perform QR iteration, accumulating Schur vectors in VS if desired */ +/* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[ + vs_offset], ldvs, &work[iwrk], &i__1, &ieval); + if (ieval > 0) { + *info = ieval; + } + +/* Sort eigenvalues if desired */ + + if (wantst && *info == 0) { + if (scalea) { + dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, & + ierr); + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*select)(&wr[i__], &wi[i__]); +/* L10: */ + } + +/* Reorder eigenvalues, transform Schur vectors, and compute */ +/* reciprocal condition numbers */ +/* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) */ +/* otherwise, need N ) */ +/* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) */ +/* otherwise, need 0 ) */ + + i__1 = *lwork - iwrk + 1; + dtrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset], + ldvs, &wr[1], &wi[1], sdim, rconde, rcondv, &work[iwrk], & + i__1, &iwork[1], liwork, &icond); + if (! wantsn) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + (*sdim << 1) * (*n - *sdim); + maxwrk = std::max(i__1,i__2); + } + if (icond == -15) { + +/* Not enough real workspace */ + + *info = -16; + } else if (icond == -17) { + +/* Not enough integer workspace */ + + *info = -18; + } else if (icond > 0) { + +/* DTRSEN failed to reorder or to restore standard Schur form */ + + *info = icond + *n; + } + } + + if (wantvs) { + +/* Undo balancing */ +/* (RWorkspace: need N) */ + + dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs, + &ierr); + } + + if (scalea) { + +/* Undo scaling for the Schur form of A */ + + dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, & + ierr); + i__1 = *lda + 1; + dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1); + if ((wantsv || wantsb) && *info == 0) { + dum[0] = *rcondv; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, & + c__1, &ierr); + *rcondv = dum[0]; + } + if (cscale == smlnum) { + +/* If scaling back towards underflow, adjust WI if an */ +/* offdiagonal element of a 2-by-2 block in the Schur form */ +/* underflows. */ + + if (ieval > 0) { + i1 = ieval + 1; + i2 = ihi - 1; + i__1 = ilo - 1; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ + 1], n, &ierr); + } else if (wantst) { + i1 = 1; + i2 = *n - 1; + } else { + i1 = ilo; + i2 = ihi - 1; + } + inxt = i1 - 1; + i__1 = i2; + for (i__ = i1; i__ <= i__1; ++i__) { + if (i__ < inxt) { + goto L20; + } + if (wi[i__] == 0.) { + inxt = i__ + 1; + } else { + if (a[i__ + 1 + i__ * a_dim1] == 0.) { + wi[i__] = 0.; + wi[i__ + 1] = 0.; + } else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + ( + i__ + 1) * a_dim1] == 0.) { + wi[i__] = 0.; + wi[i__ + 1] = 0.; + if (i__ > 1) { + i__2 = i__ - 1; + dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[( + i__ + 1) * a_dim1 + 1], &c__1); + } + if (*n > i__ + 1) { + i__2 = *n - i__ - 1; + dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, & + a[i__ + 1 + (i__ + 2) * a_dim1], lda); + } + dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1) + * vs_dim1 + 1], &c__1); + a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ * + a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 0.; + } + inxt = i__ + 2; + } +L20: + ; + } + } + i__1 = *n - ieval; +/* Computing MAX */ + i__3 = *n - ieval; + i__2 = std::max(i__3,1_integer); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval + + 1], &i__2, &ierr); + } + + if (wantst && *info == 0) { + +/* Check if reordering successful */ + + lastsl = true; + lst2sl = true; + *sdim = 0; + ip = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cursl = (*select)(&wr[i__], &wi[i__]); + if (wi[i__] == 0.) { + if (cursl) { + ++(*sdim); + } + ip = 0; + if (cursl && ! lastsl) { + *info = *n + 2; + } + } else { + if (ip == 1) { + +/* Last eigenvalue of conjugate pair */ + + cursl = cursl || lastsl; + lastsl = cursl; + if (cursl) { + *sdim += 2; + } + ip = -1; + if (cursl && ! lst2sl) { + *info = *n + 2; + } + } else { + +/* First eigenvalue of conjugate pair */ + + ip = 1; + } + } + lst2sl = lastsl; + lastsl = cursl; +/* L30: */ + } + } + + work[1] = (double) maxwrk; + if (wantsv || wantsb) { +/* Computing MAX */ + i__1 = 1, i__2 = *sdim * (*n - *sdim); + iwork[1] = std::max(i__1,i__2); + } else { + iwork[1] = 1; + } + + return 0; + +/* End of DGEESX */ + +} /* dgeesx_ */ + +/* Subroutine */ int dgeev_(const char *jobvl, const char *jobvr, integer *n, double *a, integer *lda, double *wr, double *wi, + double *vl, integer *ldvl, double *vr, integer *ldvr, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3; + double d__1, d__2; + + /* Local variables */ + integer i__, k; + double r__, cs, sn; + integer ihi; + double scl; + integer ilo; + double dum[1], eps; + integer ibal; + char side[1]; + double anrm; + integer ierr, itau; + integer iwrk, nout; + bool scalea; + double cscale; + bool select[1]; + double bignum; + integer minwrk, maxwrk; + bool wantvl; + double smlnum; + integer hswork; + bool lquery, wantvr; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEEV computes for an N-by-N real nonsymmetric matrix A, the */ +/* eigenvalues and, optionally, the left and/or right eigenvectors. */ + +/* The right eigenvector v(j) of A satisfies */ +/* A * v(j) = lambda(j) * v(j) */ +/* where lambda(j) is its eigenvalue. */ +/* The left eigenvector u(j) of A satisfies */ +/* u(j)**H * A = lambda(j) * u(j)**H */ +/* where u(j)**H denotes the conjugate transpose of u(j). */ + +/* The computed eigenvectors are normalized to have Euclidean norm */ +/* equal to 1 and largest component real. */ + +/* Arguments */ +/* ========= */ + +/* JOBVL (input) CHARACTER*1 */ +/* = 'N': left eigenvectors of A are not computed; */ +/* = 'V': left eigenvectors of A are computed. */ + +/* JOBVR (input) CHARACTER*1 */ +/* = 'N': right eigenvectors of A are not computed; */ +/* = 'V': right eigenvectors of A are computed. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the N-by-N matrix A. */ +/* On exit, A has been overwritten. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* WR (output) DOUBLE PRECISION array, dimension (N) */ +/* WI (output) DOUBLE PRECISION array, dimension (N) */ +/* WR and WI contain the real and imaginary parts, */ +/* respectively, of the computed eigenvalues. Complex */ +/* conjugate pairs of eigenvalues appear consecutively */ +/* with the eigenvalue having the positive imaginary part */ +/* first. */ + +/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ +/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* after another in the columns of VL, in the same order */ +/* as their eigenvalues. */ +/* If JOBVL = 'N', VL is not referenced. */ +/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */ +/* the j-th column of VL. */ +/* If the j-th and (j+1)-st eigenvalues form a complex */ +/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */ +/* u(j+1) = VL(:,j) - i*VL(:,j+1). */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the array VL. LDVL >= 1; if */ +/* JOBVL = 'V', LDVL >= N. */ + +/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ +/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* after another in the columns of VR, in the same order */ +/* as their eigenvalues. */ +/* If JOBVR = 'N', VR is not referenced. */ +/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */ +/* the j-th column of VR. */ +/* If the j-th and (j+1)-st eigenvalues form a complex */ +/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */ +/* v(j+1) = VR(:,j) - i*VR(:,j+1). */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the array VR. LDVR >= 1; if */ +/* JOBVR = 'V', LDVR >= N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,3*N), and */ +/* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */ +/* performance, LWORK must generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = i, the QR algorithm failed to compute all the */ +/* eigenvalues, and no eigenvectors have been computed; */ +/* elements i+1:N of WR and WI contain eigenvalues which */ +/* have converged. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --wr; + --wi; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + wantvl = lsame_(jobvl, "V"); + wantvr = lsame_(jobvr, "V"); + if (! wantvl && ! lsame_(jobvl, "N")) { + *info = -1; + } else if (! wantvr && ! lsame_(jobvr, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldvl < 1 || wantvl && *ldvl < *n) { + *info = -9; + } else if (*ldvr < 1 || wantvr && *ldvr < *n) { + *info = -11; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV. */ +/* HSWORK refers to the workspace preferred by DHSEQR, as */ +/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ +/* the worst case.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, + n, &c__0); + if (wantvl) { + minwrk = *n << 2; +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, + "DORGHR", " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); + dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ + 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info); + hswork = (integer) work[1]; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + 1, i__1 = std::max(i__1,i__2), i__2 = * + n + hswork; + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n << 2; + maxwrk = std::max(i__1,i__2); + } else if (wantvr) { + minwrk = *n << 2; +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, + "DORGHR", " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); + dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ + 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); + hswork = (integer) work[1]; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + 1, i__1 = std::max(i__1,i__2), i__2 = * + n + hswork; + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n << 2; + maxwrk = std::max(i__1,i__2); + } else { + minwrk = *n * 3; + dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ + 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); + hswork = (integer) work[1]; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + 1, i__1 = std::max(i__1,i__2), i__2 = * + n + hswork; + maxwrk = std::max(i__1,i__2); + } + maxwrk = std::max(maxwrk,minwrk); + } + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEEV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, dum); + scalea = false; + if (anrm > 0. && anrm < smlnum) { + scalea = true; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = true; + cscale = bignum; + } + if (scalea) { + dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + +/* Balance the matrix */ +/* (Workspace: need N) */ + + ibal = 1; + dgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr); + +/* Reduce to upper Hessenberg form */ +/* (Workspace: need 3*N, prefer 2*N+N*NB) */ + + itau = ibal + *n; + iwrk = itau + *n; + i__1 = *lwork - iwrk + 1; + dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, + &ierr); + + if (wantvl) { + +/* Want left eigenvectors */ +/* Copy Householder vectors to VL */ + + *(unsigned char *)side = 'L'; + dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) + ; + +/* Generate orthogonal matrix in VL */ +/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ + + i__1 = *lwork - iwrk + 1; + dorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], + &i__1, &ierr); + +/* Perform QR iteration, accumulating Schur vectors in VL */ +/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & + vl[vl_offset], ldvl, &work[iwrk], &i__1, info); + + if (wantvr) { + +/* Want left and right eigenvectors */ +/* Copy Schur vectors to VR */ + + *(unsigned char *)side = 'B'; + dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); + } + + } else if (wantvr) { + +/* Want right eigenvectors */ +/* Copy Householder vectors to VR */ + + *(unsigned char *)side = 'R'; + dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) + ; + +/* Generate orthogonal matrix in VR */ +/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ + + i__1 = *lwork - iwrk + 1; + dorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], + &i__1, &ierr); + +/* Perform QR iteration, accumulating Schur vectors in VR */ +/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & + vr[vr_offset], ldvr, &work[iwrk], &i__1, info); + + } else { + +/* Compute eigenvalues only */ +/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], & + vr[vr_offset], ldvr, &work[iwrk], &i__1, info); + } + +/* If INFO > 0 from DHSEQR, then quit */ + + if (*info > 0) { + goto L50; + } + + if (wantvl || wantvr) { + +/* Compute left and/or right eigenvectors */ +/* (Workspace: need 4*N) */ + + dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, + &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr); + } + + if (wantvl) { + +/* Undo balancing of left eigenvectors */ +/* (Workspace: need N) */ + + dgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl, + &ierr); + +/* Normalize left eigenvectors and make largest component real */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (wi[i__] == 0.) { + scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); + dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); + } else if (wi[i__] > 0.) { + d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); + scl = 1. / dlapy2_(&d__1, &d__2); + dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); + dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing 2nd power */ + d__1 = vl[k + i__ * vl_dim1]; +/* Computing 2nd power */ + d__2 = vl[k + (i__ + 1) * vl_dim1]; + work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2; +/* L10: */ + } + k = idamax_(n, &work[iwrk], &c__1); + dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1], + &cs, &sn, &r__); + drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) * + vl_dim1 + 1], &c__1, &cs, &sn); + vl[k + (i__ + 1) * vl_dim1] = 0.; + } +/* L20: */ + } + } + + if (wantvr) { + +/* Undo balancing of right eigenvectors */ +/* (Workspace: need N) */ + + dgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr, + &ierr); + +/* Normalize right eigenvectors and make largest component real */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (wi[i__] == 0.) { + scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); + dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); + } else if (wi[i__] > 0.) { + d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); + scl = 1. / dlapy2_(&d__1, &d__2); + dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); + dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing 2nd power */ + d__1 = vr[k + i__ * vr_dim1]; +/* Computing 2nd power */ + d__2 = vr[k + (i__ + 1) * vr_dim1]; + work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2; +/* L30: */ + } + k = idamax_(n, &work[iwrk], &c__1); + dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1], + &cs, &sn, &r__); + drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) * + vr_dim1 + 1], &c__1, &cs, &sn); + vr[k + (i__ + 1) * vr_dim1] = 0.; + } +/* L40: */ + } + } + +/* Undo scaling if necessary */ + +L50: + if (scalea) { + i__1 = *n - *info; +/* Computing MAX */ + i__3 = *n - *info; + i__2 = std::max(i__3,1_integer); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info + + 1], &i__2, &ierr); + i__1 = *n - *info; +/* Computing MAX */ + i__3 = *n - *info; + i__2 = std::max(i__3,1_integer); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info + + 1], &i__2, &ierr); + if (*info > 0) { + i__1 = ilo - 1; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1], + n, &ierr); + i__1 = ilo - 1; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1], + n, &ierr); + } + } + + work[1] = (double) maxwrk; + return 0; + +/* End of DGEEV */ + +} /* dgeev_ */ + +/* Subroutine */ int dgeevx_(const char *balanc, const char *jobvl, const char *jobvr, const char * + sense, integer *n, double *a, integer *lda, double *wr, + double *wi, double *vl, integer *ldvl, double *vr, + integer *ldvr, integer *ilo, integer *ihi, double *scale, + double *abnrm, double *rconde, double *rcondv, double + *work, integer *lwork, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3; + double d__1, d__2; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__, k; + double r__, cs, sn; + char job[1]; + double scl, dum[1], eps; + char side[1]; + double anrm; + integer ierr, itau; + integer iwrk, nout; + integer icond; + bool scalea; + double cscale; + bool select[1]; + double bignum; + integer minwrk, maxwrk; + bool wantvl, wntsnb; + integer hswork; + bool wntsne; + double smlnum; + bool lquery, wantvr, wntsnn, wntsnv; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the */ +/* eigenvalues and, optionally, the left and/or right eigenvectors. */ + +/* Optionally also, it computes a balancing transformation to improve */ +/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */ +/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */ +/* (RCONDE), and reciprocal condition numbers for the right */ +/* eigenvectors (RCONDV). */ + +/* The right eigenvector v(j) of A satisfies */ +/* A * v(j) = lambda(j) * v(j) */ +/* where lambda(j) is its eigenvalue. */ +/* The left eigenvector u(j) of A satisfies */ +/* u(j)**H * A = lambda(j) * u(j)**H */ +/* where u(j)**H denotes the conjugate transpose of u(j). */ + +/* The computed eigenvectors are normalized to have Euclidean norm */ +/* equal to 1 and largest component real. */ + +/* Balancing a matrix means permuting the rows and columns to make it */ +/* more nearly upper triangular, and applying a diagonal similarity */ +/* transformation D * A * D**(-1), where D is a diagonal matrix, to */ +/* make its rows and columns closer in norm and the condition numbers */ +/* of its eigenvalues and eigenvectors smaller. The computed */ +/* reciprocal condition numbers correspond to the balanced matrix. */ +/* Permuting rows and columns will not change the condition numbers */ +/* (in exact arithmetic) but diagonal scaling will. For further */ +/* explanation of balancing, see section 4.10.2 of the LAPACK */ +/* Users' Guide. */ + +/* Arguments */ +/* ========= */ + +/* BALANC (input) CHARACTER*1 */ +/* Indicates how the input matrix should be diagonally scaled */ +/* and/or permuted to improve the conditioning of its */ +/* eigenvalues. */ +/* = 'N': Do not diagonally scale or permute; */ +/* = 'P': Perform permutations to make the matrix more nearly */ +/* upper triangular. Do not diagonally scale; */ +/* = 'S': Diagonally scale the matrix, i.e. replace A by */ +/* D*A*D**(-1), where D is a diagonal matrix chosen */ +/* to make the rows and columns of A more equal in */ +/* norm. Do not permute; */ +/* = 'B': Both diagonally scale and permute A. */ + +/* Computed reciprocal condition numbers will be for the matrix */ +/* after balancing and/or permuting. Permuting does not change */ +/* condition numbers (in exact arithmetic), but balancing does. */ + +/* JOBVL (input) CHARACTER*1 */ +/* = 'N': left eigenvectors of A are not computed; */ +/* = 'V': left eigenvectors of A are computed. */ +/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */ + +/* JOBVR (input) CHARACTER*1 */ +/* = 'N': right eigenvectors of A are not computed; */ +/* = 'V': right eigenvectors of A are computed. */ +/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */ + +/* SENSE (input) CHARACTER*1 */ +/* Determines which reciprocal condition numbers are computed. */ +/* = 'N': None are computed; */ +/* = 'E': Computed for eigenvalues only; */ +/* = 'V': Computed for right eigenvectors only; */ +/* = 'B': Computed for eigenvalues and right eigenvectors. */ + +/* If SENSE = 'E' or 'B', both left and right eigenvectors */ +/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the N-by-N matrix A. */ +/* On exit, A has been overwritten. If JOBVL = 'V' or */ +/* JOBVR = 'V', A contains the real Schur form of the balanced */ +/* version of the input matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* WR (output) DOUBLE PRECISION array, dimension (N) */ +/* WI (output) DOUBLE PRECISION array, dimension (N) */ +/* WR and WI contain the real and imaginary parts, */ +/* respectively, of the computed eigenvalues. Complex */ +/* conjugate pairs of eigenvalues will appear consecutively */ +/* with the eigenvalue having the positive imaginary part */ +/* first. */ + +/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ +/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* after another in the columns of VL, in the same order */ +/* as their eigenvalues. */ +/* If JOBVL = 'N', VL is not referenced. */ +/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */ +/* the j-th column of VL. */ +/* If the j-th and (j+1)-st eigenvalues form a complex */ +/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */ +/* u(j+1) = VL(:,j) - i*VL(:,j+1). */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the array VL. LDVL >= 1; if */ +/* JOBVL = 'V', LDVL >= N. */ + +/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ +/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* after another in the columns of VR, in the same order */ +/* as their eigenvalues. */ +/* If JOBVR = 'N', VR is not referenced. */ +/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */ +/* the j-th column of VR. */ +/* If the j-th and (j+1)-st eigenvalues form a complex */ +/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */ +/* v(j+1) = VR(:,j) - i*VR(:,j+1). */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the array VR. LDVR >= 1, and if */ +/* JOBVR = 'V', LDVR >= N. */ + +/* ILO (output) INTEGER */ +/* IHI (output) INTEGER */ +/* ILO and IHI are integer values determined when A was */ +/* balanced. The balanced A(i,j) = 0 if I > J and */ +/* J = 1,...,ILO-1 or I = IHI+1,...,N. */ + +/* SCALE (output) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutations and scaling factors applied */ +/* when balancing A. If P(j) is the index of the row and column */ +/* interchanged with row and column j, and D(j) is the scaling */ +/* factor applied to row and column j, then */ +/* SCALE(J) = P(J), for J = 1,...,ILO-1 */ +/* = D(J), for J = ILO,...,IHI */ +/* = P(J) for J = IHI+1,...,N. */ +/* The order in which the interchanges are made is N to IHI+1, */ +/* then 1 to ILO-1. */ + +/* ABNRM (output) DOUBLE PRECISION */ +/* The one-norm of the balanced matrix (the maximum */ +/* of the sum of absolute values of elements of any column). */ + +/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */ +/* RCONDE(j) is the reciprocal condition number of the j-th */ +/* eigenvalue. */ + +/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */ +/* RCONDV(j) is the reciprocal condition number of the j-th */ +/* right eigenvector. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. If SENSE = 'N' or 'E', */ +/* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */ +/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */ +/* For good performance, LWORK must generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (2*N-2) */ +/* If SENSE = 'N' or 'E', not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = i, the QR algorithm failed to compute all the */ +/* eigenvalues, and no eigenvectors or condition numbers */ +/* have been computed; elements 1:ILO-1 and i+1:N of WR */ +/* and WI contain eigenvalues which have converged. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --wr; + --wi; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --scale; + --rconde; + --rcondv; + --work; + --iwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + wantvl = lsame_(jobvl, "V"); + wantvr = lsame_(jobvr, "V"); + wntsnn = lsame_(sense, "N"); + wntsne = lsame_(sense, "E"); + wntsnv = lsame_(sense, "V"); + wntsnb = lsame_(sense, "B"); + if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") + || lsame_(balanc, "B"))) { + *info = -1; + } else if (! wantvl && ! lsame_(jobvl, "N")) { + *info = -2; + } else if (! wantvr && ! lsame_(jobvr, "N")) { + *info = -3; + } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb) + && ! (wantvl && wantvr)) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldvl < 1 || wantvl && *ldvl < *n) { + *info = -11; + } else if (*ldvr < 1 || wantvr && *ldvr < *n) { + *info = -13; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV. */ +/* HSWORK refers to the workspace preferred by DHSEQR, as */ +/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ +/* the worst case.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + maxwrk = *n + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, & + c__0); + + if (wantvl) { + dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ + 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info); + } else if (wantvr) { + dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[ + 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info); + } else { + if (wntsnn) { + dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], + &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1, + info); + } else { + dhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], + &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1, + info); + } + } + hswork = (integer) work[1]; + + if (! wantvl && ! wantvr) { + minwrk = *n << 1; + if (! wntsnn) { +/* Computing MAX */ + i__1 = minwrk, i__2 = *n * *n + *n * 6; + minwrk = std::max(i__1,i__2); + } + maxwrk = std::max(maxwrk,hswork); + if (! wntsnn) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * *n + *n * 6; + maxwrk = std::max(i__1,i__2); + } + } else { + minwrk = *n * 3; + if (! wntsnn && ! wntsne) { +/* Computing MAX */ + i__1 = minwrk, i__2 = *n * *n + *n * 6; + minwrk = std::max(i__1,i__2); + } + maxwrk = std::max(maxwrk,hswork); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "DORGHR", + " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); + if (! wntsnn && ! wntsne) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * *n + *n * 6; + maxwrk = std::max(i__1,i__2); + } +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * 3; + maxwrk = std::max(i__1,i__2); + } + maxwrk = std::max(maxwrk,minwrk); + } + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -21; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEEVX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + icond = 0; + anrm = dlange_("M", n, n, &a[a_offset], lda, dum); + scalea = false; + if (anrm > 0. && anrm < smlnum) { + scalea = true; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = true; + cscale = bignum; + } + if (scalea) { + dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + +/* Balance the matrix and compute ABNRM */ + + dgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr); + *abnrm = dlange_("1", n, n, &a[a_offset], lda, dum); + if (scalea) { + dum[0] = *abnrm; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, & + ierr); + *abnrm = dum[0]; + } + +/* Reduce to upper Hessenberg form */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + itau = 1; + iwrk = itau + *n; + i__1 = *lwork - iwrk + 1; + dgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, & + ierr); + + if (wantvl) { + +/* Want left eigenvectors */ +/* Copy Householder vectors to VL */ + + *(unsigned char *)side = 'L'; + dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) + ; + +/* Generate orthogonal matrix in VL */ +/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */ + + i__1 = *lwork - iwrk + 1; + dorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], & + i__1, &ierr); + +/* Perform QR iteration, accumulating Schur vectors in VL */ +/* (Workspace: need 1, prefer HSWORK (see comments) ) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[ + vl_offset], ldvl, &work[iwrk], &i__1, info); + + if (wantvr) { + +/* Want left and right eigenvectors */ +/* Copy Schur vectors to VR */ + + *(unsigned char *)side = 'B'; + dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); + } + + } else if (wantvr) { + +/* Want right eigenvectors */ +/* Copy Householder vectors to VR */ + + *(unsigned char *)side = 'R'; + dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) + ; + +/* Generate orthogonal matrix in VR */ +/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */ + + i__1 = *lwork - iwrk + 1; + dorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], & + i__1, &ierr); + +/* Perform QR iteration, accumulating Schur vectors in VR */ +/* (Workspace: need 1, prefer HSWORK (see comments) ) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[ + vr_offset], ldvr, &work[iwrk], &i__1, info); + + } else { + +/* Compute eigenvalues only */ +/* If condition numbers desired, compute Schur form */ + + if (wntsnn) { + *(unsigned char *)job = 'E'; + } else { + *(unsigned char *)job = 'S'; + } + +/* (Workspace: need 1, prefer HSWORK (see comments) ) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + dhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[ + vr_offset], ldvr, &work[iwrk], &i__1, info); + } + +/* If INFO > 0 from DHSEQR, then quit */ + + if (*info > 0) { + goto L50; + } + + if (wantvl || wantvr) { + +/* Compute left and/or right eigenvectors */ +/* (Workspace: need 3*N) */ + + dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl, + &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr); + } + +/* Compute condition numbers if desired */ +/* (Workspace: need N*N+6*N unless SENSE = 'E') */ + + if (! wntsnn) { + dtrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout, + &work[iwrk], n, &iwork[1], &icond); + } + + if (wantvl) { + +/* Undo balancing of left eigenvectors */ + + dgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl, + &ierr); + +/* Normalize left eigenvectors and make largest component real */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (wi[i__] == 0.) { + scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); + dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); + } else if (wi[i__] > 0.) { + d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); + scl = 1. / dlapy2_(&d__1, &d__2); + dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); + dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing 2nd power */ + d__1 = vl[k + i__ * vl_dim1]; +/* Computing 2nd power */ + d__2 = vl[k + (i__ + 1) * vl_dim1]; + work[k] = d__1 * d__1 + d__2 * d__2; +/* L10: */ + } + k = idamax_(n, &work[1], &c__1); + dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1], + &cs, &sn, &r__); + drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) * + vl_dim1 + 1], &c__1, &cs, &sn); + vl[k + (i__ + 1) * vl_dim1] = 0.; + } +/* L20: */ + } + } + + if (wantvr) { + +/* Undo balancing of right eigenvectors */ + + dgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr, + &ierr); + +/* Normalize right eigenvectors and make largest component real */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (wi[i__] == 0.) { + scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); + dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); + } else if (wi[i__] > 0.) { + d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); + scl = 1. / dlapy2_(&d__1, &d__2); + dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); + dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing 2nd power */ + d__1 = vr[k + i__ * vr_dim1]; +/* Computing 2nd power */ + d__2 = vr[k + (i__ + 1) * vr_dim1]; + work[k] = d__1 * d__1 + d__2 * d__2; +/* L30: */ + } + k = idamax_(n, &work[1], &c__1); + dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1], + &cs, &sn, &r__); + drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) * + vr_dim1 + 1], &c__1, &cs, &sn); + vr[k + (i__ + 1) * vr_dim1] = 0.; + } +/* L40: */ + } + } + +/* Undo scaling if necessary */ + +L50: + if (scalea) { + i__1 = *n - *info; +/* Computing MAX */ + i__3 = *n - *info; + i__2 = std::max(i__3,1_integer); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info + + 1], &i__2, &ierr); + i__1 = *n - *info; +/* Computing MAX */ + i__3 = *n - *info; + i__2 = std::max(i__3,1_integer); + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info + + 1], &i__2, &ierr); + if (*info == 0) { + if ((wntsnv || wntsnb) && icond == 0) { + dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[ + 1], n, &ierr); + } + } else { + i__1 = *ilo - 1; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1], + n, &ierr); + i__1 = *ilo - 1; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1], + n, &ierr); + } + } + + work[1] = (double) maxwrk; + return 0; + +/* End of DGEEVX */ + +} /* dgeevx_ */ + +/* Subroutine */ int dgegs_(const char *jobvsl, const char *jobvsr, integer *n, + double *a, integer *lda, double *b, integer *ldb, double * + alphar, double *alphai, double *beta, double *vsl, + integer *ldvsl, double *vsr, integer *ldvsr, double *work, + integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b36 = 0.; + static double c_b37 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2; + + /* Local variables */ + integer nb, nb1, nb2, nb3, ihi, ilo; + double eps, anrm, bnrm; + integer itau, lopt; + integer ileft, iinfo, icols; + bool ilvsl; + integer iwork; + bool ilvsr; + integer irows; + bool ilascl, ilbscl; + double safmin; + double bignum; + integer ijobvl, iright, ijobvr; + double anrmto; + integer lwkmin; + double bnrmto; + double smlnum; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This routine is deprecated and has been replaced by routine DGGES. */ + +/* DGEGS computes the eigenvalues, real Schur form, and, optionally, */ +/* left and or/right Schur vectors of a real matrix pair (A,B). */ +/* Given two square matrices A and B, the generalized real Schur */ +/* factorization has the form */ + +/* A = Q*S*Z**T, B = Q*T*Z**T */ + +/* where Q and Z are orthogonal matrices, T is upper triangular, and S */ +/* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */ +/* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */ +/* of eigenvalues of (A,B). The columns of Q are the left Schur vectors */ +/* and the columns of Z are the right Schur vectors. */ + +/* If only the eigenvalues of (A,B) are needed, the driver routine */ +/* DGEGV should be used instead. See DGEGV for a description of the */ +/* eigenvalues of the generalized nonsymmetric eigenvalue problem */ +/* (GNEP). */ + +/* Arguments */ +/* ========= */ + +/* JOBVSL (input) CHARACTER*1 */ +/* = 'N': do not compute the left Schur vectors; */ +/* = 'V': compute the left Schur vectors (returned in VSL). */ + +/* JOBVSR (input) CHARACTER*1 */ +/* = 'N': do not compute the right Schur vectors; */ +/* = 'V': compute the right Schur vectors (returned in VSR). */ + +/* N (input) INTEGER */ +/* The order of the matrices A, B, VSL, and VSR. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the matrix A. */ +/* On exit, the upper quasi-triangular matrix S from the */ +/* generalized real Schur factorization. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the matrix B. */ +/* On exit, the upper triangular matrix T from the generalized */ +/* real Schur factorization. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B. LDB >= max(1,N). */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ +/* The real parts of each scalar alpha defining an eigenvalue */ +/* of GNEP. */ + +/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ +/* The imaginary parts of each scalar alpha defining an */ +/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */ +/* eigenvalue is real; if positive, then the j-th and (j+1)-st */ +/* eigenvalues are a complex conjugate pair, with */ +/* ALPHAI(j+1) = -ALPHAI(j). */ + +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* The scalars beta that define the eigenvalues of GNEP. */ +/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ +/* beta = BETA(j) represent the j-th eigenvalue of the matrix */ +/* pair (A,B), in one of the forms lambda = alpha/beta or */ +/* mu = beta/alpha. Since either lambda or mu may overflow, */ +/* they should not, in general, be computed. */ + +/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */ +/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */ +/* Not referenced if JOBVSL = 'N'. */ + +/* LDVSL (input) INTEGER */ +/* The leading dimension of the matrix VSL. LDVSL >=1, and */ +/* if JOBVSL = 'V', LDVSL >= N. */ + +/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */ +/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */ +/* Not referenced if JOBVSR = 'N'. */ + +/* LDVSR (input) INTEGER */ +/* The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* if JOBVSR = 'V', LDVSR >= N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,4*N). */ +/* For good performance, LWORK must generally be larger. */ +/* To compute the optimal value of LWORK, call ILAENV to get */ +/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */ +/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR */ +/* The optimal LWORK is 2*N + N*(NB+1). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1,...,N: */ +/* The QZ iteration failed. (A,B) are not in Schur */ +/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ +/* be correct for j=INFO+1,...,N. */ +/* > N: errors that usually indicate LAPACK problems: */ +/* =N+1: error return from DGGBAL */ +/* =N+2: error return from DGEQRF */ +/* =N+3: error return from DORMQR */ +/* =N+4: error return from DORGQR */ +/* =N+5: error return from DGGHRD */ +/* =N+6: error return from DHGEQZ (other than failed */ +/* iteration) */ +/* =N+7: error return from DGGBAK (computing VSL) */ +/* =N+8: error return from DGGBAK (computing VSR) */ +/* =N+9: error return from DLASCL (various places) */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1; + vsr -= vsr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = false; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = true; + } else { + ijobvl = -1; + ilvsl = false; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = false; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = true; + } else { + ijobvr = -1; + ilvsr = false; + } + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 2; + lwkmin = std::max(i__1,1_integer); + lwkopt = lwkmin; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -12; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -14; + } else if (*lwork < lwkmin && ! lquery) { + *info = -16; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1); + nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1); + nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1); +/* Computing MAX */ + i__1 = std::max(nb1,nb2); + nb = std::max(i__1,nb3); + lopt = (*n << 1) + *n * (nb + 1); + work[1] = (double) lopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEGS ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("E") * dlamch_("B"); + safmin = dlamch_("S"); + smlnum = *n * safmin / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = false; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = true; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = true; + } + + if (ilascl) { + dlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Scale B if max element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = false; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = true; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = true; + } + + if (ilbscl) { + dlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ +/* Workspace layout: (2*N words -- "work..." not actually used) */ +/* left_permutation, right_permutation, work... */ + + ileft = 1; + iright = *n + 1; + iwork = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L10; + } + +/* Reduce B to triangular form, and initialize VSL and/or VSR */ +/* Workspace layout: ("work..." must have at least N words) */ +/* left_permutation, right_permutation, tau, work... */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwork; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = std::max(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L10; + } + + i__1 = *lwork + 1 - iwork; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = std::max(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L10; + } + + if (ilvsl) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl); + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo + + 1 + ilo * vsl_dim1], ldvsl); + i__1 = *lwork + 1 - iwork; + dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = std::max(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L10; + } + } + + if (ilvsr) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ + + dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 5; + goto L10; + } + +/* Perform QZ algorithm, computing Schur vectors if desired */ +/* Workspace layout: ("work..." must have at least 1 word) */ +/* left_permutation, right_permutation, work... */ + + iwork = itau; + i__1 = *lwork + 1 - iwork; + dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] +, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = std::max(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L10; + } + +/* Apply permutation to VSL and VSR */ + + if (ilvsl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ + vsl_offset], ldvsl, &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L10; + } + } + if (ilvsr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ + vsr_offset], ldvsr, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L10; + } + } + +/* Undo scaling */ + + if (ilascl) { + dlascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + + if (ilbscl) { + dlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + dlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + iinfo); + if (iinfo != 0) { + *info = *n + 9; + return 0; + } + } + +L10: + work[1] = (double) lwkopt; + + return 0; + +/* End of DGEGS */ + +} /* dgegs_ */ + +/* Subroutine */ int dgegv_(const char *jobvl, const char *jobvr, integer *n, double * + a, integer *lda, double *b, integer *ldb, double *alphar, + double *alphai, double *beta, double *vl, integer *ldvl, + double *vr, integer *ldvr, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b27 = 1.; + static double c_b38 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo; + double eps; + bool ilv; + double absb, anrm, bnrm; + integer itau; + double temp; + bool ilvl, ilvr; + integer lopt; + double anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta; + integer ileft, iinfo, icols, iwork, irows; + double salfai; + double salfar; + double safmin; + double safmax; + char chtemp[1]; + bool ldumma[1]; + integer ijobvl, iright; + bool ilimit; + integer ijobvr; + double onepls; + integer lwkmin; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This routine is deprecated and has been replaced by routine DGGEV. */ + +/* DGEGV computes the eigenvalues and, optionally, the left and/or right */ +/* eigenvectors of a real matrix pair (A,B). */ +/* Given two square matrices A and B, */ +/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */ +/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */ +/* that */ + +/* A*x = lambda*B*x. */ + +/* An alternate form is to find the eigenvalues mu and corresponding */ +/* eigenvectors y such that */ + +/* mu*A*y = B*y. */ + +/* These two forms are equivalent with mu = 1/lambda and x = y if */ +/* neither lambda nor mu is zero. In order to deal with the case that */ +/* lambda or mu is zero or small, two values alpha and beta are returned */ +/* for each eigenvalue, such that lambda = alpha/beta and */ +/* mu = beta/alpha. */ + +/* The vectors x and y in the above equations are right eigenvectors of */ +/* the matrix pair (A,B). Vectors u and v satisfying */ + +/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */ + +/* are left eigenvectors of (A,B). */ + +/* Note: this routine performs "full balancing" on A and B -- see */ +/* "Further Details", below. */ + +/* Arguments */ +/* ========= */ + +/* JOBVL (input) CHARACTER*1 */ +/* = 'N': do not compute the left generalized eigenvectors; */ +/* = 'V': compute the left generalized eigenvectors (returned */ +/* in VL). */ + +/* JOBVR (input) CHARACTER*1 */ +/* = 'N': do not compute the right generalized eigenvectors; */ +/* = 'V': compute the right generalized eigenvectors (returned */ +/* in VR). */ + +/* N (input) INTEGER */ +/* The order of the matrices A, B, VL, and VR. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the matrix A. */ +/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */ +/* contains the real Schur form of A from the generalized Schur */ +/* factorization of the pair (A,B) after balancing. */ +/* If no eigenvectors were computed, then only the diagonal */ +/* blocks from the Schur form will be correct. See DGGHRD and */ +/* DHGEQZ for details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the matrix B. */ +/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */ +/* upper triangular matrix obtained from B in the generalized */ +/* Schur factorization of the pair (A,B) after balancing. */ +/* If no eigenvectors were computed, then only those elements of */ +/* B corresponding to the diagonal blocks from the Schur form of */ +/* A will be correct. See DGGHRD and DHGEQZ for details. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B. LDB >= max(1,N). */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ +/* The real parts of each scalar alpha defining an eigenvalue of */ +/* GNEP. */ + +/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ +/* The imaginary parts of each scalar alpha defining an */ +/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */ +/* eigenvalue is real; if positive, then the j-th and */ +/* (j+1)-st eigenvalues are a complex conjugate pair, with */ +/* ALPHAI(j+1) = -ALPHAI(j). */ + +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* The scalars beta that define the eigenvalues of GNEP. */ + +/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */ +/* beta = BETA(j) represent the j-th eigenvalue of the matrix */ +/* pair (A,B), in one of the forms lambda = alpha/beta or */ +/* mu = beta/alpha. Since either lambda or mu may overflow, */ +/* they should not, in general, be computed. */ + +/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ +/* If JOBVL = 'V', the left eigenvectors u(j) are stored */ +/* in the columns of VL, in the same order as their eigenvalues. */ +/* If the j-th eigenvalue is real, then u(j) = VL(:,j). */ +/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */ +/* pair, then */ +/* u(j) = VL(:,j) + i*VL(:,j+1) */ +/* and */ +/* u(j+1) = VL(:,j) - i*VL(:,j+1). */ + +/* Each eigenvector is scaled so that its largest component has */ +/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */ +/* corresponding to an eigenvalue with alpha = beta = 0, which */ +/* are set to zero. */ +/* Not referenced if JOBVL = 'N'. */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the matrix VL. LDVL >= 1, and */ +/* if JOBVL = 'V', LDVL >= N. */ + +/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ +/* If JOBVR = 'V', the right eigenvectors x(j) are stored */ +/* in the columns of VR, in the same order as their eigenvalues. */ +/* If the j-th eigenvalue is real, then x(j) = VR(:,j). */ +/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */ +/* pair, then */ +/* x(j) = VR(:,j) + i*VR(:,j+1) */ +/* and */ +/* x(j+1) = VR(:,j) - i*VR(:,j+1). */ + +/* Each eigenvector is scaled so that its largest component has */ +/* abs(real part) + abs(imag. part) = 1, except for eigenvalues */ +/* corresponding to an eigenvalue with alpha = beta = 0, which */ +/* are set to zero. */ +/* Not referenced if JOBVR = 'N'. */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the matrix VR. LDVR >= 1, and */ +/* if JOBVR = 'V', LDVR >= N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,8*N). */ +/* For good performance, LWORK must generally be larger. */ +/* To compute the optimal value of LWORK, call ILAENV to get */ +/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */ +/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR; */ +/* The optimal LWORK is: */ +/* 2*N + MAX( 6*N, N*(NB+1) ). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1,...,N: */ +/* The QZ iteration failed. No eigenvectors have been */ +/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ +/* should be correct for j=INFO+1,...,N. */ +/* > N: errors that usually indicate LAPACK problems: */ +/* =N+1: error return from DGGBAL */ +/* =N+2: error return from DGEQRF */ +/* =N+3: error return from DORMQR */ +/* =N+4: error return from DORGQR */ +/* =N+5: error return from DGGHRD */ +/* =N+6: error return from DHGEQZ (other than failed */ +/* iteration) */ +/* =N+7: error return from DTGEVC */ +/* =N+8: error return from DGGBAK (computing VL) */ +/* =N+9: error return from DGGBAK (computing VR) */ +/* =N+10: error return from DLASCL (various calls) */ + +/* Further Details */ +/* =============== */ + +/* Balancing */ +/* --------- */ + +/* This driver calls DGGBAL to both permute and scale rows and columns */ +/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */ +/* and PL*B*R will be upper triangular except for the diagonal blocks */ +/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */ +/* possible. The diagonal scaling matrices DL and DR are chosen so */ +/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */ +/* one (except for the elements that start out zero.) */ + +/* After the eigenvalues and eigenvectors of the balanced matrices */ +/* have been computed, DGGBAK transforms the eigenvectors back to what */ +/* they would have been (in perfect arithmetic) if they had not been */ +/* balanced. */ + +/* Contents of A and B on Exit */ +/* -------- -- - --- - -- ---- */ + +/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */ +/* both), then on exit the arrays A and B will contain the real Schur */ +/* form[*] of the "balanced" versions of A and B. If no eigenvectors */ +/* are computed, then only the diagonal blocks will be correct. */ + +/* [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations", */ +/* by Golub & van Loan, pub. by Johns Hopkins U. Press. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = false; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = true; + } else { + ijobvl = -1; + ilvl = false; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = false; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = true; + } else { + ijobvr = -1; + ilvr = false; + } + ilv = ilvl || ilvr; + +/* Test the input arguments */ + +/* Computing MAX */ + i__1 = *n << 3; + lwkmin = std::max(i__1,1_integer); + lwkopt = lwkmin; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -12; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -14; + } else if (*lwork < lwkmin && ! lquery) { + *info = -16; + } + + if (*info == 0) { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1); + nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1); + nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1); +/* Computing MAX */ + i__1 = std::max(nb1,nb2); + nb = std::max(i__1,nb3); +/* Computing MAX */ + i__1 = *n * 6, i__2 = *n * (nb + 1); + lopt = (*n << 1) + std::max(i__1,i__2); + work[1] = (double) lopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEGV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("E") * dlamch_("B"); + safmin = dlamch_("S"); + safmin += safmin; + safmax = 1. / safmin; + onepls = eps * 4 + 1.; + +/* Scale A */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + anrm1 = anrm; + anrm2 = 1.; + if (anrm < 1.) { + if (safmax * anrm < 1.) { + anrm1 = safmin; + anrm2 = safmax * anrm; + } + } + + if (anrm > 0.) { + dlascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Scale B */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + bnrm1 = bnrm; + bnrm2 = 1.; + if (bnrm < 1.) { + if (safmax * bnrm < 1.) { + bnrm1 = safmin; + bnrm2 = safmax * bnrm; + } + } + + if (bnrm > 0.) { + dlascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, & + iinfo); + if (iinfo != 0) { + *info = *n + 10; + return 0; + } + } + +/* Permute the matrix to make it more nearly triangular */ +/* Workspace layout: (8*N words -- "work" requires 6*N words) */ +/* left_permutation, right_permutation, work... */ + + ileft = 1; + iright = *n + 1; + iwork = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 1; + goto L120; + } + +/* Reduce B to triangular form, and initialize VL and/or VR */ +/* Workspace layout: ("work..." must have at least N words) */ +/* left_permutation, right_permutation, tau, work... */ + + irows = ihi + 1 - ilo; + if (ilv) { + icols = *n + 1 - ilo; + } else { + icols = irows; + } + itau = iwork; + iwork = itau + irows; + i__1 = *lwork + 1 - iwork; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = std::max(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 2; + goto L120; + } + + i__1 = *lwork + 1 - iwork; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, & + iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = std::max(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 3; + goto L120; + } + + if (ilvl) { + dlaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl) + ; + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo + + 1 + ilo * vl_dim1], ldvl); + i__1 = *lwork + 1 - iwork; + dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ + itau], &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = std::max(i__1,i__2); + } + if (iinfo != 0) { + *info = *n + 4; + goto L120; + } + } + + if (ilvr) { + dlaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr) + ; + } + +/* Reduce to generalized Hessenberg form */ + + if (ilv) { + +/* Eigenvectors requested -- work on whole matrix. */ + + dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo); + } else { + dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, + &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &iinfo); + } + if (iinfo != 0) { + *info = *n + 5; + goto L120; + } + +/* Perform QZ algorithm */ +/* Workspace layout: ("work..." must have at least 1 word) */ +/* left_permutation, right_permutation, work... */ + + iwork = itau; + if (ilv) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + i__1 = *lwork + 1 - iwork; + dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo); + if (iinfo >= 0) { +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1; + lwkopt = std::max(i__1,i__2); + } + if (iinfo != 0) { + if (iinfo > 0 && iinfo <= *n) { + *info = iinfo; + } else if (iinfo > *n && iinfo <= *n << 1) { + *info = iinfo - *n; + } else { + *info = *n + 6; + } + goto L120; + } + + if (ilv) { + +/* Compute Eigenvectors (DTGEVC requires 6*N words of workspace) */ + + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + + dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, + &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ + iwork], &iinfo); + if (iinfo != 0) { + *info = *n + 7; + goto L120; + } + +/* Undo balancing on VL and VR, rescale */ + + if (ilvl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vl[vl_offset], ldvl, &iinfo); + if (iinfo != 0) { + *info = *n + 8; + goto L120; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L50; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)); + temp = std::max(d__2,d__3); +/* L10: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)) + (d__2 = vl[jr + (jc + 1) * + vl_dim1], abs(d__2)); + temp = std::max(d__3,d__4); +/* L20: */ + } + } + if (temp < safmin) { + goto L50; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; +/* L30: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; + vl[jr + (jc + 1) * vl_dim1] *= temp; +/* L40: */ + } + } +L50: + ; + } + } + if (ilvr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vr[vr_offset], ldvr, &iinfo); + if (iinfo != 0) { + *info = *n + 9; + goto L120; + } + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L100; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)); + temp = std::max(d__2,d__3); +/* L60: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)) + (d__2 = vr[jr + (jc + 1) * + vr_dim1], abs(d__2)); + temp = std::max(d__3,d__4); +/* L70: */ + } + } + if (temp < safmin) { + goto L100; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; +/* L80: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; + vr[jr + (jc + 1) * vr_dim1] *= temp; +/* L90: */ + } + } +L100: + ; + } + } + +/* End of eigenvector calculation */ + + } + +/* Undo scaling in alpha, beta */ + +/* Note: this does not give the alpha and beta for the unscaled */ +/* problem. */ + +/* Un-scaling is limited to avoid underflow in alpha and beta */ +/* if they are significant. */ + + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + absar = (d__1 = alphar[jc], abs(d__1)); + absai = (d__1 = alphai[jc], abs(d__1)); + absb = (d__1 = beta[jc], abs(d__1)); + salfar = anrm * alphar[jc]; + salfai = anrm * alphai[jc]; + sbeta = bnrm * beta[jc]; + ilimit = false; + scale = 1.; + +/* Check for significant underflow in ALPHAI */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absar, d__1 = std::max(d__1,d__2), d__2 = eps * + absb; + if (abs(salfai) < safmin && absai >= std::max(d__1,d__2)) { + ilimit = true; +/* Computing MAX */ + d__1 = onepls * safmin, d__2 = anrm2 * absai; + scale = onepls * safmin / anrm1 / std::max(d__1,d__2); + + } else if (salfai == 0.) { + +/* If insignificant underflow in ALPHAI, then make the */ +/* conjugate eigenvalue real. */ + + if (alphai[jc] < 0. && jc > 1) { + alphai[jc - 1] = 0.; + } else if (alphai[jc] > 0. && jc < *n) { + alphai[jc + 1] = 0.; + } + } + +/* Check for significant underflow in ALPHAR */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absai, d__1 = std::max(d__1,d__2), d__2 = eps * + absb; + if (abs(salfar) < safmin && absar >= std::max(d__1,d__2)) { + ilimit = true; +/* Computing MAX */ +/* Computing MAX */ + d__3 = onepls * safmin, d__4 = anrm2 * absar; + d__1 = scale, d__2 = onepls * safmin / anrm1 / std::max(d__3,d__4); + scale = std::max(d__1,d__2); + } + +/* Check for significant underflow in BETA */ + +/* Computing MAX */ + d__1 = safmin, d__2 = eps * absar, d__1 = std::max(d__1,d__2), d__2 = eps * + absai; + if (abs(sbeta) < safmin && absb >= std::max(d__1,d__2)) { + ilimit = true; +/* Computing MAX */ +/* Computing MAX */ + d__3 = onepls * safmin, d__4 = bnrm2 * absb; + d__1 = scale, d__2 = onepls * safmin / bnrm1 / std::max(d__3,d__4); + scale = std::max(d__1,d__2); + } + +/* Check for possible overflow when limiting scaling */ + + if (ilimit) { +/* Computing MAX */ + d__1 = abs(salfar), d__2 = abs(salfai), d__1 = std::max(d__1,d__2), + d__2 = abs(sbeta); + temp = scale * safmin * std::max(d__1,d__2); + if (temp > 1.) { + scale /= temp; + } + if (scale < 1.) { + ilimit = false; + } + } + +/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */ + + if (ilimit) { + salfar = scale * alphar[jc] * anrm; + salfai = scale * alphai[jc] * anrm; + sbeta = scale * beta[jc] * bnrm; + } + alphar[jc] = salfar; + alphai[jc] = salfai; + beta[jc] = sbeta; +/* L110: */ + } + +L120: + work[1] = (double) lwkopt; + + return 0; + +/* End of DGEGV */ + +} /* dgegv_ */ + +/* Subroutine */ int dgehd2_(integer *n, integer *ilo, integer *ihi, + double *a, integer *lda, double *tau, double *work, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__; + double aii; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by */ +/* an orthogonal similarity transformation: Q' * A * Q = H . */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* It is assumed that A is already upper triangular in rows */ +/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ +/* set by a previous call to DGEBAL; otherwise they should be */ +/* set to 1 and N respectively. See Further Details. */ +/* 1 <= ILO <= IHI <= max(1,N). */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the n by n general matrix to be reduced. */ +/* On exit, the upper triangle and the first subdiagonal of A */ +/* are overwritten with the upper Hessenberg matrix H, and the */ +/* elements below the first subdiagonal, 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,N). */ + +/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ +/* 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 (ihi-ilo) elementary */ +/* reflectors */ + +/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ + +/* 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */ +/* exit in A(i+2:ihi,i), and tau in TAU(i). */ + +/* The contents of A are illustrated by the following example, with */ +/* n = 7, ilo = 2 and ihi = 6: */ + +/* on entry, on exit, */ + +/* ( a a a a a a a ) ( a a h h h h a ) */ +/* ( a a a a a a ) ( a h h h h a ) */ +/* ( a a a a a a ) ( h h h h h h ) */ +/* ( a a a a a a ) ( v2 h h h h h ) */ +/* ( a a a a a a ) ( v2 v3 h h h h ) */ +/* ( a a a a a a ) ( v2 v3 v4 h h h ) */ +/* ( a ) ( a ) */ + +/* where a denotes an element of the original matrix A, h denotes a */ +/* modified element of the upper Hessenberg matrix H, and vi denotes an */ +/* element of the vector defining H(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > std::max(1_integer,*n)) { + *info = -2; + } else if (*ihi < std::min(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEHD2", &i__1); + return 0; + } + + i__1 = *ihi - 1; + for (i__ = *ilo; i__ <= i__1; ++i__) { + +/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */ + + i__2 = *ihi - i__; +/* Computing MIN */ + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *n)+ i__ * + a_dim1], &c__1, &tau[i__]); + aii = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; + +/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */ + + i__2 = *ihi - i__; + dlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]); + +/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */ + + i__2 = *ihi - i__; + i__3 = *n - i__; + dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]); + + a[i__ + 1 + i__ * a_dim1] = aii; +/* L10: */ + } + + return 0; + +/* End of DGEHD2 */ + +} /* dgehd2_ */ + +/* Subroutine */ int dgehrd_(integer *n, integer *ilo, integer *ihi, + double *a, integer *lda, double *tau, double *work, + integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + static integer c__65 = 65; + static double c_b25 = -1.; + static double c_b26 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j; + double t[4160] /* was [65][64] */; + integer ib; + double ei; + integer nb, nh, nx, iws; + integer nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEHRD reduces a real general matrix A to upper Hessenberg form H by */ +/* an orthogonal similarity transformation: Q' * A * Q = H . */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* It is assumed that A is already upper triangular in rows */ +/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ +/* set by a previous call to DGEBAL; otherwise they should be */ +/* set to 1 and N respectively. See Further Details. */ +/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the N-by-N general matrix to be reduced. */ +/* On exit, the upper triangle and the first subdiagonal of A */ +/* are overwritten with the upper Hessenberg matrix H, and the */ +/* elements below the first subdiagonal, 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,N). */ + +/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The scalar factors of the elementary reflectors (see Further */ +/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */ +/* zero. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of the array WORK. LWORK >= max(1,N). */ +/* For optimum performance LWORK >= N*NB, where NB is the */ +/* optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* 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 (ihi-ilo) elementary */ +/* reflectors */ + +/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ + +/* 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */ +/* exit in A(i+2:ihi,i), and tau in TAU(i). */ + +/* The contents of A are illustrated by the following example, with */ +/* n = 7, ilo = 2 and ihi = 6: */ + +/* on entry, on exit, */ + +/* ( a a a a a a a ) ( a a h h h h a ) */ +/* ( a a a a a a ) ( a h h h h a ) */ +/* ( a a a a a a ) ( h h h h h h ) */ +/* ( a a a a a a ) ( v2 h h h h h ) */ +/* ( a a a a a a ) ( v2 v3 h h h h ) */ +/* ( a a a a a a ) ( v2 v3 v4 h h h ) */ +/* ( a ) ( a ) */ + +/* where a denotes an element of the original matrix A, h denotes a */ +/* modified element of the upper Hessenberg matrix H, and vi denotes an */ +/* element of the vector defining H(i). */ + +/* This file is a slight modification of LAPACK-3.0's DGEHRD */ +/* subroutine incorporating improvements proposed by Quintana-Orti and */ +/* Van de Geijn (2005). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; +/* Computing MIN */ + i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1); + nb = std::min(i__1,i__2); + lwkopt = *n * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > std::max(1_integer,*n)) { + *info = -2; + } else if (*ihi < std::min(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*lwork < std::max(1_integer,*n) && ! lquery) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEHRD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */ + + i__1 = *ilo - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.; +/* L10: */ + } + i__1 = *n - 1; + for (i__ = std::max(1_integer,*ihi); i__ <= i__1; ++i__) { + tau[i__] = 0.; +/* L20: */ + } + +/* Quick return if possible */ + + nh = *ihi - *ilo + 1; + if (nh <= 1) { + work[1] = 1.; + return 0; + } + +/* Determine the block size */ + +/* Computing MIN */ + i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1); + nb = std::min(i__1,i__2); + nbmin = 2; + iws = 1; + if (nb > 1 && nb < nh) { + +/* Determine when to cross over from blocked to unblocked code */ +/* (last block is always handled by unblocked code) */ + +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__3, "DGEHRD", " ", n, ilo, ihi, &c_n1); + nx = std::max(i__1,i__2); + if (nx < nh) { + +/* Determine if workspace is large enough for blocked code */ + + iws = *n * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: determine the */ +/* minimum value of NB, and reduce NB or force use of */ +/* unblocked code */ + +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGEHRD", " ", n, ilo, ihi, & + c_n1); + nbmin = std::max(i__1,i__2); + if (*lwork >= *n * nbmin) { + nb = *lwork / *n; + } else { + nb = 1; + } + } + } + } + ldwork = *n; + + if (nb < nbmin || nb >= nh) { + +/* Use unblocked code below */ + + i__ = *ilo; + + } else { + +/* Use blocked code */ + + i__1 = *ihi - 1 - nx; + i__2 = nb; + for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *ihi - i__; + ib = std::min(i__3,i__4); + +/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */ +/* matrices V and T of the block reflector H = I - V*T*V' */ +/* which performs the reduction, and also the matrix Y = A*V*T */ + + dlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, & + c__65, &work[1], &ldwork); + +/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */ +/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */ +/* to 1 */ + + ei = a[i__ + ib + (i__ + ib - 1) * a_dim1]; + a[i__ + ib + (i__ + ib - 1) * a_dim1] = 1.; + i__3 = *ihi - i__ - ib + 1; + dgemm_("No transpose", "Transpose", ihi, &i__3, &ib, &c_b25, & + work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, & + c_b26, &a[(i__ + ib) * a_dim1 + 1], lda); + a[i__ + ib + (i__ + ib - 1) * a_dim1] = ei; + +/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */ +/* right */ + + i__3 = ib - 1; + dtrmm_("Right", "Lower", "Transpose", "Unit", &i__, &i__3, &c_b26, + &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &ldwork); + i__3 = ib - 2; + for (j = 0; j <= i__3; ++j) { + daxpy_(&i__, &c_b25, &work[ldwork * j + 1], &c__1, &a[(i__ + + j + 1) * a_dim1 + 1], &c__1); +/* L30: */ + } + +/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */ +/* left */ + + i__3 = *ihi - i__; + i__4 = *n - i__ - ib + 1; + dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, & + i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &c__65, &a[ + i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &ldwork); +/* L40: */ + } + } + +/* Use unblocked code to reduce the rest of the matrix */ + + dgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo); + work[1] = (double) iws; + + return 0; + +/* End of DGEHRD */ + +} /* dgehrd_ */ + +/* Subroutine */ int dgelq2_(integer *m, integer *n, double *a, integer * + lda, double *tau, double *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, k; + double aii; + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGELQ2 computes an LQ factorization of a real m by n matrix A: */ +/* A = L * Q. */ + +/* 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 below the diagonal of the array */ +/* contain the m by min(m,n) lower trapezoidal matrix L (L is */ +/* lower triangular if m <= n); the elements above 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 (M) */ + +/* 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(k) . . . H(2) H(1), 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:n) is stored on exit in A(i,i+1:n), */ +/* and tau in TAU(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGELQ2", &i__1); + return 0; + } + + k = std::min(*m,*n); + + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */ + + i__2 = *n - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + std::min(i__3, *n)* a_dim1] +, lda, &tau[i__]); + if (i__ < *m) { + +/* Apply H(i) to A(i+1:m,i:n) from the right */ + + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ + i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); + a[i__ + i__ * a_dim1] = aii; + } +/* L10: */ + } + return 0; + +/* End of DGELQ2 */ + +} /* dgelq2_ */ + +/* Subroutine */ int dgelqf_(integer *m, integer *n, double *a, integer * + lda, double *tau, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, k, ib, nb, nx, iws, nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGELQF computes an LQ factorization of a real M-by-N matrix A: */ +/* A = L * Q. */ + +/* 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 below the diagonal of the array */ +/* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */ +/* lower triangular if m <= n); the elements above 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,M). */ +/* For optimum performance LWORK >= M*NB, where NB is the */ +/* optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* 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(k) . . . H(2) H(1), 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:n) is stored on exit in A(i,i+1:n), */ +/* and tau in TAU(i). */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1); + lwkopt = *m * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } else if (*lwork < std::max(1_integer,*m) && ! lquery) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGELQF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + k = std::min(*m,*n); + if (k == 0) { + work[1] = 1.; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *m; + if (nb > 1 && nb < k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1); + nx = std::max(i__1,i__2); + if (nx < k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, & + c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < k && nx < k) { + +/* Use blocked code initially */ + + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = std::min(i__3,nb); + +/* Compute the LQ factorization of the current block */ +/* A(i:i+ib-1,i:n) */ + + i__3 = *n - i__ + 1; + dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ + 1], &iinfo); + if (i__ + ib <= *m) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__3 = *n - i__ + 1; + dlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(i+ib:m,i:n) from the right */ + + i__3 = *m - i__ - ib + 1; + i__4 = *n - i__ + 1; + dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, + &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & + ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + + 1], &ldwork); + } +/* L10: */ + } + } else { + i__ = 1; + } + +/* Use unblocked code to factor the last or only block. */ + + if (i__ <= k) { + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] +, &iinfo); + } + + work[1] = (double) iws; + return 0; + +/* End of DGELQF */ + +} /* dgelqf_ */ + +/* Subroutine */ int dgels_(const char *trans, integer *m, integer *n, integer * + nrhs, double *a, integer *lda, double *b, integer *ldb, + double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b33 = 0.; + static integer c__0 = 0; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, nb, mn; + double anrm, bnrm; + integer brow; + bool tpsd; + integer iascl, ibscl; + integer wsize; + double rwork[1]; + integer scllen; + double bignum; + double smlnum; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGELS solves overdetermined or underdetermined real linear systems */ +/* involving an M-by-N matrix A, or its transpose, using a QR or LQ */ +/* factorization of A. It is assumed that A has full rank. */ + +/* The following options are provided: */ + +/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */ +/* an overdetermined system, i.e., solve the least squares problem */ +/* minimize || B - A*X ||. */ + +/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */ +/* an underdetermined system A * X = B. */ + +/* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of */ +/* an undetermined system A**T * X = B. */ + +/* 4. If TRANS = 'T' and m < n: find the least squares solution of */ +/* an overdetermined system, i.e., solve the least squares problem */ +/* minimize || B - A**T * X ||. */ + +/* Several right hand side vectors b and solution vectors x can be */ +/* handled in a single call; they are stored as the columns of the */ +/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* matrix X. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* = 'N': the linear system involves A; */ +/* = 'T': the linear system involves A**T. */ + +/* 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. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of */ +/* columns of the matrices B and X. NRHS >=0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, */ +/* if M >= N, A is overwritten by details of its QR */ +/* factorization as returned by DGEQRF; */ +/* if M < N, A is overwritten by details of its LQ */ +/* factorization as returned by DGELQF. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the matrix B of right hand side vectors, stored */ +/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */ +/* if TRANS = 'T'. */ +/* On exit, if INFO = 0, B is overwritten by the solution */ +/* vectors, stored columnwise: */ +/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */ +/* squares solution vectors; the residual sum of squares for the */ +/* solution in each column is given by the sum of squares of */ +/* elements N+1 to M in that column; */ +/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */ +/* minimum norm solution vectors; */ +/* if TRANS = 'T' and m >= n, rows 1 to M of B contain the */ +/* minimum norm solution vectors; */ +/* if TRANS = 'T' and m < n, rows 1 to M of B contain the */ +/* least squares solution vectors; the residual sum of squares */ +/* for the solution in each column is given by the sum of */ +/* squares of elements M+1 to N in that column. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= MAX(1,M,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* LWORK >= max( 1, MN + max( MN, NRHS ) ). */ +/* For optimal performance, */ +/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */ +/* where MN = min(M,N) and NB is the optimum block size. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the i-th diagonal element of the */ +/* triangular factor of A is zero, so that A does not have */ +/* full rank; the least squares solution could not be */ +/* computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + mn = std::min(*m,*n); + lquery = *lwork == -1; + if (! (lsame_(trans, "N") || lsame_(trans, "T"))) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*m)) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = std::max(1_integer,*m); + if (*ldb < std::max(i__1,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = mn + std::max(mn,*nrhs); + if (*lwork < std::max(i__1,i__2) && ! lquery) { + *info = -10; + } + } + } + +/* Figure out optimal block size */ + + if (*info == 0 || *info == -10) { + + tpsd = true; + if (lsame_(trans, "N")) { + tpsd = false; + } + + if (*m >= *n) { + nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); + if (tpsd) { +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, & + c_n1); + nb = std::max(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, & + c_n1); + nb = std::max(i__1,i__2); + } + } else { + nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1); + if (tpsd) { +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, & + c_n1); + nb = std::max(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, & + c_n1); + nb = std::max(i__1,i__2); + } + } + +/* Computing MAX */ + i__1 = 1, i__2 = mn + std::max(mn,*nrhs) * nb; + wsize = std::max(i__1,i__2); + work[1] = (double) wsize; + + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGELS ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = std::min(*m,*n); + if (std::min(i__1,*nrhs) == 0) { + i__1 = std::max(*m,*n); + dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb); + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S") / dlamch_("P"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", m, n, &a[a_offset], lda, rwork); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = std::max(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb); + goto L50; + } + + brow = *m; + if (tpsd) { + brow = *n; + } + bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], + ldb, info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], + ldb, info); + ibscl = 2; + } + + if (*m >= *n) { + +/* compute QR factorization of A */ + + i__1 = *lwork - mn; + dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) + ; + +/* workspace at least N, optimally N*NB */ + + if (! tpsd) { + +/* Least-Squares Problem min || A * X - B || */ + +/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ + + i__1 = *lwork - mn; + dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[ + 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); + +/* workspace at least NRHS, optimally NRHS*NB */ + +/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */ + + dtrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset] +, lda, &b[b_offset], ldb, info); + + if (*info > 0) { + return 0; + } + + scllen = *n; + + } else { + +/* Overdetermined system of equations A' * X = B */ + +/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */ + + dtrtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset], + lda, &b[b_offset], ldb, info); + + if (*info > 0) { + return 0; + } + +/* B(N+1:M,1:NRHS) = ZERO */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = *n + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + +/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */ + + i__1 = *lwork - mn; + dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, & + work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); + +/* workspace at least NRHS, optimally NRHS*NB */ + + scllen = *m; + + } + + } else { + +/* Compute LQ factorization of A */ + + i__1 = *lwork - mn; + dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) + ; + +/* workspace at least M, optimally M*NB. */ + + if (! tpsd) { + +/* underdetermined system of equations A * X = B */ + +/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */ + + dtrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset] +, lda, &b[b_offset], ldb, info); + + if (*info > 0) { + return 0; + } + +/* B(M+1:N,1:NRHS) = 0 */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */ + + i__1 = *lwork - mn; + dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[ + 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); + +/* workspace at least NRHS, optimally NRHS*NB */ + + scllen = *n; + + } else { + +/* overdetermined system min || A' * X - B || */ + +/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */ + + i__1 = *lwork - mn; + dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, & + work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); + +/* workspace at least NRHS, optimally NRHS*NB */ + +/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */ + + dtrtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset], + lda, &b[b_offset], ldb, info); + + if (*info > 0) { + return 0; + } + + scllen = *m; + + } + + } + +/* Undo scaling */ + + if (iascl == 1) { + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset] +, ldb, info); + } else if (iascl == 2) { + dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset] +, ldb, info); + } + if (ibscl == 1) { + dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset] +, ldb, info); + } else if (ibscl == 2) { + dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset] +, ldb, info); + } + +L50: + work[1] = (double) wsize; + + return 0; + +/* End of DGELS */ + +} /* dgels_ */ + +/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs, + double *a, integer *lda, double *b, integer *ldb, double * + s, double *rcond, integer *rank, double *work, integer *lwork, + integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__6 = 6; + static integer c_n1 = -1; + static integer c__9 = 9; + static integer c__0 = 0; + static integer c__1 = 1; + static double c_b82 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + + /* Builtin functions + double log(double); */ + + /* Local variables */ + integer ie, il, mm; + double eps, anrm, bnrm; + integer itau, nlvl, iascl, ibscl; + double sfmin; + integer minmn, maxmn, itaup, itauq, mnthr, nwork; + double bignum; + integer wlalsd; + integer ldwork; + integer minwrk, maxwrk; + double smlnum; + bool lquery; + integer smlsiz; + + +/* -- LAPACK driver routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGELSD computes the minimum-norm solution to a real linear least */ +/* squares problem: */ +/* minimize 2-norm(| b - A*x |) */ +/* using the singular value decomposition (SVD) of A. A is an M-by-N */ +/* matrix which may be rank-deficient. */ + +/* Several right hand side vectors b and solution vectors x can be */ +/* handled in a single call; they are stored as the columns of the */ +/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* matrix X. */ + +/* The problem is solved in three steps: */ +/* (1) Reduce the coefficient matrix A to bidiagonal form with */ +/* Householder transformations, reducing the original problem */ +/* into a "bidiagonal least squares problem" (BLS) */ +/* (2) Solve the BLS using a divide and conquer approach. */ +/* (3) Apply back all the Householder tranformations to solve */ +/* the original least squares problem. */ + +/* The effective rank of A is determined by treating as zero those */ +/* singular values which are less than RCOND times the largest singular */ +/* value. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of A. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, A has been destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the M-by-NRHS right hand side matrix B. */ +/* On exit, B is overwritten by the N-by-NRHS solution */ +/* matrix X. If m >= n and RANK = n, the residual */ +/* sum-of-squares for the solution in the i-th column is given */ +/* by the sum of squares of elements n+1:m in that column. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */ + +/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The singular values of A in decreasing order. */ +/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */ + +/* RCOND (input) DOUBLE PRECISION */ +/* RCOND is used to determine the effective rank of A. */ +/* Singular values S(i) <= RCOND*S(1) are treated as zero. */ +/* If RCOND < 0, machine precision is used instead. */ + +/* RANK (output) INTEGER */ +/* The effective rank of A, i.e., the number of singular values */ +/* which are greater than RCOND*S(1). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK must be at least 1. */ +/* The exact minimum amount of workspace needed depends on M, */ +/* N and NRHS. As long as LWORK is at least */ +/* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, */ +/* if M is greater than or equal to N or */ +/* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, */ +/* if M is less than N, the code will execute correctly. */ +/* SMLSIZ is returned by ILAENV and is equal to the maximum */ +/* size of the subproblems at the bottom of the computation */ +/* tree (usually about 25), and */ +/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */ +/* For good performance, LWORK should generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, */ +/* where MINMN = MIN( M,N ). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: the algorithm for computing the SVD failed to converge; */ +/* if INFO = i, i off-diagonal elements of an intermediate */ +/* bidiagonal form did not converge to zero. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* California at Berkeley, USA */ +/* Osni Marques, LBNL/NERSC, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --s; + --work; + --iwork; + + /* Function Body */ + *info = 0; + minmn = std::min(*m,*n); + maxmn = std::max(*m,*n); + mnthr = ilaenv_(&c__6, "DGELSD", " ", m, n, nrhs, &c_n1); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else if (*ldb < std::max(1_integer,maxmn)) { + *info = -7; + } + + smlsiz = ilaenv_(&c__9, "DGELSD", " ", &c__0, &c__0, &c__0, &c__0); + +/* Compute workspace. */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + minwrk = 1; + minmn = std::max(1_integer,minmn); +/* Computing MAX */ + i__1 = (integer) (log((double) minmn / (double) (smlsiz + 1)) / + log(2.)) + 1; + nlvl = std::max(i__1,0_integer); + + if (*info == 0) { + maxwrk = 0; + mm = *m; + if (*m >= *n && *m >= mnthr) { + +/* Path 1a - overdetermined, with many more rows than columns. */ + + mm = *n; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, + n, &c_n1, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT", + m, nrhs, n, &c_n1); + maxwrk = std::max(i__1,i__2); + } + if (*m >= *n) { + +/* Path 1 - overdetermined or exactly determined. */ + +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD" +, " ", &mm, n, &c_n1, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR", + "QLT", &mm, nrhs, n, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORMBR", + "PLN", n, nrhs, n, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing 2nd power */ + i__1 = smlsiz + 1; + wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * * + nrhs + i__1 * i__1; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * 3 + wlalsd; + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = std::max(i__1,i__2), + i__2 = *n * 3 + wlalsd; + minwrk = std::max(i__1,i__2); + } + if (*n > *m) { +/* Computing 2nd power */ + i__1 = smlsiz + 1; + wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * * + nrhs + i__1 * i__1; + if (*n >= mnthr) { + +/* Path 2a - underdetermined, with many more columns */ +/* than rows. */ + + maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, + &c_n1); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * + ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(& + c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * + ilaenv_(&c__1, "DORMBR", "PLN", m, nrhs, m, &c_n1); + maxwrk = std::max(i__1,i__2); + if (*nrhs > 1) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; + maxwrk = std::max(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 1); + maxwrk = std::max(i__1,i__2); + } +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ", + "LT", n, nrhs, m, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd; + maxwrk = std::max(i__1,i__2); +/* XXX: Ensure the Path 2a case below is triggered. The workspace */ +/* calculation should use queries for all routines eventually. */ +/* Computing MAX */ +/* Computing MAX */ + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = std::max(i__3,i__4), i__3 = + std::max(i__3,*nrhs), i__4 = *n - *m * 3; + i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + std::max(i__3,i__4); + maxwrk = std::max(i__1,i__2); + } else { + +/* Path 2 - remaining underdetermined cases. */ + + maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m, + n, &c_n1, &c_n1); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR" +, "QLT", m, nrhs, n, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR", + "PLN", n, nrhs, m, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * 3 + wlalsd; + maxwrk = std::max(i__1,i__2); + } +/* Computing MAX */ + i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = std::max(i__1,i__2), + i__2 = *m * 3 + wlalsd; + minwrk = std::max(i__1,i__2); + } + minwrk = std::min(minwrk,maxwrk); + work[1] = (double) maxwrk; + if (*lwork < minwrk && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGELSD", &i__1); + return 0; + } else if (lquery) { + goto L10; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters. */ + + eps = dlamch_("P"); + sfmin = dlamch_("S"); + smlnum = sfmin / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */ + + anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM. */ + + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM. */ + + dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = std::max(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb); + dlaset_("F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1); + *rank = 0; + goto L10; + } + +/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */ + + bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM. */ + + dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM. */ + + dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* If M < N make sure certain entries of B are zero. */ + + if (*m < *n) { + i__1 = *n - *m; + dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb); + } + +/* Overdetermined case. */ + + if (*m >= *n) { + +/* Path 1 - overdetermined or exactly determined. */ + + mm = *m; + if (*m >= mnthr) { + +/* Path 1a - overdetermined, with many more rows than columns. */ + + mm = *n; + itau = 1; + nwork = itau + *n; + +/* Compute A=Q*R. */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__1 = *lwork - nwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, + info); + +/* Multiply B by transpose(Q). */ +/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[nwork], &i__1, info); + +/* Zero out below R. */ + + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_("L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2], + lda); + } + } + + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + +/* Bidiagonalize R in A. */ +/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */ + + i__1 = *lwork - nwork + 1; + dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[nwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors of R. */ +/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], + &b[b_offset], ldb, &work[nwork], &i__1, info); + +/* Solve the bidiagonal least squares problem. */ + + dlalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, + rcond, rank, &work[nwork], &iwork[1], info); + if (*info != 0) { + goto L10; + } + +/* Multiply B by right bidiagonalizing vectors of R. */ + + i__1 = *lwork - nwork + 1; + dormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], & + b[b_offset], ldb, &work[nwork], &i__1, info); + + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = *m, i__2 = (*m << 1) - 4, i__1 = std::max(i__1,i__2), i__1 = std::max( + i__1,*nrhs), i__2 = *n - *m * 3, i__1 = std::max(i__1,i__2); + if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + std::max(i__1,wlalsd)) { + +/* Path 2a - underdetermined, with many more columns than rows */ +/* and sufficient workspace for an efficient algorithm. */ + + ldwork = *m; +/* Computing MAX */ +/* Computing MAX */ + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = std::max(i__3,i__4), i__3 = + std::max(i__3,*nrhs), i__4 = *n - *m * 3; + i__1 = (*m << 2) + *m * *lda + std::max(i__3,i__4), i__2 = *m * *lda + + *m + *m * *nrhs, i__1 = std::max(i__1,i__2), i__2 = (*m << 2) + + *m * *lda + wlalsd; + if (*lwork >= std::max(i__1,i__2)) { + ldwork = *lda; + } + itau = 1; + nwork = *m + 1; + +/* Compute A=L*Q. */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__1 = *lwork - nwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, + info); + il = nwork; + +/* Copy L to WORK(IL), zeroing out above its diagonal. */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); + i__1 = *m - 1; + i__2 = *m - 1; + dlaset_("U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], & + ldwork); + ie = il + ldwork * *m; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + +/* Bidiagonalize L in WORK(IL). */ +/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */ + + i__1 = *lwork - nwork + 1; + dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[nwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors of L. */ +/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[ + itauq], &b[b_offset], ldb, &work[nwork], &i__1, info); + +/* Solve the bidiagonal least squares problem. */ + + dlalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], + ldb, rcond, rank, &work[nwork], &iwork[1], info); + if (*info != 0) { + goto L10; + } + +/* Multiply B by right bidiagonalizing vectors of L. */ + + i__1 = *lwork - nwork + 1; + dormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[ + itaup], &b[b_offset], ldb, &work[nwork], &i__1, info); + +/* Zero out below first M rows of B. */ + + i__1 = *n - *m; + dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], + ldb); + nwork = itau + *m; + +/* Multiply transpose(Q) by B. */ +/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[nwork], &i__1, info); + + } else { + +/* Path 2 - remaining underdetermined cases. */ + + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + +/* Bidiagonalize A. */ +/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ + + i__1 = *lwork - nwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[nwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors. */ +/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq] +, &b[b_offset], ldb, &work[nwork], &i__1, info); + +/* Solve the bidiagonal least squares problem. */ + + dlalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], + ldb, rcond, rank, &work[nwork], &iwork[1], info); + if (*info != 0) { + goto L10; + } + +/* Multiply B by right bidiagonalizing vectors of A. */ + + i__1 = *lwork - nwork + 1; + dormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup] +, &b[b_offset], ldb, &work[nwork], &i__1, info); + + } + } + +/* Undo scaling. */ + + if (iascl == 1) { + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, info); + } else if (iascl == 2) { + dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, info); + } + if (ibscl == 1) { + dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L10: + work[1] = (double) maxwrk; + return 0; + +/* End of DGELSD */ + +} /* dgelsd_ */ + +/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs, + double *a, integer *lda, double *b, integer *ldb, double * + s, double *rcond, integer *rank, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__6 = 6; + static integer c_n1 = -1; + static integer c__1 = 1; + static integer c__0 = 0; + static double c_b74 = 0.; + static double c_b108 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + double d__1; + + /* Local variables */ + integer i__, bl, ie, il, mm; + double eps, thr, anrm, bnrm; + integer itau; + double vdum[1]; + integer iascl, ibscl; + integer chunk; + double sfmin; + integer minmn; + integer maxmn, itaup, itauq, mnthr, iwork; + integer bdspac; + double bignum; + integer ldwork; + integer minwrk, maxwrk; + double smlnum; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGELSS computes the minimum norm solution to a real linear least */ +/* squares problem: */ + +/* Minimize 2-norm(| b - A*x |). */ + +/* using the singular value decomposition (SVD) of A. A is an M-by-N */ +/* matrix which may be rank-deficient. */ + +/* Several right hand side vectors b and solution vectors x can be */ +/* handled in a single call; they are stored as the columns of the */ +/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix */ +/* X. */ + +/* The effective rank of A is determined by treating as zero those */ +/* singular values which are less than RCOND times the largest singular */ +/* value. */ + +/* 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. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, the first min(m,n) rows of A are overwritten with */ +/* its right singular vectors, stored rowwise. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the M-by-NRHS right hand side matrix B. */ +/* On exit, B is overwritten by the N-by-NRHS solution */ +/* matrix X. If m >= n and RANK = n, the residual */ +/* sum-of-squares for the solution in the i-th column is given */ +/* by the sum of squares of elements n+1:m in that column. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */ + +/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The singular values of A in decreasing order. */ +/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */ + +/* RCOND (input) DOUBLE PRECISION */ +/* RCOND is used to determine the effective rank of A. */ +/* Singular values S(i) <= RCOND*S(1) are treated as zero. */ +/* If RCOND < 0, machine precision is used instead. */ + +/* RANK (output) INTEGER */ +/* The effective rank of A, i.e., the number of singular values */ +/* which are greater than RCOND*S(1). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= 1, and also: */ +/* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) */ +/* For good performance, LWORK should generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: the algorithm for computing the SVD failed to converge; */ +/* if INFO = i, i off-diagonal elements of an intermediate */ +/* bidiagonal form did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --s; + --work; + + /* Function Body */ + *info = 0; + minmn = std::min(*m,*n); + maxmn = std::max(*m,*n); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else if (*ldb < std::max(1_integer,maxmn)) { + *info = -7; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + minwrk = 1; + maxwrk = 1; + if (minmn > 0) { + mm = *m; + mnthr = ilaenv_(&c__6, "DGELSS", " ", m, n, nrhs, &c_n1); + if (*m >= *n && *m >= mnthr) { + +/* Path 1a - overdetermined, with many more rows than */ +/* columns */ + + mm = *n; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", + " ", m, n, &c_n1, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", + "LT", m, nrhs, n, &c_n1); + maxwrk = std::max(i__1,i__2); + } + if (*m >= *n) { + +/* Path 1 - overdetermined or exactly determined */ + +/* Compute workspace needed for DBDSQR */ + +/* Computing MAX */ + i__1 = 1, i__2 = *n * 5; + bdspac = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, + "DGEBRD", " ", &mm, n, &c_n1, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR" +, "QLT", &mm, nrhs, n, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, + "DORGBR", "P", n, n, n, &c_n1); + maxwrk = std::max(i__1,i__2); + maxwrk = std::max(maxwrk,bdspac); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * *nrhs; + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = std::max(i__1, + i__2); + minwrk = std::max(i__1,bdspac); + maxwrk = std::max(minwrk,maxwrk); + } + if (*n > *m) { + +/* Compute workspace needed for DBDSQR */ + +/* Computing MAX */ + i__1 = 1, i__2 = *m * 5; + bdspac = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = std::max(i__1, + i__2); + minwrk = std::max(i__1,bdspac); + if (*n >= mnthr) { + +/* Path 2a - underdetermined, with many more columns */ +/* than rows */ + + maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * + ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * + ilaenv_(&c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * + ilaenv_(&c__1, "DORGBR", "P", m, m, m, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + *m + bdspac; + maxwrk = std::max(i__1,i__2); + if (*nrhs > 1) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; + maxwrk = std::max(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 1); + maxwrk = std::max(i__1,i__2); + } +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ" +, "LT", n, nrhs, m, &c_n1); + maxwrk = std::max(i__1,i__2); + } else { + +/* Path 2 - underdetermined */ + + maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", + " ", m, n, &c_n1, &c_n1); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, + "DORMBR", "QLT", m, nrhs, m, &c_n1); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORG" + "BR", "P", m, n, m, &c_n1); + maxwrk = std::max(i__1,i__2); + maxwrk = std::max(maxwrk,bdspac); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * *nrhs; + maxwrk = std::max(i__1,i__2); + } + } + maxwrk = std::max(minwrk,maxwrk); + } + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGELSS", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + eps = dlamch_("P"); + sfmin = dlamch_("S"); + smlnum = sfmin / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = std::max(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[b_offset], ldb); + dlaset_("F", &minmn, &c__1, &c_b74, &c_b74, &s[1], &c__1); + *rank = 0; + goto L70; + } + +/* Scale B if max element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Overdetermined case */ + + if (*m >= *n) { + +/* Path 1 - overdetermined or exactly determined */ + + mm = *m; + if (*m >= mnthr) { + +/* Path 1a - overdetermined, with many more rows than columns */ + + mm = *n; + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__1 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, + info); + +/* Multiply B by transpose(Q) */ +/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */ + + i__1 = *lwork - iwork + 1; + dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[iwork], &i__1, info); + +/* Zero out below R */ + + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_("L", &i__1, &i__2, &c_b74, &c_b74, &a[a_dim1 + 2], + lda); + } + } + + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in A */ +/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */ + + i__1 = *lwork - iwork + 1; + dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[iwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors of R */ +/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */ + + i__1 = *lwork - iwork + 1; + dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], + &b[b_offset], ldb, &work[iwork], &i__1, info); + +/* Generate right bidiagonalizing vectors of R in A */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + i__1 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], & + i__1, info); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration */ +/* multiply B by transpose of left singular vectors */ +/* compute right singular vectors in A */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda, + vdum, &c__1, &b[b_offset], ldb, &work[iwork], info) + ; + if (*info != 0) { + goto L70; + } + +/* Multiply B by reciprocals of singular values */ + +/* Computing MAX */ + d__1 = *rcond * s[1]; + thr = std::max(d__1,sfmin); + if (*rcond < 0.) { +/* Computing MAX */ + d__1 = eps * s[1]; + thr = std::max(d__1,sfmin); + } + *rank = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1], + ldb); + } +/* L10: */ + } + +/* Multiply B by right singular vectors */ +/* (Workspace: need N, prefer N*NRHS) */ + + if (*lwork >= *ldb * *nrhs && *nrhs > 1) { + dgemm_("T", "N", n, nrhs, n, &c_b108, &a[a_offset], lda, &b[ + b_offset], ldb, &c_b74, &work[1], ldb); + dlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb) + ; + } else if (*nrhs > 1) { + chunk = *lwork / *n; + i__1 = *nrhs; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *nrhs - i__ + 1; + bl = std::min(i__3,chunk); + dgemm_("T", "N", n, &bl, n, &c_b108, &a[a_offset], lda, &b[ + i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n); + dlacpy_("G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb); +/* L20: */ + } + } else { + dgemv_("T", n, n, &c_b108, &a[a_offset], lda, &b[b_offset], &c__1, + &c_b74, &work[1], &c__1); + dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); + } + + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__2 = *m, i__1 = (*m << 1) - 4, i__2 = std::max(i__2,i__1), i__2 = std::max( + i__2,*nrhs), i__1 = *n - *m * 3; + if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + std::max(i__2,i__1)) { + +/* Path 2a - underdetermined, with many more columns than rows */ +/* and sufficient workspace for an efficient algorithm */ + + ldwork = *m; +/* Computing MAX */ +/* Computing MAX */ + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = std::max(i__3,i__4), i__3 = + std::max(i__3,*nrhs), i__4 = *n - *m * 3; + i__2 = (*m << 2) + *m * *lda + std::max(i__3,i__4), i__1 = *m * *lda + + *m + *m * *nrhs; + if (*lwork >= std::max(i__2,i__1)) { + ldwork = *lda; + } + itau = 1; + iwork = *m + 1; + +/* Compute A=L*Q */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + info); + il = iwork; + +/* Copy L to WORK(IL), zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); + i__2 = *m - 1; + i__1 = *m - 1; + dlaset_("U", &i__2, &i__1, &c_b74, &c_b74, &work[il + ldwork], & + ldwork); + ie = il + ldwork * *m; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IL) */ +/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, info); + +/* Multiply B by transpose of left bidiagonalizing vectors of L */ +/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[ + itauq], &b[b_offset], ldb, &work[iwork], &i__2, info); + +/* Generate right bidiagonalizing vectors of R in WORK(IL) */ +/* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[ + iwork], &i__2, info); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, */ +/* computing right singular vectors of L in WORK(IL) and */ +/* multiplying B by transpose of left singular vectors */ +/* (Workspace: need M*M+M+BDSPAC) */ + + dbdsqr_("U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], & + ldwork, &a[a_offset], lda, &b[b_offset], ldb, &work[iwork] +, info); + if (*info != 0) { + goto L70; + } + +/* Multiply B by reciprocals of singular values */ + +/* Computing MAX */ + d__1 = *rcond * s[1]; + thr = std::max(d__1,sfmin); + if (*rcond < 0.) { +/* Computing MAX */ + d__1 = eps * s[1]; + thr = std::max(d__1,sfmin); + } + *rank = 0; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1] +, ldb); + } +/* L30: */ + } + iwork = ie; + +/* Multiply B by right singular vectors of L in WORK(IL) */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) */ + + if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { + dgemm_("T", "N", m, nrhs, m, &c_b108, &work[il], &ldwork, &b[ + b_offset], ldb, &c_b74, &work[iwork], ldb); + dlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb); + } else if (*nrhs > 1) { + chunk = (*lwork - iwork + 1) / *m; + i__2 = *nrhs; + i__1 = chunk; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__1) { +/* Computing MIN */ + i__3 = *nrhs - i__ + 1; + bl = std::min(i__3,chunk); + dgemm_("T", "N", m, &bl, m, &c_b108, &work[il], &ldwork, & + b[i__ * b_dim1 + 1], ldb, &c_b74, &work[iwork], m); + dlacpy_("G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1] +, ldb); +/* L40: */ + } + } else { + dgemv_("T", m, m, &c_b108, &work[il], &ldwork, &b[b_dim1 + 1], + &c__1, &c_b74, &work[iwork], &c__1); + dcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1); + } + +/* Zero out below first M rows of B */ + + i__1 = *n - *m; + dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[*m + 1 + b_dim1], + ldb); + iwork = itau + *m; + +/* Multiply transpose(Q) by B */ +/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */ + + i__1 = *lwork - iwork + 1; + dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[iwork], &i__1, info); + + } else { + +/* Path 2 - remaining underdetermined cases */ + + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize A */ +/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ + + i__1 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[iwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors */ +/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */ + + i__1 = *lwork - iwork + 1; + dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq] +, &b[b_offset], ldb, &work[iwork], &i__1, info); + +/* Generate right bidiagonalizing vectors in A */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__1 = *lwork - iwork + 1; + dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ + iwork], &i__1, info); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, */ +/* computing right singular vectors of A in A and */ +/* multiplying B by transpose of left singular vectors */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], + lda, vdum, &c__1, &b[b_offset], ldb, &work[iwork], info); + if (*info != 0) { + goto L70; + } + +/* Multiply B by reciprocals of singular values */ + +/* Computing MAX */ + d__1 = *rcond * s[1]; + thr = std::max(d__1,sfmin); + if (*rcond < 0.) { +/* Computing MAX */ + d__1 = eps * s[1]; + thr = std::max(d__1,sfmin); + } + *rank = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] > thr) { + drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1] +, ldb); + } +/* L50: */ + } + +/* Multiply B by right singular vectors of A */ +/* (Workspace: need N, prefer N*NRHS) */ + + if (*lwork >= *ldb * *nrhs && *nrhs > 1) { + dgemm_("T", "N", n, nrhs, m, &c_b108, &a[a_offset], lda, &b[ + b_offset], ldb, &c_b74, &work[1], ldb); + dlacpy_("F", n, nrhs, &work[1], ldb, &b[b_offset], ldb); + } else if (*nrhs > 1) { + chunk = *lwork / *n; + i__1 = *nrhs; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { +/* Computing MIN */ + i__3 = *nrhs - i__ + 1; + bl = std::min(i__3,chunk); + dgemm_("T", "N", n, &bl, m, &c_b108, &a[a_offset], lda, & + b[i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n); + dlacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], + ldb); +/* L60: */ + } + } else { + dgemv_("T", m, n, &c_b108, &a[a_offset], lda, &b[b_offset], & + c__1, &c_b74, &work[1], &c__1); + dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); + } + } + } + +/* Undo scaling */ + + if (iascl == 1) { + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, info); + } else if (iascl == 2) { + dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, info); + } + if (ibscl == 1) { + dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L70: + work[1] = (double) maxwrk; + return 0; + +/* End of DGELSS */ + +} /* dgelss_ */ + +/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs, + double *a, integer *lda, double *b, integer *ldb, integer * + jpvt, double *rcond, integer *rank, double *work, integer * + info) +{ + /* Table of constant values */ + static integer c__0 = 0; + static double c_b13 = 0.; + static integer c__2 = 2; + static integer c__1 = 1; + static double c_b36 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j, k; + double c1, c2, s1, s2, t1, t2; + integer mn; + double anrm, bnrm, smin, smax; + integer iascl, ibscl, ismin, ismax; + double bignum; + double sminpr, smaxpr, smlnum; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This routine is deprecated and has been replaced by routine DGELSY. */ + +/* DGELSX computes the minimum-norm solution to a real linear least */ +/* squares problem: */ +/* minimize || A * X - B || */ +/* using a complete orthogonal factorization of A. A is an M-by-N */ +/* matrix which may be rank-deficient. */ + +/* Several right hand side vectors b and solution vectors x can be */ +/* handled in a single call; they are stored as the columns of the */ +/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* matrix X. */ + +/* The routine first computes a QR factorization with column pivoting: */ +/* A * P = Q * [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* with R11 defined as the largest leading submatrix whose estimated */ +/* condition number is less than 1/RCOND. The order of R11, RANK, */ +/* is the effective rank of A. */ + +/* Then, R22 is considered to be negligible, and R12 is annihilated */ +/* by orthogonal transformations from the right, arriving at the */ +/* complete orthogonal factorization: */ +/* A * P = Q * [ T11 0 ] * Z */ +/* [ 0 0 ] */ +/* The minimum-norm solution is then */ +/* X = P * Z' [ inv(T11)*Q1'*B ] */ +/* [ 0 ] */ +/* where Q1 consists of the first RANK columns of Q. */ + +/* 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. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of */ +/* columns of matrices B and X. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, A has been overwritten by details of its */ +/* complete orthogonal factorization. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the M-by-NRHS right hand side matrix B. */ +/* On exit, the N-by-NRHS solution matrix X. */ +/* If m >= n and RANK = n, the residual sum-of-squares for */ +/* the solution in the i-th column is given by the sum of */ +/* squares of elements N+1:M in that column. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,M,N). */ + +/* JPVT (input/output) INTEGER array, dimension (N) */ +/* On entry, if JPVT(i) .ne. 0, the i-th column of A is an */ +/* initial column, otherwise it is a free column. Before */ +/* the QR factorization of A, all initial columns are */ +/* permuted to the leading positions; only the remaining */ +/* free columns are moved as a result of column pivoting */ +/* during the factorization. */ +/* On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* was the k-th column of A. */ + +/* RCOND (input) DOUBLE PRECISION */ +/* RCOND is used to determine the effective rank of A, which */ +/* is defined as the order of the largest leading triangular */ +/* submatrix R11 in the QR factorization with pivoting of A, */ +/* whose estimated condition number < 1/RCOND. */ + +/* RANK (output) INTEGER */ +/* The effective rank of A, i.e., the order of the submatrix */ +/* R11. This is the same as the order of the submatrix T11 */ +/* in the complete orthogonal factorization of A. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension */ +/* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )), */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --jpvt; + --work; + + /* Function Body */ + mn = std::min(*m,*n); + ismin = mn + 1; + ismax = (mn << 1) + 1; + +/* Test the input arguments. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = std::max(1_integer,*m); + if (*ldb < std::max(i__1,*n)) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGELSX", &i__1); + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = std::min(*m,*n); + if (std::min(i__1,*nrhs) == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S") / dlamch_("P"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = std::max(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb); + *rank = 0; + goto L100; + } + + bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Compute QR factorization with column pivoting of A: */ +/* A * P = Q * R */ + + dgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info); + +/* workspace 3*N. Details of Householder rotations stored */ +/* in WORK(1:MN). */ + +/* Determine RANK using incremental condition estimation */ + + work[ismin] = 1.; + work[ismax] = 1.; + smax = (d__1 = a[a_dim1 + 1], abs(d__1)); + smin = smax; + if ((d__1 = a[a_dim1 + 1], abs(d__1)) == 0.) { + *rank = 0; + i__1 = std::max(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb); + goto L100; + } else { + *rank = 1; + } + +L10: + if (*rank < mn) { + i__ = *rank + 1; + dlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &sminpr, &s1, &c1); + dlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &smaxpr, &s2, &c2); + + if (smaxpr * *rcond <= sminpr) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1]; + work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1]; +/* L20: */ + } + work[ismin + *rank] = c1; + work[ismax + *rank] = c2; + smin = sminpr; + smax = smaxpr; + ++(*rank); + goto L10; + } + } + +/* Logically partition R = [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* where R11 = R(1:RANK,1:RANK) */ + +/* [R11,R12] = [ T11, 0 ] * Y */ + + if (*rank < *n) { + dtzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info); + } + +/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ + +/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ + + dorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], & + b[b_offset], ldb, &work[(mn << 1) + 1], info); + +/* workspace NRHS */ + +/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ + + dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, & + a[a_offset], lda, &b[b_offset], ldb); + + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + b[i__ + j * b_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */ + + if (*rank < *n) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - *rank + 1; + dlatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, + &work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], + ldb, &work[(mn << 1) + 1]); +/* L50: */ + } + } + +/* workspace NRHS */ + +/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[(mn << 1) + i__] = 1.; +/* L60: */ + } + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[(mn << 1) + i__] == 1.) { + if (jpvt[i__] != i__) { + k = i__; + t1 = b[k + j * b_dim1]; + t2 = b[jpvt[k] + j * b_dim1]; +L70: + b[jpvt[k] + j * b_dim1] = t1; + work[(mn << 1) + k] = 0.; + t1 = t2; + k = jpvt[k]; + t2 = b[jpvt[k] + j * b_dim1]; + if (jpvt[k] != i__) { + goto L70; + } + b[i__ + j * b_dim1] = t1; + work[(mn << 1) + k] = 0.; + } + } +/* L80: */ + } +/* L90: */ + } + +/* Undo scaling */ + + if (iascl == 1) { + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], + lda, info); + } else if (iascl == 2) { + dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], + lda, info); + } + if (ibscl == 1) { + dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L100: + + return 0; + +/* End of DGELSX */ + +} /* dgelsx_ */ + +/* Subroutine */ int dgelsy_(integer *m, integer *n, integer *nrhs, + double *a, integer *lda, double *b, integer *ldb, integer * + jpvt, double *rcond, integer *rank, double *work, integer * + lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__0 = 0; + static double c_b31 = 0.; + static integer c__2 = 2; + static double c_b54 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double c1, c2, s1, s2; + integer nb, mn, nb1, nb2, nb3, nb4; + double anrm, bnrm, smin, smax; + integer iascl, ibscl; + integer ismin, ismax; + double wsize; + double bignum; + integer lwkmin; + double sminpr, smaxpr, smlnum; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGELSY computes the minimum-norm solution to a real linear least */ +/* squares problem: */ +/* minimize || A * X - B || */ +/* using a complete orthogonal factorization of A. A is an M-by-N */ +/* matrix which may be rank-deficient. */ + +/* Several right hand side vectors b and solution vectors x can be */ +/* handled in a single call; they are stored as the columns of the */ +/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* matrix X. */ + +/* The routine first computes a QR factorization with column pivoting: */ +/* A * P = Q * [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* with R11 defined as the largest leading submatrix whose estimated */ +/* condition number is less than 1/RCOND. The order of R11, RANK, */ +/* is the effective rank of A. */ + +/* Then, R22 is considered to be negligible, and R12 is annihilated */ +/* by orthogonal transformations from the right, arriving at the */ +/* complete orthogonal factorization: */ +/* A * P = Q * [ T11 0 ] * Z */ +/* [ 0 0 ] */ +/* The minimum-norm solution is then */ +/* X = P * Z' [ inv(T11)*Q1'*B ] */ +/* [ 0 ] */ +/* where Q1 consists of the first RANK columns of Q. */ + +/* This routine is basically identical to the original xGELSX except */ +/* three differences: */ +/* o The call to the subroutine xGEQPF has been substituted by the */ +/* the call to the subroutine xGEQP3. This subroutine is a Blas-3 */ +/* version of the QR factorization with column pivoting. */ +/* o Matrix B (the right hand side) is updated with Blas-3. */ +/* o The permutation of matrix B (the right hand side) is faster and */ +/* more simple. */ + +/* 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. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of */ +/* columns of matrices B and X. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, A has been overwritten by details of its */ +/* complete orthogonal factorization. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the M-by-NRHS right hand side matrix B. */ +/* On exit, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,M,N). */ + +/* 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 AP, otherwise column i is a free column. */ +/* On exit, if JPVT(i) = k, then the i-th column of AP */ +/* was the k-th column of A. */ + +/* RCOND (input) DOUBLE PRECISION */ +/* RCOND is used to determine the effective rank of A, which */ +/* is defined as the order of the largest leading triangular */ +/* submatrix R11 in the QR factorization with pivoting of A, */ +/* whose estimated condition number < 1/RCOND. */ + +/* RANK (output) INTEGER */ +/* The effective rank of A, i.e., the order of the submatrix */ +/* R11. This is the same as the order of the submatrix T11 */ +/* in the complete orthogonal factorization of A. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* The unblocked strategy requires that: */ +/* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ), */ +/* where MN = min( M, N ). */ +/* The block algorithm requires that: */ +/* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ), */ +/* where NB is an upper bound on the blocksize returned */ +/* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR, */ +/* and DORMRZ. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: If INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ +/* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --jpvt; + --work; + + /* Function Body */ + mn = std::min(*m,*n); + ismin = mn + 1; + ismax = (mn << 1) + 1; + +/* Test the input arguments. */ + + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = std::max(1_integer,*m); + if (*ldb < std::max(i__1,*n)) { + *info = -7; + } + } + +/* Figure out optimal block size */ + + if (*info == 0) { + if (mn == 0 || *nrhs == 0) { + lwkmin = 1; + lwkopt = 1; + } else { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); + nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); + nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, nrhs, &c_n1); + nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, nrhs, &c_n1); +/* Computing MAX */ + i__1 = std::max(nb1,nb2), i__1 = std::max(i__1,nb3); + nb = std::max(i__1,nb4); +/* Computing MAX */ + i__1 = mn << 1, i__2 = *n + 1, i__1 = std::max(i__1,i__2), i__2 = mn + + *nrhs; + lwkmin = mn + std::max(i__1,i__2); +/* Computing MAX */ + i__1 = lwkmin, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = std::max( + i__1,i__2), i__2 = (mn << 1) + nb * *nrhs; + lwkopt = std::max(i__1,i__2); + } + work[1] = (double) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGELSY", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (mn == 0 || *nrhs == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S") / dlamch_("P"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = std::max(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b31, &c_b31, &b[b_offset], ldb); + *rank = 0; + goto L70; + } + + bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Compute QR factorization with column pivoting of A: */ +/* A * P = Q * R */ + + i__1 = *lwork - mn; + dgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1, + info); + wsize = mn + work[mn + 1]; + +/* workspace: MN+2*N+NB*(N+1). */ +/* Details of Householder rotations stored in WORK(1:MN). */ + +/* Determine RANK using incremental condition estimation */ + + work[ismin] = 1.; + work[ismax] = 1.; + smax = (d__1 = a[a_dim1 + 1], abs(d__1)); + smin = smax; + if ((d__1 = a[a_dim1 + 1], abs(d__1)) == 0.) { + *rank = 0; + i__1 = std::max(*m,*n); + dlaset_("F", &i__1, nrhs, &c_b31, &c_b31, &b[b_offset], ldb); + goto L70; + } else { + *rank = 1; + } + +L10: + if (*rank < mn) { + i__ = *rank + 1; + dlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &sminpr, &s1, &c1); + dlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &smaxpr, &s2, &c2); + + if (smaxpr * *rcond <= sminpr) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1]; + work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1]; +/* L20: */ + } + work[ismin + *rank] = c1; + work[ismax + *rank] = c2; + smin = sminpr; + smax = smaxpr; + ++(*rank); + goto L10; + } + } + +/* workspace: 3*MN. */ + +/* Logically partition R = [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* where R11 = R(1:RANK,1:RANK) */ + +/* [R11,R12] = [ T11, 0 ] * Y */ + + if (*rank < *n) { + i__1 = *lwork - (mn << 1); + dtzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) + + 1], &i__1, info); + } + +/* workspace: 2*MN. */ +/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ + +/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ + + i__1 = *lwork - (mn << 1); + dormqr_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], & + b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info); +/* Computing MAX */ + d__1 = wsize, d__2 = (mn << 1) + work[(mn << 1) + 1]; + wsize = std::max(d__1,d__2); + +/* workspace: 2*MN+NB*NRHS. */ + +/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ + + dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b54, & + a[a_offset], lda, &b[b_offset], ldb); + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = *rank + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */ + + if (*rank < *n) { + i__1 = *n - *rank; + i__2 = *lwork - (mn << 1); + dormrz_("Left", "Transpose", n, nrhs, rank, &i__1, &a[a_offset], lda, + &work[mn + 1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__2, + info); + } + +/* workspace: 2*MN+NRHS. */ + +/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[jpvt[i__]] = b[i__ + j * b_dim1]; +/* L50: */ + } + dcopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1); +/* L60: */ + } + +/* workspace: N. */ + +/* Undo scaling */ + + if (iascl == 1) { + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], + lda, info); + } else if (iascl == 2) { + dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], + lda, info); + } + if (ibscl == 1) { + dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L70: + work[1] = (double) lwkopt; + + return 0; + +/* End of DGELSY */ + +} /* dgelsy_ */ + +/* Subroutine */ int dgeql2_(integer *m, integer *n, double *a, integer * + lda, double *tau, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, k; + double aii; + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEQL2 computes a QL factorization of a real m by n matrix A: */ +/* A = Q * L. */ + +/* 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, if m >= n, the lower triangle of the subarray */ +/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */ +/* if m <= n, the elements on and below the (n-m)-th */ +/* superdiagonal contain the m by n lower trapezoidal matrix L; */ +/* the remaining elements, 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(k) . . . H(2) H(1), 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */ +/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEQL2", &i__1); + return 0; + } + + k = std::min(*m,*n); + + for (i__ = k; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(1:m-k+i-1,n-k+i) */ + + i__1 = *m - k + i__; + dlarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[(*n - k + + i__) * a_dim1 + 1], &c__1, &tau[i__]); + +/* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left */ + + aii = a[*m - k + i__ + (*n - k + i__) * a_dim1]; + a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.; + i__1 = *m - k + i__; + i__2 = *n - k + i__ - 1; + dlarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, & + tau[i__], &a[a_offset], lda, &work[1]); + a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii; +/* L10: */ + } + return 0; + +/* End of DGEQL2 */ + +} /* dgeql2_ */ + + +/* Subroutine */ int dgeqlf_(integer *m, integer *n, double *a, integer * + lda, double *tau, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEQLF computes a QL factorization of a real M-by-N matrix A: */ +/* A = Q * L. */ + +/* 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, */ +/* if m >= n, the lower triangle of the subarray */ +/* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; */ +/* if m <= n, the elements on and below the (n-m)-th */ +/* superdiagonal contain the M-by-N lower trapezoidal matrix L; */ +/* the remaining elements, 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* 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(k) . . . H(2) H(1), 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */ +/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + + if (*info == 0) { + k = std::min(*m,*n); + if (k == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, "DGEQLF", " ", m, n, &c_n1, &c_n1); + lwkopt = *n * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < std::max(1_integer,*n) && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEQLF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (k == 0) { + return 0; + } + + nbmin = 2; + nx = 1; + iws = *n; + if (nb > 1 && nb < k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQLF", " ", m, n, &c_n1, &c_n1); + nx = std::max(i__1,i__2); + if (nx < k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQLF", " ", m, n, &c_n1, & + c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < k && nx < k) { + +/* Use blocked code initially. */ +/* The last kk columns are handled by the block method. */ + + ki = (k - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = k, i__2 = ki + nb; + kk = std::min(i__1,i__2); + + i__1 = k - kk + 1; + i__2 = -nb; + for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = std::min(i__3,nb); + +/* Compute the QL factorization of the current block */ +/* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) */ + + i__3 = *m - k + i__ + ib - 1; + dgeql2_(&i__3, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &tau[ + i__], &work[1], &iinfo); + if (*n - k + i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *m - k + i__ + ib - 1; + dlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - k + + i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ + + i__3 = *m - k + i__ + ib - 1; + i__4 = *n - k + i__ - 1; + dlarfb_("Left", "Transpose", "Backward", "Columnwise", &i__3, + &i__4, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, & + work[1], &ldwork, &a[a_offset], lda, &work[ib + 1], & + ldwork); + } +/* L10: */ + } + mu = *m - k + i__ + nb - 1; + nu = *n - k + i__ + nb - 1; + } else { + mu = *m; + nu = *n; + } + +/* Use unblocked code to factor the last or only block */ + + if (mu > 0 && nu > 0) { + dgeql2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo); + } + + work[1] = (double) iws; + return 0; + +/* End of DGEQLF */ + +} /* dgeqlf_ */ + +/* Subroutine */ int dgeqp3_(integer *m, integer *n, double *a, integer * + lda, integer *jpvt, double *tau, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer j, jb, na, nb, sm, sn, nx, fjb, iws, nfxd; + integer nbmin, minmn; + integer minws; + integer topbmn, sminmn; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGEQP3 computes a QR factorization with column pivoting of a */ +/* matrix A: A*P = Q*R using Level 3 BLAS. */ + +/* 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 trapezoidal 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(J).ne.0, the J-th column of A is permuted */ +/* to the front of A*P (a leading column); if JPVT(J)=0, */ +/* the J-th column of A is a free column. */ +/* On exit, if JPVT(J)=K, then the J-th column of A*P was the */ +/* the K-th column of A. */ + +/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The scalar factors of the elementary reflectors. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= 3*N+1. */ +/* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB */ +/* is the optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* 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/complex scalar, and v is a real/complex 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). */ + +/* Based on contributions by */ +/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* X. Sun, Computer Science Dept., Duke University, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test input arguments */ +/* ==================== */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --jpvt; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + + if (*info == 0) { + minmn = std::min(*m,*n); + if (minmn == 0) { + iws = 1; + lwkopt = 1; + } else { + iws = *n * 3 + 1; + nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); + lwkopt = (*n << 1) + (*n + 1) * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < iws && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEQP3", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (minmn == 0) { + return 0; + } + +/* Move initial columns up front. */ + + nfxd = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (jpvt[j] != 0) { + if (j != nfxd) { + dswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nfxd * a_dim1 + 1], & + c__1); + jpvt[j] = jpvt[nfxd]; + jpvt[nfxd] = j; + } else { + jpvt[j] = j; + } + ++nfxd; + } else { + jpvt[j] = j; + } +/* L10: */ + } + --nfxd; + +/* Factorize fixed columns */ +/* ======================= */ + +/* Compute the QR factorization of fixed columns and update */ +/* remaining columns. */ + + if (nfxd > 0) { + na = std::min(*m,nfxd); +/* CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) */ + dgeqrf_(m, &na, &a[a_offset], lda, &tau[1], &work[1], lwork, info); +/* Computing MAX */ + i__1 = iws, i__2 = (integer) work[1]; + iws = std::max(i__1,i__2); + if (na < *n) { +/* CC CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, */ +/* CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) */ + i__1 = *n - na; + dormqr_("Left", "Transpose", m, &i__1, &na, &a[a_offset], lda, & + tau[1], &a[(na + 1) * a_dim1 + 1], lda, &work[1], lwork, + info); +/* Computing MAX */ + i__1 = iws, i__2 = (integer) work[1]; + iws = std::max(i__1,i__2); + } + } + +/* Factorize free columns */ +/* ====================== */ + + if (nfxd < minmn) { + + sm = *m - nfxd; + sn = *n - nfxd; + sminmn = minmn - nfxd; + +/* Determine the block size. */ + + nb = ilaenv_(&c__1, "DGEQRF", " ", &sm, &sn, &c_n1, &c_n1); + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < sminmn) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", &sm, &sn, &c_n1, & + c_n1); + nx = std::max(i__1,i__2); + + + if (nx < sminmn) { + +/* Determine if workspace is large enough for blocked code. */ + + minws = (sn << 1) + (sn + 1) * nb; + iws = std::max(iws,minws); + if (*lwork < minws) { + +/* Not enough workspace to use optimal NB: Reduce NB and */ +/* determine the minimum value of NB. */ + + nb = (*lwork - (sn << 1)) / (sn + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", &sm, &sn, & + c_n1, &c_n1); + nbmin = std::max(i__1,i__2); + + + } + } + } + +/* Initialize partial column norms. The first N elements of work */ +/* store the exact column norms. */ + + i__1 = *n; + for (j = nfxd + 1; j <= i__1; ++j) { + work[j] = dnrm2_(&sm, &a[nfxd + 1 + j * a_dim1], &c__1); + work[*n + j] = work[j]; +/* L20: */ + } + + if (nb >= nbmin && nb < sminmn && nx < sminmn) { + +/* Use blocked code initially. */ + + j = nfxd + 1; + +/* Compute factorization: while loop. */ + + + topbmn = minmn - nx; +L30: + if (j <= topbmn) { +/* Computing MIN */ + i__1 = nb, i__2 = topbmn - j + 1; + jb = std::min(i__1,i__2); + +/* Factorize JB columns among columns J:N. */ + + i__1 = *n - j + 1; + i__2 = j - 1; + i__3 = *n - j + 1; + dlaqps_(m, &i__1, &i__2, &jb, &fjb, &a[j * a_dim1 + 1], lda, & + jpvt[j], &tau[j], &work[j], &work[*n + j], &work[(*n + << 1) + 1], &work[(*n << 1) + jb + 1], &i__3); + + j += fjb; + goto L30; + } + } else { + j = nfxd + 1; + } + +/* Use unblocked code to factor the last or only block. */ + + + if (j <= minmn) { + i__1 = *n - j + 1; + i__2 = j - 1; + dlaqp2_(m, &i__1, &i__2, &a[j * a_dim1 + 1], lda, &jpvt[j], &tau[ + j], &work[j], &work[*n + j], &work[(*n << 1) + 1]); + } + + } + + work[1] = (double) iws; + return 0; + +/* End of DGEQP3 */ + +} /* dgeqp3_ */ + +/* Subroutine */ int dgeqpf_(integer *m, integer *n, double *a, integer * + lda, integer *jpvt, double *tau, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1, d__2; + + /* Local variables */ + integer i__, j, ma, mn; + double aii; + integer pvt; + double temp; + double temp2, tol3z; + integer itemp; + +/* -- LAPACK deprecated driver routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This routine is deprecated and has been replaced by routine DGEQP3. */ + +/* 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. */ + +/* Partial column norm updating strategy modified by */ +/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* University of Zagreb, Croatia. */ +/* June 2006. */ +/* For more details see LAPACK Working Note 176. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --jpvt; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEQPF", &i__1); + return 0; + } + + mn = std::min(*m,*n); + tol3z = sqrt(dlamch_("Epsilon")); + +/* Move initial columns up front */ + + itemp = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (jpvt[i__] != 0) { + if (i__ != itemp) { + dswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1], + &c__1); + jpvt[i__] = jpvt[itemp]; + jpvt[itemp] = i__; + } else { + jpvt[i__] = i__; + } + ++itemp; + } else { + jpvt[i__] = i__; + } +/* L10: */ + } + --itemp; + +/* Compute the QR factorization and update remaining columns */ + + if (itemp > 0) { + ma = std::min(itemp,*m); + dgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info); + if (ma < *n) { + i__1 = *n - ma; + dorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, & + tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info); + } + } + + if (itemp < mn) { + +/* Initialize partial column norms. The first n elements of */ +/* work store the exact column norms. */ + + i__1 = *n; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + i__2 = *m - itemp; + work[i__] = dnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1); + work[*n + i__] = work[i__]; +/* L20: */ + } + +/* Compute factorization */ + + i__1 = mn; + for (i__ = itemp + 1; i__ <= i__1; ++i__) { + +/* Determine ith pivot column and swap if necessary */ + + i__2 = *n - i__ + 1; + pvt = i__ - 1 + idamax_(&i__2, &work[i__], &c__1); + + if (pvt != i__) { + dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[i__]; + jpvt[i__] = itemp; + work[pvt] = work[i__]; + work[*n + pvt] = work[*n + i__]; + } + +/* Generate elementary reflector H(i) */ + + if (i__ < *m) { + i__2 = *m - i__ + 1; + dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ * + a_dim1], &c__1, &tau[i__]); + } else { + dlarfp_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], & + c__1, &tau[*m]); + } + + if (i__ < *n) { + +/* Apply H(i) to A(i:m,i+1:n) from the left */ + + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dlarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & + tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(* + n << 1) + 1]); + a[i__ + i__ * a_dim1] = aii; + } + +/* Update partial column norms */ + + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (work[j] != 0.) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / work[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = std::max(d__1,d__2); +/* Computing 2nd power */ + d__1 = work[j] / work[*n + j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + if (*m - i__ > 0) { + i__3 = *m - i__; + work[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1], + &c__1); + work[*n + j] = work[j]; + } else { + work[j] = 0.; + work[*n + j] = 0.; + } + } else { + work[j] *= sqrt(temp); + } + } +/* L30: */ + } + +/* L40: */ + } + } + return 0; + +/* End of DGEQPF */ + +} /* dgeqpf_ */ + +/* Subroutine */ int dgeqr2_(integer *m, integer *n, double *a, integer * + lda, double *tau, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, k; + double aii; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEQR2", &i__1); + return 0; + } + + k = std::min(*m,*n); + + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ + + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[std::min(i__3, *m)+ i__ * a_dim1] +, &c__1, &tau[i__]); + if (i__ < *n) { + +/* Apply H(i) to A(i:m,i+1:n) from the left */ + + aii = a[i__ + i__ * a_dim1]; + a[i__ + i__ * a_dim1] = 1.; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[ + i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); + a[i__ + i__ * a_dim1] = aii; + } +/* L10: */ + } + return 0; + +/* End of DGEQR2 */ + +} /* dgeqr2_ */ + + +/* Subroutine */ int dgeqrf_(integer *m, integer *n, double *a, integer * + lda, double *tau, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, k, ib, nb, nx, iws, nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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/output) DOUBLE PRECISION array, dimension (MAX(1,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. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* 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 .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); + lwkopt = *n * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } else if (*lwork < std::max(1_integer,*n) && ! lquery) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGEQRF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + k = std::min(*m,*n); + if (k == 0) { + work[1] = 1.; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1); + nx = std::max(i__1,i__2); + if (nx < k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, & + c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < k && nx < k) { + +/* Use blocked code initially */ + + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = std::min(i__3,nb); + +/* Compute the QR factorization of the current block */ +/* A(i:m,i:i+ib-1) */ + + i__3 = *m - i__ + 1; + dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ + 1], &iinfo); + if (i__ + ib <= *n) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__3 = *m - i__ + 1; + dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H' to A(i:m,i+ib:n) from the left */ + + i__3 = *m - i__ + 1; + i__4 = *n - i__ - ib + 1; + dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, & + i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & + ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib + + 1], &ldwork); + } +/* L10: */ + } + } else { + i__ = 1; + } + +/* Use unblocked code to factor the last or only block. */ + + if (i__ <= k) { + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] +, &iinfo); + } + + work[1] = (double) iws; + return 0; + +/* End of DGEQRF */ + +} /* dgeqrf_ */ + +/* Subroutine */ int dgerfs_(const char *trans, integer *n, integer *nrhs, + double *a, integer *lda, double *af, integer *ldaf, integer * + ipiv, double *b, integer *ldb, double *x, integer *ldx, + double *ferr, double *berr, double *work, integer *iwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b15 = -1.; + static double c_b17 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s, xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + integer count; + double safmin; + bool notran; + char transt[1]; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGERFS improves the computed solution to a system of linear */ +/* equations and provides error bounds and backward error estimates for */ +/* the solution. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The original N-by-N matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* The factors L and U from the factorization A = P*L*U */ +/* as computed by DGETRF. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DGETRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -10; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGERFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x[j * x_dim1 + 1], & + c__1, &c_b17, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(op(A))*abs(X) + abs(B). */ + + if (notran) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; +/* L40: */ + } +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ + i__ + j * x_dim1], abs(d__2)); +/* L60: */ + } + work[k] += s; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n + + 1], n, info); + daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + dgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & + work[*n + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L110: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L120: */ + } + dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & + work[*n + 1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DGERFS */ + +} /* dgerfs_ */ + +/* Subroutine */ int dgerq2_(integer *m, integer *n, double *a, integer *lda, double *tau, double *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, k; + double aii; + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGERQ2 computes an RQ factorization of a real m by n matrix A: */ +/* A = R * Q. */ + +/* 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, if m <= n, the upper triangle of the subarray */ +/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */ +/* if m >= n, the elements on and above the (m-n)-th subdiagonal */ +/* contain the m by n upper trapezoidal matrix R; the remaining */ +/* elements, 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 (M) */ + +/* 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */ +/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGERQ2", &i__1); + return 0; + } + + k = std::min(*m,*n); + + for (i__ = k; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(m-k+i,1:n-k+i-1) */ + + i__1 = *n - k + i__; + dlarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[*m - k + + i__ + a_dim1], lda, &tau[i__]); + +/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */ + + aii = a[*m - k + i__ + (*n - k + i__) * a_dim1]; + a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.; + i__1 = *m - k + i__ - 1; + i__2 = *n - k + i__; + dlarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[ + i__], &a[a_offset], lda, &work[1]); + a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii; +/* L10: */ + } + return 0; + +/* End of DGERQ2 */ + +} /* dgerq2_ */ + +/* Subroutine */ int dgerqf_(integer *m, integer *n, double *a, integer * + lda, double *tau, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGERQF computes an RQ factorization of a real M-by-N matrix A: */ +/* A = R * Q. */ + +/* 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, */ +/* if m <= n, the upper triangle of the subarray */ +/* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; */ +/* if m >= n, the elements on and above the (m-n)-th subdiagonal */ +/* contain the M-by-N upper trapezoidal matrix R; */ +/* the remaining elements, 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,M). */ +/* For optimum performance LWORK >= M*NB, where NB is */ +/* the optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */ +/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + + if (*info == 0) { + k = std::min(*m,*n); + if (k == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); + lwkopt = *m * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < std::max(1_integer,*m) && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGERQF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (k == 0) { + return 0; + } + + nbmin = 2; + nx = 1; + iws = *m; + if (nb > 1 && nb < k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGERQF", " ", m, n, &c_n1, &c_n1); + nx = std::max(i__1,i__2); + if (nx < k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGERQF", " ", m, n, &c_n1, & + c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < k && nx < k) { + +/* Use blocked code initially. */ +/* The last kk rows are handled by the block method. */ + + ki = (k - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = k, i__2 = ki + nb; + kk = std::min(i__1,i__2); + + i__1 = k - kk + 1; + i__2 = -nb; + for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = std::min(i__3,nb); + +/* Compute the RQ factorization of the current block */ +/* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) */ + + i__3 = *n - k + i__ + ib - 1; + dgerq2_(&ib, &i__3, &a[*m - k + i__ + a_dim1], lda, &tau[i__], & + work[1], &iinfo); + if (*m - k + i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *n - k + i__ + ib - 1; + dlarft_("Backward", "Rowwise", &i__3, &ib, &a[*m - k + i__ + + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */ + + i__3 = *m - k + i__ - 1; + i__4 = *n - k + i__ + ib - 1; + dlarfb_("Right", "No transpose", "Backward", "Rowwise", &i__3, + &i__4, &ib, &a[*m - k + i__ + a_dim1], lda, &work[1], + &ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork); + } +/* L10: */ + } + mu = *m - k + i__ + nb - 1; + nu = *n - k + i__ + nb - 1; + } else { + mu = *m; + nu = *n; + } + +/* Use unblocked code to factor the last or only block */ + + if (mu > 0 && nu > 0) { + dgerq2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo); + } + + work[1] = (double) iws; + return 0; + +/* End of DGERQF */ + +} /* dgerqf_ */ + +/* Subroutine */ int dgesc2_(integer *n, double *a, integer *lda, + double *rhs, integer *ipiv, integer *jpiv, double *scale) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double eps, temp; + double bignum; + double smlnum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGESC2 solves a system of linear equations */ + +/* A * X = scale* RHS */ + +/* with a general N-by-N matrix A using the LU factorization with */ +/* complete pivoting computed by DGETC2. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the LU part of the factorization of the n-by-n */ +/* matrix A computed by DGETC2: A = P * L * U * Q */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1, N). */ + +/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */ +/* On entry, the right hand side vector b. */ +/* On exit, the solution vector X. */ + +/* IPIV (input) INTEGER array, dimension (N). */ +/* The pivot indices; for 1 <= i <= N, row i of the */ +/* matrix has been interchanged with row IPIV(i). */ + +/* JPIV (input) INTEGER array, dimension (N). */ +/* The pivot indices; for 1 <= j <= N, column j of the */ +/* matrix has been interchanged with column JPIV(j). */ + +/* SCALE (output) DOUBLE PRECISION */ +/* On exit, SCALE contains the scale factor. SCALE is chosen */ +/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Set constant to control owerflow */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --rhs; + --ipiv; + --jpiv; + + /* Function Body */ + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Apply permutations IPIV to RHS */ + + i__1 = *n - 1; + dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1); + +/* Solve for L part */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + rhs[j] -= a[j + i__ * a_dim1] * rhs[i__]; +/* L10: */ + } +/* L20: */ + } + +/* Solve for U part */ + + *scale = 1.; + +/* Check for scaling */ + + i__ = idamax_(n, &rhs[1], &c__1); + if (smlnum * 2. * (d__1 = rhs[i__], abs(d__1)) > (d__2 = a[*n + *n * + a_dim1], abs(d__2))) { + temp = .5 / (d__1 = rhs[i__], abs(d__1)); + dscal_(n, &temp, &rhs[1], &c__1); + *scale *= temp; + } + + for (i__ = *n; i__ >= 1; --i__) { + temp = 1. / a[i__ + i__ * a_dim1]; + rhs[i__] *= temp; + i__1 = *n; + for (j = i__ + 1; j <= i__1; ++j) { + rhs[i__] -= rhs[j] * (a[i__ + j * a_dim1] * temp); +/* L30: */ + } +/* L40: */ + } + +/* Apply permutations JPIV to the solution (RHS) */ + + i__1 = *n - 1; + dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1); + return 0; + +/* End of DGESC2 */ + +} /* dgesc2_ */ + +/* Subroutine */ int dgesdd_(const char *jobz, integer *m, integer *n, double * + a, integer *lda, double *s, double *u, integer *ldu, + double *vt, integer *ldvt, double *work, integer *lwork, + integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__0 = 0; + static double c_b227 = 0.; + static double c_b248 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, + i__2, i__3; + + /* Local variables */ + integer i__, ie, il, ir, iu, blk; + double dum[1], eps; + integer ivt, iscl; + double anrm; + integer idum[1], ierr, itau; + integer chunk, minmn, wrkbl, itaup, itauq, mnthr; + bool wntqa; + integer nwork; + bool wntqn, wntqo, wntqs; + integer bdspac; + double bignum; + integer ldwrkl, ldwrkr, minwrk, ldwrku, maxwrk, ldwkvt; + double smlnum; + bool wntqas, lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGESDD computes the singular value decomposition (SVD) of a real */ +/* M-by-N matrix A, optionally computing the left and right singular */ +/* vectors. If singular vectors are desired, it uses a */ +/* divide-and-conquer algorithm. */ + +/* The SVD is written */ + +/* A = U * SIGMA * transpose(V) */ + +/* where SIGMA is an M-by-N matrix which is zero except for its */ +/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */ +/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */ +/* are the singular values of A; they are real and non-negative, and */ +/* are returned in descending order. The first min(m,n) columns of */ +/* U and V are the left and right singular vectors of A. */ + +/* Note that the routine returns VT = V**T, not V. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* Specifies options for computing all or part of the matrix U: */ +/* = 'A': all M columns of U and all N rows of V**T are */ +/* returned in the arrays U and VT; */ +/* = 'S': the first min(M,N) columns of U and the first */ +/* min(M,N) rows of V**T are returned in the arrays U */ +/* and VT; */ +/* = 'O': If M >= N, the first N columns of U are overwritten */ +/* on the array A and all rows of V**T are returned in */ +/* the array VT; */ +/* otherwise, all columns of U are returned in the */ +/* array U and the first M rows of V**T are overwritten */ +/* in the array A; */ +/* = 'N': no columns of U or rows of V**T are computed. */ + +/* M (input) INTEGER */ +/* The number of rows of the input matrix A. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the input matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, */ +/* if JOBZ = 'O', A is overwritten with the first N columns */ +/* of U (the left singular vectors, stored */ +/* columnwise) if M >= N; */ +/* A is overwritten with the first M rows */ +/* of V**T (the right singular vectors, stored */ +/* rowwise) otherwise. */ +/* if JOBZ .ne. 'O', the contents of A are destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The singular values of A, sorted so that S(i) >= S(i+1). */ + +/* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) */ +/* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; */ +/* UCOL = min(M,N) if JOBZ = 'S'. */ +/* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M */ +/* orthogonal matrix U; */ +/* if JOBZ = 'S', U contains the first min(M,N) columns of U */ +/* (the left singular vectors, stored columnwise); */ +/* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= 1; if */ +/* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. */ + +/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */ +/* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the */ +/* N-by-N orthogonal matrix V**T; */ +/* if JOBZ = 'S', VT contains the first min(M,N) rows of */ +/* V**T (the right singular vectors, stored rowwise); */ +/* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. */ + +/* LDVT (input) INTEGER */ +/* The leading dimension of the array VT. LDVT >= 1; if */ +/* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; */ +/* if JOBZ = 'S', LDVT >= min(M,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= 1. */ +/* If JOBZ = 'N', */ +/* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)). */ +/* If JOBZ = 'O', */ +/* LWORK >= 3*min(M,N)*min(M,N) + */ +/* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). */ +/* If JOBZ = 'S' or 'A' */ +/* LWORK >= 3*min(M,N)*min(M,N) + */ +/* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)). */ +/* For good performance, LWORK should generally be larger. */ +/* If LWORK = -1 but other input arguments are legal, WORK(1) */ +/* returns the optimal LWORK. */ + +/* IWORK (workspace) INTEGER array, dimension (8*min(M,N)) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: DBDSDC did not converge, updating process failed. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --s; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + minmn = std::min(*m,*n); + wntqa = lsame_(jobz, "A"); + wntqs = lsame_(jobz, "S"); + wntqas = wntqa || wntqs; + wntqo = lsame_(jobz, "O"); + wntqn = lsame_(jobz, "N"); + lquery = *lwork == -1; + + if (! (wntqa || wntqs || wntqo || wntqn)) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < * + m) { + *info = -8; + } else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn || + wntqo && *m >= *n && *ldvt < *n) { + *info = -10; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + minwrk = 1; + maxwrk = 1; + if (*m >= *n && minmn > 0) { + +/* Compute space needed for DBDSDC */ + + mnthr = (integer) (minmn * 11. / 6.); + if (wntqn) { + bdspac = *n * 7; + } else { + bdspac = *n * 3 * *n + (*n << 2); + } + if (*m >= mnthr) { + if (wntqn) { + +/* Path 1 (M much larger than N, JOBZ='N') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *n; + maxwrk = std::max(i__1,i__2); + minwrk = bdspac + *n; + } else if (wntqo) { + +/* Path 2 (M much larger than N, JOBZ='O') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", m, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "QLN", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "PRT", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *n * 3; + wrkbl = std::max(i__1,i__2); + maxwrk = wrkbl + (*n << 1) * *n; + minwrk = bdspac + (*n << 1) * *n + *n * 3; + } else if (wntqs) { + +/* Path 3 (M much larger than N, JOBZ='S') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", m, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "QLN", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "PRT", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *n * 3; + wrkbl = std::max(i__1,i__2); + maxwrk = wrkbl + *n * *n; + minwrk = bdspac + *n * *n + *n * 3; + } else if (wntqa) { + +/* Path 4 (M much larger than N, JOBZ='A') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n + *m * ilaenv_(&c__1, "DORGQR", + " ", m, m, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "QLN", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "PRT", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *n * 3; + wrkbl = std::max(i__1,i__2); + maxwrk = wrkbl + *n * *n; + minwrk = bdspac + *n * *n + *n * 3; + } + } else { + +/* Path 5 (M at least N, but not much larger) */ + + wrkbl = *n * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, + n, &c_n1, &c_n1); + if (wntqn) { +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *n * 3; + maxwrk = std::max(i__1,i__2); + minwrk = *n * 3 + std::max(*m,bdspac); + } else if (wntqo) { +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "QLN", m, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "PRT", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *n * 3; + wrkbl = std::max(i__1,i__2); + maxwrk = wrkbl + *m * *n; +/* Computing MAX */ + i__1 = *m, i__2 = *n * *n + bdspac; + minwrk = *n * 3 + std::max(i__1,i__2); + } else if (wntqs) { +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "QLN", m, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "PRT", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *n * 3; + maxwrk = std::max(i__1,i__2); + minwrk = *n * 3 + std::max(*m,bdspac); + } else if (wntqa) { +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "QLN", m, m, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR" +, "PRT", n, n, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = bdspac + *n * 3; + maxwrk = std::max(i__1,i__2); + minwrk = *n * 3 + std::max(*m,bdspac); + } + } + } else if (minmn > 0) { + +/* Compute space needed for DBDSDC */ + + mnthr = (integer) (minmn * 11. / 6.); + if (wntqn) { + bdspac = *m * 7; + } else { + bdspac = *m * 3 * *m + (*m << 2); + } + if (*n >= mnthr) { + if (wntqn) { + +/* Path 1t (N much larger than M, JOBZ='N') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *m; + maxwrk = std::max(i__1,i__2); + minwrk = bdspac + *m; + } else if (wntqo) { + +/* Path 2t (N much larger than M, JOBZ='O') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "DORGLQ", + " ", m, n, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "QLN", m, m, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "PRT", m, m, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *m * 3; + wrkbl = std::max(i__1,i__2); + maxwrk = wrkbl + (*m << 1) * *m; + minwrk = bdspac + (*m << 1) * *m + *m * 3; + } else if (wntqs) { + +/* Path 3t (N much larger than M, JOBZ='S') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "DORGLQ", + " ", m, n, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "QLN", m, m, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "PRT", m, m, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *m * 3; + wrkbl = std::max(i__1,i__2); + maxwrk = wrkbl + *m * *m; + minwrk = bdspac + *m * *m + *m * 3; + } else if (wntqa) { + +/* Path 4t (N much larger than M, JOBZ='A') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m + *n * ilaenv_(&c__1, "DORGLQ", + " ", n, n, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "QLN", m, m, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "PRT", m, m, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *m * 3; + wrkbl = std::max(i__1,i__2); + maxwrk = wrkbl + *m * *m; + minwrk = bdspac + *m * *m + *m * 3; + } + } else { + +/* Path 5t (N greater than M, but not much larger) */ + + wrkbl = *m * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, + n, &c_n1, &c_n1); + if (wntqn) { +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *m * 3; + maxwrk = std::max(i__1,i__2); + minwrk = *m * 3 + std::max(*n,bdspac); + } else if (wntqo) { +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "QLN", m, m, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "PRT", m, n, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *m * 3; + wrkbl = std::max(i__1,i__2); + maxwrk = wrkbl + *m * *n; +/* Computing MAX */ + i__1 = *n, i__2 = *m * *m + bdspac; + minwrk = *m * 3 + std::max(i__1,i__2); + } else if (wntqs) { +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "QLN", m, m, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "PRT", m, n, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *m * 3; + maxwrk = std::max(i__1,i__2); + minwrk = *m * 3 + std::max(*n,bdspac); + } else if (wntqa) { +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "QLN", m, m, n, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR" +, "PRT", n, n, m, &c_n1); + wrkbl = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = wrkbl, i__2 = bdspac + *m * 3; + maxwrk = std::max(i__1,i__2); + minwrk = *m * 3 + std::max(*n,bdspac); + } + } + } + maxwrk = std::max(maxwrk,minwrk); + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGESDD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = sqrt(dlamch_("S")) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", m, n, &a[a_offset], lda, dum); + iscl = 0; + if (anrm > 0. && anrm < smlnum) { + iscl = 1; + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & + ierr); + } else if (anrm > bignum) { + iscl = 1; + dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & + ierr); + } + + if (*m >= *n) { + +/* A has at least as many rows as columns. If A has sufficiently */ +/* more rows than columns, first reduce using the QR */ +/* decomposition (if sufficient workspace available) */ + + if (*m >= mnthr) { + + if (wntqn) { + +/* Path 1 (M much larger than N, JOBZ='N') */ +/* No singular vectors to be computed */ + + itau = 1; + nwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__1 = *lwork - nwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & + i__1, &ierr); + +/* Zero out below R */ + + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_("L", &i__1, &i__2, &c_b227, &c_b227, &a[a_dim1 + 2], + lda); + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + +/* Bidiagonalize R in A */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__1 = *lwork - nwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[nwork], &i__1, &ierr); + nwork = ie + *n; + +/* Perform bidiagonal SVD, computing singular values only */ +/* (Workspace: need N+BDSPAC) */ + + dbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, + dum, idum, &work[nwork], &iwork[1], info); + + } else if (wntqo) { + +/* Path 2 (M much larger than N, JOBZ = 'O') */ +/* N left singular vectors to be overwritten on A and */ +/* N right singular vectors to be computed in VT */ + + ir = 1; + +/* WORK(IR) is LDWRKR by N */ + + if (*lwork >= *lda * *n + *n * *n + *n * 3 + bdspac) { + ldwrkr = *lda; + } else { + ldwrkr = (*lwork - *n * *n - *n * 3 - bdspac) / *n; + } + itau = ir + ldwrkr * *n; + nwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__1 = *lwork - nwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & + i__1, &ierr); + +/* Copy R to WORK(IR), zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); + i__1 = *n - 1; + i__2 = *n - 1; + dlaset_("L", &i__1, &i__2, &c_b227, &c_b227, &work[ir + 1], & + ldwrkr); + +/* Generate Q in A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__1 = *lwork - nwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], + &i__1, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + +/* Bidiagonalize R in VT, copying result to WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__1 = *lwork - nwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[nwork], &i__1, &ierr); + +/* WORK(IU) is N by N */ + + iu = nwork; + nwork = iu + *n * *n; + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in WORK(IU) and computing right */ +/* singular vectors of bidiagonal matrix in VT */ +/* (Workspace: need N+N*N+BDSPAC) */ + + dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[ + vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], + info); + +/* Overwrite WORK(IU) by left singular vectors of R */ +/* and VT by right singular vectors of R */ +/* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[ + itauq], &work[iu], n, &work[nwork], &i__1, &ierr); + i__1 = *lwork - nwork + 1; + dormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & + ierr); + +/* Multiply Q in A by left singular vectors of R in */ +/* WORK(IU), storing result in WORK(IR) and copying to A */ +/* (Workspace: need 2*N*N, prefer N*N+M*N) */ + + i__1 = *m; + i__2 = ldwrkr; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { +/* Computing MIN */ + i__3 = *m - i__ + 1; + chunk = std::min(i__3,ldwrkr); + dgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + a_dim1], + lda, &work[iu], n, &c_b227, &work[ir], &ldwrkr); + dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + + a_dim1], lda); +/* L10: */ + } + + } else if (wntqs) { + +/* Path 3 (M much larger than N, JOBZ='S') */ +/* N left singular vectors to be computed in U and */ +/* N right singular vectors to be computed in VT */ + + ir = 1; + +/* WORK(IR) is N by N */ + + ldwrkr = *n; + itau = ir + ldwrkr * *n; + nwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - nwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & + i__2, &ierr); + +/* Copy R to WORK(IR), zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); + i__2 = *n - 1; + i__1 = *n - 1; + dlaset_("L", &i__2, &i__1, &c_b227, &c_b227, &work[ir + 1], & + ldwrkr); + +/* Generate Q in A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - nwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork], + &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + +/* Bidiagonalize R in WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__2 = *lwork - nwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[nwork], &i__2, &ierr); + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagoal matrix in U and computing right singular */ +/* vectors of bidiagonal matrix in VT */ +/* (Workspace: need N+BDSPAC) */ + + dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ + vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], + info); + +/* Overwrite U by left singular vectors of R and VT */ +/* by right singular vectors of R */ +/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */ + + i__2 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); + + i__2 = *lwork - nwork + 1; + dormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & + ierr); + +/* Multiply Q in A by left singular vectors of R in */ +/* WORK(IR), storing result in U */ +/* (Workspace: need N*N) */ + + dlacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr); + dgemm_("N", "N", m, n, n, &c_b248, &a[a_offset], lda, &work[ + ir], &ldwrkr, &c_b227, &u[u_offset], ldu); + + } else if (wntqa) { + +/* Path 4 (M much larger than N, JOBZ='A') */ +/* M left singular vectors to be computed in U and */ +/* N right singular vectors to be computed in VT */ + + iu = 1; + +/* WORK(IU) is N by N */ + + ldwrku = *n; + itau = iu + ldwrku * *n; + nwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - nwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & + i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu); + +/* Generate Q in U */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + i__2 = *lwork - nwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork], + &i__2, &ierr); + +/* Produce R in A, zeroing out other entries */ + + i__2 = *n - 1; + i__1 = *n - 1; + dlaset_("L", &i__2, &i__1, &c_b227, &c_b227, &a[a_dim1 + 2], + lda); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + +/* Bidiagonalize R in A */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__2 = *lwork - nwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[nwork], &i__2, &ierr); + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in WORK(IU) and computing right */ +/* singular vectors of bidiagonal matrix in VT */ +/* (Workspace: need N+N*N+BDSPAC) */ + + dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[ + vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], + info); + +/* Overwrite WORK(IU) by left singular vectors of R and VT */ +/* by right singular vectors of R */ +/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */ + + i__2 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", n, n, n, &a[a_offset], lda, &work[ + itauq], &work[iu], &ldwrku, &work[nwork], &i__2, & + ierr); + i__2 = *lwork - nwork + 1; + dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & + ierr); + +/* Multiply Q in U by left singular vectors of R in */ +/* WORK(IU), storing result in A */ +/* (Workspace: need N*N) */ + + dgemm_("N", "N", m, n, n, &c_b248, &u[u_offset], ldu, &work[ + iu], &ldwrku, &c_b227, &a[a_offset], lda); + +/* Copy left singular vectors of A from A to U */ + + dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu); + + } + + } else { + +/* M .LT. MNTHR */ + +/* Path 5 (M at least N, but not much larger) */ +/* Reduce to bidiagonal form without QR decomposition */ + + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + nwork = itaup + *n; + +/* Bidiagonalize A */ +/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */ + + i__2 = *lwork - nwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[nwork], &i__2, &ierr); + if (wntqn) { + +/* Perform bidiagonal SVD, only computing singular values */ +/* (Workspace: need N+BDSPAC) */ + + dbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1, + dum, idum, &work[nwork], &iwork[1], info); + } else if (wntqo) { + iu = nwork; + if (*lwork >= *m * *n + *n * 3 + bdspac) { + +/* WORK( IU ) is M by N */ + + ldwrku = *m; + nwork = iu + ldwrku * *n; + dlaset_("F", m, n, &c_b227, &c_b227, &work[iu], &ldwrku); + } else { + +/* WORK( IU ) is N by N */ + + ldwrku = *n; + nwork = iu + ldwrku * *n; + +/* WORK(IR) is LDWRKR by N */ + + ir = nwork; + ldwrkr = (*lwork - *n * *n - *n * 3) / *n; + } + nwork = iu + ldwrku * *n; + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in WORK(IU) and computing right */ +/* singular vectors of bidiagonal matrix in VT */ +/* (Workspace: need N+N*N+BDSPAC) */ + + dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], &ldwrku, & + vt[vt_offset], ldvt, dum, idum, &work[nwork], &iwork[ + 1], info); + +/* Overwrite VT by right singular vectors of A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - nwork + 1; + dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & + ierr); + + if (*lwork >= *m * *n + *n * 3 + bdspac) { + +/* Overwrite WORK(IU) by left singular vectors of A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[ + itauq], &work[iu], &ldwrku, &work[nwork], &i__2, & + ierr); + +/* Copy left singular vectors of A from WORK(IU) to A */ + + dlacpy_("F", m, n, &work[iu], &ldwrku, &a[a_offset], lda); + } else { + +/* Generate Q in A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - nwork + 1; + dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], & + work[nwork], &i__2, &ierr); + +/* Multiply Q in A by left singular vectors of */ +/* bidiagonal matrix in WORK(IU), storing result in */ +/* WORK(IR) and copying to A */ +/* (Workspace: need 2*N*N, prefer N*N+M*N) */ + + i__2 = *m; + i__1 = ldwrkr; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__1) { +/* Computing MIN */ + i__3 = *m - i__ + 1; + chunk = std::min(i__3,ldwrkr); + dgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + + a_dim1], lda, &work[iu], &ldwrku, &c_b227, & + work[ir], &ldwrkr); + dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ + + a_dim1], lda); +/* L20: */ + } + } + + } else if (wntqs) { + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in U and computing right singular */ +/* vectors of bidiagonal matrix in VT */ +/* (Workspace: need N+BDSPAC) */ + + dlaset_("F", m, n, &c_b227, &c_b227, &u[u_offset], ldu); + dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ + vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], + info); + +/* Overwrite U by left singular vectors of A and VT */ +/* by right singular vectors of A */ +/* (Workspace: need 3*N, prefer 2*N+N*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); + i__1 = *lwork - nwork + 1; + dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & + ierr); + } else if (wntqa) { + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in U and computing right singular */ +/* vectors of bidiagonal matrix in VT */ +/* (Workspace: need N+BDSPAC) */ + + dlaset_("F", m, m, &c_b227, &c_b227, &u[u_offset], ldu); + dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[ + vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], + info); + +/* Set the right corner of U to identity matrix */ + + if (*m > *n) { + i__1 = *m - *n; + i__2 = *m - *n; + dlaset_("F", &i__1, &i__2, &c_b227, &c_b248, &u[*n + 1 + ( + *n + 1) * u_dim1], ldu); + } + +/* Overwrite U by left singular vectors of A and VT */ +/* by right singular vectors of A */ +/* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); + i__1 = *lwork - nwork + 1; + dormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & + ierr); + } + + } + + } else { + +/* A has more columns than rows. If A has sufficiently more */ +/* columns than rows, first reduce using the LQ decomposition (if */ +/* sufficient workspace available) */ + + if (*n >= mnthr) { + + if (wntqn) { + +/* Path 1t (N much larger than M, JOBZ='N') */ +/* No singular vectors to be computed */ + + itau = 1; + nwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__1 = *lwork - nwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & + i__1, &ierr); + +/* Zero out above L */ + + i__1 = *m - 1; + i__2 = *m - 1; + dlaset_("U", &i__1, &i__2, &c_b227, &c_b227, &a[(a_dim1 << 1) + + 1], lda); + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + +/* Bidiagonalize L in A */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__1 = *lwork - nwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[nwork], &i__1, &ierr); + nwork = ie + *m; + +/* Perform bidiagonal SVD, computing singular values only */ +/* (Workspace: need M+BDSPAC) */ + + dbdsdc_("U", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, + dum, idum, &work[nwork], &iwork[1], info); + + } else if (wntqo) { + +/* Path 2t (N much larger than M, JOBZ='O') */ +/* M right singular vectors to be overwritten on A and */ +/* M left singular vectors to be computed in U */ + + ivt = 1; + +/* IVT is M by M */ + + il = ivt + *m * *m; + if (*lwork >= *m * *n + *m * *m + *m * 3 + bdspac) { + +/* WORK(IL) is M by N */ + + ldwrkl = *m; + chunk = *n; + } else { + ldwrkl = *m; + chunk = (*lwork - *m * *m) / *m; + } + itau = il + ldwrkl * *m; + nwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__1 = *lwork - nwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & + i__1, &ierr); + +/* Copy L to WORK(IL), zeroing about above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl); + i__1 = *m - 1; + i__2 = *m - 1; + dlaset_("U", &i__1, &i__2, &c_b227, &c_b227, &work[il + + ldwrkl], &ldwrkl); + +/* Generate Q in A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__1 = *lwork - nwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], + &i__1, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + +/* Bidiagonalize L in WORK(IL) */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__1 = *lwork - nwork + 1; + dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[nwork], &i__1, &ierr); + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in U, and computing right singular */ +/* vectors of bidiagonal matrix in WORK(IVT) */ +/* (Workspace: need M+M*M+BDSPAC) */ + + dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & + work[ivt], m, dum, idum, &work[nwork], &iwork[1], + info); + +/* Overwrite U by left singular vectors of L and WORK(IVT) */ +/* by right singular vectors of L */ +/* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); + i__1 = *lwork - nwork + 1; + dormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[ + itaup], &work[ivt], m, &work[nwork], &i__1, &ierr); + +/* Multiply right singular vectors of L in WORK(IVT) by Q */ +/* in A, storing result in WORK(IL) and copying to A */ +/* (Workspace: need 2*M*M, prefer M*M+M*N) */ + + i__1 = *n; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { +/* Computing MIN */ + i__3 = *n - i__ + 1; + blk = std::min(i__3,chunk); + dgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], m, &a[ + i__ * a_dim1 + 1], lda, &c_b227, &work[il], & + ldwrkl); + dlacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1 + + 1], lda); +/* L30: */ + } + + } else if (wntqs) { + +/* Path 3t (N much larger than M, JOBZ='S') */ +/* M right singular vectors to be computed in VT and */ +/* M left singular vectors to be computed in U */ + + il = 1; + +/* WORK(IL) is M by M */ + + ldwrkl = *m; + itau = il + ldwrkl * *m; + nwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & + i__2, &ierr); + +/* Copy L to WORK(IL), zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl); + i__2 = *m - 1; + i__1 = *m - 1; + dlaset_("U", &i__2, &i__1, &c_b227, &c_b227, &work[il + + ldwrkl], &ldwrkl); + +/* Generate Q in A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork], + &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + +/* Bidiagonalize L in WORK(IU), copying result to U */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__2 = *lwork - nwork + 1; + dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[nwork], &i__2, &ierr); + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in U and computing right singular */ +/* vectors of bidiagonal matrix in VT */ +/* (Workspace: need M+BDSPAC) */ + + dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ + vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], + info); + +/* Overwrite U by left singular vectors of L and VT */ +/* by right singular vectors of L */ +/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); + i__2 = *lwork - nwork + 1; + dormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, & + ierr); + +/* Multiply right singular vectors of L in WORK(IL) by */ +/* Q in A, storing result in VT */ +/* (Workspace: need M*M) */ + + dlacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl); + dgemm_("N", "N", m, n, m, &c_b248, &work[il], &ldwrkl, &a[ + a_offset], lda, &c_b227, &vt[vt_offset], ldvt); + + } else if (wntqa) { + +/* Path 4t (N much larger than M, JOBZ='A') */ +/* N right singular vectors to be computed in VT and */ +/* M left singular vectors to be computed in U */ + + ivt = 1; + +/* WORK(IVT) is M by M */ + + ldwkvt = *m; + itau = ivt + ldwkvt * *m; + nwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], & + i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); + +/* Generate Q in VT */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[ + nwork], &i__2, &ierr); + +/* Produce L in A, zeroing out other entries */ + + i__2 = *m - 1; + i__1 = *m - 1; + dlaset_("U", &i__2, &i__1, &c_b227, &c_b227, &a[(a_dim1 << 1) + + 1], lda); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + +/* Bidiagonalize L in A */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__2 = *lwork - nwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[nwork], &i__2, &ierr); + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in U and computing right singular */ +/* vectors of bidiagonal matrix in WORK(IVT) */ +/* (Workspace: need M+M*M+BDSPAC) */ + + dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & + work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1] +, info); + +/* Overwrite U by left singular vectors of L and WORK(IVT) */ +/* by right singular vectors of L */ +/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, m, m, &a[a_offset], lda, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); + i__2 = *lwork - nwork + 1; + dormbr_("P", "R", "T", m, m, m, &a[a_offset], lda, &work[ + itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, & + ierr); + +/* Multiply right singular vectors of L in WORK(IVT) by */ +/* Q in VT, storing result in A */ +/* (Workspace: need M*M) */ + + dgemm_("N", "N", m, n, m, &c_b248, &work[ivt], &ldwkvt, &vt[ + vt_offset], ldvt, &c_b227, &a[a_offset], lda); + +/* Copy right singular vectors of A from A to VT */ + + dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); + + } + + } else { + +/* N .LT. MNTHR */ + +/* Path 5t (N greater than M, but not much larger) */ +/* Reduce to bidiagonal form without LQ decomposition */ + + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + nwork = itaup + *m; + +/* Bidiagonalize A */ +/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ + + i__2 = *lwork - nwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[nwork], &i__2, &ierr); + if (wntqn) { + +/* Perform bidiagonal SVD, only computing singular values */ +/* (Workspace: need M+BDSPAC) */ + + dbdsdc_("L", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1, + dum, idum, &work[nwork], &iwork[1], info); + } else if (wntqo) { + ldwkvt = *m; + ivt = nwork; + if (*lwork >= *m * *n + *m * 3 + bdspac) { + +/* WORK( IVT ) is M by N */ + + dlaset_("F", m, n, &c_b227, &c_b227, &work[ivt], &ldwkvt); + nwork = ivt + ldwkvt * *n; + } else { + +/* WORK( IVT ) is M by M */ + + nwork = ivt + ldwkvt * *m; + il = nwork; + +/* WORK(IL) is M by CHUNK */ + + chunk = (*lwork - *m * *m - *m * 3) / *m; + } + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in U and computing right singular */ +/* vectors of bidiagonal matrix in WORK(IVT) */ +/* (Workspace: need M*M+BDSPAC) */ + + dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, & + work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1] +, info); + +/* Overwrite U by left singular vectors of A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr); + + if (*lwork >= *m * *n + *m * 3 + bdspac) { + +/* Overwrite WORK(IVT) by left singular vectors of A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[ + itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, + &ierr); + +/* Copy right singular vectors of A from WORK(IVT) to A */ + + dlacpy_("F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda); + } else { + +/* Generate P**T in A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - nwork + 1; + dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], & + work[nwork], &i__2, &ierr); + +/* Multiply Q in A by right singular vectors of */ +/* bidiagonal matrix in WORK(IVT), storing result in */ +/* WORK(IL) and copying to A */ +/* (Workspace: need 2*M*M, prefer M*M+M*N) */ + + i__2 = *n; + i__1 = chunk; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__1) { +/* Computing MIN */ + i__3 = *n - i__ + 1; + blk = std::min(i__3,chunk); + dgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], & + ldwkvt, &a[i__ * a_dim1 + 1], lda, &c_b227, & + work[il], m); + dlacpy_("F", m, &blk, &work[il], m, &a[i__ * a_dim1 + + 1], lda); +/* L40: */ + } + } + } else if (wntqs) { + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in U and computing right singular */ +/* vectors of bidiagonal matrix in VT */ +/* (Workspace: need M+BDSPAC) */ + + dlaset_("F", m, n, &c_b227, &c_b227, &vt[vt_offset], ldvt); + dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ + vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], + info); + +/* Overwrite U by left singular vectors of A and VT */ +/* by right singular vectors of A */ +/* (Workspace: need 3*M, prefer 2*M+M*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); + i__1 = *lwork - nwork + 1; + dormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & + ierr); + } else if (wntqa) { + +/* Perform bidiagonal SVD, computing left singular vectors */ +/* of bidiagonal matrix in U and computing right singular */ +/* vectors of bidiagonal matrix in VT */ +/* (Workspace: need M+BDSPAC) */ + + dlaset_("F", n, n, &c_b227, &c_b227, &vt[vt_offset], ldvt); + dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[ + vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1], + info); + +/* Set the right corner of VT to identity matrix */ + + if (*n > *m) { + i__1 = *n - *m; + i__2 = *n - *m; + dlaset_("F", &i__1, &i__2, &c_b227, &c_b248, &vt[*m + 1 + + (*m + 1) * vt_dim1], ldvt); + } + +/* Overwrite U by left singular vectors of A and VT */ +/* by right singular vectors of A */ +/* (Workspace: need 2*M+N, prefer 2*M+N*NB) */ + + i__1 = *lwork - nwork + 1; + dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[ + itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr); + i__1 = *lwork - nwork + 1; + dormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[ + itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, & + ierr); + } + + } + + } + +/* Undo scaling if necessary */ + + if (iscl == 1) { + if (anrm > bignum) { + dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, &ierr); + } + if (anrm < smlnum) { + dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, &ierr); + } + } + +/* Return optimal workspace in WORK(1) */ + + work[1] = (double) maxwrk; + + return 0; + +/* End of DGESDD */ + +} /* dgesdd_ */ + +/* Subroutine */ int dgesv_(integer *n, integer *nrhs, double *a, integer + *lda, integer *ipiv, double *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGESV computes the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ + +/* The LU decomposition with partial pivoting and row interchanges is */ +/* used to factor A as */ +/* A = P * L * U, */ +/* where P is a permutation matrix, L is unit lower triangular, and U is */ +/* upper triangular. The factored form of A is then used to solve the */ +/* system of equations A * X = B. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the N-by-N coefficient matrix A. */ +/* On exit, the factors L and U from the factorization */ +/* A = P*L*U; the unit diagonal elements of L are not stored. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* The pivot indices that define the permutation matrix P; */ +/* row i of the matrix was interchanged with row IPIV(i). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS matrix of right hand side matrix B. */ +/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly */ +/* singular, so the solution could not be computed. */ + +/* ===================================================================== */ + +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGESV ", &i__1); + return 0; + } + +/* Compute the LU factorization of A. */ + + dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[ + b_offset], ldb, info); + } + return 0; + +/* End of DGESV */ + +} /* dgesv_ */ + +/* Subroutine */ int dgesvd_(const char *jobu, const char *jobvt, integer *m, integer *n, + double *a, integer *lda, double *s, double *u, integer * + ldu, double *vt, integer *ldvt, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__6 = 6; + static integer c__0 = 0; + static integer c__2 = 2; + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b421 = 0.; + static double c_b443 = 1.; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2], + i__2, i__3, i__4; + char ch__1[3]; + + /* Local variables */ + integer i__, ie, ir, iu, blk, ncu; + double dum[1], eps; + integer nru, iscl; + double anrm; + integer ierr, itau, ncvt, nrvt; + integer chunk, minmn, wrkbl, itaup, itauq, mnthr, iwork; + bool wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs; + integer bdspac; + double bignum; + integer ldwrkr, minwrk, ldwrku, maxwrk; + double smlnum; + bool lquery, wntuas, wntvas; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGESVD computes the singular value decomposition (SVD) of a real */ +/* M-by-N matrix A, optionally computing the left and/or right singular */ +/* vectors. The SVD is written */ + +/* A = U * SIGMA * transpose(V) */ + +/* where SIGMA is an M-by-N matrix which is zero except for its */ +/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */ +/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */ +/* are the singular values of A; they are real and non-negative, and */ +/* are returned in descending order. The first min(m,n) columns of */ +/* U and V are the left and right singular vectors of A. */ + +/* Note that the routine returns V**T, not V. */ + +/* Arguments */ +/* ========= */ + +/* JOBU (input) CHARACTER*1 */ +/* Specifies options for computing all or part of the matrix U: */ +/* = 'A': all M columns of U are returned in array U: */ +/* = 'S': the first min(m,n) columns of U (the left singular */ +/* vectors) are returned in the array U; */ +/* = 'O': the first min(m,n) columns of U (the left singular */ +/* vectors) are overwritten on the array A; */ +/* = 'N': no columns of U (no left singular vectors) are */ +/* computed. */ + +/* JOBVT (input) CHARACTER*1 */ +/* Specifies options for computing all or part of the matrix */ +/* V**T: */ +/* = 'A': all N rows of V**T are returned in the array VT; */ +/* = 'S': the first min(m,n) rows of V**T (the right singular */ +/* vectors) are returned in the array VT; */ +/* = 'O': the first min(m,n) rows of V**T (the right singular */ +/* vectors) are overwritten on the array A; */ +/* = 'N': no rows of V**T (no right singular vectors) are */ +/* computed. */ + +/* JOBVT and JOBU cannot both be 'O'. */ + +/* M (input) INTEGER */ +/* The number of rows of the input matrix A. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the input matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, */ +/* if JOBU = 'O', A is overwritten with the first min(m,n) */ +/* columns of U (the left singular vectors, */ +/* stored columnwise); */ +/* if JOBVT = 'O', A is overwritten with the first min(m,n) */ +/* rows of V**T (the right singular vectors, */ +/* stored rowwise); */ +/* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */ +/* are destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The singular values of A, sorted so that S(i) >= S(i+1). */ + +/* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) */ +/* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */ +/* If JOBU = 'A', U contains the M-by-M orthogonal matrix U; */ +/* if JOBU = 'S', U contains the first min(m,n) columns of U */ +/* (the left singular vectors, stored columnwise); */ +/* if JOBU = 'N' or 'O', U is not referenced. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= 1; if */ +/* JOBU = 'S' or 'A', LDU >= M. */ + +/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */ +/* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix */ +/* V**T; */ +/* if JOBVT = 'S', VT contains the first min(m,n) rows of */ +/* V**T (the right singular vectors, stored rowwise); */ +/* if JOBVT = 'N' or 'O', VT is not referenced. */ + +/* LDVT (input) INTEGER */ +/* The leading dimension of the array VT. LDVT >= 1; if */ +/* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */ +/* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged */ +/* superdiagonal elements of an upper bidiagonal matrix B */ +/* whose diagonal is in S (not necessarily sorted). B */ +/* satisfies A = U * B * VT, so it has the same singular values */ +/* as A, and singular vectors related by U and VT. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). */ +/* For good performance, LWORK should generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if DBDSQR did not converge, INFO specifies how many */ +/* superdiagonals of an intermediate bidiagonal form B */ +/* did not converge to zero. See the description of WORK */ +/* above for details. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --s; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + --work; + + /* Function Body */ + *info = 0; + minmn = std::min(*m,*n); + wntua = lsame_(jobu, "A"); + wntus = lsame_(jobu, "S"); + wntuas = wntua || wntus; + wntuo = lsame_(jobu, "O"); + wntun = lsame_(jobu, "N"); + wntva = lsame_(jobvt, "A"); + wntvs = lsame_(jobvt, "S"); + wntvas = wntva || wntvs; + wntvo = lsame_(jobvt, "O"); + wntvn = lsame_(jobvt, "N"); + lquery = *lwork == -1; + + if (! (wntua || wntus || wntuo || wntun)) { + *info = -1; + } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*m)) { + *info = -6; + } else if (*ldu < 1 || wntuas && *ldu < *m) { + *info = -9; + } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) { + *info = -11; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + minwrk = 1; + maxwrk = 1; + if (*m >= *n && minmn > 0) { + +/* Compute space needed for DBDSQR */ + +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = const_cast(jobu); + i__1[1] = 1, a__1[1] = const_cast(jobvt); + s_cat(ch__1, a__1, i__1, &c__2, 2_integer); + ch__1 [2] = '\0'; + mnthr = ilaenv_(&c__6, "DGESVD", ch__1, m, n, &c__0, &c__0); + bdspac = *n * 5; + if (*m >= mnthr) { + if (wntun) { + +/* Path 1 (M much larger than N, JOBU='N') */ + + maxwrk = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = maxwrk, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + maxwrk = std::max(i__2,i__3); + if (wntvo || wntvas) { +/* Computing MAX */ + i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(& + c__1, "DORGBR", "P", n, n, n, &c_n1); + maxwrk = std::max(i__2,i__3); + } + maxwrk = std::max(maxwrk,bdspac); +/* Computing MAX */ + i__2 = *n << 2; + minwrk = std::max(i__2,bdspac); + } else if (wntuo && wntvn) { + +/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", m, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" +, "Q", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); +/* Computing MAX */ + i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; + maxwrk = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } else if (wntuo && wntvas) { + +/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or */ +/* 'A') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", m, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" +, "Q", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, + "DORGBR", "P", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); +/* Computing MAX */ + i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n; + maxwrk = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } else if (wntus && wntvn) { + +/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", m, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" +, "Q", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = *n * *n + wrkbl; +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } else if (wntus && wntvo) { + +/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", m, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" +, "Q", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, + "DORGBR", "P", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = (*n << 1) * *n + wrkbl; +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } else if (wntus && wntvas) { + +/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or */ +/* 'A') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", m, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" +, "Q", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, + "DORGBR", "P", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = *n * *n + wrkbl; +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } else if (wntua && wntvn) { + +/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR", + " ", m, m, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" +, "Q", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = *n * *n + wrkbl; +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } else if (wntua && wntvo) { + +/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR", + " ", m, m, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" +, "Q", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, + "DORGBR", "P", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = (*n << 1) * *n + wrkbl; +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } else if (wntua && wntvas) { + +/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or */ +/* 'A') */ + + wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR", + " ", m, m, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1, + "DGEBRD", " ", n, n, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR" +, "Q", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, + "DORGBR", "P", n, n, n, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = *n * *n + wrkbl; +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } + } else { + +/* Path 10 (M at least N, but not much larger) */ + + maxwrk = *n * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, + n, &c_n1, &c_n1); + if (wntus || wntuo) { +/* Computing MAX */ + i__2 = maxwrk, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORG" + "BR", "Q", m, n, n, &c_n1); + maxwrk = std::max(i__2,i__3); + } + if (wntua) { +/* Computing MAX */ + i__2 = maxwrk, i__3 = *n * 3 + *m * ilaenv_(&c__1, "DORG" + "BR", "Q", m, m, n, &c_n1); + maxwrk = std::max(i__2,i__3); + } + if (! wntvn) { +/* Computing MAX */ + i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1, + "DORGBR", "P", n, n, n, &c_n1); + maxwrk = std::max(i__2,i__3); + } + maxwrk = std::max(maxwrk,bdspac); +/* Computing MAX */ + i__2 = *n * 3 + *m; + minwrk = std::max(i__2,bdspac); + } + } else if (minmn > 0) { + +/* Compute space needed for DBDSQR */ + +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = const_cast(jobu); + i__1[1] = 1, a__1[1] = const_cast(jobvt); + s_cat(ch__1, a__1, i__1, &c__2, 2_integer); + ch__1 [2] = '\0'; + mnthr = ilaenv_(&c__6, "DGESVD", ch__1, m, n, &c__0, &c__0); + bdspac = *m * 5; + if (*n >= mnthr) { + if (wntvn) { + +/* Path 1t(N much larger than M, JOBVT='N') */ + + maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = maxwrk, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + maxwrk = std::max(i__2,i__3); + if (wntuo || wntuas) { +/* Computing MAX */ + i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1, + "DORGBR", "Q", m, m, m, &c_n1); + maxwrk = std::max(i__2,i__3); + } + maxwrk = std::max(maxwrk,bdspac); +/* Computing MAX */ + i__2 = *m << 2; + minwrk = std::max(i__2,bdspac); + } else if (wntvo && wntun) { + +/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", + " ", m, n, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "P", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); +/* Computing MAX */ + i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; + maxwrk = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } else if (wntvo && wntuas) { + +/* Path 3t(N much larger than M, JOBU='S' or 'A', */ +/* JOBVT='O') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", + " ", m, n, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "P", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" +, "Q", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); +/* Computing MAX */ + i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m; + maxwrk = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } else if (wntvs && wntun) { + +/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", + " ", m, n, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "P", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = *m * *m + wrkbl; +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } else if (wntvs && wntuo) { + +/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", + " ", m, n, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "P", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" +, "Q", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = (*m << 1) * *m + wrkbl; +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } else if (wntvs && wntuas) { + +/* Path 6t(N much larger than M, JOBU='S' or 'A', */ +/* JOBVT='S') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ", + " ", m, n, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "P", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" +, "Q", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = *m * *m + wrkbl; +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } else if (wntva && wntun) { + +/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ", + " ", n, n, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "P", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = *m * *m + wrkbl; +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } else if (wntva && wntuo) { + +/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ", + " ", n, n, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "P", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" +, "Q", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = (*m << 1) * *m + wrkbl; +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } else if (wntva && wntuas) { + +/* Path 9t(N much larger than M, JOBU='S' or 'A', */ +/* JOBVT='A') */ + + wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, & + c_n1, &c_n1); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ", + " ", n, n, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1, + "DGEBRD", " ", m, m, &c_n1, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "P", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); +/* Computing MAX */ + i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR" +, "Q", m, m, m, &c_n1); + wrkbl = std::max(i__2,i__3); + wrkbl = std::max(wrkbl,bdspac); + maxwrk = *m * *m + wrkbl; +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } + } else { + +/* Path 10t(N greater than M, but not much larger) */ + + maxwrk = *m * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m, + n, &c_n1, &c_n1); + if (wntvs || wntvo) { +/* Computing MAX */ + i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORG" + "BR", "P", m, n, m, &c_n1); + maxwrk = std::max(i__2,i__3); + } + if (wntva) { +/* Computing MAX */ + i__2 = maxwrk, i__3 = *m * 3 + *n * ilaenv_(&c__1, "DORG" + "BR", "P", n, n, m, &c_n1); + maxwrk = std::max(i__2,i__3); + } + if (! wntun) { +/* Computing MAX */ + i__2 = maxwrk, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1, + "DORGBR", "Q", m, m, m, &c_n1); + maxwrk = std::max(i__2,i__3); + } + maxwrk = std::max(maxwrk,bdspac); +/* Computing MAX */ + i__2 = *m * 3 + *n; + minwrk = std::max(i__2,bdspac); + } + } + maxwrk = std::max(maxwrk,minwrk); + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__2 = -(*info); + xerbla_("DGESVD", &i__2); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = sqrt(dlamch_("S")) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", m, n, &a[a_offset], lda, dum); + iscl = 0; + if (anrm > 0. && anrm < smlnum) { + iscl = 1; + dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, & + ierr); + } else if (anrm > bignum) { + iscl = 1; + dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, & + ierr); + } + + if (*m >= *n) { + +/* A has at least as many rows as columns. If A has sufficiently */ +/* more rows than columns, first reduce using the QR */ +/* decomposition (if sufficient workspace available) */ + + if (*m >= mnthr) { + + if (wntun) { + +/* Path 1 (M much larger than N, JOBU='N') */ +/* No left singular vectors to be computed */ + + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & + i__2, &ierr); + +/* Zero out below R */ + + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[a_dim1 + 2], + lda); + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in A */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); + ncvt = 0; + if (wntvo || wntvas) { + +/* If right singular vectors desired, generate P'. */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], & + work[iwork], &i__2, &ierr); + ncvt = *n; + } + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing right */ +/* singular vectors of A in A if desired */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, dum, &c__1, dum, &c__1, &work[iwork], + info); + +/* If right singular vectors desired in VT, copy them there */ + + if (wntvas) { + dlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + } + + } else if (wntuo && wntvn) { + +/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */ +/* N left singular vectors to be overwritten on A and */ +/* no right singular vectors to be computed */ + +/* Computing MAX */ + i__2 = *n << 2; + if (*lwork >= *n * *n + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + ir = 1; +/* Computing MAX */ + i__2 = wrkbl, i__3 = *lda * *n + *n; + if (*lwork >= std::max(i__2,i__3) + *lda * *n) { + +/* WORK(IU) is LDA by N, WORK(IR) is LDA by N */ + + ldwrku = *lda; + ldwrkr = *lda; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__2 = wrkbl, i__3 = *lda * *n + *n; + if (*lwork >= std::max(i__2,i__3) + *n * *n) { + +/* WORK(IU) is LDA by N, WORK(IR) is N by N */ + + ldwrku = *lda; + ldwrkr = *n; + } else { + +/* WORK(IU) is LDWRKU by N, WORK(IR) is N by N */ + + ldwrku = (*lwork - *n * *n - *n) / *n; + ldwrkr = *n; + } + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] +, &i__2, &ierr); + +/* Copy R to WORK(IR) and zero out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir + 1] +, &ldwrkr); + +/* Generate Q in A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); + +/* Generate left vectors bidiagonalizing R */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & + work[iwork], &i__2, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of R in WORK(IR) */ +/* (Workspace: need N*N+BDSPAC) */ + + dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, & + c__1, &work[ir], &ldwrkr, dum, &c__1, &work[iwork] +, info); + iu = ie + *n; + +/* Multiply Q in A by left singular vectors of R in */ +/* WORK(IR), storing result in WORK(IU) and copying to A */ +/* (Workspace: need N*N+2*N, prefer N*N+M*N+N) */ + + i__2 = *m; + i__3 = ldwrku; + for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__3) { +/* Computing MIN */ + i__4 = *m - i__ + 1; + chunk = std::min(i__4,ldwrku); + dgemm_("N", "N", &chunk, n, n, &c_b443, &a[i__ + + a_dim1], lda, &work[ir], &ldwrkr, &c_b421, & + work[iu], &ldwrku); + dlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ + + a_dim1], lda); +/* L10: */ + } + + } else { + +/* Insufficient workspace for a fast algorithm */ + + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize A */ +/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */ + + i__3 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__3, &ierr); + +/* Generate left vectors bidiagonalizing A */ +/* (Workspace: need 4*N, prefer 3*N+N*NB) */ + + i__3 = *lwork - iwork + 1; + dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], & + work[iwork], &i__3, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in A */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, & + c__1, &a[a_offset], lda, dum, &c__1, &work[iwork], + info); + + } + + } else if (wntuo && wntvas) { + +/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') */ +/* N left singular vectors to be overwritten on A and */ +/* N right singular vectors to be computed in VT */ + +/* Computing MAX */ + i__3 = *n << 2; + if (*lwork >= *n * *n + std::max(i__3,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + ir = 1; +/* Computing MAX */ + i__3 = wrkbl, i__2 = *lda * *n + *n; + if (*lwork >= std::max(i__3,i__2) + *lda * *n) { + +/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ + + ldwrku = *lda; + ldwrkr = *lda; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__3 = wrkbl, i__2 = *lda * *n + *n; + if (*lwork >= std::max(i__3,i__2) + *n * *n) { + +/* WORK(IU) is LDA by N and WORK(IR) is N by N */ + + ldwrku = *lda; + ldwrkr = *n; + } else { + +/* WORK(IU) is LDWRKU by N and WORK(IR) is N by N */ + + ldwrku = (*lwork - *n * *n - *n) / *n; + ldwrkr = *n; + } + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__3 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] +, &i__3, &ierr); + +/* Copy R to VT, zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + if (*n > 1) { + i__3 = *n - 1; + i__2 = *n - 1; + dlaset_("L", &i__3, &i__2, &c_b421, &c_b421, &vt[ + vt_dim1 + 2], ldvt); + } + +/* Generate Q in A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__3 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__3, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in VT, copying result to WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__3 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], &i__3, & + ierr); + dlacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], & + ldwrkr); + +/* Generate left vectors bidiagonalizing R in WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ + + i__3 = *lwork - iwork + 1; + dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], & + work[iwork], &i__3, &ierr); + +/* Generate right vectors bidiagonalizing R in VT */ +/* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) */ + + i__3 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], + &work[iwork], &i__3, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of R in WORK(IR) and computing right */ +/* singular vectors of R in VT */ +/* (Workspace: need N*N+BDSPAC) */ + + dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &work[ir], &ldwrkr, dum, &c__1, + &work[iwork], info); + iu = ie + *n; + +/* Multiply Q in A by left singular vectors of R in */ +/* WORK(IR), storing result in WORK(IU) and copying to A */ +/* (Workspace: need N*N+2*N, prefer N*N+M*N+N) */ + + i__3 = *m; + i__2 = ldwrku; + for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += + i__2) { +/* Computing MIN */ + i__4 = *m - i__ + 1; + chunk = std::min(i__4,ldwrku); + dgemm_("N", "N", &chunk, n, n, &c_b443, &a[i__ + + a_dim1], lda, &work[ir], &ldwrkr, &c_b421, & + work[iu], &ldwrku); + dlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ + + a_dim1], lda); +/* L20: */ + } + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] +, &i__2, &ierr); + +/* Copy R to VT, zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[ + vt_dim1 + 2], ldvt); + } + +/* Generate Q in A */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in VT */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], &i__2, & + ierr); + +/* Multiply Q in A by left vectors bidiagonalizing R */ +/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, & + work[itauq], &a[a_offset], lda, &work[iwork], & + i__2, &ierr); + +/* Generate right vectors bidiagonalizing R in VT */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], + &work[iwork], &i__2, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in A and computing right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & + work[iwork], info); + + } + + } else if (wntus) { + + if (wntvn) { + +/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */ +/* N left singular vectors to be computed in U and */ +/* no right singular vectors to be computed */ + +/* Computing MAX */ + i__2 = *n << 2; + if (*lwork >= *n * *n + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + ir = 1; + if (*lwork >= wrkbl + *lda * *n) { + +/* WORK(IR) is LDA by N */ + + ldwrkr = *lda; + } else { + +/* WORK(IR) is N by N */ + + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + +/* Copy R to WORK(IR), zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], & + ldwrkr); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir + + 1], &ldwrkr); + +/* Generate Q in A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Generate left vectors bidiagonalizing R in WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] +, &work[iwork], &i__2, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of R in WORK(IR) */ +/* (Workspace: need N*N+BDSPAC) */ + + dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], + dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, & + work[iwork], info); + +/* Multiply Q in A by left singular vectors of R in */ +/* WORK(IR), storing result in U */ +/* (Workspace: need N*N) */ + + dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda, + &work[ir], &ldwrkr, &c_b421, &u[u_offset], + ldu); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Generate Q in U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Zero out below R in A */ + + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[ + a_dim1 + 2], lda); + +/* Bidiagonalize R in A */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply Q in U by left vectors bidiagonalizing R */ +/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & + work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr) + ; + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], + dum, &c__1, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info); + + } + + } else if (wntvo) { + +/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */ +/* N left singular vectors to be computed in U and */ +/* N right singular vectors to be overwritten on A */ + +/* Computing MAX */ + i__2 = *n << 2; + if (*lwork >= (*n << 1) * *n + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *n) { + +/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ + + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *n) * *n) { + +/* WORK(IU) is LDA by N and WORK(IR) is N by N */ + + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } else { + +/* WORK(IU) is N by N and WORK(IR) is N by N */ + + ldwrku = *n; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + +/* Copy R to WORK(IU), zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & + ldwrku); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu + + 1], &ldwrku); + +/* Generate Q in A */ +/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in WORK(IU), copying result to */ +/* WORK(IR) */ +/* (Workspace: need 2*N*N+4*N, */ +/* prefer 2*N*N+3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], & + ldwrkr); + +/* Generate left bidiagonalizing vectors in WORK(IU) */ +/* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] +, &work[iwork], &i__2, &ierr); + +/* Generate right bidiagonalizing vectors in WORK(IR) */ +/* (Workspace: need 2*N*N+4*N-1, */ +/* prefer 2*N*N+3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup] +, &work[iwork], &i__2, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of R in WORK(IU) and computing */ +/* right singular vectors of R in WORK(IR) */ +/* (Workspace: need 2*N*N+BDSPAC) */ + + dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[ + ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1, + &work[iwork], info); + +/* Multiply Q in A by left singular vectors of R in */ +/* WORK(IU), storing result in U */ +/* (Workspace: need N*N) */ + + dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda, + &work[iu], &ldwrku, &c_b421, &u[u_offset], + ldu); + +/* Copy right singular vectors of R to A */ +/* (Workspace: need N*N) */ + + dlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset], + lda); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Generate Q in U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Zero out below R in A */ + + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[ + a_dim1 + 2], lda); + +/* Bidiagonalize R in A */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply Q in U by left vectors bidiagonalizing R */ +/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & + work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr) + ; + +/* Generate right vectors bidiagonalizing R in A */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], + &work[iwork], &i__2, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U and computing right */ +/* singular vectors of A in A */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, + &work[iwork], info); + + } + + } else if (wntvas) { + +/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' */ +/* or 'A') */ +/* N left singular vectors to be computed in U and */ +/* N right singular vectors to be computed in VT */ + +/* Computing MAX */ + i__2 = *n << 2; + if (*lwork >= *n * *n + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + iu = 1; + if (*lwork >= wrkbl + *lda * *n) { + +/* WORK(IU) is LDA by N */ + + ldwrku = *lda; + } else { + +/* WORK(IU) is N by N */ + + ldwrku = *n; + } + itau = iu + ldwrku * *n; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + +/* Copy R to WORK(IU), zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & + ldwrku); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu + + 1], &ldwrku); + +/* Generate Q in A */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in WORK(IU), copying result to VT */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset], + ldvt); + +/* Generate left bidiagonalizing vectors in WORK(IU) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] +, &work[iwork], &i__2, &ierr); + +/* Generate right bidiagonalizing vectors in VT */ +/* (Workspace: need N*N+4*N-1, */ +/* prefer N*N+3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ + itaup], &work[iwork], &i__2, &ierr) + ; + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of R in WORK(IU) and computing */ +/* right singular vectors of R in VT */ +/* (Workspace: need N*N+BDSPAC) */ + + dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &work[iu], &ldwrku, dum, & + c__1, &work[iwork], info); + +/* Multiply Q in A by left singular vectors of R in */ +/* WORK(IU), storing result in U */ +/* (Workspace: need N*N) */ + + dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda, + &work[iu], &ldwrku, &c_b421, &u[u_offset], + ldu); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Generate Q in U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + +/* Copy R to VT, zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[ + vt_dim1 + 2], ldvt); + } + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in VT */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], + &work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply Q in U by left bidiagonalizing vectors */ +/* in VT */ +/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, + &work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr); + +/* Generate right bidiagonalizing vectors in VT */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ + itaup], &work[iwork], &i__2, &ierr) + ; + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U and computing right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, & + c__1, &work[iwork], info); + + } + + } + + } else if (wntua) { + + if (wntvn) { + +/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */ +/* M left singular vectors to be computed in U and */ +/* no right singular vectors to be computed */ + +/* Computing MAX */ + i__2 = *n + *m, i__3 = *n << 2, i__2 = std::max(i__2,i__3); + if (*lwork >= *n * *n + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + ir = 1; + if (*lwork >= wrkbl + *lda * *n) { + +/* WORK(IR) is LDA by N */ + + ldwrkr = *lda; + } else { + +/* WORK(IR) is N by N */ + + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Copy R to WORK(IR), zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], & + ldwrkr); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir + + 1], &ldwrkr); + +/* Generate Q in U */ +/* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Generate left bidiagonalizing vectors in WORK(IR) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq] +, &work[iwork], &i__2, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of R in WORK(IR) */ +/* (Workspace: need N*N+BDSPAC) */ + + dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], + dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, & + work[iwork], info); + +/* Multiply Q in U by left singular vectors of R in */ +/* WORK(IR), storing result in A */ +/* (Workspace: need N*N) */ + + dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu, + &work[ir], &ldwrkr, &c_b421, &a[a_offset], + lda); + +/* Copy left singular vectors of A from A to U */ + + dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Generate Q in U */ +/* (Workspace: need N+M, prefer N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Zero out below R in A */ + + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[ + a_dim1 + 2], lda); + +/* Bidiagonalize R in A */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply Q in U by left bidiagonalizing vectors */ +/* in A */ +/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & + work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr) + ; + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], + dum, &c__1, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info); + + } + + } else if (wntvo) { + +/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */ +/* M left singular vectors to be computed in U and */ +/* N right singular vectors to be overwritten on A */ + +/* Computing MAX */ + i__2 = *n + *m, i__3 = *n << 2, i__2 = std::max(i__2,i__3); + if (*lwork >= (*n << 1) * *n + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *n) { + +/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */ + + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *n) * *n) { + +/* WORK(IU) is LDA by N and WORK(IR) is N by N */ + + ldwrku = *lda; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } else { + +/* WORK(IU) is N by N and WORK(IR) is N by N */ + + ldwrku = *n; + ir = iu + ldwrku * *n; + ldwrkr = *n; + } + itau = ir + ldwrkr * *n; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Generate Q in U */ +/* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + +/* Copy R to WORK(IU), zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & + ldwrku); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu + + 1], &ldwrku); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in WORK(IU), copying result to */ +/* WORK(IR) */ +/* (Workspace: need 2*N*N+4*N, */ +/* prefer 2*N*N+3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], & + ldwrkr); + +/* Generate left bidiagonalizing vectors in WORK(IU) */ +/* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] +, &work[iwork], &i__2, &ierr); + +/* Generate right bidiagonalizing vectors in WORK(IR) */ +/* (Workspace: need 2*N*N+4*N-1, */ +/* prefer 2*N*N+3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup] +, &work[iwork], &i__2, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of R in WORK(IU) and computing */ +/* right singular vectors of R in WORK(IR) */ +/* (Workspace: need 2*N*N+BDSPAC) */ + + dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[ + ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1, + &work[iwork], info); + +/* Multiply Q in U by left singular vectors of R in */ +/* WORK(IU), storing result in A */ +/* (Workspace: need N*N) */ + + dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu, + &work[iu], &ldwrku, &c_b421, &a[a_offset], + lda); + +/* Copy left singular vectors of A from A to U */ + + dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Copy right singular vectors of R from WORK(IR) to A */ + + dlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset], + lda); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Generate Q in U */ +/* (Workspace: need N+M, prefer N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Zero out below R in A */ + + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[ + a_dim1 + 2], lda); + +/* Bidiagonalize R in A */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply Q in U by left bidiagonalizing vectors */ +/* in A */ +/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, & + work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr) + ; + +/* Generate right bidiagonalizing vectors in A */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], + &work[iwork], &i__2, &ierr); + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U and computing right */ +/* singular vectors of A in A */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, + &work[iwork], info); + + } + + } else if (wntvas) { + +/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' */ +/* or 'A') */ +/* M left singular vectors to be computed in U and */ +/* N right singular vectors to be computed in VT */ + +/* Computing MAX */ + i__2 = *n + *m, i__3 = *n << 2, i__2 = std::max(i__2,i__3); + if (*lwork >= *n * *n + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + iu = 1; + if (*lwork >= wrkbl + *lda * *n) { + +/* WORK(IU) is LDA by N */ + + ldwrku = *lda; + } else { + +/* WORK(IU) is N by N */ + + ldwrku = *n; + } + itau = iu + ldwrku * *n; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Generate Q in U */ +/* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + +/* Copy R to WORK(IU), zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], & + ldwrku); + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu + + 1], &ldwrku); + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in WORK(IU), copying result to VT */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset], + ldvt); + +/* Generate left bidiagonalizing vectors in WORK(IU) */ +/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq] +, &work[iwork], &i__2, &ierr); + +/* Generate right bidiagonalizing vectors in VT */ +/* (Workspace: need N*N+4*N-1, */ +/* prefer N*N+3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ + itaup], &work[iwork], &i__2, &ierr) + ; + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of R in WORK(IU) and computing */ +/* right singular vectors of R in VT */ +/* (Workspace: need N*N+BDSPAC) */ + + dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &work[iu], &ldwrku, dum, & + c__1, &work[iwork], info); + +/* Multiply Q in U by left singular vectors of R in */ +/* WORK(IU), storing result in A */ +/* (Workspace: need N*N) */ + + dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu, + &work[iu], &ldwrku, &c_b421, &a[a_offset], + lda); + +/* Copy left singular vectors of A from A to U */ + + dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R, copying result to U */ +/* (Workspace: need 2*N, prefer N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], + ldu); + +/* Generate Q in U */ +/* (Workspace: need N+M, prefer N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], & + work[iwork], &i__2, &ierr); + +/* Copy R from A to VT, zeroing out below it */ + + dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + if (*n > 1) { + i__2 = *n - 1; + i__3 = *n - 1; + dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[ + vt_dim1 + 2], ldvt); + } + ie = itau; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in VT */ +/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], + &work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply Q in U by left bidiagonalizing vectors */ +/* in VT */ +/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, + &work[itauq], &u[u_offset], ldu, &work[iwork], + &i__2, &ierr); + +/* Generate right bidiagonalizing vectors in VT */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[ + itaup], &work[iwork], &i__2, &ierr) + ; + iwork = ie + *n; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U and computing right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, & + c__1, &work[iwork], info); + + } + + } + + } + + } else { + +/* M .LT. MNTHR */ + +/* Path 10 (M at least N, but not much larger) */ +/* Reduce to bidiagonal form without QR decomposition */ + + ie = 1; + itauq = ie + *n; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize A */ +/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[iwork], &i__2, &ierr); + if (wntuas) { + +/* If left singular vectors desired in U, copy result to U */ +/* and generate left bidiagonalizing vectors in U */ +/* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB) */ + + dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu); + if (wntus) { + ncu = *n; + } + if (wntua) { + ncu = *m; + } + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], & + work[iwork], &i__2, &ierr); + } + if (wntvas) { + +/* If right singular vectors desired in VT, copy result to */ +/* VT and generate right bidiagonalizing vectors in VT */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt); + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], & + work[iwork], &i__2, &ierr); + } + if (wntuo) { + +/* If left singular vectors desired in A, generate left */ +/* bidiagonalizing vectors in A */ +/* (Workspace: need 4*N, prefer 3*N+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[ + iwork], &i__2, &ierr); + } + if (wntvo) { + +/* If right singular vectors desired in A, generate right */ +/* bidiagonalizing vectors in A */ +/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[ + iwork], &i__2, &ierr); + } + iwork = ie + *n; + if (wntuas || wntuo) { + nru = *m; + } + if (wntun) { + nru = 0; + } + if (wntvas || wntvo) { + ncvt = *n; + } + if (wntvn) { + ncvt = 0; + } + if (! wntuo && ! wntvo) { + +/* Perform bidiagonal QR iteration, if desired, computing */ +/* left singular vectors in U and computing right singular */ +/* vectors in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info); + } else if (! wntuo && wntvo) { + +/* Perform bidiagonal QR iteration, if desired, computing */ +/* left singular vectors in U and computing right singular */ +/* vectors in A */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[ + iwork], info); + } else { + +/* Perform bidiagonal QR iteration, if desired, computing */ +/* left singular vectors in A and computing right singular */ +/* vectors in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & + work[iwork], info); + } + + } + + } else { + +/* A has more columns than rows. If A has sufficiently more */ +/* columns than rows, first reduce using the LQ decomposition (if */ +/* sufficient workspace available) */ + + if (*n >= mnthr) { + + if (wntvn) { + +/* Path 1t(N much larger than M, JOBVT='N') */ +/* No right singular vectors to be computed */ + + itau = 1; + iwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], & + i__2, &ierr); + +/* Zero out above L */ + + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(a_dim1 << 1) + + 1], lda); + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in A */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); + if (wntuo || wntuas) { + +/* If left singular vectors desired, generate Q */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], & + work[iwork], &i__2, &ierr); + } + iwork = ie + *m; + nru = 0; + if (wntuo || wntuas) { + nru = *m; + } + +/* Perform bidiagonal QR iteration, computing left singular */ +/* vectors of A in A if desired */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, & + c__1, &a[a_offset], lda, dum, &c__1, &work[iwork], + info); + +/* If left singular vectors desired in U, copy them there */ + + if (wntuas) { + dlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu); + } + + } else if (wntvo && wntun) { + +/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */ +/* M right singular vectors to be overwritten on A and */ +/* no left singular vectors to be computed */ + +/* Computing MAX */ + i__2 = *m << 2; + if (*lwork >= *m * *m + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + ir = 1; +/* Computing MAX */ + i__2 = wrkbl, i__3 = *lda * *n + *m; + if (*lwork >= std::max(i__2,i__3) + *lda * *m) { + +/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */ + + ldwrku = *lda; + chunk = *n; + ldwrkr = *lda; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__2 = wrkbl, i__3 = *lda * *n + *m; + if (*lwork >= std::max(i__2,i__3) + *m * *m) { + +/* WORK(IU) is LDA by N and WORK(IR) is M by M */ + + ldwrku = *lda; + chunk = *n; + ldwrkr = *m; + } else { + +/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */ + + ldwrku = *m; + chunk = (*lwork - *m * *m - *m) / *m; + ldwrkr = *m; + } + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] +, &i__2, &ierr); + +/* Copy L to WORK(IR) and zero out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir + + ldwrkr], &ldwrkr); + +/* Generate Q in A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IR) */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); + +/* Generate right vectors bidiagonalizing L */ +/* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & + work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing right */ +/* singular vectors of L in WORK(IR) */ +/* (Workspace: need M*M+BDSPAC) */ + + dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[ + ir], &ldwrkr, dum, &c__1, dum, &c__1, &work[iwork] +, info); + iu = ie + *m; + +/* Multiply right singular vectors of L in WORK(IR) by Q */ +/* in A, storing result in WORK(IU) and copying to A */ +/* (Workspace: need M*M+2*M, prefer M*M+M*N+M) */ + + i__2 = *n; + i__3 = chunk; + for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__3) { +/* Computing MIN */ + i__4 = *n - i__ + 1; + blk = std::min(i__4,chunk); + dgemm_("N", "N", m, &blk, m, &c_b443, &work[ir], & + ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b421, & + work[iu], &ldwrku); + dlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ * + a_dim1 + 1], lda); +/* L30: */ + } + + } else { + +/* Insufficient workspace for a fast algorithm */ + + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize A */ +/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ + + i__3 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__3, &ierr); + +/* Generate right vectors bidiagonalizing A */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__3 = *lwork - iwork + 1; + dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], & + work[iwork], &i__3, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing right */ +/* singular vectors of A in A */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, dum, &c__1, dum, &c__1, &work[ + iwork], info); + + } + + } else if (wntvo && wntuas) { + +/* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') */ +/* M right singular vectors to be overwritten on A and */ +/* M left singular vectors to be computed in U */ + +/* Computing MAX */ + i__3 = *m << 2; + if (*lwork >= *m * *m + std::max(i__3,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + ir = 1; +/* Computing MAX */ + i__3 = wrkbl, i__2 = *lda * *n + *m; + if (*lwork >= std::max(i__3,i__2) + *lda * *m) { + +/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */ + + ldwrku = *lda; + chunk = *n; + ldwrkr = *lda; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__3 = wrkbl, i__2 = *lda * *n + *m; + if (*lwork >= std::max(i__3,i__2) + *m * *m) { + +/* WORK(IU) is LDA by N and WORK(IR) is M by M */ + + ldwrku = *lda; + chunk = *n; + ldwrkr = *m; + } else { + +/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */ + + ldwrku = *m; + chunk = (*lwork - *m * *m - *m) / *m; + ldwrkr = *m; + } + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__3 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] +, &i__3, &ierr); + +/* Copy L to U, zeroing about above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu); + i__3 = *m - 1; + i__2 = *m - 1; + dlaset_("U", &i__3, &i__2, &c_b421, &c_b421, &u[(u_dim1 << + 1) + 1], ldu); + +/* Generate Q in A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__3 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__3, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in U, copying result to WORK(IR) */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__3 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__3, &ierr); + dlacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr); + +/* Generate right vectors bidiagonalizing L in WORK(IR) */ +/* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */ + + i__3 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], & + work[iwork], &i__3, &ierr); + +/* Generate left vectors bidiagonalizing L in U */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */ + + i__3 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], & + work[iwork], &i__3, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of L in U, and computing right */ +/* singular vectors of L in WORK(IR) */ +/* (Workspace: need M*M+BDSPAC) */ + + dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ir], + &ldwrkr, &u[u_offset], ldu, dum, &c__1, &work[ + iwork], info); + iu = ie + *m; + +/* Multiply right singular vectors of L in WORK(IR) by Q */ +/* in A, storing result in WORK(IU) and copying to A */ +/* (Workspace: need M*M+2*M, prefer M*M+M*N+M)) */ + + i__3 = *n; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += + i__2) { +/* Computing MIN */ + i__4 = *n - i__ + 1; + blk = std::min(i__4,chunk); + dgemm_("N", "N", m, &blk, m, &c_b443, &work[ir], & + ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b421, & + work[iu], &ldwrku); + dlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ * + a_dim1 + 1], lda); +/* L40: */ + } + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork] +, &i__2, &ierr); + +/* Copy L to U, zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[(u_dim1 << + 1) + 1], ldu); + +/* Generate Q in A */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in U */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[ + itauq], &work[itaup], &work[iwork], &i__2, &ierr); + +/* Multiply right vectors bidiagonalizing L by Q in A */ +/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &work[ + itaup], &a[a_offset], lda, &work[iwork], &i__2, & + ierr); + +/* Generate left vectors bidiagonalizing L in U */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], & + work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U and computing right */ +/* singular vectors of A in A */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info); + + } + + } else if (wntvs) { + + if (wntun) { + +/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */ +/* M right singular vectors to be computed in VT and */ +/* no left singular vectors to be computed */ + +/* Computing MAX */ + i__2 = *m << 2; + if (*lwork >= *m * *m + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + ir = 1; + if (*lwork >= wrkbl + *lda * *m) { + +/* WORK(IR) is LDA by M */ + + ldwrkr = *lda; + } else { + +/* WORK(IR) is M by M */ + + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + +/* Copy L to WORK(IR), zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], & + ldwrkr); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir + + ldwrkr], &ldwrkr); + +/* Generate Q in A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IR) */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Generate right vectors bidiagonalizing L in */ +/* WORK(IR) */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup] +, &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing right */ +/* singular vectors of L in WORK(IR) */ +/* (Workspace: need M*M+BDSPAC) */ + + dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], & + work[ir], &ldwrkr, dum, &c__1, dum, &c__1, & + work[iwork], info); + +/* Multiply right singular vectors of L in WORK(IR) by */ +/* Q in A, storing result in VT */ +/* (Workspace: need M*M) */ + + dgemm_("N", "N", m, n, m, &c_b443, &work[ir], &ldwrkr, + &a[a_offset], lda, &c_b421, &vt[vt_offset], + ldvt); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + +/* Copy result to VT */ + + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Generate Q in VT */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Zero out above L in A */ + + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[( + a_dim1 << 1) + 1], lda); + +/* Bidiagonalize L in A */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply right vectors bidiagonalizing L by Q in VT */ +/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], & + vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, & + work[iwork], info); + + } + + } else if (wntuo) { + +/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */ +/* M right singular vectors to be computed in VT and */ +/* M left singular vectors to be overwritten on A */ + +/* Computing MAX */ + i__2 = *m << 2; + if (*lwork >= (*m << 1) * *m + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *m) { + +/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */ + + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *m) * *m) { + +/* WORK(IU) is LDA by M and WORK(IR) is M by M */ + + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } else { + +/* WORK(IU) is M by M and WORK(IR) is M by M */ + + ldwrku = *m; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + +/* Copy L to WORK(IU), zeroing out below it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & + ldwrku); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu + + ldwrku], &ldwrku); + +/* Generate Q in A */ +/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IU), copying result to */ +/* WORK(IR) */ +/* (Workspace: need 2*M*M+4*M, */ +/* prefer 2*M*M+3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], & + ldwrkr); + +/* Generate right bidiagonalizing vectors in WORK(IU) */ +/* (Workspace: need 2*M*M+4*M-1, */ +/* prefer 2*M*M+3*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] +, &work[iwork], &i__2, &ierr); + +/* Generate left bidiagonalizing vectors in WORK(IR) */ +/* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] +, &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of L in WORK(IR) and computing */ +/* right singular vectors of L in WORK(IU) */ +/* (Workspace: need 2*M*M+BDSPAC) */ + + dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ + iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1, + &work[iwork], info); + +/* Multiply right singular vectors of L in WORK(IU) by */ +/* Q in A, storing result in VT */ +/* (Workspace: need M*M) */ + + dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku, + &a[a_offset], lda, &c_b421, &vt[vt_offset], + ldvt); + +/* Copy left singular vectors of L to A */ +/* (Workspace: need M*M) */ + + dlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset], + lda); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Generate Q in VT */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Zero out above L in A */ + + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[( + a_dim1 << 1) + 1], lda); + +/* Bidiagonalize L in A */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply right vectors bidiagonalizing L by Q in VT */ +/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr); + +/* Generate left bidiagonalizing vectors of L in A */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], + &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, compute left */ +/* singular vectors of A in A and compute right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, & + c__1, &work[iwork], info); + + } + + } else if (wntuas) { + +/* Path 6t(N much larger than M, JOBU='S' or 'A', */ +/* JOBVT='S') */ +/* M right singular vectors to be computed in VT and */ +/* M left singular vectors to be computed in U */ + +/* Computing MAX */ + i__2 = *m << 2; + if (*lwork >= *m * *m + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + iu = 1; + if (*lwork >= wrkbl + *lda * *m) { + +/* WORK(IU) is LDA by N */ + + ldwrku = *lda; + } else { + +/* WORK(IU) is LDA by M */ + + ldwrku = *m; + } + itau = iu + ldwrku * *m; + iwork = itau + *m; + +/* Compute A=L*Q */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + +/* Copy L to WORK(IU), zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & + ldwrku); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu + + ldwrku], &ldwrku); + +/* Generate Q in A */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &a[a_offset], lda, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IU), copying result to U */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset], + ldu); + +/* Generate right bidiagonalizing vectors in WORK(IU) */ +/* (Workspace: need M*M+4*M-1, */ +/* prefer M*M+3*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] +, &work[iwork], &i__2, &ierr); + +/* Generate left bidiagonalizing vectors in U */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], + &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of L in U and computing right */ +/* singular vectors of L in WORK(IU) */ +/* (Workspace: need M*M+BDSPAC) */ + + dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ + iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info); + +/* Multiply right singular vectors of L in WORK(IU) by */ +/* Q in A, storing result in VT */ +/* (Workspace: need M*M) */ + + dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku, + &a[a_offset], lda, &c_b421, &vt[vt_offset], + ldvt); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Generate Q in VT */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + +/* Copy L to U, zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], + ldu); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[( + u_dim1 << 1) + 1], ldu); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in U */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply right bidiagonalizing vectors in U by Q */ +/* in VT */ +/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr); + +/* Generate left bidiagonalizing vectors in U */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], + &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U and computing right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, & + c__1, &work[iwork], info); + + } + + } + + } else if (wntva) { + + if (wntun) { + +/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */ +/* N right singular vectors to be computed in VT and */ +/* no left singular vectors to be computed */ + +/* Computing MAX */ + i__2 = *n + *m, i__3 = *m << 2, i__2 = std::max(i__2,i__3); + if (*lwork >= *m * *m + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + ir = 1; + if (*lwork >= wrkbl + *lda * *m) { + +/* WORK(IR) is LDA by M */ + + ldwrkr = *lda; + } else { + +/* WORK(IR) is M by M */ + + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Copy L to WORK(IR), zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], & + ldwrkr); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir + + ldwrkr], &ldwrkr); + +/* Generate Q in VT */ +/* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IR) */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Generate right bidiagonalizing vectors in WORK(IR) */ +/* (Workspace: need M*M+4*M-1, */ +/* prefer M*M+3*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup] +, &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing right */ +/* singular vectors of L in WORK(IR) */ +/* (Workspace: need M*M+BDSPAC) */ + + dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], & + work[ir], &ldwrkr, dum, &c__1, dum, &c__1, & + work[iwork], info); + +/* Multiply right singular vectors of L in WORK(IR) by */ +/* Q in VT, storing result in A */ +/* (Workspace: need M*M) */ + + dgemm_("N", "N", m, n, m, &c_b443, &work[ir], &ldwrkr, + &vt[vt_offset], ldvt, &c_b421, &a[a_offset], + lda); + +/* Copy right singular vectors of A from A to VT */ + + dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Generate Q in VT */ +/* (Workspace: need M+N, prefer M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Zero out above L in A */ + + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[( + a_dim1 << 1) + 1], lda); + +/* Bidiagonalize L in A */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply right bidiagonalizing vectors in A by Q */ +/* in VT */ +/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], & + vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, & + work[iwork], info); + + } + + } else if (wntuo) { + +/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */ +/* N right singular vectors to be computed in VT and */ +/* M left singular vectors to be overwritten on A */ + +/* Computing MAX */ + i__2 = *n + *m, i__3 = *m << 2, i__2 = std::max(i__2,i__3); + if (*lwork >= (*m << 1) * *m + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + iu = 1; + if (*lwork >= wrkbl + (*lda << 1) * *m) { + +/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */ + + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *lda; + } else if (*lwork >= wrkbl + (*lda + *m) * *m) { + +/* WORK(IU) is LDA by M and WORK(IR) is M by M */ + + ldwrku = *lda; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } else { + +/* WORK(IU) is M by M and WORK(IR) is M by M */ + + ldwrku = *m; + ir = iu + ldwrku * *m; + ldwrkr = *m; + } + itau = ir + ldwrkr * *m; + iwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Generate Q in VT */ +/* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + +/* Copy L to WORK(IU), zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & + ldwrku); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu + + ldwrku], &ldwrku); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IU), copying result to */ +/* WORK(IR) */ +/* (Workspace: need 2*M*M+4*M, */ +/* prefer 2*M*M+3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], & + ldwrkr); + +/* Generate right bidiagonalizing vectors in WORK(IU) */ +/* (Workspace: need 2*M*M+4*M-1, */ +/* prefer 2*M*M+3*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] +, &work[iwork], &i__2, &ierr); + +/* Generate left bidiagonalizing vectors in WORK(IR) */ +/* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq] +, &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of L in WORK(IR) and computing */ +/* right singular vectors of L in WORK(IU) */ +/* (Workspace: need 2*M*M+BDSPAC) */ + + dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ + iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1, + &work[iwork], info); + +/* Multiply right singular vectors of L in WORK(IU) by */ +/* Q in VT, storing result in A */ +/* (Workspace: need M*M) */ + + dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku, + &vt[vt_offset], ldvt, &c_b421, &a[a_offset], + lda); + +/* Copy right singular vectors of A from A to VT */ + + dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Copy left singular vectors of A from WORK(IR) to A */ + + dlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset], + lda); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Generate Q in VT */ +/* (Workspace: need M+N, prefer M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Zero out above L in A */ + + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[( + a_dim1 << 1) + 1], lda); + +/* Bidiagonalize L in A */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply right bidiagonalizing vectors in A by Q */ +/* in VT */ +/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr); + +/* Generate left bidiagonalizing vectors in A */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], + &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in A and computing right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, & + c__1, &work[iwork], info); + + } + + } else if (wntuas) { + +/* Path 9t(N much larger than M, JOBU='S' or 'A', */ +/* JOBVT='A') */ +/* N right singular vectors to be computed in VT and */ +/* M left singular vectors to be computed in U */ + +/* Computing MAX */ + i__2 = *n + *m, i__3 = *m << 2, i__2 = std::max(i__2,i__3); + if (*lwork >= *m * *m + std::max(i__2,bdspac)) { + +/* Sufficient workspace for a fast algorithm */ + + iu = 1; + if (*lwork >= wrkbl + *lda * *m) { + +/* WORK(IU) is LDA by M */ + + ldwrku = *lda; + } else { + +/* WORK(IU) is M by M */ + + ldwrku = *m; + } + itau = iu + ldwrku * *m; + iwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Generate Q in VT */ +/* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + +/* Copy L to WORK(IU), zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], & + ldwrku); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu + + ldwrku], &ldwrku); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IU), copying result to U */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + dlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset], + ldu); + +/* Generate right bidiagonalizing vectors in WORK(IU) */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup] +, &work[iwork], &i__2, &ierr); + +/* Generate left bidiagonalizing vectors in U */ +/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], + &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of L in U and computing right */ +/* singular vectors of L in WORK(IU) */ +/* (Workspace: need M*M+BDSPAC) */ + + dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ + iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info); + +/* Multiply right singular vectors of L in WORK(IU) by */ +/* Q in VT, storing result in A */ +/* (Workspace: need M*M) */ + + dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku, + &vt[vt_offset], ldvt, &c_b421, &a[a_offset], + lda); + +/* Copy right singular vectors of A from A to VT */ + + dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + + } else { + +/* Insufficient workspace for a fast algorithm */ + + itau = 1; + iwork = itau + *m; + +/* Compute A=L*Q, copying result to VT */ +/* (Workspace: need 2*M, prefer M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[ + iwork], &i__2, &ierr); + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], + ldvt); + +/* Generate Q in VT */ +/* (Workspace: need M+N, prefer M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], & + work[iwork], &i__2, &ierr); + +/* Copy L to U, zeroing out above it */ + + dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], + ldu); + i__2 = *m - 1; + i__3 = *m - 1; + dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[( + u_dim1 << 1) + 1], ldu); + ie = itau; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in U */ +/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], & + work[itauq], &work[itaup], &work[iwork], & + i__2, &ierr); + +/* Multiply right bidiagonalizing vectors in U by Q */ +/* in VT */ +/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */ + + i__2 = *lwork - iwork + 1; + dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, & + work[itaup], &vt[vt_offset], ldvt, &work[ + iwork], &i__2, &ierr); + +/* Generate left bidiagonalizing vectors in U */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], + &work[iwork], &i__2, &ierr); + iwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing left */ +/* singular vectors of A in U and computing right */ +/* singular vectors of A in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, & + c__1, &work[iwork], info); + + } + + } + + } + + } else { + +/* N .LT. MNTHR */ + +/* Path 10t(N greater than M, but not much larger) */ +/* Reduce to bidiagonal form without LQ decomposition */ + + ie = 1; + itauq = ie + *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize A */ +/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ + + i__2 = *lwork - iwork + 1; + dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & + work[itaup], &work[iwork], &i__2, &ierr); + if (wntuas) { + +/* If left singular vectors desired in U, copy result to U */ +/* and generate left bidiagonalizing vectors in U */ +/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) */ + + dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu); + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[ + iwork], &i__2, &ierr); + } + if (wntvas) { + +/* If right singular vectors desired in VT, copy result to */ +/* VT and generate right bidiagonalizing vectors in VT */ +/* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB) */ + + dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt); + if (wntva) { + nrvt = *n; + } + if (wntvs) { + nrvt = *m; + } + i__2 = *lwork - iwork + 1; + dorgbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup], + &work[iwork], &i__2, &ierr); + } + if (wntuo) { + +/* If left singular vectors desired in A, generate left */ +/* bidiagonalizing vectors in A */ +/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[ + iwork], &i__2, &ierr); + } + if (wntvo) { + +/* If right singular vectors desired in A, generate right */ +/* bidiagonalizing vectors in A */ +/* (Workspace: need 4*M, prefer 3*M+M*NB) */ + + i__2 = *lwork - iwork + 1; + dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ + iwork], &i__2, &ierr); + } + iwork = ie + *m; + if (wntuas || wntuo) { + nru = *m; + } + if (wntun) { + nru = 0; + } + if (wntvas || wntvo) { + ncvt = *n; + } + if (wntvn) { + ncvt = 0; + } + if (! wntuo && ! wntvo) { + +/* Perform bidiagonal QR iteration, if desired, computing */ +/* left singular vectors in U and computing right singular */ +/* vectors in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, & + work[iwork], info); + } else if (! wntuo && wntvo) { + +/* Perform bidiagonal QR iteration, if desired, computing */ +/* left singular vectors in U and computing right singular */ +/* vectors in A */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[ + a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[ + iwork], info); + } else { + +/* Perform bidiagonal QR iteration, if desired, computing */ +/* left singular vectors in A and computing right singular */ +/* vectors in VT */ +/* (Workspace: need BDSPAC) */ + + dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[ + vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, & + work[iwork], info); + } + + } + + } + +/* If DBDSQR failed to converge, copy unconverged superdiagonals */ +/* to WORK( 2:MINMN ) */ + + if (*info != 0) { + if (ie > 2) { + i__2 = minmn - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + 1] = work[i__ + ie - 1]; +/* L50: */ + } + } + if (ie < 2) { + for (i__ = minmn - 1; i__ >= 1; --i__) { + work[i__ + 1] = work[i__ + ie - 1]; +/* L60: */ + } + } + } + +/* Undo scaling if necessary */ + + if (iscl == 1) { + if (anrm > bignum) { + dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, &ierr); + } + if (*info != 0 && anrm > bignum) { + i__2 = minmn - 1; + dlascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2], + &minmn, &ierr); + } + if (anrm < smlnum) { + dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, &ierr); + } + if (*info != 0 && anrm < smlnum) { + i__2 = minmn - 1; + dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2], + &minmn, &ierr); + } + } + +/* Return optimal workspace in WORK(1) */ + + work[1] = (double) maxwrk; + + return 0; + +/* End of DGESVD */ + +} /* dgesvd_ */ + + +/* Subroutine */ int dgesvx_(const char *fact, const char *trans, integer *n, integer * + nrhs, double *a, integer *lda, double *af, integer *ldaf, + integer *ipiv, char *equed, double *r__, double *c__, + double *b, integer *ldb, double *x, integer *ldx, double * + rcond, double *ferr, double *berr, double *work, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double amax; + char norm[1]; + double rcmin, rcmax, anorm; + bool equil; + double colcnd; + bool nofact; + double bignum; + integer infequ; + bool colequ; + double rowcnd; + bool notran; + double smlnum; + bool rowequ; + double rpvgrw; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGESVX uses the LU factorization to compute the solution to a real */ +/* system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* the system: */ +/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ +/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ +/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ +/* Whether or not the system will be equilibrated depends on the */ +/* scaling of the matrix A, but if equilibration is used, A is */ +/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ +/* or diag(C)*B (if TRANS = 'T' or 'C'). */ + +/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */ +/* matrix A (after equilibration if FACT = 'E') as */ +/* A = P * L * U, */ +/* where P is a permutation matrix, L is a unit lower triangular */ +/* matrix, and U is upper triangular. */ + +/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */ +/* returns with INFO = i. Otherwise, the factored form of A is used */ +/* to estimate the condition number of the matrix A. If the */ +/* reciprocal of the condition number is less than machine precision, */ +/* INFO = N+1 is returned as a warning, but the routine still goes on */ +/* to solve for X and compute error bounds as described below. */ + +/* 4. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 5. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* 6. If equilibration was used, the matrix X is premultiplied by */ +/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ +/* that it solves the original system before equilibration. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of the matrix A is */ +/* supplied on entry, and if not, whether the matrix A should be */ +/* equilibrated before it is factored. */ +/* = 'F': On entry, AF and IPIV contain the factored form of A. */ +/* If EQUED is not 'N', the matrix A has been */ +/* equilibrated with scaling factors given by R and C. */ +/* A, AF, and IPIV are not modified. */ +/* = 'N': The matrix A will be copied to AF and factored. */ +/* = 'E': The matrix A will be equilibrated if necessary, then */ +/* copied to AF and factored. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Transpose) */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */ +/* not 'N', then A must have been equilibrated by the scaling */ +/* factors in R and/or C. A is not modified if FACT = 'F' or */ +/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */ + +/* On exit, if EQUED .ne. 'N', A is scaled as follows: */ +/* EQUED = 'R': A := diag(R) * A */ +/* EQUED = 'C': A := A * diag(C) */ +/* EQUED = 'B': A := diag(R) * A * diag(C). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* If FACT = 'F', then AF is an input argument and on entry */ +/* contains the factors L and U from the factorization */ +/* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then */ +/* AF is the factored form of the equilibrated matrix A. */ + +/* If FACT = 'N', then AF is an output argument and on exit */ +/* returns the factors L and U from the factorization A = P*L*U */ +/* of the original matrix A. */ + +/* If FACT = 'E', then AF is an output argument and on exit */ +/* returns the factors L and U from the factorization A = P*L*U */ +/* of the equilibrated matrix A (see the description of A for */ +/* the form of the equilibrated matrix). */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* IPIV (input or output) INTEGER array, dimension (N) */ +/* If FACT = 'F', then IPIV is an input argument and on entry */ +/* contains the pivot indices from the factorization A = P*L*U */ +/* as computed by DGETRF; row i of the matrix was interchanged */ +/* with row IPIV(i). */ + +/* If FACT = 'N', then IPIV is an output argument and on exit */ +/* contains the pivot indices from the factorization A = P*L*U */ +/* of the original matrix A. */ + +/* If FACT = 'E', then IPIV is an output argument and on exit */ +/* contains the pivot indices from the factorization A = P*L*U */ +/* of the equilibrated matrix A. */ + +/* EQUED (input or output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration (always true if FACT = 'N'). */ +/* = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* diag(R). */ +/* = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* by diag(C). */ +/* = 'B': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(R) * A * diag(C). */ +/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* output argument. */ + +/* R (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* is not accessed. R is an input argument if FACT = 'F'; */ +/* otherwise, R is an output argument. If FACT = 'F' and */ +/* EQUED = 'R' or 'B', each element of R must be positive. */ + +/* C (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* is not accessed. C is an input argument if FACT = 'F'; */ +/* otherwise, C is an output argument. If FACT = 'F' and */ +/* EQUED = 'C' or 'B', each element of C must be positive. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, */ +/* if EQUED = 'N', B is not modified; */ +/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ +/* diag(R)*B; */ +/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ +/* overwritten by diag(C)*B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */ +/* to the original system of equations. Note that A and B are */ +/* modified on exit if EQUED .ne. 'N', and the solution to the */ +/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */ +/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */ +/* and EQUED = 'R' or 'B'. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The estimate of the reciprocal condition number of the matrix */ +/* A after equilibration (if done). If RCOND is less than the */ +/* machine precision (in particular, if RCOND = 0), the matrix */ +/* is singular to working precision. This condition is */ +/* indicated by a return code of INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (4*N) */ +/* On exit, WORK(1) contains the reciprocal pivot growth */ +/* factor norm(A)/norm(U). The "max absolute element" norm is */ +/* used. If WORK(1) is much less than 1, then the stability */ +/* of the LU factorization of the (equilibrated) matrix A */ +/* could be poor. This also means that the solution X, condition */ +/* estimator RCOND, and forward error bound FERR could be */ +/* unreliable. If factorization fails with 0 0: if INFO = i, and i is */ +/* <= N: U(i,i) is exactly zero. The factorization has */ +/* been completed, but the factor U is exactly */ +/* singular, so the solution and error bounds */ +/* could not be computed. RCOND = 0 is returned. */ +/* = N+1: U is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + notran = lsame_(trans, "N"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rowequ = false; + colequ = false; + } else { + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -8; + } else if (lsame_(fact, "F") && ! (rowequ || colequ + || lsame_(equed, "N"))) { + *info = -10; + } else { + if (rowequ) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[j]; + rcmax = std::max(d__1,d__2); +/* L10: */ + } + if (rcmin <= 0.) { + *info = -11; + } else if (*n > 0) { + rowcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } else { + rowcnd = 1.; + } + } + if (colequ && *info == 0) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = std::max(d__1,d__2); +/* L20: */ + } + if (rcmin <= 0.) { + *info = -12; + } else if (*n > 0) { + colcnd = std::max(rcmin,smlnum) / std::min(rcmax,bignum); + } else { + colcnd = 1.; + } + } + if (*info == 0) { + if (*ldb < std::max(1_integer,*n)) { + *info = -14; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -16; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGESVX", &i__1); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, & + amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, & + colcnd, &amax, equed); + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + } + +/* Scale the right hand side. */ + + if (notran) { + if (rowequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else if (colequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1]; +/* L50: */ + } +/* L60: */ + } + } + + if (nofact || equil) { + +/* Compute the LU factorization of A. */ + + dlacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf); + dgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + rpvgrw = dlantr_("M", "U", "N", info, info, &af[af_offset], ldaf, + &work[1]); + if (rpvgrw == 0.) { + rpvgrw = 1.; + } else { + rpvgrw = dlange_("M", n, info, &a[a_offset], lda, &work[1]) / rpvgrw; + } + work[1] = rpvgrw; + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A and the */ +/* reciprocal pivot growth factor RPVGRW. */ + + if (notran) { + *(unsigned char *)norm = '1'; + } else { + *(unsigned char *)norm = 'I'; + } + anorm = dlange_(norm, n, n, &a[a_offset], lda, &work[1]); + rpvgrw = dlantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &work[1]); + if (rpvgrw == 0.) { + rpvgrw = 1.; + } else { + rpvgrw = dlange_("M", n, n, &a[a_offset], lda, &work[1]) / + rpvgrw; + } + +/* Compute the reciprocal of the condition number of A. */ + + dgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1], + info); + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, + info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], + &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[ + 1], &iwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (notran) { + if (colequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1]; +/* L70: */ + } +/* L80: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= colcnd; +/* L90: */ + } + } + } else if (rowequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1]; +/* L100: */ + } +/* L110: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= rowcnd; +/* L120: */ + } + } + + work[1] = rpvgrw; + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + return 0; + +/* End of DGESVX */ + +} /* dgesvx_ */ + +/* Subroutine */ int dgetc2_(integer *n, double *a, integer *lda, integer + *ipiv, integer *jpiv, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b10 = -1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer i__, j, ip, jp; + double eps; + integer ipv, jpv; + double smin, xmax; + double bignum, smlnum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGETC2 computes an LU factorization with complete pivoting of the */ +/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */ +/* where P and Q are permutation matrices, L is lower triangular with */ +/* unit diagonal elements and U is upper triangular. */ + +/* This is the Level 2 BLAS algorithm. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the n-by-n matrix A to be factored. */ +/* On exit, the factors L and U from the factorization */ +/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */ +/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */ +/* value of SMIN, i.e., giving a nonsingular perturbed system. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (output) INTEGER array, dimension(N). */ +/* The pivot indices; for 1 <= i <= N, row i of the */ +/* matrix has been interchanged with row IPIV(i). */ + +/* JPIV (output) INTEGER array, dimension(N). */ +/* The pivot indices; for 1 <= j <= N, column j of the */ +/* matrix has been interchanged with column JPIV(j). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* > 0: if INFO = k, U(k, k) is likely to produce owerflow if */ +/* we try to solve for x in Ax = b. So U is perturbed to */ +/* avoid the overflow. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Set constants to control overflow */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + --jpiv; + + /* Function Body */ + *info = 0; + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Factorize A using complete pivoting. */ +/* Set pivots less than SMIN to SMIN. */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Find max element in matrix A */ + + xmax = 0.; + i__2 = *n; + for (ip = i__; ip <= i__2; ++ip) { + i__3 = *n; + for (jp = i__; jp <= i__3; ++jp) { + if ((d__1 = a[ip + jp * a_dim1], abs(d__1)) >= xmax) { + xmax = (d__1 = a[ip + jp * a_dim1], abs(d__1)); + ipv = ip; + jpv = jp; + } +/* L10: */ + } +/* L20: */ + } + if (i__ == 1) { +/* Computing MAX */ + d__1 = eps * xmax; + smin = std::max(d__1,smlnum); + } + +/* Swap rows */ + + if (ipv != i__) { + dswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda); + } + ipiv[i__] = ipv; + +/* Swap columns */ + + if (jpv != i__) { + dswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + } + jpiv[i__] = jpv; + +/* Check for singularity */ + + if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) < smin) { + *info = i__; + a[i__ + i__ * a_dim1] = smin; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + a[j + i__ * a_dim1] /= a[i__ + i__ * a_dim1]; +/* L30: */ + } + i__2 = *n - i__; + i__3 = *n - i__; + dger_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[i__ + + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda); +/* L40: */ + } + + if ((d__1 = a[*n + *n * a_dim1], abs(d__1)) < smin) { + *info = *n; + a[*n + *n * a_dim1] = smin; + } + + return 0; + +/* End of DGETC2 */ + +} /* dgetc2_ */ + +/* Subroutine */ int dgetf2_(integer *m, integer *n, double *a, integer * + lda, integer *ipiv, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b8 = -1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer i__, j, jp; + double sfmin; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGETF2 computes an LU factorization of a general m-by-n matrix A */ +/* using partial pivoting with row interchanges. */ + +/* The factorization has the form */ +/* A = P * L * U */ +/* where P is a permutation matrix, L is lower triangular with unit */ +/* diagonal elements (lower trapezoidal if m > n), and U is upper */ +/* triangular (upper trapezoidal if m < n). */ + +/* This is the right-looking Level 2 BLAS version of the algorithm. */ + +/* 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 to be factored. */ +/* On exit, the factors L and U from the factorization */ +/* A = P*L*U; the unit diagonal elements of L are not stored. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* IPIV (output) INTEGER array, dimension (min(M,N)) */ +/* The pivot indices; for 1 <= i <= min(M,N), row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly */ +/* singular, and division by zero will occur if it is used */ +/* to solve a system of equations. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGETF2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Compute machine safe minimum */ + + sfmin = dlamch_("S"); + + i__1 = std::min(*m,*n); + for (j = 1; j <= i__1; ++j) { + +/* Find pivot and test for singularity. */ + + i__2 = *m - j + 1; + jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1); + ipiv[j] = jp; + if (a[jp + j * a_dim1] != 0.) { + +/* Apply the interchange to columns 1:N. */ + + if (jp != j) { + dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda); + } + +/* Compute elements J+1:M of J-th column. */ + + if (j < *m) { + if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) { + i__2 = *m - j; + d__1 = 1. / a[j + j * a_dim1]; + dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); + } else { + i__2 = *m - j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[j + i__ + j * a_dim1] /= a[j + j * a_dim1]; +/* L20: */ + } + } + } + + } else if (*info == 0) { + + *info = j; + } + + if (j < std::min(*m,*n)) { + +/* Update trailing submatrix. */ + + i__2 = *m - j; + i__3 = *n - j; + dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + ( + j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda); + } +/* L10: */ + } + return 0; + +/* End of DGETF2 */ + +} /* dgetf2_ */ + +/* Subroutine */ int dgetrf_(integer *m, integer *n, double *a, integer * + lda, integer *ipiv, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b16 = 1.; + static double c_b19 = -1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, j, jb, nb; + integer iinfo; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGETRF computes an LU factorization of a general M-by-N matrix A */ +/* using partial pivoting with row interchanges. */ + +/* The factorization has the form */ +/* A = P * L * U */ +/* where P is a permutation matrix, L is lower triangular with unit */ +/* diagonal elements (lower trapezoidal if m > n), and U is upper */ +/* triangular (upper trapezoidal if m < n). */ + +/* This is the right-looking Level 3 BLAS version of the algorithm. */ + +/* 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 to be factored. */ +/* On exit, the factors L and U from the factorization */ +/* A = P*L*U; the unit diagonal elements of L are not stored. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* IPIV (output) INTEGER array, dimension (min(M,N)) */ +/* The pivot indices; for 1 <= i <= min(M,N), row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly */ +/* singular, and division by zero will occur if it is used */ +/* to solve a system of equations. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGETRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "DGETRF", " ", m, n, &c_n1, &c_n1); + if (nb <= 1 || nb >= std::min(*m,*n)) { + +/* Use unblocked code. */ + + dgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info); + } else { + +/* Use blocked code. */ + + i__1 = std::min(*m,*n); + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = std::min(*m,*n) - j + 1; + jb = std::min(i__3,nb); + +/* Factor diagonal and subdiagonal blocks and test for exact */ +/* singularity. */ + + i__3 = *m - j + 1; + dgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo); + +/* Adjust INFO and the pivot indices. */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo + j - 1; + } +/* Computing MIN */ + i__4 = *m, i__5 = j + jb - 1; + i__3 = std::min(i__4,i__5); + for (i__ = j; i__ <= i__3; ++i__) { + ipiv[i__] = j - 1 + ipiv[i__]; +/* L10: */ + } + +/* Apply interchanges to columns 1:J-1. */ + + i__3 = j - 1; + i__4 = j + jb - 1; + dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1); + + if (j + jb <= *n) { + +/* Apply interchanges to columns J+JB:N. */ + + i__3 = *n - j - jb + 1; + i__4 = j + jb - 1; + dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, & + ipiv[1], &c__1); + +/* Compute block row of U. */ + + i__3 = *n - j - jb + 1; + dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, & + c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) * + a_dim1], lda); + if (j + jb <= *m) { + +/* Update trailing submatrix. */ + + i__3 = *m - j - jb + 1; + i__4 = *n - j - jb + 1; + dgemm_("No transpose", "No transpose", &i__3, &i__4, &jb, + &c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j + + jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) * + a_dim1], lda); + } + } +/* L20: */ + } + } + return 0; + +/* End of DGETRF */ + +} /* dgetrf_ */ + +/* Subroutine */ int dgetri_(integer *n, double *a, integer *lda, integer + *ipiv, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + static double c_b20 = -1.; + static double c_b22 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, jb, nb, jj, jp, nn, iws; + integer nbmin; + integer ldwork; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGETRI computes the inverse of a matrix using the LU factorization */ +/* computed by DGETRF. */ + +/* This method inverts U and then computes inv(A) by solving the system */ +/* inv(A)*L = inv(U) for inv(A). */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the factors L and U from the factorization */ +/* A = P*L*U as computed by DGETRF. */ +/* On exit, if INFO = 0, the inverse of the original matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,N). */ +/* For optimal performance LWORK >= N*NB, where NB is */ +/* the optimal blocksize returned by ILAENV. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is */ +/* singular and its inverse could not be computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "DGETRI", " ", n, &c_n1, &c_n1, &c_n1); + lwkopt = *n * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*lda < std::max(1_integer,*n)) { + *info = -3; + } else if (*lwork < std::max(1_integer,*n) && ! lquery) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGETRI", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, */ +/* and the inverse is not computed. */ + + dtrtri_("Upper", "Non-unit", n, &a[a_offset], lda, info); + if (*info > 0) { + return 0; + } + + nbmin = 2; + ldwork = *n; + if (nb > 1 && nb < *n) { +/* Computing MAX */ + i__1 = ldwork * nb; + iws = std::max(i__1,1_integer); + if (*lwork < iws) { + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGETRI", " ", n, &c_n1, &c_n1, & + c_n1); + nbmin = std::max(i__1,i__2); + } + } else { + iws = *n; + } + +/* Solve the equation inv(A)*L = inv(U) for inv(A). */ + + if (nb < nbmin || nb >= *n) { + +/* Use unblocked code. */ + + for (j = *n; j >= 1; --j) { + +/* Copy current column of L to WORK and replace with zeros. */ + + i__1 = *n; + for (i__ = j + 1; i__ <= i__1; ++i__) { + work[i__] = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = 0.; +/* L10: */ + } + +/* Compute current column of inv(A). */ + + if (j < *n) { + i__1 = *n - j; + dgemv_("No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1 + + 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1 + + 1], &c__1); + } +/* L20: */ + } + } else { + +/* Use blocked code. */ + + nn = (*n - 1) / nb * nb + 1; + i__1 = -nb; + for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) { +/* Computing MIN */ + i__2 = nb, i__3 = *n - j + 1; + jb = std::min(i__2,i__3); + +/* Copy current block column of L to WORK and replace with */ +/* zeros. */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = *n; + for (i__ = jj + 1; i__ <= i__3; ++i__) { + work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1]; + a[i__ + jj * a_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + +/* Compute current block column of inv(A). */ + + if (j + jb <= *n) { + i__2 = *n - j - jb + 1; + dgemm_("No transpose", "No transpose", n, &jb, &i__2, &c_b20, + &a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], & + ldwork, &c_b22, &a[j * a_dim1 + 1], lda); + } + dtrsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b22, & + work[j], &ldwork, &a[j * a_dim1 + 1], lda); +/* L50: */ + } + } + +/* Apply column interchanges. */ + + for (j = *n - 1; j >= 1; --j) { + jp = ipiv[j]; + if (jp != j) { + dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1); + } +/* L60: */ + } + + work[1] = (double) iws; + return 0; + +/* End of DGETRI */ + +} /* dgetri_ */ + +/* Subroutine */ int dgetrs_(const char *trans, integer *n, integer *nrhs, + double *a, integer *lda, integer *ipiv, double *b, integer * + ldb, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b12 = 1.; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + bool notran; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGETRS solves a system of linear equations */ +/* A * X = B or A' * X = B */ +/* with a general N-by-N matrix A using the LU factorization computed */ +/* by DGETRF. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A'* X = B (Transpose) */ +/* = 'C': A'* X = B (Conjugate transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The factors L and U from the factorization A = P*L*U */ +/* as computed by DGETRF. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ +/* matrix was interchanged with row IPIV(i). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGETRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (notran) { + +/* Solve A * X = B. */ + +/* Apply row interchanges to the right hand sides. */ + + dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); + +/* Solve L*X = B, overwriting B with X. */ + + dtrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[ + a_offset], lda, &b[b_offset], ldb); + +/* Solve U*X = B, overwriting B with X. */ + + dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, & + a[a_offset], lda, &b[b_offset], ldb); + } else { + +/* Solve A' * X = B. */ + +/* Solve U'*X = B, overwriting B with X. */ + + dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[ + a_offset], lda, &b[b_offset], ldb); + +/* Solve L'*X = B, overwriting B with X. */ + + dtrsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[ + a_offset], lda, &b[b_offset], ldb); + +/* Apply row interchanges to the solution vectors. */ + + dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); + } + + return 0; + +/* End of DGETRS */ + +} /* dgetrs_ */ + +/* Subroutine */ int dggbak_(const char *job, const char *side, integer *n, integer *ilo, + integer *ihi, double *lscale, double *rscale, integer *m, + double *v, integer *ldv, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, i__1; + + /* Local variables */ + integer i__, k; + bool leftv; + bool rightv; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGBAK forms the right or left eigenvectors of a real generalized */ +/* eigenvalue problem A*x = lambda*B*x, by backward transformation on */ +/* the computed eigenvectors of the balanced pair of matrices output by */ +/* DGGBAL. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* Specifies the type of backward transformation required: */ +/* = 'N': do nothing, return immediately; */ +/* = 'P': do backward transformation for permutation only; */ +/* = 'S': do backward transformation for scaling only; */ +/* = 'B': do backward transformations for both permutation and */ +/* scaling. */ +/* JOB must be the same as the argument JOB supplied to DGGBAL. */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'R': V contains right eigenvectors; */ +/* = 'L': V contains left eigenvectors. */ + +/* N (input) INTEGER */ +/* The number of rows of the matrix V. N >= 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* The integers ILO and IHI determined by DGGBAL. */ +/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ + +/* LSCALE (input) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutations and/or scaling factors applied */ +/* to the left side of A and B, as returned by DGGBAL. */ + +/* RSCALE (input) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutations and/or scaling factors applied */ +/* to the right side of A and B, as returned by DGGBAL. */ + +/* M (input) INTEGER */ +/* The number of columns of the matrix V. M >= 0. */ + +/* V (input/output) DOUBLE PRECISION array, dimension (LDV,M) */ +/* On entry, the matrix of right or left eigenvectors to be */ +/* transformed, as returned by DTGEVC. */ +/* On exit, V is overwritten by the transformed eigenvectors. */ + +/* LDV (input) INTEGER */ +/* The leading dimension of the matrix V. LDV >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* See R.C. Ward, Balancing the generalized eigenvalue problem, */ +/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + --lscale; + --rscale; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + + /* Function Body */ + rightv = lsame_(side, "R"); + leftv = lsame_(side, "L"); + + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") + && ! lsame_(job, "B")) { + *info = -1; + } else if (! rightv && ! leftv) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1) { + *info = -4; + } else if (*n == 0 && *ihi == 0 && *ilo != 1) { + *info = -4; + } else if (*n > 0 && (*ihi < *ilo || *ihi > std::max(1_integer,*n))) { + *info = -5; + } else if (*n == 0 && *ilo == 1 && *ihi != 0) { + *info = -5; + } else if (*m < 0) { + *info = -8; + } else if (*ldv < std::max(1_integer,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGBAK", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*m == 0) { + return 0; + } + if (lsame_(job, "N")) { + return 0; + } + + if (*ilo == *ihi) { + goto L30; + } + +/* Backward balance */ + + if (lsame_(job, "S") || lsame_(job, "B")) { + +/* Backward transformation on right eigenvectors */ + + if (rightv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + dscal_(m, &rscale[i__], &v[i__ + v_dim1], ldv); +/* L10: */ + } + } + +/* Backward transformation on left eigenvectors */ + + if (leftv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + dscal_(m, &lscale[i__], &v[i__ + v_dim1], ldv); +/* L20: */ + } + } + } + +/* Backward permutation */ + +L30: + if (lsame_(job, "P") || lsame_(job, "B")) { + +/* Backward permutation on right eigenvectors */ + + if (rightv) { + if (*ilo == 1) { + goto L50; + } + + for (i__ = *ilo - 1; i__ >= 1; --i__) { + k = (integer) rscale[i__]; + if (k == i__) { + goto L40; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L40: + ; + } + +L50: + if (*ihi == *n) { + goto L70; + } + i__1 = *n; + for (i__ = *ihi + 1; i__ <= i__1; ++i__) { + k = (integer) rscale[i__]; + if (k == i__) { + goto L60; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L60: + ; + } + } + +/* Backward permutation on left eigenvectors */ + +L70: + if (leftv) { + if (*ilo == 1) { + goto L90; + } + for (i__ = *ilo - 1; i__ >= 1; --i__) { + k = (integer) lscale[i__]; + if (k == i__) { + goto L80; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L80: + ; + } + +L90: + if (*ihi == *n) { + goto L110; + } + i__1 = *n; + for (i__ = *ihi + 1; i__ <= i__1; ++i__) { + k = (integer) lscale[i__]; + if (k == i__) { + goto L100; + } + dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L100: + ; + } + } + } + +L110: + + return 0; + +/* End of DGGBAK */ + +} /* dggbak_ */ + + +/* Subroutine */ int dggbal_(const char *job, integer *n, double *a, integer * + lda, double *b, integer *ldb, integer *ilo, integer *ihi, + double *lscale, double *rscale, double *work, integer * + info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b35 = 10.; + static double c_b71 = .5; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k, l, m; + double t; + integer jc; + double ta, tb, tc; + integer ir; + double ew; + integer it, nr, ip1, jp1, lm1; + double cab, rab, ewc, cor, sum; + integer nrp2, icab, lcab; + double beta, coef; + integer irab, lrab; + double basl, cmax; + double coef2, coef5, gamma, alpha; + double sfmin, sfmax; + integer iflow; + integer kount; + double pgamma; + integer lsfmin, lsfmax; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGBAL balances a pair of general real matrices (A,B). This */ +/* involves, first, permuting A and B by similarity transformations to */ +/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */ +/* elements on the diagonal; and second, applying a diagonal similarity */ +/* transformation to rows and columns ILO to IHI to make the rows */ +/* and columns as close in norm as possible. Both steps are optional. */ + +/* Balancing may reduce the 1-norm of the matrices, and improve the */ +/* accuracy of the computed eigenvalues and/or eigenvectors in the */ +/* generalized eigenvalue problem A*x = lambda*B*x. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* Specifies the operations to be performed on A and B: */ +/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */ +/* and RSCALE(I) = 1.0 for i = 1,...,N. */ +/* = 'P': permute only; */ +/* = 'S': scale only; */ +/* = 'B': both permute and scale. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the input matrix A. */ +/* On exit, A is overwritten by the balanced matrix. */ +/* If JOB = 'N', A is not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ +/* On entry, the input matrix B. */ +/* On exit, B is overwritten by the balanced matrix. */ +/* If JOB = 'N', B is not referenced. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* ILO (output) INTEGER */ +/* IHI (output) INTEGER */ +/* ILO and IHI are set to integers such that on exit */ +/* A(i,j) = 0 and B(i,j) = 0 if i > j and */ +/* j = 1,...,ILO-1 or i = IHI+1,...,N. */ +/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */ + +/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutations and scaling factors applied */ +/* to the left side of A and B. If P(j) is the index of the */ +/* row interchanged with row j, and D(j) */ +/* is the scaling factor applied to row j, then */ +/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */ +/* = D(j) for J = ILO,...,IHI */ +/* = P(j) for J = IHI+1,...,N. */ +/* The order in which the interchanges are made is N to IHI+1, */ +/* then 1 to ILO-1. */ + +/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutations and scaling factors applied */ +/* to the right side of A and B. If P(j) is the index of the */ +/* column interchanged with column j, and D(j) */ +/* is the scaling factor applied to column j, then */ +/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */ +/* = D(j) for J = ILO,...,IHI */ +/* = P(j) for J = IHI+1,...,N. */ +/* The order in which the interchanges are made is N to IHI+1, */ +/* then 1 to ILO-1. */ + +/* WORK (workspace) REAL array, dimension (lwork) */ +/* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and */ +/* at least 1 when JOB = 'N' or 'P'. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* See R.C. WARD, Balancing the generalized eigenvalue problem, */ +/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --lscale; + --rscale; + --work; + + /* Function Body */ + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") + && ! lsame_(job, "B")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGBAL", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *ilo = 1; + *ihi = *n; + return 0; + } + + if (*n == 1) { + *ilo = 1; + *ihi = *n; + lscale[1] = 1.; + rscale[1] = 1.; + return 0; + } + + if (lsame_(job, "N")) { + *ilo = 1; + *ihi = *n; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + lscale[i__] = 1.; + rscale[i__] = 1.; +/* L10: */ + } + return 0; + } + + k = 1; + l = *n; + if (lsame_(job, "S")) { + goto L190; + } + + goto L30; + +/* Permute the matrices A and B to isolate the eigenvalues. */ + +/* Find row with one nonzero in columns 1 through L */ + +L20: + l = lm1; + if (l != 1) { + goto L30; + } + + rscale[1] = 1.; + lscale[1] = 1.; + goto L190; + +L30: + lm1 = l - 1; + for (i__ = l; i__ >= 1; --i__) { + i__1 = lm1; + for (j = 1; j <= i__1; ++j) { + jp1 = j + 1; + if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { + goto L50; + } +/* L40: */ + } + j = l; + goto L70; + +L50: + i__1 = l; + for (j = jp1; j <= i__1; ++j) { + if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { + goto L80; + } +/* L60: */ + } + j = jp1 - 1; + +L70: + m = l; + iflow = 1; + goto L160; +L80: + ; + } + goto L100; + +/* Find column with one nonzero in rows K through N */ + +L90: + ++k; + +L100: + i__1 = l; + for (j = k; j <= i__1; ++j) { + i__2 = lm1; + for (i__ = k; i__ <= i__2; ++i__) { + ip1 = i__ + 1; + if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { + goto L120; + } +/* L110: */ + } + i__ = l; + goto L140; +L120: + i__2 = l; + for (i__ = ip1; i__ <= i__2; ++i__) { + if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) { + goto L150; + } +/* L130: */ + } + i__ = ip1 - 1; +L140: + m = k; + iflow = 2; + goto L160; +L150: + ; + } + goto L190; + +/* Permute rows M and I */ + +L160: + lscale[m] = (double) i__; + if (i__ == m) { + goto L170; + } + i__1 = *n - k + 1; + dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda); + i__1 = *n - k + 1; + dswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb); + +/* Permute columns M and J */ + +L170: + rscale[m] = (double) j; + if (j == m) { + goto L180; + } + dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1); + dswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1); + +L180: + switch (iflow) { + case 1: goto L20; + case 2: goto L90; + } + +L190: + *ilo = k; + *ihi = l; + + if (lsame_(job, "P")) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + lscale[i__] = 1.; + rscale[i__] = 1.; +/* L195: */ + } + return 0; + } + + if (*ilo == *ihi) { + return 0; + } + +/* Balance the submatrix in rows ILO to IHI. */ + + nr = *ihi - *ilo + 1; + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + rscale[i__] = 0.; + lscale[i__] = 0.; + + work[i__] = 0.; + work[i__ + *n] = 0.; + work[i__ + (*n << 1)] = 0.; + work[i__ + *n * 3] = 0.; + work[i__ + (*n << 2)] = 0.; + work[i__ + *n * 5] = 0.; +/* L200: */ + } + +/* Compute right side vector in resulting linear equations */ + + basl = d_lg10(&c_b35); + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + i__2 = *ihi; + for (j = *ilo; j <= i__2; ++j) { + tb = b[i__ + j * b_dim1]; + ta = a[i__ + j * a_dim1]; + if (ta == 0.) { + goto L210; + } + d__1 = abs(ta); + ta = d_lg10(&d__1) / basl; +L210: + if (tb == 0.) { + goto L220; + } + d__1 = abs(tb); + tb = d_lg10(&d__1) / basl; +L220: + work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb; + work[j + *n * 5] = work[j + *n * 5] - ta - tb; +/* L230: */ + } +/* L240: */ + } + + coef = 1. / (double) (nr << 1); + coef2 = coef * coef; + coef5 = coef2 * .5; + nrp2 = nr + 2; + beta = 0.; + it = 1; + +/* Start generalized conjugate gradient iteration */ + +L250: + + gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)] +, &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + * + n * 5], &c__1); + + ew = 0.; + ewc = 0.; + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + ew += work[i__ + (*n << 2)]; + ewc += work[i__ + *n * 5]; +/* L260: */ + } + +/* Computing 2nd power */ + d__1 = ew; +/* Computing 2nd power */ + d__2 = ewc; +/* Computing 2nd power */ + d__3 = ew - ewc; + gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * ( + d__3 * d__3); + if (gamma == 0.) { + goto L350; + } + if (it != 1) { + beta = gamma / pgamma; + } + t = coef5 * (ewc - ew * 3.); + tc = coef5 * (ew - ewc * 3.); + + dscal_(&nr, &beta, &work[*ilo], &c__1); + dscal_(&nr, &beta, &work[*ilo + *n], &c__1); + + daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], & + c__1); + daxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1); + + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + work[i__] += tc; + work[i__ + *n] += t; +/* L270: */ + } + +/* Apply matrix to vector */ + + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + kount = 0; + sum = 0.; + i__2 = *ihi; + for (j = *ilo; j <= i__2; ++j) { + if (a[i__ + j * a_dim1] == 0.) { + goto L280; + } + ++kount; + sum += work[j]; +L280: + if (b[i__ + j * b_dim1] == 0.) { + goto L290; + } + ++kount; + sum += work[j]; +L290: + ; + } + work[i__ + (*n << 1)] = (double) kount * work[i__ + *n] + sum; +/* L300: */ + } + + i__1 = *ihi; + for (j = *ilo; j <= i__1; ++j) { + kount = 0; + sum = 0.; + i__2 = *ihi; + for (i__ = *ilo; i__ <= i__2; ++i__) { + if (a[i__ + j * a_dim1] == 0.) { + goto L310; + } + ++kount; + sum += work[i__ + *n]; +L310: + if (b[i__ + j * b_dim1] == 0.) { + goto L320; + } + ++kount; + sum += work[i__ + *n]; +L320: + ; + } + work[j + *n * 3] = (double) kount * work[j] + sum; +/* L330: */ + } + + sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1) + + ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1); + alpha = gamma / sum; + +/* Determine correction to current iteration */ + + cmax = 0.; + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + cor = alpha * work[i__ + *n]; + if (abs(cor) > cmax) { + cmax = abs(cor); + } + lscale[i__] += cor; + cor = alpha * work[i__]; + if (abs(cor) > cmax) { + cmax = abs(cor); + } + rscale[i__] += cor; +/* L340: */ + } + if (cmax < .5) { + goto L350; + } + + d__1 = -alpha; + daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)] +, &c__1); + d__1 = -alpha; + daxpy_(&nr, &d__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], & + c__1); + + pgamma = gamma; + ++it; + if (it <= nrp2) { + goto L250; + } + +/* End generalized conjugate gradient iteration */ + +L350: + sfmin = dlamch_("S"); + sfmax = 1. / sfmin; + lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.); + lsfmax = (integer) (d_lg10(&sfmax) / basl); + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + i__2 = *n - *ilo + 1; + irab = idamax_(&i__2, &a[i__ + *ilo * a_dim1], lda); + rab = (d__1 = a[i__ + (irab + *ilo - 1) * a_dim1], abs(d__1)); + i__2 = *n - *ilo + 1; + irab = idamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb); +/* Computing MAX */ + d__2 = rab, d__3 = (d__1 = b[i__ + (irab + *ilo - 1) * b_dim1], abs( + d__1)); + rab = std::max(d__2,d__3); + d__1 = rab + sfmin; + lrab = (integer) (d_lg10(&d__1) / basl + 1.); + ir = (integer) (lscale[i__] + d_sign(&c_b71, &lscale[i__])); +/* Computing MIN */ + i__2 = std::max(ir,lsfmin), i__2 = std::min(i__2,lsfmax), i__3 = lsfmax - lrab; + ir = std::min(i__2,i__3); + lscale[i__] = pow_di(&c_b35, &ir); + icab = idamax_(ihi, &a[i__ * a_dim1 + 1], &c__1); + cab = (d__1 = a[icab + i__ * a_dim1], abs(d__1)); + icab = idamax_(ihi, &b[i__ * b_dim1 + 1], &c__1); +/* Computing MAX */ + d__2 = cab, d__3 = (d__1 = b[icab + i__ * b_dim1], abs(d__1)); + cab = std::max(d__2,d__3); + d__1 = cab + sfmin; + lcab = (integer) (d_lg10(&d__1) / basl + 1.); + jc = (integer) (rscale[i__] + d_sign(&c_b71, &rscale[i__])); +/* Computing MIN */ + i__2 = std::max(jc,lsfmin), i__2 = std::min(i__2,lsfmax), i__3 = lsfmax - lcab; + jc = std::min(i__2,i__3); + rscale[i__] = pow_di(&c_b35, &jc); +/* L360: */ + } + +/* Row scaling of matrices A and B */ + + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + i__2 = *n - *ilo + 1; + dscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda); + i__2 = *n - *ilo + 1; + dscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb); +/* L370: */ + } + +/* Column scaling of matrices A and B */ + + i__1 = *ihi; + for (j = *ilo; j <= i__1; ++j) { + dscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1); + dscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1); +/* L380: */ + } + + return 0; + +/* End of DGGBAL */ + +} /* dggbal_ */ + +/* Subroutine */ int dgges_(const char *jobvsl, const char *jobvsr, const char *sort, + bool (*selctg)(const double *, const double *, const double *), + integer *n, double *a, integer *lda, double *b, + integer *ldb, integer *sdim, double *alphar, double *alphai, + double *beta, double *vsl, integer *ldvsl, double *vsr, + integer *ldvsr, double *work, integer *lwork, bool *bwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static integer c_n1 = -1; + static double c_b38 = 0.; + static double c_b39 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2; + double d__1; + + /* Builtin functions + double sqrt(double);*/ + + /* Local variables */ + integer i__, ip; + double dif[2]; + integer ihi, ilo; + double eps, anrm, bnrm; + integer idum[1], ierr, itau, iwrk; + double pvsl, pvsr; + integer ileft, icols; + bool cursl, ilvsl, ilvsr; + integer irows; + bool lst2sl; + bool ilascl, ilbscl; + double safmin; + double safmax; + double bignum; + integer ijobvl, iright; + integer ijobvr; + double anrmto, bnrmto; + bool lastsl; + integer minwrk, maxwrk; + double smlnum; + bool wantst, lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ +/* .. Function Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), */ +/* the generalized eigenvalues, the generalized real Schur form (S,T), */ +/* optionally, the left and/or right matrices of Schur vectors (VSL and */ +/* VSR). This gives the generalized Schur factorization */ + +/* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) */ + +/* Optionally, it also orders the eigenvalues so that a selected cluster */ +/* of eigenvalues appears in the leading diagonal blocks of the upper */ +/* quasi-triangular matrix S and the upper triangular matrix T.The */ +/* leading columns of VSL and VSR then form an orthonormal basis for the */ +/* corresponding left and right eigenspaces (deflating subspaces). */ + +/* (If only the generalized eigenvalues are needed, use the driver */ +/* DGGEV instead, which is faster.) */ + +/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */ +/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */ +/* usually represented as the pair (alpha,beta), as there is a */ +/* reasonable interpretation for beta=0 or both being zero. */ + +/* A pair of matrices (S,T) is in generalized real Schur form if T is */ +/* upper triangular with non-negative diagonal and S is block upper */ +/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */ +/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */ +/* "standardized" by making the corresponding elements of T have the */ +/* form: */ +/* [ a 0 ] */ +/* [ 0 b ] */ + +/* and the pair of corresponding 2-by-2 blocks in S and T will have a */ +/* complex conjugate pair of generalized eigenvalues. */ + + +/* Arguments */ +/* ========= */ + +/* JOBVSL (input) CHARACTER*1 */ +/* = 'N': do not compute the left Schur vectors; */ +/* = 'V': compute the left Schur vectors. */ + +/* JOBVSR (input) CHARACTER*1 */ +/* = 'N': do not compute the right Schur vectors; */ +/* = 'V': compute the right Schur vectors. */ + +/* SORT (input) CHARACTER*1 */ +/* Specifies whether or not to order the eigenvalues on the */ +/* diagonal of the generalized Schur form. */ +/* = 'N': Eigenvalues are not ordered; */ +/* = 'S': Eigenvalues are ordered (see SELCTG); */ + +/* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments */ +/* SELCTG must be declared EXTERNAL in the calling subroutine. */ +/* If SORT = 'N', SELCTG is not referenced. */ +/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */ +/* to the top left of the Schur form. */ +/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */ +/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */ +/* one of a complex conjugate pair of eigenvalues is selected, */ +/* then both complex eigenvalues are selected. */ + +/* Note that in the ill-conditioned case, a selected complex */ +/* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), */ +/* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 */ +/* in this case. */ + +/* N (input) INTEGER */ +/* The order of the matrices A, B, VSL, and VSR. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the first of the pair of matrices. */ +/* On exit, A has been overwritten by its generalized Schur */ +/* form S. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the second of the pair of matrices. */ +/* On exit, B has been overwritten by its generalized Schur */ +/* form T. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B. LDB >= max(1,N). */ + +/* SDIM (output) INTEGER */ +/* If SORT = 'N', SDIM = 0. */ +/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ +/* for which SELCTG is true. (Complex conjugate pairs for which */ +/* SELCTG is true for either eigenvalue count as 2.) */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ +/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, */ +/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */ +/* form (S,T) that would result if the 2-by-2 diagonal blocks of */ +/* the real Schur form of (A,B) were further reduced to */ +/* triangular form using 2-by-2 complex unitary transformations. */ +/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* positive, then the j-th and (j+1)-st eigenvalues are a */ +/* complex conjugate pair, with ALPHAI(j+1) negative. */ + +/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* may easily over- or underflow, and BETA(j) may even be zero. */ +/* Thus, the user should avoid naively computing the ratio. */ +/* However, ALPHAR and ALPHAI will be always less than and */ +/* usually comparable with norm(A) in magnitude, and BETA always */ +/* less than and usually comparable with norm(B). */ + +/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */ +/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */ +/* Not referenced if JOBVSL = 'N'. */ + +/* LDVSL (input) INTEGER */ +/* The leading dimension of the matrix VSL. LDVSL >=1, and */ +/* if JOBVSL = 'V', LDVSL >= N. */ + +/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */ +/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */ +/* Not referenced if JOBVSR = 'N'. */ + +/* LDVSR (input) INTEGER */ +/* The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* if JOBVSR = 'V', LDVSR >= N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* If N = 0, LWORK >= 1, else LWORK >= 8*N+16. */ +/* For good performance , LWORK must generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* BWORK (workspace) LOGICAL array, dimension (N) */ +/* Not referenced if SORT = 'N'. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1,...,N: */ +/* The QZ iteration failed. (A,B) are not in Schur */ +/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ +/* be correct for j=INFO+1,...,N. */ +/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */ +/* =N+2: after reordering, roundoff changed values of */ +/* some complex eigenvalues so that leading */ +/* eigenvalues in the Generalized Schur form no */ +/* longer satisfy SELCTG=.TRUE. This could also */ +/* be caused due to scaling. */ +/* =N+3: reordering failed in DTGSEN. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1; + vsr -= vsr_offset; + --work; + --bwork; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = false; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = true; + } else { + ijobvl = -1; + ilvsl = false; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = false; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = true; + } else { + ijobvr = -1; + ilvsr = false; + } + + wantst = lsame_(sort, "S"); + +/* Test the input arguments */ + + *info = 0; + lquery = *lwork == -1; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -3; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -15; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -17; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + if (*n > 0) { +/* Computing MAX */ + i__1 = *n << 3, i__2 = *n * 6 + 16; + minwrk = std::max(i__1,i__2); + maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & + c__1, n, &c__0); +/* Computing MAX */ + i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR", + " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); + if (ilvsl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR" + "GQR", " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); + } + } else { + minwrk = 1; + maxwrk = 1; + } + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -19; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGES ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + safmin = dlamch_("S"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + smlnum = sqrt(safmin) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = false; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = true; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = true; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if max element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = false; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = true; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = true; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute the matrix to make it more nearly triangular */ +/* (Workspace: need 6*N + 2*N space for storing balancing factors) */ + + ileft = 1; + iright = *n + 1; + iwrk = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwrk], &ierr); + +/* Reduce B to triangular form (QR decomposition of B) */ +/* (Workspace: need N, prefer N*NB) */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwrk; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to matrix A */ +/* (Workspace: need N, prefer N*NB) */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VSL */ +/* (Workspace: need N, prefer N*NB) */ + + if (ilvsl) { + dlaset_("Full", n, n, &c_b38, &c_b39, &vsl[vsl_offset], ldvsl); + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ + ilo + 1 + ilo * vsl_dim1], ldvsl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwrk], &i__1, &ierr); + } + +/* Initialize VSR */ + + if (ilvsr) { + dlaset_("Full", n, n, &c_b38, &c_b39, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ +/* (Workspace: none needed) */ + + dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr); + +/* Perform QZ algorithm, computing Schur vectors if desired */ +/* (Workspace: need N) */ + + iwrk = itau; + i__1 = *lwork + 1 - iwrk; + dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] +, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L50; + } + +/* Sort eigenvalues ALPHA/BETA if desired */ +/* (Workspace: need 4*N+16 ) */ + + *sdim = 0; + if (wantst) { + +/* Undo scaling on eigenvalues before SELCTGing */ + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], + n, &ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], + n, &ierr); + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, + &ierr); + } + +/* Select eigenvalues */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); +/* L10: */ + } + + i__1 = *lwork - iwrk + 1; + dtgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ + vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pvsl, & + pvsr, dif, &work[iwrk], &i__1, idum, &c__1, &ierr); + if (ierr == 1) { + *info = *n + 3; + } + + } + +/* Apply back-permutation to VSL and VSR */ +/* (Workspace: none needed) */ + + if (ilvsl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ + vsl_offset], ldvsl, &ierr); + } + + if (ilvsr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ + vsr_offset], ldvsr, &ierr); + } + +/* Check if unscaling would cause over/underflow, if so, rescale */ +/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */ +/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */ + + if (ilascl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[ + i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__], + abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } else if (alphai[i__] / safmax > anrmto / anrm || safmin / + alphai[i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[ + i__], abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L20: */ + } + } + + if (ilbscl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__] + > bnrm / bnrmto) { + work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs( + d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L30: */ + } + } + +/* Undo scaling */ + + if (ilascl) { + dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + ierr); + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + + if (wantst) { + +/* Check if reordering is correct */ + + lastsl = true; + lst2sl = true; + *sdim = 0; + ip = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); + if (alphai[i__] == 0.) { + if (cursl) { + ++(*sdim); + } + ip = 0; + if (cursl && ! lastsl) { + *info = *n + 2; + } + } else { + if (ip == 1) { + +/* Last eigenvalue of conjugate pair */ + + cursl = cursl || lastsl; + lastsl = cursl; + if (cursl) { + *sdim += 2; + } + ip = -1; + if (cursl && ! lst2sl) { + *info = *n + 2; + } + } else { + +/* First eigenvalue of conjugate pair */ + + ip = 1; + } + } + lst2sl = lastsl; + lastsl = cursl; +/* L40: */ + } + + } + +L50: + + work[1] = (double) maxwrk; + + return 0; + +/* End of DGGES */ + +} /* dgges_ */ + +/* Subroutine */ int dggesx_(const char *jobvsl, const char *jobvsr, const char *sort, + bool (*selctg)(const double *, const double *, const double *), + const char *sense, integer *n, double *a, integer *lda, + double *b, integer *ldb, integer *sdim, double *alphar, + double *alphai, double *beta, double *vsl, integer *ldvsl, + double *vsr, integer *ldvsr, double *rconde, double * + rcondv, double *work, integer *lwork, integer *iwork, integer * + liwork, bool *bwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static integer c_n1 = -1; + static double c_b42 = 0.; + static double c_b43 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset, + vsr_dim1, vsr_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, ip; + double pl, pr, dif[2]; + integer ihi, ilo; + double eps; + integer ijob; + double anrm, bnrm; + integer ierr, itau, iwrk, lwrk; + integer ileft, icols; + bool cursl, ilvsl, ilvsr; + integer irows; + bool lst2sl; + bool ilascl, ilbscl; + double safmin; + double safmax; + double bignum; + integer ijobvl, iright; + integer ijobvr; + bool wantsb; + integer liwmin; + bool wantse, lastsl; + double anrmto, bnrmto; + integer minwrk, maxwrk; + bool wantsn; + double smlnum; + bool wantst, lquery, wantsv; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ +/* .. Function Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGESX computes for a pair of N-by-N real nonsymmetric matrices */ +/* (A,B), the generalized eigenvalues, the real Schur form (S,T), and, */ +/* optionally, the left and/or right matrices of Schur vectors (VSL and */ +/* VSR). This gives the generalized Schur factorization */ + +/* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T ) */ + +/* Optionally, it also orders the eigenvalues so that a selected cluster */ +/* of eigenvalues appears in the leading diagonal blocks of the upper */ +/* quasi-triangular matrix S and the upper triangular matrix T; computes */ +/* a reciprocal condition number for the average of the selected */ +/* eigenvalues (RCONDE); and computes a reciprocal condition number for */ +/* the right and left deflating subspaces corresponding to the selected */ +/* eigenvalues (RCONDV). The leading columns of VSL and VSR then form */ +/* an orthonormal basis for the corresponding left and right eigenspaces */ +/* (deflating subspaces). */ + +/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */ +/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */ +/* usually represented as the pair (alpha,beta), as there is a */ +/* reasonable interpretation for beta=0 or for both being zero. */ + +/* A pair of matrices (S,T) is in generalized real Schur form if T is */ +/* upper triangular with non-negative diagonal and S is block upper */ +/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */ +/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */ +/* "standardized" by making the corresponding elements of T have the */ +/* form: */ +/* [ a 0 ] */ +/* [ 0 b ] */ + +/* and the pair of corresponding 2-by-2 blocks in S and T will have a */ +/* complex conjugate pair of generalized eigenvalues. */ + + +/* Arguments */ +/* ========= */ + +/* JOBVSL (input) CHARACTER*1 */ +/* = 'N': do not compute the left Schur vectors; */ +/* = 'V': compute the left Schur vectors. */ + +/* JOBVSR (input) CHARACTER*1 */ +/* = 'N': do not compute the right Schur vectors; */ +/* = 'V': compute the right Schur vectors. */ + +/* SORT (input) CHARACTER*1 */ +/* Specifies whether or not to order the eigenvalues on the */ +/* diagonal of the generalized Schur form. */ +/* = 'N': Eigenvalues are not ordered; */ +/* = 'S': Eigenvalues are ordered (see SELCTG). */ + +/* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments */ +/* SELCTG must be declared EXTERNAL in the calling subroutine. */ +/* If SORT = 'N', SELCTG is not referenced. */ +/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */ +/* to the top left of the Schur form. */ +/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */ +/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */ +/* one of a complex conjugate pair of eigenvalues is selected, */ +/* then both complex eigenvalues are selected. */ +/* Note that a selected complex eigenvalue may no longer satisfy */ +/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering, */ +/* since ordering may change the value of complex eigenvalues */ +/* (especially if the eigenvalue is ill-conditioned), in this */ +/* case INFO is set to N+3. */ + +/* SENSE (input) CHARACTER*1 */ +/* Determines which reciprocal condition numbers are computed. */ +/* = 'N' : None are computed; */ +/* = 'E' : Computed for average of selected eigenvalues only; */ +/* = 'V' : Computed for selected deflating subspaces only; */ +/* = 'B' : Computed for both. */ +/* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. */ + +/* N (input) INTEGER */ +/* The order of the matrices A, B, VSL, and VSR. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the first of the pair of matrices. */ +/* On exit, A has been overwritten by its generalized Schur */ +/* form S. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the second of the pair of matrices. */ +/* On exit, B has been overwritten by its generalized Schur */ +/* form T. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B. LDB >= max(1,N). */ + +/* SDIM (output) INTEGER */ +/* If SORT = 'N', SDIM = 0. */ +/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */ +/* for which SELCTG is true. (Complex conjugate pairs for which */ +/* SELCTG is true for either eigenvalue count as 2.) */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ +/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */ +/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */ +/* form (S,T) that would result if the 2-by-2 diagonal blocks of */ +/* the real Schur form of (A,B) were further reduced to */ +/* triangular form using 2-by-2 complex unitary transformations. */ +/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* positive, then the j-th and (j+1)-st eigenvalues are a */ +/* complex conjugate pair, with ALPHAI(j+1) negative. */ + +/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* may easily over- or underflow, and BETA(j) may even be zero. */ +/* Thus, the user should avoid naively computing the ratio. */ +/* However, ALPHAR and ALPHAI will be always less than and */ +/* usually comparable with norm(A) in magnitude, and BETA always */ +/* less than and usually comparable with norm(B). */ + +/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */ +/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */ +/* Not referenced if JOBVSL = 'N'. */ + +/* LDVSL (input) INTEGER */ +/* The leading dimension of the matrix VSL. LDVSL >=1, and */ +/* if JOBVSL = 'V', LDVSL >= N. */ + +/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */ +/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */ +/* Not referenced if JOBVSR = 'N'. */ + +/* LDVSR (input) INTEGER */ +/* The leading dimension of the matrix VSR. LDVSR >= 1, and */ +/* if JOBVSR = 'V', LDVSR >= N. */ + +/* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 ) */ +/* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the */ +/* reciprocal condition numbers for the average of the selected */ +/* eigenvalues. */ +/* Not referenced if SENSE = 'N' or 'V'. */ + +/* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 ) */ +/* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the */ +/* reciprocal condition numbers for the selected deflating */ +/* subspaces. */ +/* Not referenced if SENSE = 'N' or 'E'. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', */ +/* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else */ +/* LWORK >= max( 8*N, 6*N+16 ). */ +/* Note that 2*SDIM*(N-SDIM) <= N*N/2. */ +/* Note also that an error is only returned if */ +/* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B' */ +/* this may not be large enough. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the bound on the optimal size of the WORK */ +/* array and the minimum size of the IWORK array, returns these */ +/* values as the first entries of the WORK and IWORK arrays, and */ +/* no error message related to LWORK or LIWORK is issued by */ +/* XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise */ +/* LIWORK >= N+6. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the bound on the optimal size of the */ +/* WORK array and the minimum size of the IWORK array, returns */ +/* these values as the first entries of the WORK and IWORK */ +/* arrays, and no error message related to LWORK or LIWORK is */ +/* issued by XERBLA. */ + +/* BWORK (workspace) LOGICAL array, dimension (N) */ +/* Not referenced if SORT = 'N'. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1,...,N: */ +/* The QZ iteration failed. (A,B) are not in Schur */ +/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */ +/* be correct for j=INFO+1,...,N. */ +/* > N: =N+1: other than QZ iteration failed in DHGEQZ */ +/* =N+2: after reordering, roundoff changed values of */ +/* some complex eigenvalues so that leading */ +/* eigenvalues in the Generalized Schur form no */ +/* longer satisfy SELCTG=.TRUE. This could also */ +/* be caused due to scaling. */ +/* =N+3: reordering failed in DTGSEN. */ + +/* Further details */ +/* =============== */ + +/* An approximate (asymptotic) bound on the average absolute error of */ +/* the selected eigenvalues is */ + +/* EPS * norm((A, B)) / RCONDE( 1 ). */ + +/* An approximate (asymptotic) bound on the maximum angular error in */ +/* the computed deflating subspaces is */ + +/* EPS * norm((A, B)) / RCONDV( 2 ). */ + +/* See LAPACK User's Guide, section 4.11 for more information. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vsl_dim1 = *ldvsl; + vsl_offset = 1 + vsl_dim1; + vsl -= vsl_offset; + vsr_dim1 = *ldvsr; + vsr_offset = 1 + vsr_dim1; + vsr -= vsr_offset; + --rconde; + --rcondv; + --work; + --iwork; + --bwork; + + /* Function Body */ + if (lsame_(jobvsl, "N")) { + ijobvl = 1; + ilvsl = false; + } else if (lsame_(jobvsl, "V")) { + ijobvl = 2; + ilvsl = true; + } else { + ijobvl = -1; + ilvsl = false; + } + + if (lsame_(jobvsr, "N")) { + ijobvr = 1; + ilvsr = false; + } else if (lsame_(jobvsr, "V")) { + ijobvr = 2; + ilvsr = true; + } else { + ijobvr = -1; + ilvsr = false; + } + + wantst = lsame_(sort, "S"); + wantsn = lsame_(sense, "N"); + wantse = lsame_(sense, "E"); + wantsv = lsame_(sense, "V"); + wantsb = lsame_(sense, "B"); + lquery = *lwork == -1 || *liwork == -1; + if (wantsn) { + ijob = 0; + } else if (wantse) { + ijob = 1; + } else if (wantsv) { + ijob = 2; + } else if (wantsb) { + ijob = 4; + } + +/* Test the input arguments */ + + *info = 0; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -3; + } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && ! + wantsn) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -10; + } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) { + *info = -16; + } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) { + *info = -18; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + if (*n > 0) { +/* Computing MAX */ + i__1 = *n << 3, i__2 = *n * 6 + 16; + minwrk = std::max(i__1,i__2); + maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & + c__1, n, &c__0); +/* Computing MAX */ + i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR", + " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); + if (ilvsl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR" + "GQR", " ", n, &c__1, n, &c_n1); + maxwrk = std::max(i__1,i__2); + } + lwrk = maxwrk; + if (ijob >= 1) { +/* Computing MAX */ + i__1 = lwrk, i__2 = *n * *n / 2; + lwrk = std::max(i__1,i__2); + } + } else { + minwrk = 1; + maxwrk = 1; + lwrk = 1; + } + work[1] = (double) lwrk; + if (wantsn || *n == 0) { + liwmin = 1; + } else { + liwmin = *n + 6; + } + iwork[1] = liwmin; + + if (*lwork < minwrk && ! lquery) { + *info = -22; + } else if (*liwork < liwmin && ! lquery) { + *info = -24; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGESX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + safmin = dlamch_("S"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + smlnum = sqrt(safmin) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = false; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = true; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = true; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if max element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = false; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = true; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = true; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute the matrix to make it more nearly triangular */ +/* (Workspace: need 6*N + 2*N for permutation parameters) */ + + ileft = 1; + iright = *n + 1; + iwrk = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwrk], &ierr); + +/* Reduce B to triangular form (QR decomposition of B) */ +/* (Workspace: need N, prefer N*NB) */ + + irows = ihi + 1 - ilo; + icols = *n + 1 - ilo; + itau = iwrk; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to matrix A */ +/* (Workspace: need N, prefer N*NB) */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VSL */ +/* (Workspace: need N, prefer N*NB) */ + + if (ilvsl) { + dlaset_("Full", n, n, &c_b42, &c_b43, &vsl[vsl_offset], ldvsl); + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ + ilo + 1 + ilo * vsl_dim1], ldvsl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, & + work[itau], &work[iwrk], &i__1, &ierr); + } + +/* Initialize VSR */ + + if (ilvsr) { + dlaset_("Full", n, n, &c_b42, &c_b43, &vsr[vsr_offset], ldvsr); + } + +/* Reduce to generalized Hessenberg form */ +/* (Workspace: none needed) */ + + dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr); + + *sdim = 0; + +/* Perform QZ algorithm, computing Schur vectors if desired */ +/* (Workspace: need N) */ + + iwrk = itau; + i__1 = *lwork + 1 - iwrk; + dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset] +, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L60; + } + +/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of */ +/* condition number(s) */ +/* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) ) */ +/* otherwise, need 8*(N+1) ) */ + + if (wantst) { + +/* Undo scaling on eigenvalues before SELCTGing */ + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], + n, &ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], + n, &ierr); + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, + &ierr); + } + +/* Select eigenvalues */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); +/* L10: */ + } + +/* Reorder eigenvalues, transform Generalized Schur vectors, and */ +/* compute reciprocal condition numbers */ + + i__1 = *lwork - iwrk + 1; + dtgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[ + vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pl, &pr, + dif, &work[iwrk], &i__1, &iwork[1], liwork, &ierr); + + if (ijob >= 1) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim); + maxwrk = std::max(i__1,i__2); + } + if (ierr == -22) { + +/* not enough real workspace */ + + *info = -22; + } else { + if (ijob == 1 || ijob == 4) { + rconde[1] = pl; + rconde[2] = pr; + } + if (ijob == 2 || ijob == 4) { + rcondv[1] = dif[0]; + rcondv[2] = dif[1]; + } + if (ierr == 1) { + *info = *n + 3; + } + } + + } + +/* Apply permutation to VSL and VSR */ +/* (Workspace: none needed) */ + + if (ilvsl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[ + vsl_offset], ldvsl, &ierr); + } + + if (ilvsr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[ + vsr_offset], ldvsr, &ierr); + } + +/* Check if unscaling would cause over/underflow, if so, rescale */ +/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */ +/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */ + + if (ilascl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[ + i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__], + abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } else if (alphai[i__] / safmax > anrmto / anrm || safmin / + alphai[i__] > anrm / anrmto) { + work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[ + i__], abs(d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L20: */ + } + } + + if (ilbscl) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (alphai[i__] != 0.) { + if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__] + > bnrm / bnrmto) { + work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs( + d__1)); + beta[i__] *= work[1]; + alphar[i__] *= work[1]; + alphai[i__] *= work[1]; + } + } +/* L30: */ + } + } + +/* Undo scaling */ + + if (ilascl) { + dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, & + ierr); + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + + if (wantst) { + +/* Check if reordering is correct */ + + lastsl = true; + lst2sl = true; + *sdim = 0; + ip = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]); + if (alphai[i__] == 0.) { + if (cursl) { + ++(*sdim); + } + ip = 0; + if (cursl && ! lastsl) { + *info = *n + 2; + } + } else { + if (ip == 1) { + +/* Last eigenvalue of conjugate pair */ + + cursl = cursl || lastsl; + lastsl = cursl; + if (cursl) { + *sdim += 2; + } + ip = -1; + if (cursl && ! lst2sl) { + *info = *n + 2; + } + } else { + +/* First eigenvalue of conjugate pair */ + + ip = 1; + } + } + lst2sl = lastsl; + lastsl = cursl; +/* L50: */ + } + + } + +L60: + + work[1] = (double) maxwrk; + iwork[1] = liwmin; + + return 0; + +/* End of DGGESX */ + +} /* dggesx_ */ + +/* Subroutine */ int dggev_(const char *jobvl, const char *jobvr, integer *n, double * + a, integer *lda, double *b, integer *ldb, double *alphar, + double *alphai, double *beta, double *vl, integer *ldvl, + double *vr, integer *ldvr, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static integer c_n1 = -1; + static double c_b36 = 0.; + static double c_b37 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer jc, in, jr, ihi, ilo; + double eps; + bool ilv; + double anrm, bnrm; + integer ierr, itau; + double temp; + bool ilvl, ilvr; + integer iwrk; + integer ileft, icols, irows; + bool ilascl, ilbscl; + bool ldumma[1]; + char chtemp[1]; + double bignum; + integer ijobvl, iright, ijobvr; + double anrmto, bnrmto; + integer minwrk, maxwrk; + double smlnum; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B) */ +/* the generalized eigenvalues, and optionally, the left and/or right */ +/* generalized eigenvectors. */ + +/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */ +/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */ +/* singular. It is usually represented as the pair (alpha,beta), as */ +/* there is a reasonable interpretation for beta=0, and even for both */ +/* being zero. */ + +/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */ +/* of (A,B) satisfies */ + +/* A * v(j) = lambda(j) * B * v(j). */ + +/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */ +/* of (A,B) satisfies */ + +/* u(j)**H * A = lambda(j) * u(j)**H * B . */ + +/* where u(j)**H is the conjugate-transpose of u(j). */ + + +/* Arguments */ +/* ========= */ + +/* JOBVL (input) CHARACTER*1 */ +/* = 'N': do not compute the left generalized eigenvectors; */ +/* = 'V': compute the left generalized eigenvectors. */ + +/* JOBVR (input) CHARACTER*1 */ +/* = 'N': do not compute the right generalized eigenvectors; */ +/* = 'V': compute the right generalized eigenvectors. */ + +/* N (input) INTEGER */ +/* The order of the matrices A, B, VL, and VR. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the matrix A in the pair (A,B). */ +/* On exit, A has been overwritten. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the matrix B in the pair (A,B). */ +/* On exit, B has been overwritten. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B. LDB >= max(1,N). */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ +/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */ +/* the j-th eigenvalue is real; if positive, then the j-th and */ +/* (j+1)-st eigenvalues are a complex conjugate pair, with */ +/* ALPHAI(j+1) negative. */ + +/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* may easily over- or underflow, and BETA(j) may even be zero. */ +/* Thus, the user should avoid naively computing the ratio */ +/* alpha/beta. However, ALPHAR and ALPHAI will be always less */ +/* than and usually comparable with norm(A) in magnitude, and */ +/* BETA always less than and usually comparable with norm(B). */ + +/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ +/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* after another in the columns of VL, in the same order as */ +/* their eigenvalues. If the j-th eigenvalue is real, then */ +/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */ +/* (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */ +/* Each eigenvector is scaled so the largest component has */ +/* abs(real part)+abs(imag. part)=1. */ +/* Not referenced if JOBVL = 'N'. */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the matrix VL. LDVL >= 1, and */ +/* if JOBVL = 'V', LDVL >= N. */ + +/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ +/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* after another in the columns of VR, in the same order as */ +/* their eigenvalues. If the j-th eigenvalue is real, then */ +/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */ +/* (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */ +/* Each eigenvector is scaled so the largest component has */ +/* abs(real part)+abs(imag. part)=1. */ +/* Not referenced if JOBVR = 'N'. */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the matrix VR. LDVR >= 1, and */ +/* if JOBVR = 'V', LDVR >= N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,8*N). */ +/* For good performance, LWORK must generally be larger. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1,...,N: */ +/* The QZ iteration failed. No eigenvectors have been */ +/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ +/* should be correct for j=INFO+1,...,N. */ +/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */ +/* =N+2: error return from DTGEVC. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = false; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = true; + } else { + ijobvl = -1; + ilvl = false; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = false; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = true; + } else { + ijobvr = -1; + ilvr = false; + } + ilv = ilvl || ilvr; + +/* Test the input arguments */ + + *info = 0; + lquery = *lwork == -1; + if (ijobvl <= 0) { + *info = -1; + } else if (ijobvr <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -12; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -14; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV. The workspace is */ +/* computed assuming ILO = 1 and IHI = N, the worst case.) */ + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 3; + minwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * (ilaenv_(&c__1, "DGEQRF", " ", n, &c__1, n, & + c__0) + 7); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "DORMQR", " ", n, &c__1, n, + &c__0) + 7); + maxwrk = std::max(i__1,i__2); + if (ilvl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "DORGQR", " ", n, & + c__1, n, &c_n1) + 7); + maxwrk = std::max(i__1,i__2); + } + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -16; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGEV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = false; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = true; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = true; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if max element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = false; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = true; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = true; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute the matrices A, B to isolate eigenvalues if possible */ +/* (Workspace: need 6*N) */ + + ileft = 1; + iright = *n + 1; + iwrk = iright + *n; + dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[ + ileft], &work[iright], &work[iwrk], &ierr); + +/* Reduce B to triangular form (QR decomposition of B) */ +/* (Workspace: need N, prefer N*NB) */ + + irows = ihi + 1 - ilo; + if (ilv) { + icols = *n + 1 - ilo; + } else { + icols = irows; + } + itau = iwrk; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to matrix A */ +/* (Workspace: need N, prefer N*NB) */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, & + work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VL */ +/* (Workspace: need N, prefer N*NB) */ + + if (ilvl) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vl[vl_offset], ldvl) + ; + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ + ilo + 1 + ilo * vl_dim1], ldvl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[ + itau], &work[iwrk], &i__1, &ierr); + } + +/* Initialize VR */ + + if (ilvr) { + dlaset_("Full", n, n, &c_b36, &c_b37, &vr[vr_offset], ldvr) + ; + } + +/* Reduce to generalized Hessenberg form */ +/* (Workspace: none needed) */ + + if (ilv) { + +/* Eigenvectors requested -- work on whole matrix. */ + + dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); + } else { + dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda, + &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &ierr); + } + +/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */ +/* Schur forms and Schur vectors) */ +/* (Workspace: need N) */ + + iwrk = itau; + if (ilv) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + i__1 = *lwork + 1 - iwrk; + dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ + b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, &work[iwrk], &i__1, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L110; + } + +/* Compute Eigenvectors */ +/* (Workspace: need 6*N) */ + + if (ilv) { + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, + &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ + iwrk], &ierr); + if (ierr != 0) { + *info = *n + 2; + goto L110; + } + +/* Undo balancing on VL and VR and normalization */ +/* (Workspace: none needed) */ + + if (ilvl) { + dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vl[vl_offset], ldvl, &ierr); + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L50; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)); + temp = std::max(d__2,d__3); +/* L10: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], + abs(d__1)) + (d__2 = vl[jr + (jc + 1) * + vl_dim1], abs(d__2)); + temp = std::max(d__3,d__4); +/* L20: */ + } + } + if (temp < smlnum) { + goto L50; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; +/* L30: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; + vl[jr + (jc + 1) * vl_dim1] *= temp; +/* L40: */ + } + } +L50: + ; + } + } + if (ilvr) { + dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, & + vr[vr_offset], ldvr, &ierr); + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L100; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)); + temp = std::max(d__2,d__3); +/* L60: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], + abs(d__1)) + (d__2 = vr[jr + (jc + 1) * + vr_dim1], abs(d__2)); + temp = std::max(d__3,d__4); +/* L70: */ + } + } + if (temp < smlnum) { + goto L100; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; +/* L80: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; + vr[jr + (jc + 1) * vr_dim1] *= temp; +/* L90: */ + } + } +L100: + ; + } + } + +/* End of eigenvector calculation */ + + } + +/* Undo scaling if necessary */ + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + +L110: + + work[1] = (double) maxwrk; + + return 0; + +/* End of DGGEV */ + +} /* dggev_ */ + +/* Subroutine */ int dggevx_(const char *balanc, const char *jobvl, const char *jobvr, const char * + sense, integer *n, double *a, integer *lda, double *b, + integer *ldb, double *alphar, double *alphai, double * + beta, double *vl, integer *ldvl, double *vr, integer *ldvr, + integer *ilo, integer *ihi, double *lscale, double *rscale, + double *abnrm, double *bbnrm, double *rconde, double * + rcondv, double *work, integer *lwork, integer *iwork, bool * + bwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static double c_b59 = 0.; + static double c_b60 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + double d__1, d__2, d__3, d__4; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__, j, m, jc, in, mm, jr; + double eps; + bool ilv, pair; + double anrm, bnrm; + integer ierr, itau; + double temp; + bool ilvl, ilvr; + integer iwrk, iwrk1; + integer icols; + bool noscl; + integer irows; + bool ilascl, ilbscl; + bool ldumma[1]; + char chtemp[1]; + double bignum; + integer ijobvl; + integer ijobvr; + bool wantsb; + double anrmto; + bool wantse; + double bnrmto; + integer minwrk, maxwrk; + bool wantsn; + double smlnum; + bool lquery, wantsv; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) */ +/* the generalized eigenvalues, and optionally, the left and/or right */ +/* generalized eigenvectors. */ + +/* Optionally also, it computes a balancing transformation to improve */ +/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */ +/* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */ +/* the eigenvalues (RCONDE), and reciprocal condition numbers for the */ +/* right eigenvectors (RCONDV). */ + +/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */ +/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */ +/* singular. It is usually represented as the pair (alpha,beta), as */ +/* there is a reasonable interpretation for beta=0, and even for both */ +/* being zero. */ + +/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */ +/* of (A,B) satisfies */ + +/* A * v(j) = lambda(j) * B * v(j) . */ + +/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */ +/* of (A,B) satisfies */ + +/* u(j)**H * A = lambda(j) * u(j)**H * B. */ + +/* where u(j)**H is the conjugate-transpose of u(j). */ + + +/* Arguments */ +/* ========= */ + +/* BALANC (input) CHARACTER*1 */ +/* Specifies the balance option to be performed. */ +/* = 'N': do not diagonally scale or permute; */ +/* = 'P': permute only; */ +/* = 'S': scale only; */ +/* = 'B': both permute and scale. */ +/* Computed reciprocal condition numbers will be for the */ +/* matrices after permuting and/or balancing. Permuting does */ +/* not change condition numbers (in exact arithmetic), but */ +/* balancing does. */ + +/* JOBVL (input) CHARACTER*1 */ +/* = 'N': do not compute the left generalized eigenvectors; */ +/* = 'V': compute the left generalized eigenvectors. */ + +/* JOBVR (input) CHARACTER*1 */ +/* = 'N': do not compute the right generalized eigenvectors; */ +/* = 'V': compute the right generalized eigenvectors. */ + +/* SENSE (input) CHARACTER*1 */ +/* Determines which reciprocal condition numbers are computed. */ +/* = 'N': none are computed; */ +/* = 'E': computed for eigenvalues only; */ +/* = 'V': computed for eigenvectors only; */ +/* = 'B': computed for eigenvalues and eigenvectors. */ + +/* N (input) INTEGER */ +/* The order of the matrices A, B, VL, and VR. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the matrix A in the pair (A,B). */ +/* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */ +/* or both, then A contains the first part of the real Schur */ +/* form of the "balanced" versions of the input A and B. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the matrix B in the pair (A,B). */ +/* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */ +/* or both, then B contains the second part of the real Schur */ +/* form of the "balanced" versions of the input A and B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B. LDB >= max(1,N). */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ +/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */ +/* the j-th eigenvalue is real; if positive, then the j-th and */ +/* (j+1)-st eigenvalues are a complex conjugate pair, with */ +/* ALPHAI(j+1) negative. */ + +/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */ +/* may easily over- or underflow, and BETA(j) may even be zero. */ +/* Thus, the user should avoid naively computing the ratio */ +/* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less */ +/* than and usually comparable with norm(A) in magnitude, and */ +/* BETA always less than and usually comparable with norm(B). */ + +/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */ +/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* after another in the columns of VL, in the same order as */ +/* their eigenvalues. If the j-th eigenvalue is real, then */ +/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */ +/* (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */ +/* Each eigenvector will be scaled so the largest component have */ +/* abs(real part) + abs(imag. part) = 1. */ +/* Not referenced if JOBVL = 'N'. */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the matrix VL. LDVL >= 1, and */ +/* if JOBVL = 'V', LDVL >= N. */ + +/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */ +/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* after another in the columns of VR, in the same order as */ +/* their eigenvalues. If the j-th eigenvalue is real, then */ +/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */ +/* (j+1)-th eigenvalues form a complex conjugate pair, then */ +/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */ +/* Each eigenvector will be scaled so the largest component have */ +/* abs(real part) + abs(imag. part) = 1. */ +/* Not referenced if JOBVR = 'N'. */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the matrix VR. LDVR >= 1, and */ +/* if JOBVR = 'V', LDVR >= N. */ + +/* ILO (output) INTEGER */ +/* IHI (output) INTEGER */ +/* ILO and IHI are integer values such that on exit */ +/* A(i,j) = 0 and B(i,j) = 0 if i > j and */ +/* j = 1,...,ILO-1 or i = IHI+1,...,N. */ +/* If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */ + +/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutations and scaling factors applied */ +/* to the left side of A and B. If PL(j) is the index of the */ +/* row interchanged with row j, and DL(j) is the scaling */ +/* factor applied to row j, then */ +/* LSCALE(j) = PL(j) for j = 1,...,ILO-1 */ +/* = DL(j) for j = ILO,...,IHI */ +/* = PL(j) for j = IHI+1,...,N. */ +/* The order in which the interchanges are made is N to IHI+1, */ +/* then 1 to ILO-1. */ + +/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */ +/* Details of the permutations and scaling factors applied */ +/* to the right side of A and B. If PR(j) is the index of the */ +/* column interchanged with column j, and DR(j) is the scaling */ +/* factor applied to column j, then */ +/* RSCALE(j) = PR(j) for j = 1,...,ILO-1 */ +/* = DR(j) for j = ILO,...,IHI */ +/* = PR(j) for j = IHI+1,...,N */ +/* The order in which the interchanges are made is N to IHI+1, */ +/* then 1 to ILO-1. */ + +/* ABNRM (output) DOUBLE PRECISION */ +/* The one-norm of the balanced matrix A. */ + +/* BBNRM (output) DOUBLE PRECISION */ +/* The one-norm of the balanced matrix B. */ + +/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */ +/* If SENSE = 'E' or 'B', the reciprocal condition numbers of */ +/* the eigenvalues, stored in consecutive elements of the array. */ +/* For a complex conjugate pair of eigenvalues two consecutive */ +/* elements of RCONDE are set to the same value. Thus RCONDE(j), */ +/* RCONDV(j), and the j-th columns of VL and VR all correspond */ +/* to the j-th eigenpair. */ +/* If SENSE = 'N or 'V', RCONDE is not referenced. */ + +/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */ +/* If SENSE = 'V' or 'B', the estimated reciprocal condition */ +/* numbers of the eigenvectors, stored in consecutive elements */ +/* of the array. For a complex eigenvector two consecutive */ +/* elements of RCONDV are set to the same value. If the */ +/* eigenvalues cannot be reordered to compute RCONDV(j), */ +/* RCONDV(j) is set to 0; this can only occur when the true */ +/* value would be very small anyway. */ +/* If SENSE = 'N' or 'E', RCONDV is not referenced. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,2*N). */ +/* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', */ +/* LWORK >= max(1,6*N). */ +/* If SENSE = 'E' or 'B', LWORK >= max(1,10*N). */ +/* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (N+6) */ +/* If SENSE = 'E', IWORK is not referenced. */ + +/* BWORK (workspace) LOGICAL array, dimension (N) */ +/* If SENSE = 'N', BWORK is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1,...,N: */ +/* The QZ iteration failed. No eigenvectors have been */ +/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */ +/* should be correct for j=INFO+1,...,N. */ +/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */ +/* =N+2: error return from DTGEVC. */ + +/* Further Details */ +/* =============== */ + +/* Balancing a matrix pair (A,B) includes, first, permuting rows and */ +/* columns to isolate eigenvalues, second, applying diagonal similarity */ +/* transformation to the rows and columns to make the rows and columns */ +/* as close in norm as possible. The computed reciprocal condition */ +/* numbers correspond to the balanced matrix. Permuting rows and columns */ +/* will not change the condition numbers (in exact arithmetic) but */ +/* diagonal scaling will. For further explanation of balancing, see */ +/* section 4.11.1.2 of LAPACK Users' Guide. */ + +/* An approximate error bound on the chordal distance between the i-th */ +/* computed generalized eigenvalue w and the corresponding exact */ +/* eigenvalue lambda is */ + +/* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */ + +/* An approximate error bound for the angle between the i-th computed */ +/* eigenvector VL(i) or VR(i) is given by */ + +/* EPS * norm(ABNRM, BBNRM) / DIF(i). */ + +/* For further explanation of the reciprocal condition numbers RCONDE */ +/* and RCONDV, see section 4.11 of LAPACK User's Guide. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alphar; + --alphai; + --beta; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --lscale; + --rscale; + --rconde; + --rcondv; + --work; + --iwork; + --bwork; + + /* Function Body */ + if (lsame_(jobvl, "N")) { + ijobvl = 1; + ilvl = false; + } else if (lsame_(jobvl, "V")) { + ijobvl = 2; + ilvl = true; + } else { + ijobvl = -1; + ilvl = false; + } + + if (lsame_(jobvr, "N")) { + ijobvr = 1; + ilvr = false; + } else if (lsame_(jobvr, "V")) { + ijobvr = 2; + ilvr = true; + } else { + ijobvr = -1; + ilvr = false; + } + ilv = ilvl || ilvr; + + noscl = lsame_(balanc, "N") || lsame_(balanc, "P"); + wantsn = lsame_(sense, "N"); + wantse = lsame_(sense, "E"); + wantsv = lsame_(sense, "V"); + wantsb = lsame_(sense, "B"); + +/* Test the input arguments */ + + *info = 0; + lquery = *lwork == -1; + if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") + || lsame_(balanc, "B"))) { + *info = -1; + } else if (ijobvl <= 0) { + *info = -2; + } else if (ijobvr <= 0) { + *info = -3; + } else if (! (wantsn || wantse || wantsb || wantsv)) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldvl < 1 || ilvl && *ldvl < *n) { + *info = -14; + } else if (*ldvr < 1 || ilvr && *ldvr < *n) { + *info = -16; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV. The workspace is */ +/* computed assuming ILO = 1 and IHI = N, the worst case.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + if (noscl && ! ilv) { + minwrk = *n << 1; + } else { + minwrk = *n * 6; + } + if (wantse || wantsb) { + minwrk = *n * 10; + } + if (wantsv || wantsb) { +/* Computing MAX */ + i__1 = minwrk, i__2 = (*n << 1) * (*n + 4) + 16; + minwrk = std::max(i__1,i__2); + } + maxwrk = minwrk; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, & + c__1, n, &c__0); + maxwrk = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORMQR", " ", n, & + c__1, n, &c__0); + maxwrk = std::max(i__1,i__2); + if (ilvl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR", + " ", n, &c__1, n, &c__0); + maxwrk = std::max(i__1,i__2); + } + } + work[1] = (double) maxwrk; + + if (*lwork < minwrk && ! lquery) { + *info = -26; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGEVX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if max element outside range [SMLNUM,BIGNUM] */ + + anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]); + ilascl = false; + if (anrm > 0. && anrm < smlnum) { + anrmto = smlnum; + ilascl = true; + } else if (anrm > bignum) { + anrmto = bignum; + ilascl = true; + } + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & + ierr); + } + +/* Scale B if max element outside range [SMLNUM,BIGNUM] */ + + bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]); + ilbscl = false; + if (bnrm > 0. && bnrm < smlnum) { + bnrmto = smlnum; + ilbscl = true; + } else if (bnrm > bignum) { + bnrmto = bignum; + ilbscl = true; + } + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & + ierr); + } + +/* Permute and/or balance the matrix pair (A,B) */ +/* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */ + + dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, & + lscale[1], &rscale[1], &work[1], &ierr); + +/* Compute ABNRM and BBNRM */ + + *abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]); + if (ilascl) { + work[1] = *abnrm; + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], & + c__1, &ierr); + *abnrm = work[1]; + } + + *bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]); + if (ilbscl) { + work[1] = *bbnrm; + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], & + c__1, &ierr); + *bbnrm = work[1]; + } + +/* Reduce B to triangular form (QR decomposition of B) */ +/* (Workspace: need N, prefer N*NB ) */ + + irows = *ihi + 1 - *ilo; + if (ilv || ! wantsn) { + icols = *n + 1 - *ilo; + } else { + icols = irows; + } + itau = 1; + iwrk = itau + irows; + i__1 = *lwork + 1 - iwrk; + dgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[ + iwrk], &i__1, &ierr); + +/* Apply the orthogonal transformation to A */ +/* (Workspace: need N, prefer N*NB) */ + + i__1 = *lwork + 1 - iwrk; + dormqr_("L", "T", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, & + work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, & + ierr); + +/* Initialize VL and/or VR */ +/* (Workspace: need N, prefer N*NB) */ + + if (ilvl) { + dlaset_("Full", n, n, &c_b59, &c_b60, &vl[vl_offset], ldvl) + ; + if (irows > 1) { + i__1 = irows - 1; + i__2 = irows - 1; + dlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[ + *ilo + 1 + *ilo * vl_dim1], ldvl); + } + i__1 = *lwork + 1 - iwrk; + dorgqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, & + work[itau], &work[iwrk], &i__1, &ierr); + } + + if (ilvr) { + dlaset_("Full", n, n, &c_b59, &c_b60, &vr[vr_offset], ldvr) + ; + } + +/* Reduce to generalized Hessenberg form */ +/* (Workspace: none needed) */ + + if (ilv || ! wantsn) { + +/* Eigenvectors requested -- work on whole matrix. */ + + dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); + } else { + dgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1], + lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ + vr_offset], ldvr, &ierr); + } + +/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */ +/* Schur forms and Schur vectors) */ +/* (Workspace: need N) */ + + if (ilv || ! wantsn) { + *(unsigned char *)chtemp = 'S'; + } else { + *(unsigned char *)chtemp = 'E'; + } + + dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset] +, ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, & + vr[vr_offset], ldvr, &work[1], lwork, &ierr); + if (ierr != 0) { + if (ierr > 0 && ierr <= *n) { + *info = ierr; + } else if (ierr > *n && ierr <= *n << 1) { + *info = ierr - *n; + } else { + *info = *n + 1; + } + goto L130; + } + +/* Compute Eigenvectors and estimate condition numbers if desired */ +/* (Workspace: DTGEVC: need 6*N */ +/* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', */ +/* need N otherwise ) */ + + if (ilv || ! wantsn) { + if (ilv) { + if (ilvl) { + if (ilvr) { + *(unsigned char *)chtemp = 'B'; + } else { + *(unsigned char *)chtemp = 'L'; + } + } else { + *(unsigned char *)chtemp = 'R'; + } + + dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], + ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, & + work[1], &ierr); + if (ierr != 0) { + *info = *n + 2; + goto L130; + } + } + + if (! wantsn) { + +/* compute eigenvectors (DTGEVC) and estimate condition */ +/* numbers (DTGSNA). Note that the definition of the condition */ +/* number is not invariant under transformation (u,v) to */ +/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */ +/* Schur form (S,T), Q and Z are orthogonal matrices. In order */ +/* to avoid using extra 2*N*N workspace, we have to recalculate */ +/* eigenvectors and estimate one condition numbers at a time. */ + + pair = false; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (pair) { + pair = false; + goto L20; + } + mm = 1; + if (i__ < *n) { + if (a[i__ + 1 + i__ * a_dim1] != 0.) { + pair = true; + mm = 2; + } + } + + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + bwork[j] = false; +/* L10: */ + } + if (mm == 1) { + bwork[i__] = true; + } else if (mm == 2) { + bwork[i__] = true; + bwork[i__ + 1] = true; + } + + iwrk = mm * *n + 1; + iwrk1 = iwrk + mm * *n; + +/* Compute a pair of left and right eigenvectors. */ +/* (compute workspace: need up to 4*N + 6*N) */ + + if (wantse || wantsb) { + dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &work[1], n, &work[iwrk], n, &mm, + &m, &work[iwrk1], &ierr); + if (ierr != 0) { + *info = *n + 2; + goto L130; + } + } + + i__2 = *lwork - iwrk1 + 1; + dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[ + b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[ + i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, & + iwork[1], &ierr); + +L20: + ; + } + } + } + +/* Undo balancing on VL and VR and normalization */ +/* (Workspace: none needed) */ + + if (ilvl) { + dggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[ + vl_offset], ldvl, &ierr); + + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L70; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], abs( + d__1)); + temp = std::max(d__2,d__3); +/* L30: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], abs( + d__1)) + (d__2 = vl[jr + (jc + 1) * vl_dim1], abs( + d__2)); + temp = std::max(d__3,d__4); +/* L40: */ + } + } + if (temp < smlnum) { + goto L70; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; +/* L50: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + jc * vl_dim1] *= temp; + vl[jr + (jc + 1) * vl_dim1] *= temp; +/* L60: */ + } + } +L70: + ; + } + } + if (ilvr) { + dggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[ + vr_offset], ldvr, &ierr); + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + if (alphai[jc] < 0.) { + goto L120; + } + temp = 0.; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], abs( + d__1)); + temp = std::max(d__2,d__3); +/* L80: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], abs( + d__1)) + (d__2 = vr[jr + (jc + 1) * vr_dim1], abs( + d__2)); + temp = std::max(d__3,d__4); +/* L90: */ + } + } + if (temp < smlnum) { + goto L120; + } + temp = 1. / temp; + if (alphai[jc] == 0.) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; +/* L100: */ + } + } else { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + jc * vr_dim1] *= temp; + vr[jr + (jc + 1) * vr_dim1] *= temp; +/* L110: */ + } + } +L120: + ; + } + } + +/* Undo scaling if necessary */ + + if (ilascl) { + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & + ierr); + dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & + ierr); + } + + if (ilbscl) { + dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & + ierr); + } + +L130: + work[1] = (double) maxwrk; + + return 0; + +/* End of DGGEVX */ + +} /* dggevx_ */ + +/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, double * + a, integer *lda, double *b, integer *ldb, double *d__, + double *x, double *y, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b32 = -1.; + static double c_b34 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, nb, np, nb1, nb2, nb3, nb4, lopt; + integer lwkmin; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGGLM solves a general Gauss-Markov linear model (GLM) problem: */ + +/* minimize || y ||_2 subject to d = A*x + B*y */ +/* x */ + +/* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */ +/* given N-vector. It is assumed that M <= N <= M+P, and */ + +/* rank(A) = M and rank( A B ) = N. */ + +/* Under these assumptions, the constrained equation is always */ +/* consistent, and there is a unique solution x and a minimal 2-norm */ +/* solution y, which is obtained using a generalized QR factorization */ +/* of the matrices (A, B) given by */ + +/* A = Q*(R), B = Q*T*Z. */ +/* (0) */ + +/* In particular, if matrix B is square nonsingular, then the problem */ +/* GLM is equivalent to the following weighted linear least squares */ +/* problem */ + +/* minimize || inv(B)*(d-A*x) ||_2 */ +/* x */ + +/* where inv(B) denotes the inverse of B. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of rows of the matrices A and B. N >= 0. */ + +/* M (input) INTEGER */ +/* The number of columns of the matrix A. 0 <= M <= N. */ + +/* P (input) INTEGER */ +/* The number of columns of the matrix B. P >= N-M. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) */ +/* On entry, the N-by-M matrix A. */ +/* On exit, the upper triangular part of the array A contains */ +/* the M-by-M upper triangular matrix R. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,P) */ +/* On entry, the N-by-P matrix B. */ +/* On exit, if N <= P, the upper triangle of the subarray */ +/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */ +/* if N > P, the elements on and above the (N-P)th subdiagonal */ +/* contain the N-by-P upper trapezoidal matrix T. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, D is the left hand side of the GLM equation. */ +/* On exit, D is destroyed. */ + +/* X (output) DOUBLE PRECISION array, dimension (M) */ +/* Y (output) DOUBLE PRECISION array, dimension (P) */ +/* On exit, X and Y are the solutions of the GLM problem. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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+M+P). */ +/* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, */ +/* where NB is an upper bound for the optimal blocksizes for */ +/* DGEQRF, SGERQF, DORMQR and SORMRQ. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1: the upper triangular factor R associated with A in the */ +/* generalized QR factorization of the pair (A, B) is */ +/* singular, so that rank(A) < M; the least squares */ +/* solution could not be computed. */ +/* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */ +/* factor T associated with B in the generalized QR */ +/* factorization of the pair (A, B) is singular, so that */ +/* rank( A B ) < N; the least squares solution could not */ +/* be computed. */ + +/* =================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --d__; + --x; + --y; + --work; + + /* Function Body */ + *info = 0; + np = std::min(*n,*p); + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*m < 0 || *m > *n) { + *info = -2; + } else if (*p < 0 || *p < *n - *m) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + +/* Calculate workspace */ + + if (*info == 0) { + if (*n == 0) { + lwkmin = 1; + lwkopt = 1; + } else { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1); + nb2 = ilaenv_(&c__1, "DGERQF", " ", n, m, &c_n1, &c_n1); + nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1); + nb4 = ilaenv_(&c__1, "DORMRQ", " ", n, m, p, &c_n1); +/* Computing MAX */ + i__1 = std::max(nb1,nb2), i__1 = std::max(i__1,nb3); + nb = std::max(i__1,nb4); + lwkmin = *m + *n + *p; + lwkopt = *m + np + std::max(*n,*p) * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGGLM", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Compute the GQR factorization of matrices A and B: */ + +/* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */ +/* ( 0 ) N-M ( 0 T22 ) N-M */ +/* M M+P-N N-M */ + +/* where R11 and T22 are upper triangular, and Q and Z are */ +/* orthogonal. */ + + i__1 = *lwork - *m - np; + dggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m + + 1], &work[*m + np + 1], &i__1, info); + lopt = (integer) work[*m + np + 1]; + +/* Update left-hand-side vector d = Q'*d = ( d1 ) M */ +/* ( d2 ) N-M */ + + i__1 = std::max(1_integer,*n); + i__2 = *lwork - *m - np; + dormqr_("Left", "Transpose", n, &c__1, m, &a[a_offset], lda, &work[1], & + d__[1], &i__1, &work[*m + np + 1], &i__2, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[*m + np + 1]; + lopt = std::max(i__1,i__2); + +/* Solve T22*y2 = d2 for y2 */ + + if (*n > *m) { + i__1 = *n - *m; + i__2 = *n - *m; + dtrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1 + + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2, + info); + + if (*info > 0) { + *info = 1; + return 0; + } + + i__1 = *n - *m; + dcopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1); + } + +/* Set y1 = 0 */ + + i__1 = *m + *p - *n; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = 0.; +/* L10: */ + } + +/* Update d1 = d1 - T12*y2 */ + + i__1 = *n - *m; + dgemv_("No transpose", m, &i__1, &c_b32, &b[(*m + *p - *n + 1) * b_dim1 + + 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b34, &d__[1], &c__1); + +/* Solve triangular system: R11*x = d1 */ + + if (*m > 0) { + dtrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset], + lda, &d__[1], m, info); + + if (*info > 0) { + *info = 2; + return 0; + } + +/* Copy D to X */ + + dcopy_(m, &d__[1], &c__1, &x[1], &c__1); + } + +/* Backward transformation y = Z'*y */ + +/* Computing MAX */ + i__1 = 1, i__2 = *n - *p + 1; + i__3 = std::max(1_integer,*p); + i__4 = *lwork - *m - np; + dormrq_("Left", "Transpose", p, &c__1, &np, &b[std::max(i__1, i__2)+ b_dim1], + ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &i__4, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[*m + np + 1]; + work[1] = (double) (*m + np + std::max(i__1,i__2)); + + return 0; + +/* End of DGGGLM */ + +} /* dggglm_ */ + +/* Subroutine */ int dgghrd_(const char *compq, const char *compz, integer *n, integer * + ilo, integer *ihi, double *a, integer *lda, double *b, + integer *ldb, double *q, integer *ldq, double *z__, integer * + ldz, integer *info) +{ + /* Table of constant values */ + static double c_b10 = 0.; + static double c_b11 = 1.; + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2, i__3; + + /* Local variables */ + double c__, s; + bool ilq, ilz; + integer jcol; + double temp; + integer jrow; + integer icompq, icompz; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGHRD reduces a pair of real matrices (A,B) to generalized upper */ +/* Hessenberg form using orthogonal transformations, where A is a */ +/* general matrix and B is upper triangular. The form of the */ +/* generalized eigenvalue problem is */ +/* A*x = lambda*B*x, */ +/* and B is typically made upper triangular by computing its QR */ +/* factorization and moving the orthogonal matrix Q to the left side */ +/* of the equation. */ + +/* This subroutine simultaneously reduces A to a Hessenberg matrix H: */ +/* Q**T*A*Z = H */ +/* and transforms B to another upper triangular matrix T: */ +/* Q**T*B*Z = T */ +/* in order to reduce the problem to its standard form */ +/* H*y = lambda*T*y */ +/* where y = Z**T*x. */ + +/* The orthogonal matrices Q and Z are determined as products of Givens */ +/* rotations. They may either be formed explicitly, or they may be */ +/* postmultiplied into input matrices Q1 and Z1, so that */ + +/* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T */ + +/* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T */ + +/* If Q1 is the orthogonal matrix from the QR factorization of B in the */ +/* original equation A*x = lambda*B*x, then DGGHRD reduces the original */ +/* problem to generalized Hessenberg form. */ + +/* Arguments */ +/* ========= */ + +/* COMPQ (input) CHARACTER*1 */ +/* = 'N': do not compute Q; */ +/* = 'I': Q is initialized to the unit matrix, and the */ +/* orthogonal matrix Q is returned; */ +/* = 'V': Q must contain an orthogonal matrix Q1 on entry, */ +/* and the product Q1*Q is returned. */ + +/* COMPZ (input) CHARACTER*1 */ +/* = 'N': do not compute Z; */ +/* = 'I': Z is initialized to the unit matrix, and the */ +/* orthogonal matrix Z is returned; */ +/* = 'V': Z must contain an orthogonal matrix Z1 on entry, */ +/* and the product Z1*Z is returned. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* ILO and IHI mark the rows and columns of A which are to be */ +/* reduced. It is assumed that A is already upper triangular */ +/* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are */ +/* normally set by a previous call to SGGBAL; otherwise they */ +/* should be set to 1 and N respectively. */ +/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the N-by-N general matrix to be reduced. */ +/* On exit, the upper triangle and the first subdiagonal of A */ +/* are overwritten with the upper Hessenberg matrix H, and the */ +/* rest is set to zero. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the N-by-N upper triangular matrix B. */ +/* On exit, the upper triangular matrix T = Q**T B Z. The */ +/* elements below the diagonal are set to zero. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ +/* On entry, if COMPQ = 'V', the orthogonal matrix Q1, */ +/* typically from the QR factorization of B. */ +/* On exit, if COMPQ='I', the orthogonal matrix Q, and if */ +/* COMPQ = 'V', the product Q1*Q. */ +/* Not referenced if COMPQ='N'. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. */ +/* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* On entry, if COMPZ = 'V', the orthogonal matrix Z1. */ +/* On exit, if COMPZ='I', the orthogonal matrix Z, and if */ +/* COMPZ = 'V', the product Z1*Z. */ +/* Not referenced if COMPZ='N'. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. */ +/* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* This routine reduces A to Hessenberg and B to triangular form by */ +/* an unblocked reduction, as described in _Matrix_Computations_, */ +/* by Golub and Van Loan (Johns Hopkins Press.) */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode COMPQ */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + + /* Function Body */ + if (lsame_(compq, "N")) { + ilq = false; + icompq = 1; + } else if (lsame_(compq, "V")) { + ilq = true; + icompq = 2; + } else if (lsame_(compq, "I")) { + ilq = true; + icompq = 3; + } else { + icompq = 0; + } + +/* Decode COMPZ */ + + if (lsame_(compz, "N")) { + ilz = false; + icompz = 1; + } else if (lsame_(compz, "V")) { + ilz = true; + icompz = 2; + } else if (lsame_(compz, "I")) { + ilz = true; + icompz = 3; + } else { + icompz = 0; + } + +/* Test the input parameters. */ + + *info = 0; + if (icompq <= 0) { + *info = -1; + } else if (icompz <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1) { + *info = -4; + } else if (*ihi > *n || *ihi < *ilo - 1) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (ilq && *ldq < *n || *ldq < 1) { + *info = -11; + } else if (ilz && *ldz < *n || *ldz < 1) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGHRD", &i__1); + return 0; + } + +/* Initialize Q and Z if desired. */ + + if (icompq == 3) { + dlaset_("Full", n, n, &c_b10, &c_b11, &q[q_offset], ldq); + } + if (icompz == 3) { + dlaset_("Full", n, n, &c_b10, &c_b11, &z__[z_offset], ldz); + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + +/* Zero out lower triangle of B */ + + i__1 = *n - 1; + for (jcol = 1; jcol <= i__1; ++jcol) { + i__2 = *n; + for (jrow = jcol + 1; jrow <= i__2; ++jrow) { + b[jrow + jcol * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + +/* Reduce A and B */ + + i__1 = *ihi - 2; + for (jcol = *ilo; jcol <= i__1; ++jcol) { + + i__2 = jcol + 2; + for (jrow = *ihi; jrow >= i__2; --jrow) { + +/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */ + + temp = a[jrow - 1 + jcol * a_dim1]; + dlartg_(&temp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 + + jcol * a_dim1]); + a[jrow + jcol * a_dim1] = 0.; + i__3 = *n - jcol; + drot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + ( + jcol + 1) * a_dim1], lda, &c__, &s); + i__3 = *n + 2 - jrow; + drot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + ( + jrow - 1) * b_dim1], ldb, &c__, &s); + if (ilq) { + drot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1 + + 1], &c__1, &c__, &s); + } + +/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */ + + temp = b[jrow + jrow * b_dim1]; + dlartg_(&temp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow + + jrow * b_dim1]); + b[jrow + (jrow - 1) * b_dim1] = 0.; + drot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 + + 1], &c__1, &c__, &s); + i__3 = jrow - 1; + drot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1 + + 1], &c__1, &c__, &s); + if (ilz) { + drot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) * + z_dim1 + 1], &c__1, &c__, &s); + } +/* L30: */ + } +/* L40: */ + } + + return 0; + +/* End of DGGHRD */ + +} /* dgghrd_ */ + +/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, double * + a, integer *lda, double *b, integer *ldb, double *c__, + double *d__, double *x, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b31 = -1.; + static double c_b33 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt; + integer lwkmin; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGLSE solves the linear equality-constrained least squares (LSE) */ +/* problem: */ + +/* minimize || c - A*x ||_2 subject to B*x = d */ + +/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */ +/* M-vector, and d is a given P-vector. It is assumed that */ +/* P <= N <= M+P, and */ + +/* rank(B) = P and rank( (A) ) = N. */ +/* ( (B) ) */ + +/* These conditions ensure that the LSE problem has a unique solution, */ +/* which is obtained using a generalized RQ factorization of the */ +/* matrices (B, A) given by */ + +/* B = (0 R)*Q, A = Z*T*Q. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrices A and B. N >= 0. */ + +/* P (input) INTEGER */ +/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */ + +/* 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 T. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ +/* On entry, the P-by-N matrix B. */ +/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */ +/* contains the P-by-P upper triangular matrix R. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,P). */ + +/* C (input/output) DOUBLE PRECISION array, dimension (M) */ +/* On entry, C contains the right hand side vector for the */ +/* least squares part of the LSE problem. */ +/* On exit, the residual sum of squares for the solution */ +/* is given by the sum of squares of elements N-P+1 to M of */ +/* vector C. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (P) */ +/* On entry, D contains the right hand side vector for the */ +/* constrained equation. */ +/* On exit, D is destroyed. */ + +/* X (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, X is the solution of the LSE problem. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,M+N+P). */ +/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */ +/* where NB is an upper bound for the optimal blocksizes for */ +/* DGEQRF, SGERQF, DORMQR and SORMRQ. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1: the upper triangular factor R associated with B in the */ +/* generalized RQ factorization of the pair (B, A) is */ +/* singular, so that rank(B) < P; the least squares */ +/* solution could not be computed. */ +/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */ +/* T associated with A in the generalized RQ factorization */ +/* of the pair (B, A) is singular, so that */ +/* rank( (A) ) < N; the least squares solution could not */ +/* ( (B) ) */ +/* be computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --c__; + --d__; + --x; + --work; + + /* Function Body */ + *info = 0; + mn = std::min(*m,*n); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*p < 0 || *p > *n || *p < *n - *m) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*p)) { + *info = -7; + } + +/* Calculate workspace */ + + if (*info == 0) { + if (*n == 0) { + lwkmin = 1; + lwkopt = 1; + } else { + nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1); + nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); + nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, p, &c_n1); + nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1); +/* Computing MAX */ + i__1 = std::max(nb1,nb2), i__1 = std::max(i__1,nb3); + nb = std::max(i__1,nb4); + lwkmin = *m + *n + *p; + lwkopt = *p + mn + std::max(*m,*n) * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGLSE", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Compute the GRQ factorization of matrices B and A: */ + +/* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P */ +/* N-P P ( 0 R22 ) M+P-N */ +/* N-P P */ + +/* where T12 and R11 are upper triangular, and Q and Z are */ +/* orthogonal. */ + + i__1 = *lwork - *p - mn; + dggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p + + 1], &work[*p + mn + 1], &i__1, info); + lopt = (integer) work[*p + mn + 1]; + +/* Update c = Z'*c = ( c1 ) N-P */ +/* ( c2 ) M+P-N */ + + i__1 = std::max(1_integer,*m); + i__2 = *lwork - *p - mn; + dormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p + + 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[*p + mn + 1]; + lopt = std::max(i__1,i__2); + +/* Solve T12*x2 = d for x2 */ + + if (*p > 0) { + dtrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p + + 1) * b_dim1 + 1], ldb, &d__[1], p, info); + + if (*info > 0) { + *info = 1; + return 0; + } + +/* Put the solution in X */ + + dcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1); + +/* Update c1 */ + + i__1 = *n - *p; + dgemv_("No transpose", &i__1, p, &c_b31, &a[(*n - *p + 1) * a_dim1 + + 1], lda, &d__[1], &c__1, &c_b33, &c__[1], &c__1); + } + +/* Solve R11*x1 = c1 for x1 */ + + if (*n > *p) { + i__1 = *n - *p; + i__2 = *n - *p; + dtrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[ + a_offset], lda, &c__[1], &i__2, info); + + if (*info > 0) { + *info = 2; + return 0; + } + +/* Put the solutions in X */ + + i__1 = *n - *p; + dcopy_(&i__1, &c__[1], &c__1, &x[1], &c__1); + } + +/* Compute the residual vector: */ + + if (*m < *n) { + nr = *m + *p - *n; + if (nr > 0) { + i__1 = *n - *m; + dgemv_("No transpose", &nr, &i__1, &c_b31, &a[*n - *p + 1 + (*m + + 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b33, &c__[*n - + *p + 1], &c__1); + } + } else { + nr = *p; + } + if (nr > 0) { + dtrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n + - *p + 1) * a_dim1], lda, &d__[1], &c__1); + daxpy_(&nr, &c_b31, &d__[1], &c__1, &c__[*n - *p + 1], &c__1); + } + +/* Backward transformation x = Q'*x */ + + i__1 = *lwork - *p - mn; + dormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[ + 1], n, &work[*p + mn + 1], &i__1, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[*p + mn + 1]; + work[1] = (double) (*p + mn + std::max(i__1,i__2)); + + return 0; + +/* End of DGGLSE */ + +} /* dgglse_ */ + +/* Subroutine */ int dggqrf_(integer *n, integer *m, integer *p, double * + a, integer *lda, double *taua, double *b, integer *ldb, + double *taub, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer nb, nb1, nb2, nb3, lopt; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGQRF computes a generalized QR factorization of an N-by-M matrix A */ +/* and an N-by-P matrix B: */ + +/* A = Q*R, B = Q*T*Z, */ + +/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */ +/* matrix, and R and T assume one of the forms: */ + +/* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, */ +/* ( 0 ) N-M N M-N */ +/* M */ + +/* where R11 is upper triangular, and */ + +/* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, */ +/* P-N N ( T21 ) P */ +/* P */ + +/* where T12 or T21 is upper triangular. */ + +/* In particular, if B is square and nonsingular, the GQR factorization */ +/* of A and B implicitly gives the QR factorization of inv(B)*A: */ + +/* inv(B)*A = Z'*(inv(T)*R) */ + +/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */ +/* transpose of the matrix Z. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of rows of the matrices A and B. N >= 0. */ + +/* M (input) INTEGER */ +/* The number of columns of the matrix A. M >= 0. */ + +/* P (input) INTEGER */ +/* The number of columns of the matrix B. P >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) */ +/* On entry, the N-by-M matrix A. */ +/* On exit, the elements on and above the diagonal of the array */ +/* contain the min(N,M)-by-M upper trapezoidal matrix R (R is */ +/* upper triangular if N >= M); the elements below the diagonal, */ +/* with the array TAUA, represent the orthogonal matrix Q as a */ +/* product of min(N,M) elementary reflectors (see Further */ +/* Details). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* TAUA (output) DOUBLE PRECISION array, dimension (min(N,M)) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix Q (see Further Details). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,P) */ +/* On entry, the N-by-P matrix B. */ +/* On exit, if N <= P, the upper triangle of the subarray */ +/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */ +/* if N > P, the elements on and above the (N-P)-th subdiagonal */ +/* contain the N-by-P upper trapezoidal matrix T; the remaining */ +/* elements, with the array TAUB, represent the orthogonal */ +/* matrix Z as a product of elementary reflectors (see Further */ +/* Details). */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* TAUB (output) DOUBLE PRECISION array, dimension (min(N,P)) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix Z (see Further Details). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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,M,P). */ +/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */ +/* where NB1 is the optimal blocksize for the QR factorization */ +/* of an N-by-M matrix, NB2 is the optimal blocksize for the */ +/* RQ factorization of an N-by-P matrix, and NB3 is the optimal */ +/* blocksize for a call of DORMQR. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* 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(n,m). */ + +/* Each H(i) has the form */ + +/* H(i) = I - taua * v * v' */ + +/* where taua is a real scalar, and v is a real vector with */ +/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ +/* and taua in TAUA(i). */ +/* To form Q explicitly, use LAPACK subroutine DORGQR. */ +/* To use Q to update another matrix, use LAPACK subroutine DORMQR. */ + +/* The matrix Z is represented as a product of elementary reflectors */ + +/* Z = H(1) H(2) . . . H(k), where k = min(n,p). */ + +/* Each H(i) has the form */ + +/* H(i) = I - taub * v * v' */ + +/* where taub is a real scalar, and v is a real vector with */ +/* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in */ +/* B(n-k+i,1:p-k+i-1), and taub in TAUB(i). */ +/* To form Z explicitly, use LAPACK subroutine DORGRQ. */ +/* To use Z to update another matrix, use LAPACK subroutine DORMRQ. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --taua; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --taub; + --work; + + /* Function Body */ + *info = 0; + nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1); + nb2 = ilaenv_(&c__1, "DGERQF", " ", n, p, &c_n1, &c_n1); + nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1); +/* Computing MAX */ + i__1 = std::max(nb1,nb2); + nb = std::max(i__1,nb3); +/* Computing MAX */ + i__1 = std::max(*n,*m); + lwkopt = std::max(i__1,*p) * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*p < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = std::max(1_integer,*n), i__1 = std::max(i__1,*m); + if (*lwork < std::max(i__1,*p) && ! lquery) { + *info = -11; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGQRF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* QR factorization of N-by-M matrix A: A = Q*R */ + + dgeqrf_(n, m, &a[a_offset], lda, &taua[1], &work[1], lwork, info); + lopt = (integer) work[1]; + +/* Update B := Q'*B. */ + + i__1 = std::min(*n,*m); + dormqr_("Left", "Transpose", n, p, &i__1, &a[a_offset], lda, &taua[1], &b[ + b_offset], ldb, &work[1], lwork, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[1]; + lopt = std::max(i__1,i__2); + +/* RQ factorization of N-by-P matrix B: B = T*Z. */ + + dgerqf_(n, p, &b[b_offset], ldb, &taub[1], &work[1], lwork, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[1]; + work[1] = (double) std::max(i__1,i__2); + + return 0; + +/* End of DGGQRF */ + +} /* dggqrf_ */ + +/* Subroutine */ int dggrqf_(integer *m, integer *p, integer *n, double * + a, integer *lda, double *taua, double *b, integer *ldb, + double *taub, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer nb, nb1, nb2, nb3, lopt; + integer lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A */ +/* and a P-by-N matrix B: */ + +/* A = R*Q, B = Z*T*Q, */ + +/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */ +/* matrix, and R and T assume one of the forms: */ + +/* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, */ +/* N-M M ( R21 ) N */ +/* N */ + +/* where R12 or R21 is upper triangular, and */ + +/* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, */ +/* ( 0 ) P-N P N-P */ +/* N */ + +/* where T11 is upper triangular. */ + +/* In particular, if B is square and nonsingular, the GRQ factorization */ +/* of A and B implicitly gives the RQ factorization of A*inv(B): */ + +/* A*inv(B) = (R*inv(T))*Z' */ + +/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */ +/* transpose of the matrix Z. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. M >= 0. */ + +/* P (input) INTEGER */ +/* The number of rows of the matrix B. P >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, if M <= N, the upper triangle of the subarray */ +/* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; */ +/* if M > N, the elements on and above the (M-N)-th subdiagonal */ +/* contain the M-by-N upper trapezoidal matrix R; the remaining */ +/* elements, with the array TAUA, 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). */ + +/* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N)) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix Q (see Further Details). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ +/* On entry, the P-by-N matrix B. */ +/* On exit, the elements on and above the diagonal of the array */ +/* contain the min(P,N)-by-N upper trapezoidal matrix T (T is */ +/* upper triangular if P >= N); the elements below the diagonal, */ +/* with the array TAUB, represent the orthogonal matrix Z as a */ +/* product of elementary reflectors (see Further Details). */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,P). */ + +/* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N)) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix Z (see Further Details). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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,M,P). */ +/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */ +/* where NB1 is the optimal blocksize for the RQ factorization */ +/* of an M-by-N matrix, NB2 is the optimal blocksize for the */ +/* QR factorization of a P-by-N matrix, and NB3 is the optimal */ +/* blocksize for a call of DORMRQ. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INF0= -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 - taua * v * v' */ + +/* where taua is a real scalar, and v is a real vector with */ +/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */ +/* A(m-k+i,1:n-k+i-1), and taua in TAUA(i). */ +/* To form Q explicitly, use LAPACK subroutine DORGRQ. */ +/* To use Q to update another matrix, use LAPACK subroutine DORMRQ. */ + +/* The matrix Z is represented as a product of elementary reflectors */ + +/* Z = H(1) H(2) . . . H(k), where k = min(p,n). */ + +/* Each H(i) has the form */ + +/* H(i) = I - taub * v * v' */ + +/* where taub is a real scalar, and v is a real vector with */ +/* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), */ +/* and taub in TAUB(i). */ +/* To form Z explicitly, use LAPACK subroutine DORGQR. */ +/* To use Z to update another matrix, use LAPACK subroutine DORMQR. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --taua; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --taub; + --work; + + /* Function Body */ + *info = 0; + nb1 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); + nb2 = ilaenv_(&c__1, "DGEQRF", " ", p, n, &c_n1, &c_n1); + nb3 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1); +/* Computing MAX */ + i__1 = std::max(nb1,nb2); + nb = std::max(i__1,nb3); +/* Computing MAX */ + i__1 = std::max(*n,*m); + lwkopt = std::max(i__1,*p) * nb; + work[1] = (double) lwkopt; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*p < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*p)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = std::max(1_integer,*m), i__1 = std::max(i__1,*p); + if (*lwork < std::max(i__1,*n) && ! lquery) { + *info = -11; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGRQF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* RQ factorization of M-by-N matrix A: A = R*Q */ + + dgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info); + lopt = (integer) work[1]; + +/* Update B := B*Q' */ + + i__1 = std::min(*m,*n); +/* Computing MAX */ + i__2 = 1, i__3 = *m - *n + 1; + dormrq_("Right", "Transpose", p, n, &i__1, &a[std::max(i__2, i__3)+ a_dim1], + lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[1]; + lopt = std::max(i__1,i__2); + +/* QR factorization of P-by-N matrix B: B = Z*T */ + + dgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info); +/* Computing MAX */ + i__1 = lopt, i__2 = (integer) work[1]; + work[1] = (double) std::max(i__1,i__2); + + return 0; + +/* End of DGGRQF */ + +} /* dggrqf_ */ + +/* Subroutine */ int dggsvd_(const char *jobu, const char *jobv, const char *jobq, integer *m, + integer *n, integer *p, integer *k, integer *l, double *a, + integer *lda, double *b, integer *ldb, double *alpha, + double *beta, double *u, integer *ldu, double *v, integer + *ldv, double *q, integer *ldq, double *work, integer *iwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + double ulp; + integer ibnd; + double tola; + integer isub; + double tolb, unfl, temp, smax; + double anorm, bnorm; + bool wantq, wantu, wantv; + integer ncycle; + +/* -- LAPACK driver routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGSVD computes the generalized singular value decomposition (GSVD) */ +/* of an M-by-N real matrix A and P-by-N real matrix B: */ + +/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ) */ + +/* where U, V and Q are orthogonal matrices, and Z' is the transpose */ +/* of Z. Let K+L = the effective numerical rank of the matrix (A',B')', */ +/* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */ +/* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */ +/* following structures, respectively: */ + +/* If M-K-L >= 0, */ + +/* K L */ +/* D1 = K ( I 0 ) */ +/* L ( 0 C ) */ +/* M-K-L ( 0 0 ) */ + +/* K L */ +/* D2 = L ( 0 S ) */ +/* P-L ( 0 0 ) */ + +/* N-K-L K L */ +/* ( 0 R ) = K ( 0 R11 R12 ) */ +/* L ( 0 0 R22 ) */ + +/* where */ + +/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* C**2 + S**2 = I. */ + +/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */ + +/* If M-K-L < 0, */ + +/* K M-K K+L-M */ +/* D1 = K ( I 0 0 ) */ +/* M-K ( 0 C 0 ) */ + +/* K M-K K+L-M */ +/* D2 = M-K ( 0 S 0 ) */ +/* K+L-M ( 0 0 I ) */ +/* P-L ( 0 0 0 ) */ + +/* N-K-L K M-K K+L-M */ +/* ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* M-K ( 0 0 R22 R23 ) */ +/* K+L-M ( 0 0 0 R33 ) */ + +/* where */ + +/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* S = diag( BETA(K+1), ... , BETA(M) ), */ +/* C**2 + S**2 = I. */ + +/* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */ +/* ( 0 R22 R23 ) */ +/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */ + +/* The routine computes C, S, R, and optionally the orthogonal */ +/* transformation matrices U, V and Q. */ + +/* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */ +/* A and B implicitly gives the SVD of A*inv(B): */ +/* A*inv(B) = U*(D1*inv(D2))*V'. */ +/* If ( A',B')' has orthonormal columns, then the GSVD of A and B is */ +/* also equal to the CS decomposition of A and B. Furthermore, the GSVD */ +/* can be used to derive the solution of the eigenvalue problem: */ +/* A'*A x = lambda* B'*B x. */ +/* In some literature, the GSVD of A and B is presented in the form */ +/* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 ) */ +/* where U and V are orthogonal and X is nonsingular, D1 and D2 are */ +/* ``diagonal''. The former GSVD form can be converted to the latter */ +/* form by taking the nonsingular matrix X as */ + +/* X = Q*( I 0 ) */ +/* ( 0 inv(R) ). */ + +/* Arguments */ +/* ========= */ + +/* JOBU (input) CHARACTER*1 */ +/* = 'U': Orthogonal matrix U is computed; */ +/* = 'N': U is not computed. */ + +/* JOBV (input) CHARACTER*1 */ +/* = 'V': Orthogonal matrix V is computed; */ +/* = 'N': V is not computed. */ + +/* JOBQ (input) CHARACTER*1 */ +/* = 'Q': Orthogonal matrix Q is computed; */ +/* = 'N': Q is not computed. */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrices A and B. N >= 0. */ + +/* P (input) INTEGER */ +/* The number of rows of the matrix B. P >= 0. */ + +/* K (output) INTEGER */ +/* L (output) INTEGER */ +/* On exit, K and L specify the dimension of the subblocks */ +/* described in the Purpose section. */ +/* K + L = effective numerical rank of (A',B')'. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, A contains the triangular matrix R, or part of R. */ +/* See Purpose for details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ +/* On entry, the P-by-N matrix B. */ +/* On exit, B contains the triangular matrix R if M-K-L < 0. */ +/* See Purpose for details. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,P). */ + +/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */ +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, ALPHA and BETA contain the generalized singular */ +/* value pairs of A and B; */ +/* ALPHA(1:K) = 1, */ +/* BETA(1:K) = 0, */ +/* and if M-K-L >= 0, */ +/* ALPHA(K+1:K+L) = C, */ +/* BETA(K+1:K+L) = S, */ +/* or if M-K-L < 0, */ +/* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */ +/* BETA(K+1:M) =S, BETA(M+1:K+L) =1 */ +/* and */ +/* ALPHA(K+L+1:N) = 0 */ +/* BETA(K+L+1:N) = 0 */ + +/* U (output) DOUBLE PRECISION array, dimension (LDU,M) */ +/* If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */ +/* If JOBU = 'N', U is not referenced. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= max(1,M) if */ +/* JOBU = 'U'; LDU >= 1 otherwise. */ + +/* V (output) DOUBLE PRECISION array, dimension (LDV,P) */ +/* If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */ +/* If JOBV = 'N', V is not referenced. */ + +/* LDV (input) INTEGER */ +/* The leading dimension of the array V. LDV >= max(1,P) if */ +/* JOBV = 'V'; LDV >= 1 otherwise. */ + +/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */ +/* If JOBQ = 'N', Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N) if */ +/* JOBQ = 'Q'; LDQ >= 1 otherwise. */ + +/* WORK (workspace) DOUBLE PRECISION array, */ +/* dimension (max(3*N,M,P)+N) */ + +/* IWORK (workspace/output) INTEGER array, dimension (N) */ +/* On exit, IWORK stores the sorting information. More */ +/* precisely, the following loop will sort ALPHA */ +/* for I = K+1, min(M,K+L) */ +/* swap ALPHA(I) and ALPHA(IWORK(I)) */ +/* endfor */ +/* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, the Jacobi-type procedure failed to */ +/* converge. For further details, see subroutine DTGSJA. */ + +/* Internal Parameters */ +/* =================== */ + +/* TOLA DOUBLE PRECISION */ +/* TOLB DOUBLE PRECISION */ +/* TOLA and TOLB are the thresholds to determine the effective */ +/* rank of (A',B')'. Generally, they are set to */ +/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */ +/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */ +/* The size of TOLA and TOLB may affect the size of backward */ +/* errors of the decomposition. */ + +/* Further Details */ +/* =============== */ + +/* 2-96 Based on modifications by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --work; + --iwork; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*p < 0) { + *info = -6; + } else if (*lda < std::max(1_integer,*m)) { + *info = -10; + } else if (*ldb < std::max(1_integer,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGSVD", &i__1); + return 0; + } + +/* Compute the Frobenius norm of matrices A and B */ + + anorm = dlange_("1", m, n, &a[a_offset], lda, &work[1]); + bnorm = dlange_("1", p, n, &b[b_offset], ldb, &work[1]); + +/* Get machine precision and set up threshold for determining */ +/* the effective numerical rank of the matrices A and B. */ + + ulp = dlamch_("Precision"); + unfl = dlamch_("Safe Minimum"); + tola = std::max(*m,*n) * std::max(anorm,unfl) * ulp; + tolb = std::max(*p,*n) * std::max(bnorm,unfl) * ulp; + +/* Preprocessing */ + + dggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, & + tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[ + q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], info); + +/* Compute the GSVD of two upper "triangular" matrices */ + + dtgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset], + ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[ + v_offset], ldv, &q[q_offset], ldq, &work[1], &ncycle, info); + +/* Sort the singular values and store the pivot indices in IWORK */ +/* Copy ALPHA to WORK, then sort ALPHA in WORK */ + + dcopy_(n, &alpha[1], &c__1, &work[1], &c__1); +/* Computing MIN */ + i__1 = *l, i__2 = *m - *k; + ibnd = std::min(i__1,i__2); + i__1 = ibnd; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for largest ALPHA(K+I) */ + + isub = i__; + smax = work[*k + i__]; + i__2 = ibnd; + for (j = i__ + 1; j <= i__2; ++j) { + temp = work[*k + j]; + if (temp > smax) { + isub = j; + smax = temp; + } +/* L10: */ + } + if (isub != i__) { + work[*k + isub] = work[*k + i__]; + work[*k + i__] = smax; + iwork[*k + i__] = *k + isub; + } else { + iwork[*k + i__] = *k + i__; + } +/* L20: */ + } + + return 0; + +/* End of DGGSVD */ + +} /* dggsvd_ */ + +/* Subroutine */ int dggsvp_(const char *jobu, const char *jobv, const char *jobq, integer *m, + integer *p, integer *n, double *a, integer *lda, double *b, + integer *ldb, double *tola, double *tolb, integer *k, integer + *l, double *u, integer *ldu, double *v, integer *ldv, + double *q, integer *ldq, integer *iwork, double *tau, + double *work, integer *info) +{ + /* Table of constant values */ + static double c_b12 = 0.; + static double c_b22 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer i__, j; + bool wantq, wantu, wantv; + bool forwrd; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGGSVP computes orthogonal matrices U, V and Q such that */ + +/* N-K-L K L */ +/* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* L ( 0 0 A23 ) */ +/* M-K-L ( 0 0 0 ) */ + +/* N-K-L K L */ +/* = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* M-K ( 0 0 A23 ) */ + +/* N-K-L K L */ +/* V'*B*Q = L ( 0 0 B13 ) */ +/* P-L ( 0 0 0 ) */ + +/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */ +/* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the */ +/* transpose of Z. */ + +/* This decomposition is the preprocessing step for computing the */ +/* Generalized Singular Value Decomposition (GSVD), see subroutine */ +/* DGGSVD. */ + +/* Arguments */ +/* ========= */ + +/* JOBU (input) CHARACTER*1 */ +/* = 'U': Orthogonal matrix U is computed; */ +/* = 'N': U is not computed. */ + +/* JOBV (input) CHARACTER*1 */ +/* = 'V': Orthogonal matrix V is computed; */ +/* = 'N': V is not computed. */ + +/* JOBQ (input) CHARACTER*1 */ +/* = 'Q': Orthogonal matrix Q is computed; */ +/* = 'N': Q is not computed. */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. M >= 0. */ + +/* P (input) INTEGER */ +/* The number of rows of the matrix B. P >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, A contains the triangular (or trapezoidal) matrix */ +/* described in the Purpose section. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ +/* On entry, the P-by-N matrix B. */ +/* On exit, B contains the triangular matrix described in */ +/* the Purpose section. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,P). */ + +/* TOLA (input) DOUBLE PRECISION */ +/* TOLB (input) DOUBLE PRECISION */ +/* TOLA and TOLB are the thresholds to determine the effective */ +/* numerical rank of matrix B and a subblock of A. Generally, */ +/* they are set to */ +/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */ +/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */ +/* The size of TOLA and TOLB may affect the size of backward */ +/* errors of the decomposition. */ + +/* K (output) INTEGER */ +/* L (output) INTEGER */ +/* On exit, K and L specify the dimension of the subblocks */ +/* described in Purpose. */ +/* K + L = effective numerical rank of (A',B')'. */ + +/* U (output) DOUBLE PRECISION array, dimension (LDU,M) */ +/* If JOBU = 'U', U contains the orthogonal matrix U. */ +/* If JOBU = 'N', U is not referenced. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= max(1,M) if */ +/* JOBU = 'U'; LDU >= 1 otherwise. */ + +/* V (output) DOUBLE PRECISION array, dimension (LDV,M) */ +/* If JOBV = 'V', V contains the orthogonal matrix V. */ +/* If JOBV = 'N', V is not referenced. */ + +/* LDV (input) INTEGER */ +/* The leading dimension of the array V. LDV >= max(1,P) if */ +/* JOBV = 'V'; LDV >= 1 otherwise. */ + +/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* If JOBQ = 'Q', Q contains the orthogonal matrix Q. */ +/* If JOBQ = 'N', Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N) if */ +/* JOBQ = 'Q'; LDQ >= 1 otherwise. */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* TAU (workspace) DOUBLE PRECISION array, dimension (N) */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P)) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + + +/* Further Details */ +/* =============== */ + +/* The subroutine uses LAPACK subroutine DGEQPF for the QR factorization */ +/* with column pivoting to detect the effective numerical rank of the */ +/* a matrix. It may be replaced by a better rank determination strategy. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --iwork; + --tau; + --work; + + /* Function Body */ + wantu = lsame_(jobu, "U"); + wantv = lsame_(jobv, "V"); + wantq = lsame_(jobq, "Q"); + forwrd = true; + + *info = 0; + if (! (wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (wantv || lsame_(jobv, "N"))) { + *info = -2; + } else if (! (wantq || lsame_(jobq, "N"))) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < std::max(1_integer,*m)) { + *info = -8; + } else if (*ldb < std::max(1_integer,*p)) { + *info = -10; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -16; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -18; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGGSVP", &i__1); + return 0; + } + +/* QR with column pivoting of B: B*P = V*( S11 S12 ) */ +/* ( 0 0 ) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + dgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info); + +/* Update A := A*P */ + + dlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); + +/* Determine the effective rank of matrix B. */ + + *l = 0; + i__1 = std::min(*p,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) > *tolb) { + ++(*l); + } +/* L20: */ + } + + if (wantv) { + +/* Copy the details of V, and form V. */ + + dlaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv); + if (*p > 1) { + i__1 = *p - 1; + dlacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], + ldv); + } + i__1 = std::min(*p,*n); + dorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); + } + +/* Clean up B */ + + i__1 = *l - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L30: */ + } +/* L40: */ + } + if (*p > *l) { + i__1 = *p - *l; + dlaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb); + } + + if (wantq) { + +/* Set Q = I and Update Q := Q*P */ + + dlaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq); + dlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); + } + + if (*p >= *l && *n != *l) { + +/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */ + + dgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); + +/* Update A := A*Z' */ + + dormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[ + a_offset], lda, &work[1], info); + + if (wantq) { + +/* Update Q := Q*Z' */ + + dormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1], + &q[q_offset], ldq, &work[1], info); + } + +/* Clean up B */ + + i__1 = *n - *l; + dlaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb); + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + + } + +/* Let N-L L */ +/* A = ( A11 A12 ) M, */ + +/* then the following does the complete QR decomposition of A11: */ + +/* A11 = U*( 0 T12 )*P1' */ +/* ( 0 0 ) */ + + i__1 = *n - *l; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L70: */ + } + i__1 = *n - *l; + dgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info); + +/* Determine the effective rank of A11 */ + + *k = 0; +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = std::min(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) > *tola) { + ++(*k); + } +/* L80: */ + } + +/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = std::min(i__2,i__3); + dorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[( + *n - *l + 1) * a_dim1 + 1], lda, &work[1], info); + + if (wantu) { + +/* Copy the details of U, and form U */ + + dlaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu); + if (*m > 1) { + i__1 = *m - 1; + i__2 = *n - *l; + dlacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] +, ldu); + } +/* Computing MIN */ + i__2 = *m, i__3 = *n - *l; + i__1 = std::min(i__2,i__3); + dorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); + } + + if (wantq) { + +/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ + + i__1 = *n - *l; + dlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); + } + +/* Clean up A: set the strictly lower triangular part of */ +/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L90: */ + } +/* L100: */ + } + if (*m > *k) { + i__1 = *m - *k; + i__2 = *n - *l; + dlaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1], + lda); + } + + if (*n - *l > *k) { + +/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ + + i__1 = *n - *l; + dgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); + + if (wantq) { + +/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */ + + i__1 = *n - *l; + dormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, & + tau[1], &q[q_offset], ldq, &work[1], info); + } + +/* Clean up A */ + + i__1 = *n - *l - *k; + dlaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda); + i__1 = *n - *l; + for (j = *n - *l - *k + 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L110: */ + } +/* L120: */ + } + + } + + if (*m > *k) { + +/* QR factorization of A( K+1:M,N-L+1:N ) */ + + i__1 = *m - *k; + dgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & + work[1], info); + + if (wantu) { + +/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ + + i__1 = *m - *k; +/* Computing MIN */ + i__3 = *m - *k; + i__2 = std::min(i__3,*l); + dorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n + - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + + 1], ldu, &work[1], info); + } + +/* Clean up */ + + i__1 = *n; + for (j = *n - *l + 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L130: */ + } +/* L140: */ + } + + } + + return 0; + +/* End of DGGSVP */ + +} /* dggsvp_ */ + +/* Subroutine */ int dgtcon_(const char *norm, integer *n, double *dl, + double *d__, double *du, double *du2, integer *ipiv, + double *anorm, double *rcond, double *work, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, kase, kase1; + integer isave[3]; + double ainvnm; + bool onenrm; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGTCON estimates the reciprocal of the condition number of a real */ +/* tridiagonal matrix A using the LU factorization as computed by */ +/* DGTTRF. */ + +/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies whether the 1-norm condition number or the */ +/* infinity-norm condition number is required: */ +/* = '1' or 'O': 1-norm; */ +/* = 'I': Infinity-norm. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) multipliers that define the matrix L from the */ +/* LU factorization of A as computed by DGTTRF. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the upper triangular matrix U from */ +/* the LU factorization of A. */ + +/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) elements of the first superdiagonal of U. */ + +/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */ +/* The (n-2) elements of the second superdiagonal of U. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* interchanged with row IPIV(i). IPIV(i) will always be either */ +/* i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* required. */ + +/* ANORM (input) DOUBLE PRECISION */ +/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ +/* If NORM = 'I', the infinity-norm of the original matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* estimate of the 1-norm of inv(A) computed in this routine. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments. */ + + /* Parameter adjustments */ + --iwork; + --work; + --ipiv; + --du2; + --du; + --d__; + --dl; + + /* Function Body */ + *info = 0; + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*anorm < 0.) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + +/* Check that D(1:N) is non-zero. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] == 0.) { + return 0; + } +/* L10: */ + } + + ainvnm = 0.; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L20: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(U)*inv(L). */ + + dgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1] +, &ipiv[1], &work[1], n, info); + } else { + +/* Multiply by inv(L')*inv(U'). */ + + dgttrs_("Transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1], & + ipiv[1], &work[1], n, info); + } + goto L20; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + + return 0; + +/* End of DGTCON */ + +} /* dgtcon_ */ + +/* Subroutine */ int dgtrfs_(const char *trans, integer *n, integer *nrhs, + double *dl, double *d__, double *du, double *dlf, + double *df, double *duf, double *du2, integer *ipiv, + double *b, integer *ldb, double *x, integer *ldx, double * + ferr, double *berr, double *work, integer *iwork, integer * + info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b18 = -1.; + static double c_b19 = 1.; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, j; + double s; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + integer count; + double safmin; + bool notran; + char transn[1]; + char transt[1]; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGTRFS improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is tridiagonal, and provides */ +/* error bounds and backward error estimates for the solution. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of A. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of A. */ + +/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) superdiagonal elements of A. */ + +/* DLF (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) multipliers that define the matrix L from the */ +/* LU factorization of A as computed by DGTTRF. */ + +/* DF (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the upper triangular matrix U from */ +/* the LU factorization of A. */ + +/* DUF (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) elements of the first superdiagonal of U. */ + +/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */ +/* The (n-2) elements of the second superdiagonal of U. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* interchanged with row IPIV(i). IPIV(i) will always be either */ +/* i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* required. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DGTTRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --dl; + --d__; + --du; + --dlf; + --df; + --duf; + --du2; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -13; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transn = 'N'; + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transn = 'T'; + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = 4; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dlagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j * + x_dim1 + 1], ldx, &c_b19, &work[*n + 1], n); + +/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward */ +/* error bound. */ + + if (notran) { + if (*n == 1) { + work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ + 1] * x[j * x_dim1 + 1], abs(d__2)); + } else { + work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ + 1] * x[j * x_dim1 + 1], abs(d__2)) + (d__3 = du[1] * + x[j * x_dim1 + 2], abs(d__3)); + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)) + ( + d__2 = dl[i__ - 1] * x[i__ - 1 + j * x_dim1], abs( + d__2)) + (d__3 = d__[i__] * x[i__ + j * x_dim1], + abs(d__3)) + (d__4 = du[i__] * x[i__ + 1 + j * + x_dim1], abs(d__4)); +/* L30: */ + } + work[*n] = (d__1 = b[*n + j * b_dim1], abs(d__1)) + (d__2 = + dl[*n - 1] * x[*n - 1 + j * x_dim1], abs(d__2)) + ( + d__3 = d__[*n] * x[*n + j * x_dim1], abs(d__3)); + } + } else { + if (*n == 1) { + work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ + 1] * x[j * x_dim1 + 1], abs(d__2)); + } else { + work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[ + 1] * x[j * x_dim1 + 1], abs(d__2)) + (d__3 = dl[1] * + x[j * x_dim1 + 2], abs(d__3)); + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)) + ( + d__2 = du[i__ - 1] * x[i__ - 1 + j * x_dim1], abs( + d__2)) + (d__3 = d__[i__] * x[i__ + j * x_dim1], + abs(d__3)) + (d__4 = dl[i__] * x[i__ + 1 + j * + x_dim1], abs(d__4)); +/* L40: */ + } + work[*n] = (d__1 = b[*n + j * b_dim1], abs(d__1)) + (d__2 = + du[*n - 1] * x[*n - 1 + j * x_dim1], abs(d__2)) + ( + d__3 = d__[*n] * x[*n + j * x_dim1], abs(d__3)); + } + } + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L50: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[ + 1], &work[*n + 1], n, info); + daxpy_(n, &c_b19, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L60: */ + } + + kase = 0; +L70: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + dgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], & + ipiv[1], &work[*n + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L80: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L90: */ + } + dgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], & + ipiv[1], &work[*n + 1], n, info); + } + goto L70; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L100: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L110: */ + } + + return 0; + +/* End of DGTRFS */ + +} /* dgtrfs_ */ + +/* Subroutine */ int dgtsv_(integer *n, integer *nrhs, double *dl, + double *d__, double *du, double *b, integer *ldb, integer + *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double fact, temp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGTSV solves the equation */ + +/* A*X = B, */ + +/* where A is an n by n tridiagonal matrix, by Gaussian elimination with */ +/* partial pivoting. */ + +/* Note that the equation A'*X = B may be solved by interchanging the */ +/* order of the arguments DU and DL. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* DL (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, DL must contain the (n-1) sub-diagonal elements of */ +/* A. */ + +/* On exit, DL is overwritten by the (n-2) elements of the */ +/* second super-diagonal of the upper triangular matrix U from */ +/* the LU factorization of A, in DL(1), ..., DL(n-2). */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, D must contain the diagonal elements of A. */ + +/* On exit, D is overwritten by the n diagonal elements of U. */ + +/* DU (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, DU must contain the (n-1) super-diagonal elements */ +/* of A. */ + +/* On exit, DU is overwritten by the (n-1) elements of the first */ +/* super-diagonal of U. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N by NRHS matrix of right hand side matrix B. */ +/* On exit, if INFO = 0, the N by NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, U(i,i) is exactly zero, and the solution */ +/* has not been computed. The factorization has not been */ +/* completed unless i = N. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --dl; + --d__; + --du; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTSV ", &i__1); + return 0; + } + + if (*n == 0) { + return 0; + } + + if (*nrhs == 1) { + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + +/* No row interchange required */ + + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + d__[i__ + 1] -= fact * du[i__]; + b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1]; + } else { + *info = i__; + return 0; + } + dl[i__] = 0.; + } else { + +/* Interchange rows I and I+1 */ + + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + temp = d__[i__ + 1]; + d__[i__ + 1] = du[i__] - fact * temp; + dl[i__] = du[i__ + 1]; + du[i__ + 1] = -fact * dl[i__]; + du[i__] = temp; + temp = b[i__ + b_dim1]; + b[i__ + b_dim1] = b[i__ + 1 + b_dim1]; + b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1]; + } +/* L10: */ + } + if (*n > 1) { + i__ = *n - 1; + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + d__[i__ + 1] -= fact * du[i__]; + b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1]; + } else { + *info = i__; + return 0; + } + } else { + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + temp = d__[i__ + 1]; + d__[i__ + 1] = du[i__] - fact * temp; + du[i__] = temp; + temp = b[i__ + b_dim1]; + b[i__ + b_dim1] = b[i__ + 1 + b_dim1]; + b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1]; + } + } + if (d__[*n] == 0.) { + *info = *n; + return 0; + } + } else { + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + +/* No row interchange required */ + + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + d__[i__ + 1] -= fact * du[i__]; + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1]; +/* L20: */ + } + } else { + *info = i__; + return 0; + } + dl[i__] = 0.; + } else { + +/* Interchange rows I and I+1 */ + + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + temp = d__[i__ + 1]; + d__[i__ + 1] = du[i__] - fact * temp; + dl[i__] = du[i__ + 1]; + du[i__ + 1] = -fact * dl[i__]; + du[i__] = temp; + i__2 = *nrhs; + for (j = 1; j <= i__2; ++j) { + temp = b[i__ + j * b_dim1]; + b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j * + b_dim1]; +/* L30: */ + } + } +/* L40: */ + } + if (*n > 1) { + i__ = *n - 1; + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + d__[i__ + 1] -= fact * du[i__]; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1]; +/* L50: */ + } + } else { + *info = i__; + return 0; + } + } else { + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + temp = d__[i__ + 1]; + d__[i__ + 1] = du[i__] - fact * temp; + du[i__] = temp; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + temp = b[i__ + j * b_dim1]; + b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j * + b_dim1]; +/* L60: */ + } + } + } + if (d__[*n] == 0.) { + *info = *n; + return 0; + } + } + +/* Back solve with the matrix U from the factorization. */ + + if (*nrhs <= 2) { + j = 1; +L70: + b[*n + j * b_dim1] /= d__[*n]; + if (*n > 1) { + b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] * b[ + *n + j * b_dim1]) / d__[*n - 1]; + } + for (i__ = *n - 2; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + 1 + + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1]) / d__[ + i__]; +/* L80: */ + } + if (j < *nrhs) { + ++j; + goto L70; + } + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + b[*n + j * b_dim1] /= d__[*n]; + if (*n > 1) { + b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] + * b[*n + j * b_dim1]) / d__[*n - 1]; + } + for (i__ = *n - 2; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + + 1 + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1]) + / d__[i__]; +/* L90: */ + } +/* L100: */ + } + } + + return 0; + +/* End of DGTSV */ + +} /* dgtsv_ */ + +/* Subroutine */ int dgtsvx_(const char *fact, const char *trans, integer *n, integer * + nrhs, double *dl, double *d__, double *du, double * + dlf, double *df, double *duf, double *du2, integer *ipiv, + double *b, integer *ldb, double *x, integer *ldx, double * + rcond, double *ferr, double *berr, double *work, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1; + + /* Local variables */ + char norm[1]; + double anorm; + bool nofact; + bool notran; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGTSVX uses the LU factorization to compute the solution to a real */ +/* system of linear equations A * X = B or A**T * X = B, */ +/* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */ +/* matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */ +/* as A = L * U, where L is a product of permutation and unit lower */ +/* bidiagonal matrices and U is upper triangular with nonzeros in */ +/* only the main diagonal and first two superdiagonals. */ + +/* 2. If some U(i,i)=0, so that U is exactly singular, then the routine */ +/* returns with INFO = i. Otherwise, the factored form of A is used */ +/* to estimate the condition number of the matrix A. If the */ +/* reciprocal of the condition number is less than machine precision, */ +/* INFO = N+1 is returned as a warning, but the routine still goes on */ +/* to solve for X and compute error bounds as described below. */ + +/* 3. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 4. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of A has been */ +/* supplied on entry. */ +/* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored */ +/* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV */ +/* will not be modified. */ +/* = 'N': The matrix will be copied to DLF, DF, and DUF */ +/* and factored. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of A. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of A. */ + +/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) superdiagonal elements of A. */ + +/* DLF (input or output) DOUBLE PRECISION array, dimension (N-1) */ +/* If FACT = 'F', then DLF is an input argument and on entry */ +/* contains the (n-1) multipliers that define the matrix L from */ +/* the LU factorization of A as computed by DGTTRF. */ + +/* If FACT = 'N', then DLF is an output argument and on exit */ +/* contains the (n-1) multipliers that define the matrix L from */ +/* the LU factorization of A. */ + +/* DF (input or output) DOUBLE PRECISION array, dimension (N) */ +/* If FACT = 'F', then DF is an input argument and on entry */ +/* contains the n diagonal elements of the upper triangular */ +/* matrix U from the LU factorization of A. */ + +/* If FACT = 'N', then DF is an output argument and on exit */ +/* contains the n diagonal elements of the upper triangular */ +/* matrix U from the LU factorization of A. */ + +/* DUF (input or output) DOUBLE PRECISION array, dimension (N-1) */ +/* If FACT = 'F', then DUF is an input argument and on entry */ +/* contains the (n-1) elements of the first superdiagonal of U. */ + +/* If FACT = 'N', then DUF is an output argument and on exit */ +/* contains the (n-1) elements of the first superdiagonal of U. */ + +/* DU2 (input or output) DOUBLE PRECISION array, dimension (N-2) */ +/* If FACT = 'F', then DU2 is an input argument and on entry */ +/* contains the (n-2) elements of the second superdiagonal of */ +/* U. */ + +/* If FACT = 'N', then DU2 is an output argument and on exit */ +/* contains the (n-2) elements of the second superdiagonal of */ +/* U. */ + +/* IPIV (input or output) INTEGER array, dimension (N) */ +/* If FACT = 'F', then IPIV is an input argument and on entry */ +/* contains the pivot indices from the LU factorization of A as */ +/* computed by DGTTRF. */ + +/* If FACT = 'N', then IPIV is an output argument and on exit */ +/* contains the pivot indices from the LU factorization of A; */ +/* row i of the matrix was interchanged with row IPIV(i). */ +/* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */ +/* a row interchange was not required. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The N-by-NRHS right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The estimate of the reciprocal condition number of the matrix */ +/* A. If RCOND is less than the machine precision (in */ +/* particular, if RCOND = 0), the matrix is singular to working */ +/* precision. This condition is indicated by a return code of */ +/* INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= N: U(i,i) is exactly zero. The factorization */ +/* has not been completed unless i = N, but the */ +/* factor U is exactly singular, so the solution */ +/* and error bounds could not be computed. */ +/* RCOND = 0 is returned. */ +/* = N+1: U is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --dl; + --d__; + --du; + --dlf; + --df; + --duf; + --du2; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + notran = lsame_(trans, "N"); + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -14; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTSVX", &i__1); + return 0; + } + + if (nofact) { + +/* Compute the LU factorization of A. */ + + dcopy_(n, &d__[1], &c__1, &df[1], &c__1); + if (*n > 1) { + i__1 = *n - 1; + dcopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &du[1], &c__1, &duf[1], &c__1); + } + dgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + if (notran) { + *(unsigned char *)norm = '1'; + } else { + *(unsigned char *)norm = 'I'; + } + anorm = dlangt_(norm, n, &dl[1], &d__[1], &du[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm, + rcond, &work[1], &iwork[1], info); + +/* Compute the solution vectors X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[ + x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + dgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1], + &du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1] +, &berr[1], &work[1], &iwork[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of DGTSVX */ + +} /* dgtsvx_ */ + +/* Subroutine */ int dgttrf_(integer *n, double *dl, double *d__, + double *du, double *du2, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + integer i__; + double fact, temp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGTTRF computes an LU factorization of a real tridiagonal matrix A */ +/* using elimination with partial pivoting and row interchanges. */ + +/* The factorization has the form */ +/* A = L * U */ +/* where L is a product of permutation and unit lower bidiagonal */ +/* matrices and U is upper triangular with nonzeros in only the main */ +/* diagonal and first two superdiagonals. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. */ + +/* DL (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, DL must contain the (n-1) sub-diagonal elements of */ +/* A. */ + +/* On exit, DL is overwritten by the (n-1) multipliers that */ +/* define the matrix L from the LU factorization of A. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, D must contain the diagonal elements of A. */ + +/* On exit, D is overwritten by the n diagonal elements of the */ +/* upper triangular matrix U from the LU factorization of A. */ + +/* DU (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, DU must contain the (n-1) super-diagonal elements */ +/* of A. */ + +/* On exit, DU is overwritten by the (n-1) elements of the first */ +/* super-diagonal of U. */ + +/* DU2 (output) DOUBLE PRECISION array, dimension (N-2) */ +/* On exit, DU2 is overwritten by the (n-2) elements of the */ +/* second super-diagonal of U. */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* interchanged with row IPIV(i). IPIV(i) will always be either */ +/* i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* required. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly */ +/* singular, and division by zero will occur if it is used */ +/* to solve a system of equations. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ipiv; + --du2; + --du; + --d__; + --dl; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("DGTTRF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Initialize IPIV(i) = i and DU2(I) = 0 */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ipiv[i__] = i__; +/* L10: */ + } + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + du2[i__] = 0.; +/* L20: */ + } + + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + +/* No row interchange required, eliminate DL(I) */ + + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + dl[i__] = fact; + d__[i__ + 1] -= fact * du[i__]; + } + } else { + +/* Interchange rows I and I+1, eliminate DL(I) */ + + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + dl[i__] = fact; + temp = du[i__]; + du[i__] = d__[i__ + 1]; + d__[i__ + 1] = temp - fact * d__[i__ + 1]; + du2[i__] = du[i__ + 1]; + du[i__ + 1] = -fact * du[i__ + 1]; + ipiv[i__] = i__ + 1; + } +/* L30: */ + } + if (*n > 1) { + i__ = *n - 1; + if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) { + if (d__[i__] != 0.) { + fact = dl[i__] / d__[i__]; + dl[i__] = fact; + d__[i__ + 1] -= fact * du[i__]; + } + } else { + fact = d__[i__] / dl[i__]; + d__[i__] = dl[i__]; + dl[i__] = fact; + temp = du[i__]; + du[i__] = d__[i__ + 1]; + d__[i__ + 1] = temp - fact * d__[i__ + 1]; + ipiv[i__] = i__ + 1; + } + } + +/* Check for a zero on the diagonal of U. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] == 0.) { + *info = i__; + goto L50; + } +/* L40: */ + } +L50: + + return 0; + +/* End of DGTTRF */ + +} /* dgttrf_ */ + +/* Subroutine */ int dgttrs_(const char *trans, integer *n, integer *nrhs, + double *dl, double *d__, double *du, double *du2, + integer *ipiv, double *b, integer *ldb, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer j, jb, nb; + integer itrans; + bool notran; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGTTRS solves one of the systems of equations */ +/* A*X = B or A'*X = B, */ +/* with a tridiagonal matrix A using the LU factorization computed */ +/* by DGTTRF. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations. */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A'* X = B (Transpose) */ +/* = 'C': A'* X = B (Conjugate transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The order of the matrix A. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) multipliers that define the matrix L from the */ +/* LU factorization of A. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the upper triangular matrix U from */ +/* the LU factorization of A. */ + +/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) elements of the first super-diagonal of U. */ + +/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */ +/* The (n-2) elements of the second super-diagonal of U. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* interchanged with row IPIV(i). IPIV(i) will always be either */ +/* i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* required. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the matrix of right hand side vectors B. */ +/* On exit, B is overwritten by the solution vectors X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --dl; + --d__; + --du; + --du2; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + notran = *(unsigned char *)trans == 'N' || *(unsigned char *)trans == 'n'; + if (! notran && ! (*(unsigned char *)trans == 'T' || *(unsigned char *) + trans == 't') && ! (*(unsigned char *)trans == 'C' || *(unsigned + char *)trans == 'c')) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(*n,1_integer)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGTTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Decode TRANS */ + + if (notran) { + itrans = 0; + } else { + itrans = 1; + } + +/* Determine the number of right-hand sides to solve at a time. */ + + if (*nrhs == 1) { + nb = 1; + } else { +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "DGTTRS", trans, n, nrhs, &c_n1, & + c_n1); + nb = std::max(i__1,i__2); + } + + if (nb >= *nrhs) { + dgtts2_(&itrans, n, nrhs, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[1], + &b[b_offset], ldb); + } else { + i__1 = *nrhs; + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nrhs - j + 1; + jb = std::min(i__3,nb); + dgtts2_(&itrans, n, &jb, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[ + 1], &b[j * b_dim1 + 1], ldb); +/* L10: */ + } + } + +/* End of DGTTRS */ + + return 0; +} /* dgttrs_ */ + +/* Subroutine */ int dgtts2_(integer *itrans, integer *n, integer *nrhs, + double *dl, double *d__, double *du, double *du2, + integer *ipiv, double *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ip; + double temp; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DGTTS2 solves one of the systems of equations */ +/* A*X = B or A'*X = B, */ +/* with a tridiagonal matrix A using the LU factorization computed */ +/* by DGTTRF. */ + +/* Arguments */ +/* ========= */ + +/* ITRANS (input) INTEGER */ +/* Specifies the form of the system of equations. */ +/* = 0: A * X = B (No transpose) */ +/* = 1: A'* X = B (Transpose) */ +/* = 2: A'* X = B (Conjugate transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The order of the matrix A. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) multipliers that define the matrix L from the */ +/* LU factorization of A. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the upper triangular matrix U from */ +/* the LU factorization of A. */ + +/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) elements of the first super-diagonal of U. */ + +/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */ +/* The (n-2) elements of the second super-diagonal of U. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices; for 1 <= i <= n, row i of the matrix was */ +/* interchanged with row IPIV(i). IPIV(i) will always be either */ +/* i or i+1; IPIV(i) = i indicates a row interchange was not */ +/* required. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the matrix of right hand side vectors B. */ +/* On exit, B is overwritten by the solution vectors X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + --dl; + --d__; + --du; + --du2; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (*itrans == 0) { + +/* Solve A*X = B using the LU factorization of A, */ +/* overwriting each right hand side vector with its solution. */ + + if (*nrhs <= 1) { + j = 1; +L10: + +/* Solve L*x = b. */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + ip = ipiv[i__]; + temp = b[i__ + 1 - ip + i__ + j * b_dim1] - dl[i__] * b[ip + + j * b_dim1]; + b[i__ + j * b_dim1] = b[ip + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = temp; +/* L20: */ + } + +/* Solve U*x = b. */ + + b[*n + j * b_dim1] /= d__[*n]; + if (*n > 1) { + b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] + * b[*n + j * b_dim1]) / d__[*n - 1]; + } + for (i__ = *n - 2; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j * b_dim1] + ) / d__[i__]; +/* L30: */ + } + if (j < *nrhs) { + ++j; + goto L10; + } + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve L*x = b. */ + + i__2 = *n - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (ipiv[i__] == i__) { + b[i__ + 1 + j * b_dim1] -= dl[i__] * b[i__ + j * + b_dim1]; + } else { + temp = b[i__ + j * b_dim1]; + b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = temp - dl[i__] * b[i__ + j * + b_dim1]; + } +/* L40: */ + } + +/* Solve U*x = b. */ + + b[*n + j * b_dim1] /= d__[*n]; + if (*n > 1) { + b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n + - 1] * b[*n + j * b_dim1]) / d__[*n - 1]; + } + for (i__ = *n - 2; i__ >= 1; --i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[ + i__ + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j * + b_dim1]) / d__[i__]; +/* L50: */ + } +/* L60: */ + } + } + } else { + +/* Solve A' * X = B. */ + + if (*nrhs <= 1) { + +/* Solve U'*x = b. */ + + j = 1; +L70: + b[j * b_dim1 + 1] /= d__[1]; + if (*n > 1) { + b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j * b_dim1 + + 1]) / d__[2]; + } + i__1 = *n; + for (i__ = 3; i__ <= i__1; ++i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] * b[ + i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ - 2 + j * + b_dim1]) / d__[i__]; +/* L80: */ + } + +/* Solve L'*x = b. */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + ip = ipiv[i__]; + temp = b[i__ + j * b_dim1] - dl[i__] * b[i__ + 1 + j * b_dim1] + ; + b[i__ + j * b_dim1] = b[ip + j * b_dim1]; + b[ip + j * b_dim1] = temp; +/* L90: */ + } + if (j < *nrhs) { + ++j; + goto L70; + } + + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Solve U'*x = b. */ + + b[j * b_dim1 + 1] /= d__[1]; + if (*n > 1) { + b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j * + b_dim1 + 1]) / d__[2]; + } + i__2 = *n; + for (i__ = 3; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] * + b[i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ - + 2 + j * b_dim1]) / d__[i__]; +/* L100: */ + } + for (i__ = *n - 1; i__ >= 1; --i__) { + if (ipiv[i__] == i__) { + b[i__ + j * b_dim1] -= dl[i__] * b[i__ + 1 + j * + b_dim1]; + } else { + temp = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - dl[ + i__] * temp; + b[i__ + j * b_dim1] = temp; + } +/* L110: */ + } +/* L120: */ + } + } + } + +/* End of DGTTS2 */ + + return 0; +} /* dgtts2_ */ diff --git a/external/clapack/lapack_dlaq.cpp b/external/clapack/lapack_dlaq.cpp new file mode 100644 index 00000000..69c111af --- /dev/null +++ b/external/clapack/lapack_dlaq.cpp @@ -0,0 +1,25562 @@ +#include "clapack.h" +#include "f2cP.h" + +double dla_gbrcond__(const char *trans, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, double *afb, integer *ldafb, + integer *ipiv, integer *cmode, double *c__, integer *info, + double *work, integer *iwork, integer trans_len) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; + double ret_val, d__1; + + /* Local variables */ + integer i__, j, kd, ke; + double tmp; + integer kase; + integer isave[3]; + double ainvnm; + bool notrans; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLA_GERCOND Estimates the Skeel condition number of op(A) * op2(C) */ +/* where op2 is determined by CMODE as follows */ +/* CMODE = 1 op2(C) = C */ +/* CMODE = 0 op2(C) = I */ +/* CMODE = -1 op2(C) = inv(C) */ +/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */ +/* is computed by computing scaling factors R such that */ +/* diag(R)*A*op2(C) is row equilibrated and computing the standard */ +/* infinity-norm condition number. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ + +/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* Details of the LU factorization of the band matrix A, as */ +/* computed by DGBTRF. U is stored as an upper triangular */ +/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* and the multipliers used during the factorization are stored */ +/* in rows KL+KU+2 to 2*KL+KU+1. */ + +/* LDAFB (input) INTEGER */ +/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices from the factorization A = P*L*U */ +/* as computed by DGBTRF; row i of the matrix was interchanged */ +/* with row IPIV(i). */ + +/* CMODE (input) INTEGER */ +/* Determines op2(C) in the formula op(A) * op2(C) as follows: */ +/* CMODE = 1 op2(C) = C */ +/* CMODE = 0 op2(C) = I */ +/* CMODE = -1 op2(C) = inv(C) */ + +/* C (input) DOUBLE PRECISION array, dimension (N) */ +/* The vector C in the formula op(A) * op2(C). */ + +/* INFO (output) INTEGER */ +/* = 0: Successful exit. */ +/* i > 0: The ith argument is invalid. */ + +/* WORK (input) DOUBLE PRECISION array, dimension (5*N). */ +/* Workspace. */ + +/* IWORK (input) INTEGER array, dimension (N). */ +/* Workspace. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + --ipiv; + --c__; + --work; + --iwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + notrans = lsame_(trans, "N"); + if (! notrans && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0 || *kl > *n - 1) { + *info = -3; + } else if (*ku < 0 || *ku > *n - 1) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLA_GBRCOND", &i__1); + return ret_val; + } + if (*n == 0) { + ret_val = 1.; + return ret_val; + } + +/* Compute the equilibration matrix R such that */ +/* inv(R)*A*C has unit 1-norm. */ + + kd = *ku + 1; + ke = *kl + 1; + if (notrans) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = std::min(i__4,*n); + for (j = std::max(i__2,1_integer); j <= i__3; ++j) { + tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1] * c__[j], + abs(d__1)); + } + } else if (*cmode == 0) { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = std::min(i__4,*n); + for (j = std::max(i__3,1_integer); j <= i__2; ++j) { + tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(d__1)); + } + } else { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = std::min(i__4,*n); + for (j = std::max(i__2,1_integer); j <= i__3; ++j) { + tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1] / c__[j], + abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = std::min(i__4,*n); + for (j = std::max(i__3,1_integer); j <= i__2; ++j) { + tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1] * c__[j], + abs(d__1)); + } + } else if (*cmode == 0) { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = std::min(i__4,*n); + for (j = std::max(i__2,1_integer); j <= i__3; ++j) { + tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1], abs(d__1) + ); + } + } else { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = std::min(i__4,*n); + for (j = std::max(i__3,1_integer); j <= i__2; ++j) { + tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1] / c__[j], + abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + if (notrans) { + dgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } else { + dgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } + +/* Multiply by inv(C). */ + + if (*cmode == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] /= c__[i__]; + } + } else if (*cmode == -1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= c__[i__]; + } + } + } else { + +/* Multiply by inv(C'). */ + + if (*cmode == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] /= c__[i__]; + } + } else if (*cmode == -1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= c__[i__]; + } + } + if (notrans) { + dgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } else { + dgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* dla_gbrcond__ */ + +#if 0 +/* Subroutine */ int dla_gbrfsx_extended__(integer *prec_type__, integer * + trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs, + double *ab, integer *ldab, double *afb, integer *ldafb, + integer *ipiv, bool *colequ, double *c__, double *b, + integer *ldb, double *y, integer *ldy, double *berr_out__, + integer *n_norms__, double *err_bnds_norm__, double * + err_bnds_comp__, double *res, double *ayb, double *dy, + double *y_tail__, double *rcond, integer *ithresh, double + *rthresh, double *dz_ub__, bool *ignore_cwise__, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b6 = -1.; + static double c_b8 = 1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3; + double d__1, d__2; + char ch__1[1]; + + /* Local variables */ + double dxratmax, dzratmax; + integer i__, j, m; + bool incr_prec__; + double prev_dz_z__, yk, final_dx_x__; + double final_dz_z__, prevnormdx; + integer cnt; + double dyk, eps, incr_thresh__, dx_x__, dz_z__; + double ymin; + integer y_prec_state__; + double dxrat, dzrat; + char trans[1]; + double normx, normy; + double normdx; + double hugeval; + integer x_state__, z_state__; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLA_GBRFSX_EXTENDED improves the computed solution to a system of */ +/* linear equations by performing extra-precise iterative refinement */ +/* and provides error bounds and backward error estimates for the solution. */ +/* This subroutine is called by DGBRFSX to perform iterative refinement. */ +/* In addition to normwise error bound, the code provides maximum */ +/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */ +/* and ERR_BNDS_COMP for details of the error bounds. Note that this */ +/* subroutine is only resonsible for setting the second fields of */ +/* ERR_BNDS_NORM and ERR_BNDS_COMP. */ + +/* Arguments */ +/* ========= */ + +/* PREC_TYPE (input) INTEGER */ +/* Specifies the intermediate precision to be used in refinement. */ +/* The value is defined by ILAPREC(P) where P is a CHARACTER and */ +/* P = 'S': Single */ +/* = 'D': Double */ +/* = 'I': Indigenous */ +/* = 'X', 'E': Extra */ + +/* TRANS_TYPE (input) INTEGER */ +/* Specifies the transposition operation on A. */ +/* The value is defined by ILATRANS(T) where T is a CHARACTER and */ +/* T = 'N': No transpose */ +/* = 'T': Transpose */ +/* = 'C': Conjugate transpose */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0 */ + +/* NRHS (input) INTEGER */ +/* The number of right-hand-sides, i.e., the number of columns of the */ +/* matrix B. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the N-by-N matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* The factors L and U from the factorization */ +/* A = P*L*U as computed by DGBTRF. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* The pivot indices from the factorization A = P*L*U */ +/* as computed by DGBTRF; row i of the matrix was interchanged */ +/* with row IPIV(i). */ + +/* COLEQU (input) LOGICAL */ +/* If .TRUE. then column equilibration was done to A before calling */ +/* this routine. This is needed to compute the solution and error */ +/* bounds correctly. */ + +/* C (input) DOUBLE PRECISION array, dimension (N) */ +/* The column scale factors for A. If COLEQU = .FALSE., C */ +/* is not accessed. If C is input, each element of C should be a power */ +/* of the radix to ensure a reliable solution and error estimates. */ +/* Scaling by powers of the radix does not cause rounding errors unless */ +/* the result underflows or overflows. Rounding errors during scaling */ +/* lead to refining with a matrix that is not equivalent to the */ +/* input matrix, producing error estimates that may not be */ +/* reliable. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right-hand-side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* Y (input/output) DOUBLE PRECISION array, dimension */ +/* (LDY,NRHS) */ +/* On entry, the solution matrix X, as computed by DGBTRS. */ +/* On exit, the improved solution matrix Y. */ + +/* LDY (input) INTEGER */ +/* The leading dimension of the array Y. LDY >= max(1,N). */ + +/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* error for right-hand-side j from the formula */ +/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. This is computed by DLA_LIN_BERR. */ + +/* N_NORMS (input) INTEGER */ +/* Determines which error bounds to return (see ERR_BNDS_NORM */ +/* and ERR_BNDS_COMP). */ +/* If N_NORMS >= 1 return normwise error bounds. */ +/* If N_NORMS >= 2 return componentwise error bounds. */ + +/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */ +/* (NRHS, N_ERR_BNDS) */ +/* For each right-hand side, this array contains information about */ +/* various error bounds and condition numbers corresponding to the */ +/* normwise relative error, which is defined as follows: */ + +/* Normwise relative error in the ith solution vector: */ +/* max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* ------------------------------ */ +/* max_j abs(X(j,i)) */ + +/* The array is indexed by the type of error information as described */ +/* below. There currently are up to three pieces of information */ +/* returned. */ + +/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* right-hand side. */ + +/* The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* three fields: */ +/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* reciprocal condition number is less than the threshold */ +/* sqrt(n) * slamch('Epsilon'). */ + +/* err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* almost certainly within a factor of 10 of the true error */ +/* so long as the next entry is greater than the threshold */ +/* sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* be trusted if the previous boolean is true. */ + +/* err = 3 Reciprocal condition number: Estimated normwise */ +/* reciprocal condition number. Compared with the threshold */ +/* sqrt(n) * slamch('Epsilon') to determine if the error */ +/* estimate is "guaranteed". These reciprocal condition */ +/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* appropriately scaled matrix Z. */ +/* Let Z = S*A, where S scales each row by a power of the */ +/* radix so all absolute row sums of Z are approximately 1. */ + +/* This subroutine is only responsible for setting the second field */ +/* above. */ +/* See Lapack Working Note 165 for further details and extra */ +/* cautions. */ + +/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */ +/* (NRHS, N_ERR_BNDS) */ +/* For each right-hand side, this array contains information about */ +/* various error bounds and condition numbers corresponding to the */ +/* componentwise relative error, which is defined as follows: */ + +/* Componentwise relative error in the ith solution vector: */ +/* abs(XTRUE(j,i) - X(j,i)) */ +/* max_j ---------------------- */ +/* abs(X(j,i)) */ + +/* The array is indexed by the right-hand side i (on which the */ +/* componentwise relative error depends), and the type of error */ +/* information as described below. There currently are up to three */ +/* pieces of information returned for each right-hand side. If */ +/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ +/* the first (:,N_ERR_BNDS) entries are returned. */ + +/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* right-hand side. */ + +/* The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* three fields: */ +/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* reciprocal condition number is less than the threshold */ +/* sqrt(n) * slamch('Epsilon'). */ + +/* err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* almost certainly within a factor of 10 of the true error */ +/* so long as the next entry is greater than the threshold */ +/* sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* be trusted if the previous boolean is true. */ + +/* err = 3 Reciprocal condition number: Estimated componentwise */ +/* reciprocal condition number. Compared with the threshold */ +/* sqrt(n) * slamch('Epsilon') to determine if the error */ +/* estimate is "guaranteed". These reciprocal condition */ +/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* appropriately scaled matrix Z. */ +/* Let Z = S*(A*diag(x)), where x is the solution for the */ +/* current right-hand side and S scales each row of */ +/* A*diag(x) by a power of the radix so all absolute row */ +/* sums of Z are approximately 1. */ + +/* This subroutine is only responsible for setting the second field */ +/* above. */ +/* See Lapack Working Note 165 for further details and extra */ +/* cautions. */ + +/* RES (input) DOUBLE PRECISION array, dimension (N) */ +/* Workspace to hold the intermediate residual. */ + +/* AYB (input) DOUBLE PRECISION array, dimension (N) */ +/* Workspace. This can be the same workspace passed for Y_TAIL. */ + +/* DY (input) DOUBLE PRECISION array, dimension (N) */ +/* Workspace to hold the intermediate solution. */ + +/* Y_TAIL (input) DOUBLE PRECISION array, dimension (N) */ +/* Workspace to hold the trailing bits of the intermediate solution. */ + +/* RCOND (input) DOUBLE PRECISION */ +/* Reciprocal scaled condition number. This is an estimate of the */ +/* reciprocal Skeel condition number of the matrix A after */ +/* equilibration (if done). If this is less than the machine */ +/* precision (in particular, if it is zero), the matrix is singular */ +/* to working precision. Note that the error may still be small even */ +/* if this number is very small and the matrix appears ill- */ +/* conditioned. */ + +/* ITHRESH (input) INTEGER */ +/* The maximum number of residual computations allowed for */ +/* refinement. The default is 10. For 'aggressive' set to 100 to */ +/* permit convergence using approximate factorizations or */ +/* factorizations other than LU. If the factorization uses a */ +/* technique other than Gaussian elimination, the guarantees in */ +/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ + +/* RTHRESH (input) DOUBLE PRECISION */ +/* Determines when to stop refinement if the error estimate stops */ +/* decreasing. Refinement will stop when the next solution no longer */ +/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* for more details. */ + +/* DZ_UB (input) DOUBLE PRECISION */ +/* Determines when to start considering componentwise convergence. */ +/* Componentwise convergence is only considered after each component */ +/* of the solution Y is stable, which we definte as the relative */ +/* change in each component being less than DZ_UB. The default value */ +/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* more details. */ + +/* IGNORE_CWISE (input) LOGICAL */ +/* If .TRUE. then ignore componentwise convergence. Default value */ +/* is .FALSE.. */ + +/* INFO (output) INTEGER */ +/* = 0: Successful exit. */ +/* < 0: if INFO = -i, the ith argument to DGBTRS had an illegal */ +/* value */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Parameters .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1; + err_bnds_norm__ -= err_bnds_norm_offset; + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + --ipiv; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + if (*info != 0) { + return 0; + } + chla_transtype__(ch__1, 1_integer, trans_type__); + *(unsigned char *)trans = *(unsigned char *)&ch__1[0]; + eps = dlamch_("Epsilon"); + hugeval = dlamch_("Overflow"); +/* Force HUGEVAL to Inf */ + hugeval *= hugeval; +/* Using HUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (double) (*n) * eps; + m = *kl + *ku + 1; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + y_tail__[i__] = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = hugeval; + final_dz_z__ = hugeval; + prevnormdx = hugeval; + prev_dz_z__ = hugeval; + dz_z__ = hugeval; + dx_x__ = hugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = false; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + dgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[ + j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_dgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ + ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, & + res[1], &c__1, prec_type__); + } else { + blas_dgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ + ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], & + c__1, &c_b8, &res[1], &c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + dcopy_(n, &res[1], &c__1, &dy[1], &c__1); + dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] +, &dy[1], n, info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = hugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + yk = (d__1 = y[i__ + j * y_dim1], abs(d__1)); + dyk = (d__1 = dy[i__], abs(d__1)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = std::max(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = hugeval; + } + ymin = std::min(ymin,yk); + normy = std::max(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = std::max(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = std::max(d__1,d__2); + } else { + normx = normy; + normdx = std::max(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = hugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy + && y_prec_state__ < 2) { + incr_prec__ = true; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = true; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = hugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = true; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + +/* Exit if both normwise and componentwise stopped working, */ +/* but if componentwise is unstable, let it go at least two */ +/* iterations. */ + + if (x_state__ != 1) { + if (*ignore_cwise__) { + goto L666; + } + if (z_state__ == 3 || z_state__ == 2) { + goto L666; + } + if (z_state__ == 0 && cnt > 1) { + goto L666; + } + } + if (incr_prec__) { + incr_prec__ = false; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + y_tail__[i__] = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + daxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + dla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */ +L666: + +/* Set final_* when cnt hits ithresh. */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds. */ + + if (*n_norms__ >= 1) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( + 1 - dxratmax); + } + if (*n_norms__ >= 2) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( + 1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + dgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j * + y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + dla_gbamv__(trans_type__, n, n, kl, ku, &c_b8, &ab[ab_offset], ldab, & + y[j * y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1); + dla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS */ + + } + + return 0; +} /* dla_gbrfsx_extended__ */ +#endif + +double dla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer * + ncols, double *ab, integer *ldab, double *afb, integer *ldafb) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; + double ret_val, d__1, d__2; + + /* Local variables */ + integer i__, j, kd; + double amax, umax, rpvgrw; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLA_GBRPVGRW computes the reciprocal pivot growth factor */ +/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */ +/* much less than 1, the stability of the LU factorization of the */ +/* (equilibrated) matrix A could be poor. This also means that the */ +/* solution X, estimated condition numbers, and error bounds could be */ +/* unreliable. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* NCOLS (input) INTEGER */ +/* The number of columns of the matrix A. NCOLS >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ + +/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */ +/* Details of the LU factorization of the band matrix A, as */ +/* computed by DGBTRF. U is stored as an upper triangular */ +/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* and the multipliers used during the factorization are stored */ +/* in rows KL+KU+2 to 2*KL+KU+1. */ + +/* LDAFB (input) INTEGER */ +/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1; + afb -= afb_offset; + + /* Function Body */ + rpvgrw = 1.; + kd = *ku + 1; + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + amax = 0.; + umax = 0.; +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = std::min(i__4,*n); + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(d__1)); + amax = std::max(d__2,amax); + } +/* Computing MAX */ + i__3 = j - *ku; + i__2 = j; + for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = (d__1 = afb[kd + i__ - j + j * afb_dim1], abs(d__1)); + umax = std::max(d__2,umax); + } + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = std::min(d__1,rpvgrw); + } + } + ret_val = rpvgrw; + return ret_val; +} /* dla_gbrpvgrw__ */ + +double dla_porcond__(const char *uplo, integer *n, double *a, integer *lda, + double *af, integer *ldaf, integer *cmode, double *c__, + integer *info, double *work, integer *iwork, integer uplo_len) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2; + double ret_val, d__1; + + /* Local variables */ + integer i__, j; + bool up; + double tmp; + integer kase; + integer isave[3]; + double ainvnm; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) */ +/* where op2 is determined by CMODE as follows */ +/* CMODE = 1 op2(C) = C */ +/* CMODE = 0 op2(C) = I */ +/* CMODE = -1 op2(C) = inv(C) */ +/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */ +/* is computed by computing scaling factors R such that */ +/* diag(R)*A*op2(C) is row equilibrated and computing the standard */ +/* infinity-norm condition number. */ + +/* Arguments */ +/* ========== */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* A (input) REAL array, dimension (LDA,N) */ +/* On entry, the N-by-N matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* The triangular factor U or L from the Cholesky factorization */ +/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* CMODE (input) INTEGER */ +/* Determines op2(C) in the formula op(A) * op2(C) as follows: */ +/* CMODE = 1 op2(C) = C */ +/* CMODE = 0 op2(C) = I */ +/* CMODE = -1 op2(C) = inv(C) */ + +/* C (input) DOUBLE PRECISION array, dimension (N) */ +/* The vector C in the formula op(A) * op2(C). */ + +/* INFO (output) INTEGER */ +/* = 0: Successful exit. */ +/* i > 0: The ith argument is invalid. */ + +/* WORK (input) DOUBLE PRECISION array, dimension (3*N). */ +/* Workspace. */ + +/* IWORK (input) INTEGER array, dimension (N). */ +/* Workspace. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --c__; + --work; + --iwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLA_PORCOND", &i__1); + return ret_val; + } + if (*n == 0) { + ret_val = 1.; + return ret_val; + } + up = false; + if (lsame_(uplo, "U")) { + up = true; + } + +/* Compute the equilibration matrix R such that */ +/* inv(R)*A*C has unit 1-norm. */ + + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*cmode == 1) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1)); + } + } else if (*cmode == 0) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)); + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1)); + } + } + work[(*n << 1) + i__] = tmp; + } + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + if (up) { + dpotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + dpotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + +/* Multiply by inv(C). */ + + if (*cmode == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] /= c__[i__]; + } + } else if (*cmode == -1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= c__[i__]; + } + } + } else { + +/* Multiply by inv(C'). */ + + if (*cmode == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] /= c__[i__]; + } + } else if (*cmode == -1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= c__[i__]; + } + } + if (up) { + dpotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + dpotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] *= work[(*n << 1) + i__]; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* dla_porcond__ */ + +int dla_wwaddw__(integer *n, double *x, double *y, double *w) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__; + double s; + + +/* -- LAPACK routine (version 3.2) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLA_WWADDW adds a vector W into a doubled-single vector (X, Y). */ + +/* This works for all extant IBM's hex and binary floating point */ +/* arithmetics, but not for decimal. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The length of vectors X, Y, and W. */ + +/* X, Y (input/output) DOUBLE PRECISION array, length N */ +/* The doubled-single accumulation vector. */ + +/* W (input) DOUBLE PRECISION array, length N */ +/* The vector to be added. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --w; + --y; + --x; + + /* Function Body */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s = x[i__] + w[i__]; + s = s + s - s; + y[i__] = x[i__] - s + w[i__] + y[i__]; + x[i__] = s; +/* L10: */ + } + return 0; +} /* dla_wwaddw__ */ + +/* Subroutine */ int dlabad_(double *small, double *large) +{ + /* Builtin functions + double d_lg10(double *), sqrt(double);*/ + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLABAD takes as input the values computed by DLAMCH for underflow and */ +/* overflow, and returns the square root of each of these values if the */ +/* log of LARGE is sufficiently large. This subroutine is intended to */ +/* identify machines with a large exponent range, such as the Crays, and */ +/* redefine the underflow and overflow limits to be the square roots of */ +/* the values computed by DLAMCH. This subroutine is needed because */ +/* DLAMCH does not compensate for poor arithmetic in the upper half of */ +/* the exponent range, as is found on a Cray. */ + +/* Arguments */ +/* ========= */ + +/* SMALL (input/output) DOUBLE PRECISION */ +/* On entry, the underflow threshold as computed by DLAMCH. */ +/* On exit, if LOG10(LARGE) is sufficiently large, the square */ +/* root of SMALL, otherwise unchanged. */ + +/* LARGE (input/output) DOUBLE PRECISION */ +/* On entry, the overflow threshold as computed by DLAMCH. */ +/* On exit, if LOG10(LARGE) is sufficiently large, the square */ +/* root of LARGE, otherwise unchanged. */ + +/* ===================================================================== */ + +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* If it looks like we're on a Cray, take the square root of */ +/* SMALL and LARGE to avoid overflow and underflow problems. */ + + if (d_lg10(large) > 2e3) { + *small = sqrt(*small); + *large = sqrt(*large); + } + + return 0; + +/* End of DLABAD */ + +} /* dlabad_ */ + +/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, double * + a, integer *lda, double *d__, double *e, double *tauq, + double *taup, double *x, integer *ldx, double *y, integer + *ldy) +{ + /* Table of constant values */ + static double c_b4 = -1.; + static double c_b5 = 1.; + static integer c__1 = 1; + static double c_b16 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLABRD reduces the first NB rows and columns of a real general */ +/* m by n matrix A to upper or lower bidiagonal form by an orthogonal */ +/* transformation Q' * A * P, and returns the matrices X and Y which */ +/* are needed to apply the transformation to the unreduced part of A. */ + +/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */ +/* bidiagonal form. */ + +/* This is an auxiliary routine called by DGEBRD */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows in the matrix A. */ + +/* N (input) INTEGER */ +/* The number of columns in the matrix A. */ + +/* NB (input) INTEGER */ +/* The number of leading rows and columns of A to be reduced. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the m by n general matrix to be reduced. */ +/* On exit, the first NB rows and columns of the matrix are */ +/* overwritten; the rest of the array is unchanged. */ +/* If m >= n, elements on and below the diagonal in the first NB */ +/* columns, with the array TAUQ, represent the orthogonal */ +/* matrix Q as a product of elementary reflectors; and */ +/* elements above the diagonal in the first NB rows, with the */ +/* array TAUP, represent the orthogonal matrix P as a product */ +/* of elementary reflectors. */ +/* If m < n, elements below the diagonal in the first NB */ +/* columns, with the array TAUQ, represent the orthogonal */ +/* matrix Q as a product of elementary reflectors, and */ +/* elements on and above the diagonal in the first NB rows, */ +/* with the array TAUP, represent the orthogonal matrix P as */ +/* a product of elementary reflectors. */ +/* See Further Details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* D (output) DOUBLE PRECISION array, dimension (NB) */ +/* The diagonal elements of the first NB rows and columns of */ +/* the reduced matrix. D(i) = A(i,i). */ + +/* E (output) DOUBLE PRECISION array, dimension (NB) */ +/* The off-diagonal elements of the first NB rows and columns of */ +/* the reduced matrix. */ + +/* TAUQ (output) DOUBLE PRECISION array dimension (NB) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix Q. See Further Details. */ + +/* TAUP (output) DOUBLE PRECISION array, dimension (NB) */ +/* The scalar factors of the elementary reflectors which */ +/* represent the orthogonal matrix P. See Further Details. */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NB) */ +/* The m-by-nb matrix X required to update the unreduced part */ +/* of A. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= M. */ + +/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */ +/* The n-by-nb matrix Y required to update the unreduced part */ +/* of A. */ + +/* LDY (input) INTEGER */ +/* The leading dimension of the array Y. LDY >= N. */ + +/* Further Details */ +/* =============== */ + +/* The matrices Q and P are represented as products of elementary */ +/* reflectors: */ + +/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */ + +/* Each H(i) and G(i) has the form: */ + +/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */ + +/* where tauq and taup are real scalars, and v and u are real vectors. */ + +/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */ +/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */ +/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ + +/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */ +/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */ +/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ + +/* The elements of the vectors v and u together form the m-by-nb matrix */ +/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */ +/* the transformation to the unreduced part of the matrix, using a block */ +/* update of the form: A := A - V*Y' - X*U'. */ + +/* The contents of A on exit are illustrated by the following examples */ +/* with nb = 2: */ + +/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ + +/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */ +/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */ +/* ( v1 v2 a a a ) ( v1 1 a a a a ) */ +/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */ +/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */ +/* ( v1 v2 a a a ) */ + +/* where a denotes an element of the original matrix which is unchanged, */ +/* vi denotes an element of the vector defining H(i), and ui an element */ +/* of the vector defining G(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1; + y -= y_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + + if (*m >= *n) { + +/* Reduce to upper bidiagonal form */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i:m,i) */ + + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda, + &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], & + c__1); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx, + &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ * + a_dim1], &c__1); + +/* Generate reflection Q(i) to annihilate A(i+1:m,i) */ + + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[std::min(i__3, *m)+ i__ * + a_dim1], &c__1, &tauq[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + if (i__ < *n) { + a[i__ + i__ * a_dim1] = 1.; + +/* Compute Y(i+1:n,i) */ + + i__2 = *m - i__ + 1; + i__3 = *n - i__; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) * + a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, & + y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], + lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * + y_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ + i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1], + ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ * + y_dim1 + 1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * + a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, + &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *n - i__; + dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + +/* Update A(i,i+1:n) */ + + i__2 = *n - i__; + dgemv_("No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + ( + i__ + 1) * a_dim1], lda); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) * + a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[ + i__ + (i__ + 1) * a_dim1], lda); + +/* Generate reflection P(i) to annihilate A(i,i+2:n) */ + + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + std::min( + i__3, *n)* a_dim1], lda, &taup[i__]); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + a[i__ + (i__ + 1) * a_dim1] = 1.; + +/* Compute X(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = *n - i__; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], + lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *n - i__; + dgemv_("Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1], + ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[ + i__ * x_dim1 + 1], &c__1); + i__2 = *m - i__; + dgemv_("No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 + + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b16, &x[i__ * x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *m - i__; + dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + } +/* L10: */ + } + } else { + +/* Reduce to lower bidiagonal form */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i,i:n) */ + + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy, + &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1], + lda); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1], + lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1], + lda); + +/* Generate reflection P(i) to annihilate A(i,i+1:n) */ + + i__2 = *n - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + std::min(i__3, *n)* + a_dim1], lda, &taup[i__]); + d__[i__] = a[i__ + i__ * a_dim1]; + if (i__ < *m) { + a[i__ + i__ * a_dim1] = 1.; + +/* Compute X(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = *n - i__ + 1; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ * + a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, & + x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1], + ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * + x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 + + 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ * + x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *m - i__; + dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + +/* Update A(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 + + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + + 1 + i__ * a_dim1], &c__1); + i__2 = *m - i__; + dgemv_("No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 + + x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[ + i__ + 1 + i__ * a_dim1], &c__1); + +/* Generate reflection Q(i) to annihilate A(i+2:m,i) */ + + i__2 = *m - i__; +/* Computing MIN */ + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *m)+ + i__ * a_dim1], &c__1, &tauq[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; + +/* Compute Y(i+1:n,i) */ + + i__2 = *m - i__; + i__3 = *n - i__; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ + + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, + &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ + i__ * y_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 + + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[ + i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__; + dgemv_("Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1], + ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[ + i__ * y_dim1 + 1], &c__1); + i__2 = *n - i__; + dgemv_("Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1 + + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__ + + 1 + i__ * y_dim1], &c__1); + i__2 = *n - i__; + dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + } +/* L20: */ + } + } + return 0; + +/* End of DLABRD */ + +} /* dlabrd_ */ + +/* Subroutine */ int dlacn2_(integer *n, double *v, double *x, + integer *isgn, double *est, integer *kase, integer *isave) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b11 = 1.; + + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer i__; + double temp; + integer jlast; + double altsgn, estold; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLACN2 estimates the 1-norm of a square, real matrix A. */ +/* Reverse communication is used for evaluating matrix-vector products. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 1. */ + +/* V (workspace) DOUBLE PRECISION array, dimension (N) */ +/* On the final return, V = A*W, where EST = norm(V)/norm(W) */ +/* (W is not returned). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On an intermediate return, X should be overwritten by */ +/* A * X, if KASE=1, */ +/* A' * X, if KASE=2, */ +/* and DLACN2 must be re-called with all the other parameters */ +/* unchanged. */ + +/* ISGN (workspace) INTEGER array, dimension (N) */ + +/* EST (input/output) DOUBLE PRECISION */ +/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */ +/* unchanged from the previous call to DLACN2. */ +/* On exit, EST is an estimate (a lower bound) for norm(A). */ + +/* KASE (input/output) INTEGER */ +/* On the initial call to DLACN2, KASE should be 0. */ +/* On an intermediate return, KASE will be 1 or 2, indicating */ +/* whether X should be overwritten by A * X or A' * X. */ +/* On the final return from DLACN2, KASE will again be 0. */ + +/* ISAVE (input/output) INTEGER array, dimension (3) */ +/* ISAVE is used to save variables between calls to DLACN2 */ + +/* Further Details */ +/* ======= ======= */ + +/* Contributed by Nick Higham, University of Manchester. */ +/* Originally named SONEST, dated March 16, 1988. */ + +/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */ +/* a real or complex matrix, with applications to condition estimation", */ +/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ + +/* This is a thread safe version of DLACON, which uses the array ISAVE */ +/* in place of a SAVE statement, as follows: */ + +/* DLACON DLACN2 */ +/* JUMP ISAVE(1) */ +/* J ISAVE(2) */ +/* ITER ISAVE(3) */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --isave; + --isgn; + --x; + --v; + + /* Function Body */ + if (*kase == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 1. / (double) (*n); +/* L10: */ + } + *kase = 1; + isave[1] = 1; + return 0; + } + + switch (isave[1]) { + case 1: goto L20; + case 2: goto L40; + case 3: goto L70; + case 4: goto L110; + case 5: goto L140; + } + +/* ................ ENTRY (ISAVE( 1 ) = 1) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ + +L20: + if (*n == 1) { + v[1] = x[1]; + *est = abs(v[1]); +/* ... QUIT */ + goto L150; + } + *est = dasum_(n, &x[1], &c__1); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = d_sign(&c_b11, &x[i__]); + isgn[i__] = i_dnnt(&x[i__]); +/* L30: */ + } + *kase = 2; + isave[1] = 2; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 2) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L40: + isave[2] = idamax_(n, &x[1], &c__1); + isave[3] = 2; + +/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ + +L50: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 0.; +/* L60: */ + } + x[isave[2]] = 1.; + *kase = 1; + isave[1] = 3; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 3) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L70: + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = dasum_(n, &v[1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = d_sign(&c_b11, &x[i__]); + if (i_dnnt(&d__1) != isgn[i__]) { + goto L90; + } +/* L80: */ + } +/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ + goto L120; + +L90: +/* TEST FOR CYCLING. */ + if (*est <= estold) { + goto L120; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = d_sign(&c_b11, &x[i__]); + isgn[i__] = i_dnnt(&x[i__]); +/* L100: */ + } + *kase = 2; + isave[1] = 4; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 4) */ +/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L110: + jlast = isave[2]; + isave[2] = idamax_(n, &x[1], &c__1); + if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) { + ++isave[3]; + goto L50; + } + +/* ITERATION COMPLETE. FINAL STAGE. */ + +L120: + altsgn = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = altsgn * ((double) (i__ - 1) / (double) (*n - 1) + + 1.); + altsgn = -altsgn; +/* L130: */ + } + *kase = 1; + isave[1] = 5; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 5) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L140: + temp = dasum_(n, &x[1], &c__1) / (double) (*n * 3) * 2.; + if (temp > *est) { + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } + +L150: + *kase = 0; + return 0; + +/* End of DLACN2 */ + +} /* dlacn2_ */ + +/* Subroutine */ int dlacon_(integer *n, double *v, double *x, + integer *isgn, double *est, integer *kase) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b11 = 1.; + + /* System generated locals */ + integer i__1; + double d__1; + + /* Builtin functions + double d_sign(double *, double *); + integer i_dnnt(double *); */ + + /* Local variables */ + static integer i__, j, iter; + static double temp; + static integer jump; + static integer jlast; + static double altsgn, estold; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLACON estimates the 1-norm of a square, real matrix A. */ +/* Reverse communication is used for evaluating matrix-vector products. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 1. */ + +/* V (workspace) DOUBLE PRECISION array, dimension (N) */ +/* On the final return, V = A*W, where EST = norm(V)/norm(W) */ +/* (W is not returned). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On an intermediate return, X should be overwritten by */ +/* A * X, if KASE=1, */ +/* A' * X, if KASE=2, */ +/* and DLACON must be re-called with all the other parameters */ +/* unchanged. */ + +/* ISGN (workspace) INTEGER array, dimension (N) */ + +/* EST (input/output) DOUBLE PRECISION */ +/* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */ +/* unchanged from the previous call to DLACON. */ +/* On exit, EST is an estimate (a lower bound) for norm(A). */ + +/* KASE (input/output) INTEGER */ +/* On the initial call to DLACON, KASE should be 0. */ +/* On an intermediate return, KASE will be 1 or 2, indicating */ +/* whether X should be overwritten by A * X or A' * X. */ +/* On the final return from DLACON, KASE will again be 0. */ + +/* Further Details */ +/* ======= ======= */ + +/* Contributed by Nick Higham, University of Manchester. */ +/* Originally named SONEST, dated March 16, 1988. */ + +/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */ +/* a real or complex matrix, with applications to condition estimation", */ +/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Save statement .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --isgn; + --x; + --v; + + /* Function Body */ + if (*kase == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 1. / (double) (*n); +/* L10: */ + } + *kase = 1; + jump = 1; + return 0; + } + + switch (jump) { + case 1: goto L20; + case 2: goto L40; + case 3: goto L70; + case 4: goto L110; + case 5: goto L140; + } + +/* ................ ENTRY (JUMP = 1) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ + +L20: + if (*n == 1) { + v[1] = x[1]; + *est = abs(v[1]); +/* ... QUIT */ + goto L150; + } + *est = dasum_(n, &x[1], &c__1); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = d_sign(&c_b11, &x[i__]); + isgn[i__] = i_dnnt(&x[i__]); +/* L30: */ + } + *kase = 2; + jump = 2; + return 0; + +/* ................ ENTRY (JUMP = 2) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L40: + j = idamax_(n, &x[1], &c__1); + iter = 2; + +/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ + +L50: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = 0.; +/* L60: */ + } + x[j] = 1.; + *kase = 1; + jump = 3; + return 0; + +/* ................ ENTRY (JUMP = 3) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L70: + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = dasum_(n, &v[1], &c__1); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = d_sign(&c_b11, &x[i__]); + if (i_dnnt(&d__1) != isgn[i__]) { + goto L90; + } +/* L80: */ + } +/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ + goto L120; + +L90: +/* TEST FOR CYCLING. */ + if (*est <= estold) { + goto L120; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = d_sign(&c_b11, &x[i__]); + isgn[i__] = i_dnnt(&x[i__]); +/* L100: */ + } + *kase = 2; + jump = 4; + return 0; + +/* ................ ENTRY (JUMP = 4) */ +/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ + +L110: + jlast = j; + j = idamax_(n, &x[1], &c__1); + if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) { + ++iter; + goto L50; + } + +/* ITERATION COMPLETE. FINAL STAGE. */ + +L120: + altsgn = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + x[i__] = altsgn * ((double) (i__ - 1) / (double) (*n - 1) + + 1.); + altsgn = -altsgn; +/* L130: */ + } + *kase = 1; + jump = 5; + return 0; + +/* ................ ENTRY (JUMP = 5) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L140: + temp = dasum_(n, &x[1], &c__1) / (double) (*n * 3) * 2.; + if (temp > *est) { + dcopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } + +L150: + *kase = 0; + return 0; + +/* End of DLACON */ + +} /* dlacon_ */ + +/* Subroutine */ int dlacpy_(const char *uplo, integer *m, integer *n, double * + a, integer *lda, double *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLACPY copies all or part of a two-dimensional matrix A to another */ +/* matrix B. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies the part of the matrix A to be copied to B. */ +/* = 'U': Upper triangular part */ +/* = 'L': Lower triangular part */ +/* Otherwise: All of the matrix A */ + +/* 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) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The m by n matrix A. If UPLO = 'U', only the upper triangle */ +/* or trapezoid is accessed; if UPLO = 'L', only the lower */ +/* triangle or trapezoid is accessed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (output) DOUBLE PRECISION array, dimension (LDB,N) */ +/* On exit, B = A in the locations specified by UPLO. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,M). */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = std::min(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(uplo, "L")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = a[i__ + j * a_dim1]; +/* L50: */ + } +/* L60: */ + } + } + return 0; + +/* End of DLACPY */ + +} /* dlacpy_ */ + +/* Subroutine */ int dladiv_(double *a, double *b, double *c__, + double *d__, double *p, double *q) +{ + double e, f; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (abs(*d__) < abs(*c__)) { + 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; + } + + return 0; + +/* End of DLADIV */ + +} /* dladiv_ */ + +/* Subroutine */ int dlae2_(double *a, double *b, double *c__, + double *rt1, double *rt2) +{ + /* System generated locals */ + double d__1; + + /* Builtin functions + double sqrt(double);*/ + + /* Local variables */ + double ab, df, tb, sm, rt, adf, acmn, acmx; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix */ +/* [ A B ] */ +/* [ B C ]. */ +/* On return, RT1 is the eigenvalue of larger absolute value, and RT2 */ +/* is the eigenvalue of smaller absolute value. */ + +/* Arguments */ +/* ========= */ + +/* A (input) DOUBLE PRECISION */ +/* The (1,1) element of the 2-by-2 matrix. */ + +/* B (input) DOUBLE PRECISION */ +/* The (1,2) and (2,1) elements of the 2-by-2 matrix. */ + +/* C (input) DOUBLE PRECISION */ +/* The (2,2) element of the 2-by-2 matrix. */ + +/* RT1 (output) DOUBLE PRECISION */ +/* The eigenvalue of larger absolute value. */ + +/* RT2 (output) DOUBLE PRECISION */ +/* The eigenvalue of smaller absolute value. */ + +/* Further Details */ +/* =============== */ + +/* RT1 is accurate to a few ulps barring over/underflow. */ + +/* RT2 may be inaccurate if there is massive cancellation in the */ +/* determinant A*C-B*B; higher precision or correctly rounded or */ +/* correctly truncated arithmetic would be needed to compute RT2 */ +/* accurately in all cases. */ + +/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */ +/* Underflow is harmless if the input data is 0 or exceeds */ +/* underflow_threshold / macheps. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Compute the eigenvalues */ + + sm = *a + *c__; + df = *a - *c__; + adf = abs(df); + tb = *b + *b; + ab = abs(tb); + if (abs(*a) > abs(*c__)) { + acmx = *a; + acmn = *c__; + } else { + acmx = *c__; + acmn = *a; + } + if (adf > ab) { +/* Computing 2nd power */ + d__1 = ab / adf; + rt = adf * sqrt(d__1 * d__1 + 1.); + } else if (adf < ab) { +/* Computing 2nd power */ + d__1 = adf / ab; + rt = ab * sqrt(d__1 * d__1 + 1.); + } else { + +/* Includes case AB=ADF=0 */ + + rt = ab * sqrt(2.); + } + if (sm < 0.) { + *rt1 = (sm - rt) * .5; + +/* Order of execution important. */ +/* To get fully accurate smaller eigenvalue, */ +/* next line needs to be executed in higher precision. */ + + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else if (sm > 0.) { + *rt1 = (sm + rt) * .5; + +/* Order of execution important. */ +/* To get fully accurate smaller eigenvalue, */ +/* next line needs to be executed in higher precision. */ + + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else { + +/* Includes case RT1 = RT2 = 0 */ + + *rt1 = rt * .5; + *rt2 = rt * -.5; + } + return 0; + +/* End of DLAE2 */ + +} /* dlae2_ */ + +/* Subroutine */ int dlaebz_(integer *ijob, integer *nitmax, integer *n, + integer *mmax, integer *minp, integer *nbmin, double *abstol, + double *reltol, double *pivmin, double *d__, double * + e, double *e2, integer *nval, double *ab, double *c__, + integer *mout, integer *nab, double *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4, + i__5, i__6; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer j, kf, ji, kl, jp, jit; + double tmp1, tmp2; + integer itmp1, itmp2, kfnew, klnew; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAEBZ contains the iteration loops which compute and use the */ +/* function N(w), which is the count of eigenvalues of a symmetric */ +/* tridiagonal matrix T less than or equal to its argument w. It */ +/* performs a choice of two types of loops: */ + +/* IJOB=1, followed by */ +/* IJOB=2: It takes as input a list of intervals and returns a list of */ +/* sufficiently small intervals whose union contains the same */ +/* eigenvalues as the union of the original intervals. */ +/* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. */ +/* The output interval (AB(j,1),AB(j,2)] will contain */ +/* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. */ + +/* IJOB=3: It performs a binary search in each input interval */ +/* (AB(j,1),AB(j,2)] for a point w(j) such that */ +/* N(w(j))=NVAL(j), and uses C(j) as the starting point of */ +/* the search. If such a w(j) is found, then on output */ +/* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output */ +/* (AB(j,1),AB(j,2)] will be a small interval containing the */ +/* point where N(w) jumps through NVAL(j), unless that point */ +/* lies outside the initial interval. */ + +/* Note that the intervals are in all cases half-open intervals, */ +/* i.e., of the form (a,b] , which includes b but not a . */ + +/* To avoid underflow, the matrix should be scaled so that its largest */ +/* element is no greater than overflow**(1/2) * underflow**(1/4) */ +/* in absolute value. To assure the most accurate computation */ +/* of small eigenvalues, the matrix should be scaled to be */ +/* not much smaller than that, either. */ + +/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ +/* Matrix", Report CS41, Computer Science Dept., Stanford */ +/* University, July 21, 1966 */ + +/* Note: the arguments are, in general, *not* checked for unreasonable */ +/* values. */ + +/* Arguments */ +/* ========= */ + +/* IJOB (input) INTEGER */ +/* Specifies what is to be done: */ +/* = 1: Compute NAB for the initial intervals. */ +/* = 2: Perform bisection iteration to find eigenvalues of T. */ +/* = 3: Perform bisection iteration to invert N(w), i.e., */ +/* to find a point which has a specified number of */ +/* eigenvalues of T to its left. */ +/* Other values will cause DLAEBZ to return with INFO=-1. */ + +/* NITMAX (input) INTEGER */ +/* The maximum number of "levels" of bisection to be */ +/* performed, i.e., an interval of width W will not be made */ +/* smaller than 2^(-NITMAX) * W. If not all intervals */ +/* have converged after NITMAX iterations, then INFO is set */ +/* to the number of non-converged intervals. */ + +/* N (input) INTEGER */ +/* The dimension n of the tridiagonal matrix T. It must be at */ +/* least 1. */ + +/* MMAX (input) INTEGER */ +/* The maximum number of intervals. If more than MMAX intervals */ +/* are generated, then DLAEBZ will quit with INFO=MMAX+1. */ + +/* MINP (input) INTEGER */ +/* The initial number of intervals. It may not be greater than */ +/* MMAX. */ + +/* NBMIN (input) INTEGER */ +/* The smallest number of intervals that should be processed */ +/* using a vector loop. If zero, then only the scalar loop */ +/* will be used. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The minimum (absolute) width of an interval. When an */ +/* interval is narrower than ABSTOL, or than RELTOL times the */ +/* larger (in magnitude) endpoint, then it is considered to be */ +/* sufficiently small, i.e., converged. This must be at least */ +/* zero. */ + +/* RELTOL (input) DOUBLE PRECISION */ +/* The minimum relative width of an interval. When an interval */ +/* is narrower than ABSTOL, or than RELTOL times the larger (in */ +/* magnitude) endpoint, then it is considered to be */ +/* sufficiently small, i.e., converged. Note: this should */ +/* always be at least radix*machine epsilon. */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum absolute value of a "pivot" in the Sturm */ +/* sequence loop. This *must* be at least max |e(j)**2| * */ +/* safe_min and at least safe_min, where safe_min is at least */ +/* the smallest number that can divide one without overflow. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of the tridiagonal matrix T. */ + +/* E (input) DOUBLE PRECISION array, dimension (N) */ +/* The offdiagonal elements of the tridiagonal matrix T in */ +/* positions 1 through N-1. E(N) is arbitrary. */ + +/* E2 (input) DOUBLE PRECISION array, dimension (N) */ +/* The squares of the offdiagonal elements of the tridiagonal */ +/* matrix T. E2(N) is ignored. */ + +/* NVAL (input/output) INTEGER array, dimension (MINP) */ +/* If IJOB=1 or 2, not referenced. */ +/* If IJOB=3, the desired values of N(w). The elements of NVAL */ +/* will be reordered to correspond with the intervals in AB. */ +/* Thus, NVAL(j) on output will not, in general be the same as */ +/* NVAL(j) on input, but it will correspond with the interval */ +/* (AB(j,1),AB(j,2)] on output. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2) */ +/* The endpoints of the intervals. AB(j,1) is a(j), the left */ +/* endpoint of the j-th interval, and AB(j,2) is b(j), the */ +/* right endpoint of the j-th interval. The input intervals */ +/* will, in general, be modified, split, and reordered by the */ +/* calculation. */ + +/* C (input/output) DOUBLE PRECISION array, dimension (MMAX) */ +/* If IJOB=1, ignored. */ +/* If IJOB=2, workspace. */ +/* If IJOB=3, then on input C(j) should be initialized to the */ +/* first search point in the binary search. */ + +/* MOUT (output) INTEGER */ +/* If IJOB=1, the number of eigenvalues in the intervals. */ +/* If IJOB=2 or 3, the number of intervals output. */ +/* If IJOB=3, MOUT will equal MINP. */ + +/* NAB (input/output) INTEGER array, dimension (MMAX,2) */ +/* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). */ +/* If IJOB=2, then on input, NAB(i,j) should be set. It must */ +/* satisfy the condition: */ +/* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), */ +/* which means that in interval i only eigenvalues */ +/* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, */ +/* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with */ +/* IJOB=1. */ +/* On output, NAB(i,j) will contain */ +/* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of */ +/* the input interval that the output interval */ +/* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the */ +/* the input values of NAB(k,1) and NAB(k,2). */ +/* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), */ +/* unless N(w) > NVAL(i) for all search points w , in which */ +/* case NAB(i,1) will not be modified, i.e., the output */ +/* value will be the same as the input value (modulo */ +/* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) */ +/* for all search points w , in which case NAB(i,2) will */ +/* not be modified. Normally, NAB should be set to some */ +/* distinctive value(s) before DLAEBZ is called. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX) */ +/* Workspace. */ + +/* IWORK (workspace) INTEGER array, dimension (MMAX) */ +/* Workspace. */ + +/* INFO (output) INTEGER */ +/* = 0: All intervals converged. */ +/* = 1--MMAX: The last INFO intervals did not converge. */ +/* = MMAX+1: More than MMAX intervals were generated. */ + +/* Further Details */ +/* =============== */ + +/* This routine is intended to be called only by other LAPACK */ +/* routines, thus the interface is less user-friendly. It is intended */ +/* for two purposes: */ + +/* (a) finding eigenvalues. In this case, DLAEBZ should have one or */ +/* more initial intervals set up in AB, and DLAEBZ should be called */ +/* with IJOB=1. This sets up NAB, and also counts the eigenvalues. */ +/* Intervals with no eigenvalues would usually be thrown out at */ +/* this point. Also, if not all the eigenvalues in an interval i */ +/* are desired, NAB(i,1) can be increased or NAB(i,2) decreased. */ +/* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest */ +/* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX */ +/* no smaller than the value of MOUT returned by the call with */ +/* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 */ +/* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the */ +/* tolerance specified by ABSTOL and RELTOL. */ + +/* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). */ +/* In this case, start with a Gershgorin interval (a,b). Set up */ +/* AB to contain 2 search intervals, both initially (a,b). One */ +/* NVAL element should contain f-1 and the other should contain l */ +/* , while C should contain a and b, resp. NAB(i,1) should be -1 */ +/* and NAB(i,2) should be N+1, to flag an error if the desired */ +/* interval does not lie in (a,b). DLAEBZ is then called with */ +/* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- */ +/* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while */ +/* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r */ +/* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and */ +/* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and */ +/* w(l-r)=...=w(l+k) are handled similarly. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Check for Errors */ + + /* Parameter adjustments */ + nab_dim1 = *mmax; + nab_offset = 1 + nab_dim1; + nab -= nab_offset; + ab_dim1 = *mmax; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --d__; + --e; + --e2; + --nval; + --c__; + --work; + --iwork; + + /* Function Body */ + *info = 0; + if (*ijob < 1 || *ijob > 3) { + *info = -1; + return 0; + } + +/* Initialize NAB */ + + if (*ijob == 1) { + +/* Compute the number of eigenvalues in the initial intervals. */ + + *mout = 0; +/* DIR$ NOVECTOR */ + i__1 = *minp; + for (ji = 1; ji <= i__1; ++ji) { + for (jp = 1; jp <= 2; ++jp) { + tmp1 = d__[1] - ab[ji + jp * ab_dim1]; + if (abs(tmp1) < *pivmin) { + tmp1 = -(*pivmin); + } + nab[ji + jp * nab_dim1] = 0; + if (tmp1 <= 0.) { + nab[ji + jp * nab_dim1] = 1; + } + + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + tmp1 = d__[j] - e2[j - 1] / tmp1 - ab[ji + jp * ab_dim1]; + if (abs(tmp1) < *pivmin) { + tmp1 = -(*pivmin); + } + if (tmp1 <= 0.) { + ++nab[ji + jp * nab_dim1]; + } +/* L10: */ + } +/* L20: */ + } + *mout = *mout + nab[ji + (nab_dim1 << 1)] - nab[ji + nab_dim1]; +/* L30: */ + } + return 0; + } + +/* Initialize for loop */ + +/* KF and KL have the following meaning: */ +/* Intervals 1,...,KF-1 have converged. */ +/* Intervals KF,...,KL still need to be refined. */ + + kf = 1; + kl = *minp; + +/* If IJOB=2, initialize C. */ +/* If IJOB=3, use the user-supplied starting point. */ + + if (*ijob == 2) { + i__1 = *minp; + for (ji = 1; ji <= i__1; ++ji) { + c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5; +/* L40: */ + } + } + +/* Iteration loop */ + + i__1 = *nitmax; + for (jit = 1; jit <= i__1; ++jit) { + +/* Loop over intervals */ + + if (kl - kf + 1 >= *nbmin && *nbmin > 0) { + +/* Begin of Parallel Version of the loop */ + + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + +/* Compute N(c), the number of eigenvalues less than c */ + + work[ji] = d__[1] - c__[ji]; + iwork[ji] = 0; + if (work[ji] <= *pivmin) { + iwork[ji] = 1; +/* Computing MIN */ + d__1 = work[ji], d__2 = -(*pivmin); + work[ji] = std::min(d__1,d__2); + } + + i__3 = *n; + for (j = 2; j <= i__3; ++j) { + work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji]; + if (work[ji] <= *pivmin) { + ++iwork[ji]; +/* Computing MIN */ + d__1 = work[ji], d__2 = -(*pivmin); + work[ji] = std::min(d__1,d__2); + } +/* L50: */ + } +/* L60: */ + } + + if (*ijob <= 2) { + +/* IJOB=2: Choose all intervals containing eigenvalues. */ + + klnew = kl; + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + +/* Insure that N(w) is monotone */ + +/* Computing MIN */ +/* Computing MAX */ + i__5 = nab[ji + nab_dim1], i__6 = iwork[ji]; + i__3 = nab[ji + (nab_dim1 << 1)], i__4 = std::max(i__5,i__6); + iwork[ji] = std::min(i__3,i__4); + +/* Update the Queue -- add intervals if both halves */ +/* contain eigenvalues. */ + + if (iwork[ji] == nab[ji + (nab_dim1 << 1)]) { + +/* No eigenvalue in the upper interval: */ +/* just use the lower interval. */ + + ab[ji + (ab_dim1 << 1)] = c__[ji]; + + } else if (iwork[ji] == nab[ji + nab_dim1]) { + +/* No eigenvalue in the lower interval: */ +/* just use the upper interval. */ + + ab[ji + ab_dim1] = c__[ji]; + } else { + ++klnew; + if (klnew <= *mmax) { + +/* Eigenvalue in both intervals -- add upper to */ +/* queue. */ + + ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << + 1)]; + nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 + << 1)]; + ab[klnew + ab_dim1] = c__[ji]; + nab[klnew + nab_dim1] = iwork[ji]; + ab[ji + (ab_dim1 << 1)] = c__[ji]; + nab[ji + (nab_dim1 << 1)] = iwork[ji]; + } else { + *info = *mmax + 1; + } + } +/* L70: */ + } + if (*info != 0) { + return 0; + } + kl = klnew; + } else { + +/* IJOB=3: Binary search. Keep only the interval containing */ +/* w s.t. N(w) = NVAL */ + + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + if (iwork[ji] <= nval[ji]) { + ab[ji + ab_dim1] = c__[ji]; + nab[ji + nab_dim1] = iwork[ji]; + } + if (iwork[ji] >= nval[ji]) { + ab[ji + (ab_dim1 << 1)] = c__[ji]; + nab[ji + (nab_dim1 << 1)] = iwork[ji]; + } +/* L80: */ + } + } + + } else { + +/* End of Parallel Version of the loop */ + +/* Begin of Serial Version of the loop */ + + klnew = kl; + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + +/* Compute N(w), the number of eigenvalues less than w */ + + tmp1 = c__[ji]; + tmp2 = d__[1] - tmp1; + itmp1 = 0; + if (tmp2 <= *pivmin) { + itmp1 = 1; +/* Computing MIN */ + d__1 = tmp2, d__2 = -(*pivmin); + tmp2 = std::min(d__1,d__2); + } + +/* A series of compiler directives to defeat vectorization */ +/* for the next loop */ + +/* $PL$ CMCHAR=' ' */ +/* DIR$ NEXTSCALAR */ +/* $DIR SCALAR */ +/* DIR$ NEXT SCALAR */ +/* VD$L NOVECTOR */ +/* DEC$ NOVECTOR */ +/* VD$ NOVECTOR */ +/* VDIR NOVECTOR */ +/* VOCL LOOP,SCALAR */ +/* IBM PREFER SCALAR */ +/* $PL$ CMCHAR='*' */ + + i__3 = *n; + for (j = 2; j <= i__3; ++j) { + tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1; + if (tmp2 <= *pivmin) { + ++itmp1; +/* Computing MIN */ + d__1 = tmp2, d__2 = -(*pivmin); + tmp2 = std::min(d__1,d__2); + } +/* L90: */ + } + + if (*ijob <= 2) { + +/* IJOB=2: Choose all intervals containing eigenvalues. */ + +/* Insure that N(w) is monotone */ + +/* Computing MIN */ +/* Computing MAX */ + i__5 = nab[ji + nab_dim1]; + i__3 = nab[ji + (nab_dim1 << 1)], i__4 = std::max(i__5,itmp1); + itmp1 = std::min(i__3,i__4); + +/* Update the Queue -- add intervals if both halves */ +/* contain eigenvalues. */ + + if (itmp1 == nab[ji + (nab_dim1 << 1)]) { + +/* No eigenvalue in the upper interval: */ +/* just use the lower interval. */ + + ab[ji + (ab_dim1 << 1)] = tmp1; + + } else if (itmp1 == nab[ji + nab_dim1]) { + +/* No eigenvalue in the lower interval: */ +/* just use the upper interval. */ + + ab[ji + ab_dim1] = tmp1; + } else if (klnew < *mmax) { + +/* Eigenvalue in both intervals -- add upper to queue. */ + + ++klnew; + ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 1)]; + nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 << + 1)]; + ab[klnew + ab_dim1] = tmp1; + nab[klnew + nab_dim1] = itmp1; + ab[ji + (ab_dim1 << 1)] = tmp1; + nab[ji + (nab_dim1 << 1)] = itmp1; + } else { + *info = *mmax + 1; + return 0; + } + } else { + +/* IJOB=3: Binary search. Keep only the interval */ +/* containing w s.t. N(w) = NVAL */ + + if (itmp1 <= nval[ji]) { + ab[ji + ab_dim1] = tmp1; + nab[ji + nab_dim1] = itmp1; + } + if (itmp1 >= nval[ji]) { + ab[ji + (ab_dim1 << 1)] = tmp1; + nab[ji + (nab_dim1 << 1)] = itmp1; + } + } +/* L100: */ + } + kl = klnew; + +/* End of Serial Version of the loop */ + + } + +/* Check for convergence */ + + kfnew = kf; + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + tmp1 = (d__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], abs( + d__1)); +/* Computing MAX */ + d__3 = (d__1 = ab[ji + (ab_dim1 << 1)], abs(d__1)), d__4 = (d__2 = + ab[ji + ab_dim1], abs(d__2)); + tmp2 = std::max(d__3,d__4); +/* Computing MAX */ + d__1 = std::max(*abstol,*pivmin), d__2 = *reltol * tmp2; + if (tmp1 < std::max(d__1,d__2) || nab[ji + nab_dim1] >= nab[ji + ( + nab_dim1 << 1)]) { + +/* Converged -- Swap with position KFNEW, */ +/* then increment KFNEW */ + + if (ji > kfnew) { + tmp1 = ab[ji + ab_dim1]; + tmp2 = ab[ji + (ab_dim1 << 1)]; + itmp1 = nab[ji + nab_dim1]; + itmp2 = nab[ji + (nab_dim1 << 1)]; + ab[ji + ab_dim1] = ab[kfnew + ab_dim1]; + ab[ji + (ab_dim1 << 1)] = ab[kfnew + (ab_dim1 << 1)]; + nab[ji + nab_dim1] = nab[kfnew + nab_dim1]; + nab[ji + (nab_dim1 << 1)] = nab[kfnew + (nab_dim1 << 1)]; + ab[kfnew + ab_dim1] = tmp1; + ab[kfnew + (ab_dim1 << 1)] = tmp2; + nab[kfnew + nab_dim1] = itmp1; + nab[kfnew + (nab_dim1 << 1)] = itmp2; + if (*ijob == 3) { + itmp1 = nval[ji]; + nval[ji] = nval[kfnew]; + nval[kfnew] = itmp1; + } + } + ++kfnew; + } +/* L110: */ + } + kf = kfnew; + +/* Choose Midpoints */ + + i__2 = kl; + for (ji = kf; ji <= i__2; ++ji) { + c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5; +/* L120: */ + } + +/* If no more intervals to refine, quit. */ + + if (kf > kl) { + goto L140; + } +/* L130: */ + } + +/* Converged */ + +L140: +/* Computing MAX */ + i__1 = kl + 1 - kf; + *info = std::max(i__1,0_integer); + *mout = kl; + + return 0; + +/* End of DLAEBZ */ + +} /* dlaebz_ */ + +/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n, + double *d__, double *e, double *q, integer *ldq, + double *qstore, integer *ldqs, double *work, integer *iwork, + integer *info) +{ + /* Table of constant values */ + static integer c__9 = 9; + static integer c__0 = 0; + static integer c__2 = 2; + static double c_b23 = 1.; + static double c_b24 = 0.; + static integer c__1 = 1; + + /* System generated locals */ + integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2; + double temp; + integer curr; + integer iperm; + integer indxq, iwrem; + integer iqptr; + integer tlvls; + integer igivcl; + integer igivnm, submat, curprb, subpbs, igivpt; + integer curlvl, matsiz, iprmpt, smlsiz; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAED0 computes all eigenvalues and corresponding eigenvectors of a */ +/* symmetric tridiagonal matrix using the divide and conquer method. */ + +/* Arguments */ +/* ========= */ + +/* ICOMPQ (input) INTEGER */ +/* = 0: Compute eigenvalues only. */ +/* = 1: Compute eigenvectors of original dense symmetric matrix */ +/* also. On entry, Q contains the orthogonal matrix used */ +/* to reduce the original matrix to tridiagonal form. */ +/* = 2: Compute eigenvalues and eigenvectors of tridiagonal */ +/* matrix. */ + +/* QSIZ (input) INTEGER */ +/* The dimension of the orthogonal matrix used to reduce */ +/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ + +/* N (input) INTEGER */ +/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the main diagonal of the tridiagonal matrix. */ +/* On exit, its eigenvalues. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The off-diagonal elements of the tridiagonal matrix. */ +/* On exit, E has been destroyed. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ +/* On entry, Q must contain an N-by-N orthogonal matrix. */ +/* If ICOMPQ = 0 Q is not referenced. */ +/* If ICOMPQ = 1 On entry, Q is a subset of the columns of the */ +/* orthogonal matrix used to reduce the full */ +/* matrix to tridiagonal form corresponding to */ +/* the subset of the full matrix which is being */ +/* decomposed at this time. */ +/* If ICOMPQ = 2 On entry, Q will be the identity matrix. */ +/* On exit, Q contains the eigenvectors of the */ +/* tridiagonal matrix. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. If eigenvectors are */ +/* desired, then LDQ >= max(1,N). In any case, LDQ >= 1. */ + +/* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N) */ +/* Referenced only when ICOMPQ = 1. Used to store parts of */ +/* the eigenvector matrix when the updating matrix multiplies */ +/* take place. */ + +/* LDQS (input) INTEGER */ +/* The leading dimension of the array QSTORE. If ICOMPQ = 1, */ +/* then LDQS >= max(1,N). In any case, LDQS >= 1. */ + +/* WORK (workspace) DOUBLE PRECISION array, */ +/* If ICOMPQ = 0 or 1, the dimension of WORK must be at least */ +/* 1 + 3*N + 2*N*lg N + 2*N**2 */ +/* ( lg( N ) = smallest integer k */ +/* such that 2^k >= N ) */ +/* If ICOMPQ = 2, the dimension of WORK must be at least */ +/* 4*N + N**2. */ + +/* IWORK (workspace) INTEGER array, */ +/* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least */ +/* 6 + 6*N + 5*N*lg N. */ +/* ( lg( N ) = smallest integer k */ +/* such that 2^k >= N ) */ +/* If ICOMPQ = 2, the dimension of IWORK must be at least */ +/* 3 + 5*N. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: The algorithm failed to compute an eigenvalue while */ +/* working on the submatrix lying in rows and columns */ +/* INFO/(N+1) through mod(INFO,N+1). */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + qstore_dim1 = *ldqs; + qstore_offset = 1 + qstore_dim1; + qstore -= qstore_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 2) { + *info = -1; + } else if (*icompq == 1 && *qsiz < std::max(0_integer,*n)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldq < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldqs < std::max(1_integer,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED0", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + smlsiz = ilaenv_(&c__9, "DLAED0", " ", &c__0, &c__0, &c__0, &c__0); + +/* Determine the size and placement of the submatrices, and save in */ +/* the leading elements of IWORK. */ + + iwork[1] = *n; + subpbs = 1; + tlvls = 0; +L10: + if (iwork[subpbs] > smlsiz) { + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; +/* L20: */ + } + ++tlvls; + subpbs <<= 1; + goto L10; + } + i__1 = subpbs; + for (j = 2; j <= i__1; ++j) { + iwork[j] += iwork[j - 1]; +/* L30: */ + } + +/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */ +/* using rank-1 modifications (cuts). */ + + spm1 = subpbs - 1; + i__1 = spm1; + for (i__ = 1; i__ <= i__1; ++i__) { + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (d__1 = e[smm1], abs(d__1)); + d__[submat] -= (d__1 = e[smm1], abs(d__1)); +/* L40: */ + } + + indxq = (*n << 2) + 3; + if (*icompq != 2) { + +/* Set up workspaces for eigenvalues only/accumulate new vectors */ +/* routine */ + + temp = log((double) (*n)) / log(2.); + lgn = (integer) temp; + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + iprmpt = indxq + *n + 1; + iperm = iprmpt + *n * lgn; + iqptr = iperm + *n * lgn; + igivpt = iqptr + *n + 2; + igivcl = igivpt + *n * lgn; + + igivnm = 1; + iq = igivnm + (*n << 1) * lgn; +/* Computing 2nd power */ + i__1 = *n; + iwrem = iq + i__1 * i__1 + 1; + +/* Initialize pointers */ + + i__1 = subpbs; + for (i__ = 0; i__ <= i__1; ++i__) { + iwork[iprmpt + i__] = 1; + iwork[igivpt + i__] = 1; +/* L50: */ + } + iwork[iqptr] = 1; + } + +/* Solve each submatrix eigenproblem at the bottom of the divide and */ +/* conquer tree. */ + + curr = 0; + i__1 = spm1; + for (i__ = 0; i__ <= i__1; ++i__) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 1] - iwork[i__]; + } + if (*icompq == 2) { + dsteqr_("I", &matsiz, &d__[submat], &e[submat], &q[submat + + submat * q_dim1], ldq, &work[1], info); + if (*info != 0) { + goto L130; + } + } else { + dsteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 + + iwork[iqptr + curr]], &matsiz, &work[1], info); + if (*info != 0) { + goto L130; + } + if (*icompq == 1) { + dgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat * + q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]], + &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1], + ldqs); + } +/* Computing 2nd power */ + i__2 = matsiz; + iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; + ++curr; + } + k = 1; + i__2 = iwork[i__ + 1]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j] = k; + ++k; +/* L60: */ + } +/* L70: */ + } + +/* Successively merge eigensystems of adjacent submatrices */ +/* into eigensystem for the corresponding larger matrix. */ + +/* while ( SUBPBS > 1 ) */ + + curlvl = 1; +L80: + if (subpbs > 1) { + spm2 = subpbs - 2; + i__1 = spm2; + for (i__ = 0; i__ <= i__1; i__ += 2) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[2]; + msd2 = iwork[1]; + curprb = 0; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 2] - iwork[i__]; + msd2 = matsiz / 2; + ++curprb; + } + +/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */ +/* into an eigensystem of size MATSIZ. */ +/* DLAED1 is used only for the full eigensystem of a tridiagonal */ +/* matrix. */ +/* DLAED7 handles the cases in which eigenvalues only or eigenvalues */ +/* and eigenvectors of a full symmetric matrix (which was reduced to */ +/* tridiagonal form) are desired. */ + + if (*icompq == 2) { + dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1], + ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], & + msd2, &work[1], &iwork[subpbs + 1], info); + } else { + dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[ + submat], &qstore[submat * qstore_dim1 + 1], ldqs, & + iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, & + work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm] +, &iwork[igivpt], &iwork[igivcl], &work[igivnm], & + work[iwrem], &iwork[subpbs + 1], info); + } + if (*info != 0) { + goto L130; + } + iwork[i__ / 2 + 1] = iwork[i__ + 2]; +/* L90: */ + } + subpbs /= 2; + ++curlvl; + goto L80; + } + +/* end while */ + +/* Re-merge the eigenvalues/vectors which were deflated at the final */ +/* merge step. */ + + if (*icompq == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + + 1], &c__1); +/* L100: */ + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + } else if (*icompq == 2) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; + dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1); +/* L110: */ + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + dlacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq); + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + work[i__] = d__[j]; +/* L120: */ + } + dcopy_(n, &work[1], &c__1, &d__[1], &c__1); + } + goto L140; + +L130: + *info = submat * (*n + 1) + submat + matsiz - 1; + +L140: + return 0; + +/* End of DLAED0 */ + +} /* dlaed0_ */ + +/* Subroutine */ int dlaed1_(integer *n, double *d__, double *q, + integer *ldq, integer *indxq, double *rho, integer *cutpnt, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + + /* Local variables */ + integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc; + integer indxp; + integer idlmda; + integer coltyp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAED1 computes the updated eigensystem of a diagonal */ +/* matrix after modification by a rank-one symmetric matrix. This */ +/* routine is used only for the eigenproblem which requires all */ +/* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles */ +/* the case in which eigenvalues only or eigenvalues and eigenvectors */ +/* of a full symmetric matrix (which was reduced to tridiagonal form) */ +/* are desired. */ + +/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */ + +/* where Z = Q'u, u is a vector of length N with ones in the */ +/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */ + +/* The eigenvectors of the original matrix are stored in Q, and the */ +/* eigenvalues are in D. The algorithm consists of three stages: */ + +/* The first stage consists of deflating the size of the problem */ +/* when there are multiple eigenvalues or if there is a zero in */ +/* the Z vector. For each such occurence the dimension of the */ +/* secular equation problem is reduced by one. This stage is */ +/* performed by the routine DLAED2. */ + +/* The second stage consists of calculating the updated */ +/* eigenvalues. This is done by finding the roots of the secular */ +/* equation via the routine DLAED4 (as called by DLAED3). */ +/* This routine also calculates the eigenvectors of the current */ +/* problem. */ + +/* The final stage consists of computing the updated eigenvectors */ +/* directly using the updated eigenvalues. The eigenvectors for */ +/* the current problem are multiplied with the eigenvectors from */ +/* the overall problem. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the eigenvalues of the rank-1-perturbed matrix. */ +/* On exit, the eigenvalues of the repaired matrix. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* On entry, the eigenvectors of the rank-1-perturbed matrix. */ +/* On exit, the eigenvectors of the repaired tridiagonal matrix. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N). */ + +/* INDXQ (input/output) INTEGER array, dimension (N) */ +/* On entry, the permutation which separately sorts the two */ +/* subproblems in D into ascending order. */ +/* On exit, the permutation which will reintegrate the */ +/* subproblems back into sorted order, */ +/* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. */ + +/* RHO (input) DOUBLE PRECISION */ +/* The subdiagonal entry used to create the rank-1 modification. */ + +/* CUTPNT (input) INTEGER */ +/* The location of the last eigenvalue in the leading sub-matrix. */ +/* min(1,N) <= CUTPNT <= N/2. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2) */ + +/* IWORK (workspace) INTEGER array, dimension (4*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an eigenvalue did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ +/* Modified by Francoise Tisseur, University of Tennessee. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -1; + } else if (*ldq < std::max(1_integer,*n)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MIN */ + i__1 = 1, i__2 = *n / 2; + if (std::min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) { + *info = -7; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED1", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* The following values are integer pointers which indicate */ +/* the portion of the workspace */ +/* used by a particular array in DLAED2 and DLAED3. */ + + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq2 = iw + *n; + + indx = 1; + indxc = indx + *n; + coltyp = indxc + *n; + indxp = coltyp + *n; + + +/* Form the z-vector which consists of the last row of Q_1 and the */ +/* first row of Q_2. */ + + dcopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1); + zpp1 = *cutpnt + 1; + i__1 = *n - *cutpnt; + dcopy_(&i__1, &q[zpp1 + zpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1); + +/* Deflate eigenvalues. */ + + dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[ + iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[ + indxc], &iwork[indxp], &iwork[coltyp], info); + + if (*info != 0) { + goto L20; + } + +/* Solve Secular Equation. */ + + if (k != 0) { + is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp + + 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2; + dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda], + &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[ + is], info); + if (*info != 0) { + goto L20; + } + +/* Prepare the INDXQ sorting permutation. */ + + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; +/* L10: */ + } + } + +L20: + return 0; + +/* End of DLAED1 */ + +} /* dlaed1_ */ + +/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, double * + d__, double *q, integer *ldq, integer *indxq, double *rho, + double *z__, double *dlamda, double *w, double *q2, + integer *indx, integer *indxc, integer *indxp, integer *coltyp, + integer *info) +{ + /* Table of constant values */ + static double c_b3 = -1.; + static integer c__1 = 1; + + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + double d__1, d__2, d__3, d__4; + + /* Builtin functions + double sqrt(double);*/ + + /* Local variables */ + double c__; + integer i__, j; + double s, t; + integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1; + double eps, tau, tol; + integer psm[4], imax, jmax; + integer ctot[4]; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAED2 merges the two sets of eigenvalues together into a single */ +/* sorted set. Then it tries to deflate the size of the problem. */ +/* There are two ways in which deflation can occur: when two or more */ +/* eigenvalues are close together or if there is a tiny entry in the */ +/* Z vector. For each such occurrence the order of the related secular */ +/* equation problem is reduced by one. */ + +/* Arguments */ +/* ========= */ + +/* K (output) INTEGER */ +/* The number of non-deflated eigenvalues, and the order of the */ +/* related secular equation. 0 <= K <=N. */ + +/* N (input) INTEGER */ +/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ + +/* N1 (input) INTEGER */ +/* The location of the last eigenvalue in the leading sub-matrix. */ +/* min(1,N) <= N1 <= N/2. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, D contains the eigenvalues of the two submatrices to */ +/* be combined. */ +/* On exit, D contains the trailing (N-K) updated eigenvalues */ +/* (those which were deflated) sorted into increasing order. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ +/* On entry, Q contains the eigenvectors of two submatrices in */ +/* the two square blocks with corners at (1,1), (N1,N1) */ +/* and (N1+1, N1+1), (N,N). */ +/* On exit, Q contains the trailing (N-K) updated eigenvectors */ +/* (those which were deflated) in its last N-K columns. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N). */ + +/* INDXQ (input/output) INTEGER array, dimension (N) */ +/* The permutation which separately sorts the two sub-problems */ +/* in D into ascending order. Note that elements in the second */ +/* half of this permutation must first have N1 added to their */ +/* values. Destroyed on exit. */ + +/* RHO (input/output) DOUBLE PRECISION */ +/* On entry, the off-diagonal element associated with the rank-1 */ +/* cut which originally split the two submatrices which are now */ +/* being recombined. */ +/* On exit, RHO has been modified to the value required by */ +/* DLAED3. */ + +/* Z (input) DOUBLE PRECISION array, dimension (N) */ +/* On entry, Z contains the updating vector (the last */ +/* row of the first sub-eigenvector matrix and the first row of */ +/* the second sub-eigenvector matrix). */ +/* On exit, the contents of Z have been destroyed by the updating */ +/* process. */ + +/* DLAMDA (output) DOUBLE PRECISION array, dimension (N) */ +/* A copy of the first K eigenvalues which will be used by */ +/* DLAED3 to form the secular equation. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first k values of the final deflation-altered z-vector */ +/* which will be passed to DLAED3. */ + +/* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) */ +/* A copy of the first K eigenvectors which will be used by */ +/* DLAED3 in a matrix multiply (DGEMM) to solve for the new */ +/* eigenvectors. */ + +/* INDX (workspace) INTEGER array, dimension (N) */ +/* The permutation used to sort the contents of DLAMDA into */ +/* ascending order. */ + +/* INDXC (output) INTEGER array, dimension (N) */ +/* The permutation used to arrange the columns of the deflated */ +/* Q matrix into three groups: the first group contains non-zero */ +/* elements only at and above N1, the second contains */ +/* non-zero elements only below N1, and the third is dense. */ + +/* INDXP (workspace) INTEGER array, dimension (N) */ +/* The permutation used to place deflated values of D at the end */ +/* of the array. INDXP(1:K) points to the nondeflated D-values */ +/* and INDXP(K+1:N) points to the deflated eigenvalues. */ + +/* COLTYP (workspace/output) INTEGER array, dimension (N) */ +/* During execution, a label which will indicate which of the */ +/* following types a column in the Q2 matrix is: */ +/* 1 : non-zero in the upper half only; */ +/* 2 : dense; */ +/* 3 : non-zero in the lower half only; */ +/* 4 : deflated. */ +/* On exit, COLTYP(i) is the number of columns of type i, */ +/* for i=1 to 4 only. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ +/* Modified by Francoise Tisseur, University of Tennessee. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --z__; + --dlamda; + --w; + --q2; + --indx; + --indxc; + --indxp; + --coltyp; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -2; + } else if (*ldq < std::max(1_integer,*n)) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MIN */ + i__1 = 1, i__2 = *n / 2; + if (std::min(i__1,i__2) > *n1 || *n / 2 < *n1) { + *info = -3; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + n2 = *n - *n1; + n1p1 = *n1 + 1; + + if (*rho < 0.) { + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + +/* Normalize z so that norm(z) = 1. Since z is the concatenation of */ +/* two normalized vectors, norm2(z) = sqrt(2). */ + + t = 1. / sqrt(2.); + dscal_(n, &t, &z__[1], &c__1); + +/* RHO = ABS( norm(z)**2 * RHO ) */ + + *rho = (d__1 = *rho * 2., abs(d__1)); + +/* Sort the eigenvalues into increasing order */ + + i__1 = *n; + for (i__ = n1p1; i__ <= i__1; ++i__) { + indxq[i__] += *n1; +/* L10: */ + } + +/* re-integrate the deflated parts from the last pass */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = d__[indxq[i__]]; +/* L20: */ + } + dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indx[i__] = indxq[indxc[i__]]; +/* L30: */ + } + +/* Calculate the allowable deflation tolerance */ + + imax = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_("Epsilon"); +/* Computing MAX */ + d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2)) + ; + tol = eps * 8. * std::max(d__3,d__4); + +/* If the rank-1 modifier is small enough, no more needs to be done */ +/* except to reorganize Q so that its columns correspond with the */ +/* elements in D. */ + + if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { + *k = 0; + iq2 = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = indx[j]; + dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + dlamda[j] = d__[i__]; + iq2 += *n; +/* L40: */ + } + dlacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq); + dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1); + goto L190; + } + +/* If there are multiple eigenvalues then the problem deflates. Here */ +/* the number of equal eigenvalues are found. As each equal */ +/* eigenvalue is found, an elementary reflector is computed to rotate */ +/* the corresponding eigensubspace so that the corresponding */ +/* components of Z are zero in this new basis. */ + + i__1 = *n1; + for (i__ = 1; i__ <= i__1; ++i__) { + coltyp[i__] = 1; +/* L50: */ + } + i__1 = *n; + for (i__ = n1p1; i__ <= i__1; ++i__) { + coltyp[i__] = 3; +/* L60: */ + } + + + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + nj = indx[j]; + if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + coltyp[nj] = 4; + indxp[k2] = nj; + if (j == *n) { + goto L100; + } + } else { + pj = nj; + goto L80; + } +/* L70: */ + } +L80: + ++j; + nj = indx[j]; + if (j > *n) { + goto L100; + } + if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + coltyp[nj] = 4; + indxp[k2] = nj; + } else { + +/* Check if eigenvalues are close enough to allow deflation. */ + + s = z__[pj]; + c__ = z__[nj]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = dlapy2_(&c__, &s); + t = d__[nj] - d__[pj]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + +/* Deflation is possible. */ + + z__[nj] = tau; + z__[pj] = 0.; + if (coltyp[nj] != coltyp[pj]) { + coltyp[nj] = 2; + } + coltyp[pj] = 4; + drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, & + c__, &s); +/* Computing 2nd power */ + d__1 = c__; +/* Computing 2nd power */ + d__2 = s; + t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); +/* Computing 2nd power */ + d__1 = s; +/* Computing 2nd power */ + d__2 = c__; + d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2); + d__[pj] = t; + --k2; + i__ = 1; +L90: + if (k2 + i__ <= *n) { + if (d__[pj] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = pj; + ++i__; + goto L90; + } else { + indxp[k2 + i__ - 1] = pj; + } + } else { + indxp[k2 + i__ - 1] = pj; + } + pj = nj; + } else { + ++(*k); + dlamda[*k] = d__[pj]; + w[*k] = z__[pj]; + indxp[*k] = pj; + pj = nj; + } + } + goto L80; +L100: + +/* Record the last eigenvalue. */ + + ++(*k); + dlamda[*k] = d__[pj]; + w[*k] = z__[pj]; + indxp[*k] = pj; + +/* Count up the total number of the various types of columns, then */ +/* form a permutation which positions the four column types into */ +/* four uniform groups (although one or more of these groups may be */ +/* empty). */ + + for (j = 1; j <= 4; ++j) { + ctot[j - 1] = 0; +/* L110: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ct = coltyp[j]; + ++ctot[ct - 1]; +/* L120: */ + } + +/* PSM(*) = Position in SubMatrix (of types 1 through 4) */ + + psm[0] = 1; + psm[1] = ctot[0] + 1; + psm[2] = psm[1] + ctot[1]; + psm[3] = psm[2] + ctot[2]; + *k = *n - ctot[3]; + +/* Fill out the INDXC array so that the permutation which it induces */ +/* will place all type-1 columns first, all type-2 columns next, */ +/* then all type-3's, and finally all type-4's. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + js = indxp[j]; + ct = coltyp[js]; + indx[psm[ct - 1]] = js; + indxc[psm[ct - 1]] = j; + ++psm[ct - 1]; +/* L130: */ + } + +/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */ +/* and Q2 respectively. The eigenvalues/vectors which were not */ +/* deflated go into the first K slots of DLAMDA and Q2 respectively, */ +/* while those which were deflated go into the last N - K slots. */ + + i__ = 1; + iq1 = 1; + iq2 = (ctot[0] + ctot[1]) * *n1 + 1; + i__1 = ctot[0]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + z__[i__] = d__[js]; + ++i__; + iq1 += *n1; +/* L140: */ + } + + i__1 = ctot[1]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1); + dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); + z__[i__] = d__[js]; + ++i__; + iq1 += *n1; + iq2 += n2; +/* L150: */ + } + + i__1 = ctot[2]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1); + z__[i__] = d__[js]; + ++i__; + iq2 += n2; +/* L160: */ + } + + iq1 = iq2; + i__1 = ctot[3]; + for (j = 1; j <= i__1; ++j) { + js = indx[i__]; + dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1); + iq2 += *n; + z__[i__] = d__[js]; + ++i__; +/* L170: */ + } + +/* The deflated eigenvalues and their corresponding vectors go back */ +/* into the last N - K slots of D and Q respectively. */ + + dlacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq); + i__1 = *n - *k; + dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1); + +/* Copy CTOT into COLTYP for referencing in DLAED3. */ + + for (j = 1; j <= 4; ++j) { + coltyp[j] = ctot[j - 1]; +/* L180: */ + } + +L190: + return 0; + +/* End of DLAED2 */ + +} /* dlaed2_ */ + +/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, double * + d__, double *q, integer *ldq, double *rho, double *dlamda, + double *q2, integer *indx, integer *ctot, double *w, + double *s, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b22 = 1.; + static double c_b23 = 0.; + + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + double d__1; + + /* Builtin functions + double sqrt(double), d_sign(double *, double *);*/ + + /* Local variables */ + integer i__, j, n2, n12, ii, n23, iq2; + double temp; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAED3 finds the roots of the secular equation, as defined by the */ +/* values in D, W, and RHO, between 1 and K. It makes the */ +/* appropriate calls to DLAED4 and then updates the eigenvectors by */ +/* multiplying the matrix of eigenvectors of the pair of eigensystems */ +/* being combined by the matrix of eigenvectors of the K-by-K system */ +/* which is solved here. */ + +/* This code makes very mild assumptions about floating point */ +/* arithmetic. It will work on machines with a guard digit in */ +/* add/subtract, or on those binary machines without guard digits */ +/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ +/* It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* K (input) INTEGER */ +/* The number of terms in the rational function to be solved by */ +/* DLAED4. K >= 0. */ + +/* N (input) INTEGER */ +/* The number of rows and columns in the Q matrix. */ +/* N >= K (deflation may result in N>K). */ + +/* N1 (input) INTEGER */ +/* The location of the last eigenvalue in the leading submatrix. */ +/* min(1,N) <= N1 <= N/2. */ + +/* D (output) DOUBLE PRECISION array, dimension (N) */ +/* D(I) contains the updated eigenvalues for */ +/* 1 <= I <= K. */ + +/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* Initially the first K columns are used as workspace. */ +/* On output the columns 1 to K contain */ +/* the updated eigenvectors. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N). */ + +/* RHO (input) DOUBLE PRECISION */ +/* The value of the parameter in the rank one update equation. */ +/* RHO >= 0 required. */ + +/* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K) */ +/* The first K elements of this array contain the old roots */ +/* of the deflated updating problem. These are the poles */ +/* of the secular equation. May be changed on output by */ +/* having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */ +/* Cray-2, or Cray C-90, as described above. */ + +/* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N) */ +/* The first K columns of this matrix contain the non-deflated */ +/* eigenvectors for the split problem. */ + +/* INDX (input) INTEGER array, dimension (N) */ +/* The permutation used to arrange the columns of the deflated */ +/* Q matrix into three groups (see DLAED2). */ +/* The rows of the eigenvectors found by DLAED4 must be likewise */ +/* permuted before the matrix multiply can take place. */ + +/* CTOT (input) INTEGER array, dimension (4) */ +/* A count of the total number of the various types of columns */ +/* in Q, as described in INDX. The fourth column type is any */ +/* column which has been deflated. */ + +/* W (input/output) DOUBLE PRECISION array, dimension (K) */ +/* The first K elements of this array contain the components */ +/* of the deflation-adjusted updating vector. Destroyed on */ +/* output. */ + +/* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K */ +/* Will contain the eigenvectors of the repaired matrix which */ +/* will be multiplied by the previously accumulated eigenvectors */ +/* to update the system. */ + +/* LDS (input) INTEGER */ +/* The leading dimension of S. LDS >= max(1,K). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an eigenvalue did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ +/* Modified by Francoise Tisseur, University of Tennessee. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --dlamda; + --q2; + --indx; + --ctot; + --w; + --s; + + /* Function Body */ + *info = 0; + + if (*k < 0) { + *info = -1; + } else if (*n < *k) { + *info = -2; + } else if (*ldq < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED3", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*k == 0) { + return 0; + } + +/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ +/* be computed with high relative accuracy (barring over/underflow). */ +/* This is a problem on machines without a guard digit in */ +/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ +/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */ +/* which on any of these machines zeros out the bottommost */ +/* bit of DLAMDA(I) if it is 1; this makes the subsequent */ +/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */ +/* occurs. On binary machines with a guard digit (almost all */ +/* machines) it does not change DLAMDA(I) at all. On hexadecimal */ +/* and decimal machines with a guard digit, it slightly */ +/* changes the bottommost bits of DLAMDA(I). It does not account */ +/* for hexadecimal or decimal machines without guard digits */ +/* (we know of none). We use a subroutine call to compute */ +/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */ +/* this code. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; +/* L10: */ + } + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], + info); + +/* If the zero finder fails, the computation is terminated. */ + + if (*info != 0) { + goto L120; + } +/* L20: */ + } + + if (*k == 1) { + goto L110; + } + if (*k == 2) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + w[1] = q[j * q_dim1 + 1]; + w[2] = q[j * q_dim1 + 2]; + ii = indx[1]; + q[j * q_dim1 + 1] = w[ii]; + ii = indx[2]; + q[j * q_dim1 + 2] = w[ii]; +/* L30: */ + } + goto L110; + } + +/* Compute updated W. */ + + dcopy_(k, &w[1], &c__1, &s[1], &c__1); + +/* Initialize W(I) = Q(I,I) */ + + i__1 = *ldq + 1; + dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); +/* L40: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); +/* L50: */ + } +/* L60: */ + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = sqrt(-w[i__]); + w[i__] = d_sign(&d__1, &s[i__]); +/* L70: */ + } + +/* Compute eigenvectors of the modified rank-1 modification. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + s[i__] = w[i__] / q[i__ + j * q_dim1]; +/* L80: */ + } + temp = dnrm2_(k, &s[1], &c__1); + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + ii = indx[i__]; + q[i__ + j * q_dim1] = s[ii] / temp; +/* L90: */ + } +/* L100: */ + } + +/* Compute the updated eigenvectors. */ + +L110: + + n2 = *n - *n1; + n12 = ctot[1] + ctot[2]; + n23 = ctot[2] + ctot[3]; + + dlacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23); + iq2 = *n1 * n12 + 1; + if (n23 != 0) { + dgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, & + c_b23, &q[*n1 + 1 + q_dim1], ldq); + } else { + dlaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq); + } + + dlacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12); + if (n12 != 0) { + dgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23, + &q[q_offset], ldq); + } else { + dlaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq); + } + + +L120: + return 0; + +/* End of DLAED3 */ + +} /* dlaed3_ */ + +/* Subroutine */ int dlaed4_(integer *n, integer *i__, double *d__, + double *z__, double *delta, double *rho, double *dlam, + integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + double a, b, c__; + integer j; + double w; + integer ii; + double dw, zz[3]; + integer ip1; + double del, eta, phi, eps, tau, psi; + integer iim1, iip1; + double dphi, dpsi; + integer iter; + double temp, prew, temp1, dltlb, dltub, midpt; + integer niter; + bool swtch; + bool swtch3; + bool orgati; + double erretm, rhoinv; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This subroutine computes the I-th updated eigenvalue of a symmetric */ +/* rank-one modification to a diagonal matrix whose elements are */ +/* given in the array d, and that */ + +/* D(i) < D(j) for i < j */ + +/* and that RHO > 0. This is arranged by the calling routine, and is */ +/* no loss in generality. The rank-one modified system is thus */ + +/* diag( D ) + RHO * Z * Z_transpose. */ + +/* where we assume the Euclidean norm of Z is 1. */ + +/* The method consists of approximating the rational functions in the */ +/* secular equation by simpler interpolating rational functions. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The length of all arrays. */ + +/* I (input) INTEGER */ +/* The index of the eigenvalue to be computed. 1 <= I <= N. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The original eigenvalues. It is assumed that they are in */ +/* order, D(I) < D(J) for I < J. */ + +/* Z (input) DOUBLE PRECISION array, dimension (N) */ +/* The components of the updating vector. */ + +/* DELTA (output) DOUBLE PRECISION array, dimension (N) */ +/* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th */ +/* component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5 */ +/* for detail. The vector DELTA contains the information necessary */ +/* to construct the eigenvectors by DLAED3 and DLAED9. */ + +/* RHO (input) DOUBLE PRECISION */ +/* The scalar in the symmetric updating formula. */ + +/* DLAM (output) DOUBLE PRECISION */ +/* The computed lambda_I, the I-th updated eigenvalue. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* > 0: if INFO = 1, the updating process failed. */ + +/* Internal Parameters */ +/* =================== */ + +/* Logical variable ORGATI (origin-at-i?) is used for distinguishing */ +/* whether D(i) or D(i+1) is treated as the origin. */ + +/* ORGATI = .true. origin at i */ +/* ORGATI = .false. origin at i+1 */ + +/* Logical variable SWTCH3 (switch-for-3-poles?) is for noting */ +/* if we are working with THREE poles! */ + +/* MAXIT is the maximum number of iterations allowed for each */ +/* eigenvalue. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ren-Cang Li, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Since this routine is called in an inner loop, we do no argument */ +/* checking. */ + +/* Quick return for N=1 and 2. */ + + /* Parameter adjustments */ + --delta; + --z__; + --d__; + + /* Function Body */ + *info = 0; + if (*n == 1) { + +/* Presumably, I=1 upon entry */ + + *dlam = d__[1] + *rho * z__[1] * z__[1]; + delta[1] = 1.; + return 0; + } + if (*n == 2) { + dlaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam); + return 0; + } + +/* Compute machine epsilon */ + + eps = dlamch_("Epsilon"); + rhoinv = 1. / *rho; + +/* The case I = N */ + + if (*i__ == *n) { + +/* Initialize some basic variables */ + + ii = *n - 1; + niter = 1; + +/* Calculate initial guess */ + + midpt = *rho / 2.; + +/* If ||Z||_2 is not one, then TEMP should be set to */ +/* RHO * ||Z||_2^2 / TWO */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; +/* L10: */ + } + + psi = 0.; + i__1 = *n - 2; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; +/* L20: */ + } + + c__ = rhoinv + psi; + w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[* + n]; + + if (w <= 0.) { + temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho) + + z__[*n] * z__[*n] / *rho; + if (c__ <= temp) { + tau = *rho; + } else { + del = d__[*n] - d__[*n - 1]; + a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n] + ; + b = z__[*n] * z__[*n] * del; + if (a < 0.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + } + +/* It can be proved that */ +/* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO */ + + dltlb = midpt; + dltub = *rho; + } else { + del = d__[*n] - d__[*n - 1]; + a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * del; + if (a < 0.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + +/* It can be proved that */ +/* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */ + + dltlb = 0.; + dltub = midpt; + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - tau; +/* L30: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L40: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + + dphi); + + w = rhoinv + phi + psi; + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + *dlam = d__[*i__] + tau; + goto L250; + } + + if (w <= 0.) { + dltlb = std::max(dltlb,tau); + } else { + dltub = std::min(dltub,tau); + } + +/* Calculate the new step */ + + ++niter; + c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; + a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * ( + dpsi + dphi); + b = delta[*n - 1] * delta[*n] * w; + if (c__ < 0.) { + c__ = abs(c__); + } + if (c__ == 0.) { +/* ETA = B/A */ +/* ETA = RHO - TAU */ + eta = dltub - tau; + } else if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ + * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) + ); + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L50: */ + } + + tau += eta; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L60: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + + dphi); + + w = rhoinv + phi + psi; + +/* Main loop to update the values of the array DELTA */ + + iter = niter + 1; + + for (niter = iter; niter <= 30; ++niter) { + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + *dlam = d__[*i__] + tau; + goto L250; + } + + if (w <= 0.) { + dltlb = std::max(dltlb,tau); + } else { + dltub = std::min(dltub,tau); + } + +/* Calculate the new step */ + + c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi; + a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * + (dpsi + dphi); + b = delta[*n - 1] * delta[*n] * w; + if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L70: */ + } + + tau += eta; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L80: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / delta[*n]; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * ( + dpsi + dphi); + + w = rhoinv + phi + psi; +/* L90: */ + } + +/* Return with INFO = 1, NITER = MAXIT and not converged */ + + *info = 1; + *dlam = d__[*i__] + tau; + goto L250; + +/* End for the case I = N */ + + } else { + +/* The case for I < N */ + + niter = 1; + ip1 = *i__ + 1; + +/* Calculate initial guess */ + + del = d__[ip1] - d__[*i__]; + midpt = del / 2.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - midpt; +/* L100: */ + } + + psi = 0.; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / delta[j]; +/* L110: */ + } + + phi = 0.; + i__1 = *i__ + 2; + for (j = *n; j >= i__1; --j) { + phi += z__[j] * z__[j] / delta[j]; +/* L120: */ + } + c__ = rhoinv + psi + phi; + w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] / + delta[ip1]; + + if (w > 0.) { + +/* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 */ + +/* We choose d(i) as origin. */ + + orgati = true; + a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * del; + if (a > 0.) { + tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } else { + tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } + dltlb = 0.; + dltub = midpt; + } else { + +/* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) */ + +/* We choose d(i+1) as origin. */ + + orgati = false; + a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * del; + if (a < 0.) { + tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( + d__1)))); + } else { + tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / + (c__ * 2.); + } + dltlb = -midpt; + dltub = 0.; + } + + if (orgati) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - tau; +/* L130: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[ip1] - tau; +/* L140: */ + } + } + if (orgati) { + ii = *i__; + } else { + ii = *i__ + 1; + } + iim1 = ii - 1; + iip1 = ii + 1; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L150: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L160: */ + } + + w = rhoinv + phi + psi; + +/* W is the value of the secular function with */ +/* its ii-th element removed. */ + + swtch3 = false; + if (orgati) { + if (w < 0.) { + swtch3 = true; + } + } else { + if (w > 0.) { + swtch3 = true; + } + } + if (ii == 1 || ii == *n) { + swtch3 = false; + } + + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w += temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + + abs(tau) * dw; + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + goto L250; + } + + if (w <= 0.) { + dltlb = std::max(dltlb,tau); + } else { + dltub = std::min(dltub,tau); + } + +/* Calculate the new step */ + + ++niter; + if (! swtch3) { + if (orgati) { +/* Computing 2nd power */ + d__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 * + d__1); + } else { +/* Computing 2nd power */ + d__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 * + d__1); + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] * + dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.) { + if (a == 0.) { + if (orgati) { + a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] * + (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] * + (dpsi + dphi); + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } + } else { + +/* Interpolation using THREE most relevant poles */ + + temp = rhoinv + psi + phi; + if (orgati) { + temp1 = z__[iim1] / delta[iim1]; + temp1 *= temp1; + c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[ + iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi); + } else { + temp1 = z__[iip1] / delta[iip1]; + temp1 *= temp1; + c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[ + iim1]) * temp1; + zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1)); + zz[2] = z__[iip1] * z__[iip1]; + } + zz[1] = z__[ii] * z__[ii]; + dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info); + if (*info != 0) { + goto L250; + } + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta >= 0.) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + + prew = w; + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L180: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L190: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L200: */ + } + + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + ( + d__1 = tau + eta, abs(d__1)) * dw; + + swtch = false; + if (orgati) { + if (-w > abs(prew) / 10.) { + swtch = true; + } + } else { + if (w > abs(prew) / 10.) { + swtch = true; + } + } + + tau += eta; + +/* Main loop to update the values of the array DELTA */ + + iter = niter + 1; + + for (niter = iter; niter <= 30; ++niter) { + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + goto L250; + } + + if (w <= 0.) { + dltlb = std::max(dltlb,tau); + } else { + dltub = std::min(dltub,tau); + } + +/* Calculate the new step */ + + if (! swtch3) { + if (! swtch) { + if (orgati) { +/* Computing 2nd power */ + d__1 = z__[*i__] / delta[*i__]; + c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * ( + d__1 * d__1); + } else { +/* Computing 2nd power */ + d__1 = z__[ip1] / delta[ip1]; + c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * + (d__1 * d__1); + } + } else { + temp = z__[ii] / delta[ii]; + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi; + } + a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] + * dw; + b = delta[*i__] * delta[ip1] * w; + if (c__ == 0.) { + if (a == 0.) { + if (! swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + delta[ip1] * + delta[ip1] * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + delta[*i__] * delta[ + *i__] * (dpsi + dphi); + } + } else { + a = delta[*i__] * delta[*i__] * dpsi + delta[ip1] + * delta[ip1] * dphi; + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) + / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, + abs(d__1)))); + } + } else { + +/* Interpolation using THREE most relevant poles */ + + temp = rhoinv + psi + phi; + if (swtch) { + c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi; + zz[0] = delta[iim1] * delta[iim1] * dpsi; + zz[2] = delta[iip1] * delta[iip1] * dphi; + } else { + if (orgati) { + temp1 = z__[iim1] / delta[iim1]; + temp1 *= temp1; + c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] + - d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + + dphi); + } else { + temp1 = z__[iip1] / delta[iip1]; + temp1 *= temp1; + c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] + - d__[iim1]) * temp1; + zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - + temp1)); + zz[2] = z__[iip1] * z__[iip1]; + } + } + dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, + info); + if (*info != 0) { + goto L250; + } + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta >= 0.) { + eta = -w / dw; + } + temp = tau + eta; + if (temp > dltub || temp < dltlb) { + if (w < 0.) { + eta = (dltub - tau) / 2.; + } else { + eta = (dltlb - tau) / 2.; + } + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; +/* L210: */ + } + + tau += eta; + prew = w; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / delta[j]; + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L220: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / delta[j]; + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L230: */ + } + + temp = z__[ii] / delta[ii]; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + + abs(tau) * dw; + if (w * prew > 0. && abs(w) > abs(prew) / 10.) { + swtch = ! swtch; + } + +/* L240: */ + } + +/* Return with INFO = 1, NITER = MAXIT and not converged */ + + *info = 1; + if (orgati) { + *dlam = d__[*i__] + tau; + } else { + *dlam = d__[ip1] + tau; + } + + } + +L250: + + return 0; + +/* End of DLAED4 */ + +} /* dlaed4_ */ + +/* Subroutine */ int dlaed5_(integer *i__, double *d__, double *z__, + double *delta, double *rho, double *dlam) +{ + /* System generated locals */ + double d__1; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + double b, c__, w, del, tau, temp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This subroutine computes the I-th eigenvalue of a symmetric rank-one */ +/* modification of a 2-by-2 diagonal matrix */ + +/* diag( D ) + RHO * Z * transpose(Z) . */ + +/* The diagonal elements in the array D are assumed to satisfy */ + +/* D(i) < D(j) for i < j . */ + +/* We also assume RHO > 0 and that the Euclidean norm of the vector */ +/* Z is one. */ + +/* Arguments */ +/* ========= */ + +/* I (input) INTEGER */ +/* The index of the eigenvalue to be computed. I = 1 or I = 2. */ + +/* D (input) DOUBLE PRECISION array, dimension (2) */ +/* The original eigenvalues. We assume D(1) < D(2). */ + +/* Z (input) DOUBLE PRECISION array, dimension (2) */ +/* The components of the updating vector. */ + +/* DELTA (output) DOUBLE PRECISION array, dimension (2) */ +/* The vector DELTA contains the information necessary */ +/* to construct the eigenvectors. */ + +/* RHO (input) DOUBLE PRECISION */ +/* The scalar in the symmetric updating formula. */ + +/* DLAM (output) DOUBLE PRECISION */ +/* The computed lambda_I, the I-th updated eigenvalue. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ren-Cang Li, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --delta; + --z__; + --d__; + + /* Function Body */ + del = d__[2] - d__[1]; + if (*i__ == 1) { + w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.; + if (w > 0.) { + b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * del; + +/* B > ZERO, always */ + + tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); + *dlam = d__[1] + tau; + delta[1] = -z__[1] / tau; + delta[2] = z__[2] / (del - tau); + } else { + b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * del; + if (b > 0.) { + tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); + } else { + tau = (b - sqrt(b * b + c__ * 4.)) / 2.; + } + *dlam = d__[2] + tau; + delta[1] = -z__[1] / (del + tau); + delta[2] = -z__[2] / tau; + } + temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); + delta[1] /= temp; + delta[2] /= temp; + } else { + +/* Now I=2 */ + + b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * del; + if (b > 0.) { + tau = (b + sqrt(b * b + c__ * 4.)) / 2.; + } else { + tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); + } + *dlam = d__[2] + tau; + delta[1] = -z__[1] / (del + tau); + delta[2] = -z__[2] / tau; + temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]); + delta[1] /= temp; + delta[2] /= temp; + } + return 0; + +/* End OF DLAED5 */ + +} /* dlaed5_ */ + +/* Subroutine */ int dlaed6_(integer *kniter, bool *orgati, double * + rho, double *d__, double *z__, double *finit, double * + tau, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + double a, b, c__, f; + integer i__; + double fc, df, ddf, lbd, eta, ubd, eps, base; + integer iter; + double temp, temp1, temp2, temp3, temp4; + bool scale; + integer niter; + double small1, small2, sminv1, sminv2; + + double dscale[3], sclfac, zscale[3], erretm, sclinv; + + +/* -- LAPACK routine (version 3.1.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* February 2007 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAED6 computes the positive or negative root (closest to the origin) */ +/* of */ +/* z(1) z(2) z(3) */ +/* f(x) = rho + --------- + ---------- + --------- */ +/* d(1)-x d(2)-x d(3)-x */ + +/* It is assumed that */ + +/* if ORGATI = .true. the root is between d(2) and d(3); */ +/* otherwise it is between d(1) and d(2) */ + +/* This routine will be called by DLAED4 when necessary. In most cases, */ +/* the root sought is the smallest in magnitude, though it might not be */ +/* in some extremely rare situations. */ + +/* Arguments */ +/* ========= */ + +/* KNITER (input) INTEGER */ +/* Refer to DLAED4 for its significance. */ + +/* ORGATI (input) LOGICAL */ +/* If ORGATI is true, the needed root is between d(2) and */ +/* d(3); otherwise it is between d(1) and d(2). See */ +/* DLAED4 for further details. */ + +/* RHO (input) DOUBLE PRECISION */ +/* Refer to the equation f(x) above. */ + +/* D (input) DOUBLE PRECISION array, dimension (3) */ +/* D satisfies d(1) < d(2) < d(3). */ + +/* Z (input) DOUBLE PRECISION array, dimension (3) */ +/* Each of the elements in z must be positive. */ + +/* FINIT (input) DOUBLE PRECISION */ +/* The value of f at 0. It is more accurate than the one */ +/* evaluated inside this routine (if someone wants to do */ +/* so). */ + +/* TAU (output) DOUBLE PRECISION */ +/* The root of the equation f(x). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* > 0: if INFO = 1, failure to converge */ + +/* Further Details */ +/* =============== */ + +/* 30/06/99: Based on contributions by */ +/* Ren-Cang Li, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* 10/02/03: This version has a few statements commented out for thread */ +/* safety (machine parameters are computed on each entry). SJH. */ + +/* 05/10/06: Modified from a new version of Ren-Cang Li, use */ +/* Gragg-Thornton-Warner cubic convergent scheme for better stability. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --z__; + --d__; + + /* Function Body */ + *info = 0; + + if (*orgati) { + lbd = d__[2]; + ubd = d__[3]; + } else { + lbd = d__[1]; + ubd = d__[2]; + } + if (*finit < 0.) { + lbd = 0.; + } else { + ubd = 0.; + } + + niter = 1; + *tau = 0.; + if (*kniter == 2) { + if (*orgati) { + temp = (d__[3] - d__[2]) / 2.; + c__ = *rho + z__[1] / (d__[1] - d__[2] - temp); + a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3]; + b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2]; + } else { + temp = (d__[1] - d__[2]) / 2.; + c__ = *rho + z__[3] / (d__[3] - d__[2] - temp); + a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2]; + b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1]; + } +/* Computing MAX */ + d__1 = abs(a), d__2 = abs(b), d__1 = std::max(d__1,d__2), d__2 = abs(c__); + temp = std::max(d__1,d__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.) { + *tau = b / a; + } else if (a <= 0.) { + *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)) + )); + } + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.; + } + if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) { + *tau = 0.; + } else { + temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau + * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / ( + d__[3] * (d__[3] - *tau)); + if (temp <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } + if (abs(*finit) <= abs(temp)) { + *tau = 0.; + } + } + } + +/* get machine parameters for possible scaling to avoid overflow */ + +/* modified by Sven: parameters SMALL1, SMINV1, SMALL2, */ +/* SMINV2, EPS are not SAVEd anymore between one call to the */ +/* others but recomputed at each call */ + + eps = dlamch_("Epsilon"); + base = dlamch_("Base"); + i__1 = (integer) (log(dlamch_("SafMin")) / log(base) / 3.); + small1 = pow_di(&base, &i__1); + sminv1 = 1. / small1; + small2 = small1 * small1; + sminv2 = sminv1 * sminv1; + +/* Determine if scaling of inputs necessary to avoid overflow */ +/* when computing 1/TEMP**3 */ + + if (*orgati) { +/* Computing MIN */ + d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - * + tau, abs(d__2)); + temp = std::min(d__3,d__4); + } else { +/* Computing MIN */ + d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - * + tau, abs(d__2)); + temp = std::min(d__3,d__4); + } + scale = false; + if (temp <= small1) { + scale = true; + if (temp <= small2) { + +/* Scale up by power of radix nearest 1/SAFMIN**(2/3) */ + + sclfac = sminv2; + sclinv = small2; + } else { + +/* Scale up by power of radix nearest 1/SAFMIN**(1/3) */ + + sclfac = sminv1; + sclinv = small1; + } + +/* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */ + + for (i__ = 1; i__ <= 3; ++i__) { + dscale[i__ - 1] = d__[i__] * sclfac; + zscale[i__ - 1] = z__[i__] * sclfac; +/* L10: */ + } + *tau *= sclfac; + lbd *= sclfac; + ubd *= sclfac; + } else { + +/* Copy D and Z to DSCALE and ZSCALE */ + + for (i__ = 1; i__ <= 3; ++i__) { + dscale[i__ - 1] = d__[i__]; + zscale[i__ - 1] = z__[i__]; +/* L20: */ + } + } + + fc = 0.; + df = 0.; + ddf = 0.; + for (i__ = 1; i__ <= 3; ++i__) { + temp = 1. / (dscale[i__ - 1] - *tau); + temp1 = zscale[i__ - 1] * temp; + temp2 = temp1 * temp; + temp3 = temp2 * temp; + fc += temp1 / dscale[i__ - 1]; + df += temp2; + ddf += temp3; +/* L30: */ + } + f = *finit + *tau * fc; + + if (abs(f) <= 0.) { + goto L60; + } + if (f <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } + +/* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */ +/* scheme */ + +/* It is not hard to see that */ + +/* 1) Iterations will go up monotonically */ +/* if FINIT < 0; */ + +/* 2) Iterations will go down monotonically */ +/* if FINIT > 0. */ + + iter = niter + 1; + + for (niter = iter; niter <= 40; ++niter) { + + if (*orgati) { + temp1 = dscale[1] - *tau; + temp2 = dscale[2] - *tau; + } else { + temp1 = dscale[0] - *tau; + temp2 = dscale[1] - *tau; + } + a = (temp1 + temp2) * f - temp1 * temp2 * df; + b = temp1 * temp2 * f; + c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf; +/* Computing MAX */ + d__1 = abs(a), d__2 = abs(b), d__1 = std::max(d__1,d__2), d__2 = abs(c__); + temp = std::max(d__1,d__2); + a /= temp; + b /= temp; + c__ /= temp; + if (c__ == 0.) { + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ + * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) + ); + } + if (f * eta >= 0.) { + eta = -f / df; + } + + *tau += eta; + if (*tau < lbd || *tau > ubd) { + *tau = (lbd + ubd) / 2.; + } + + fc = 0.; + erretm = 0.; + df = 0.; + ddf = 0.; + for (i__ = 1; i__ <= 3; ++i__) { + temp = 1. / (dscale[i__ - 1] - *tau); + temp1 = zscale[i__ - 1] * temp; + temp2 = temp1 * temp; + temp3 = temp2 * temp; + temp4 = temp1 / dscale[i__ - 1]; + fc += temp4; + erretm += abs(temp4); + df += temp2; + ddf += temp3; +/* L40: */ + } + f = *finit + *tau * fc; + erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df; + if (abs(f) <= eps * erretm) { + goto L60; + } + if (f <= 0.) { + lbd = *tau; + } else { + ubd = *tau; + } +/* L50: */ + } + *info = 1; +L60: + +/* Undo scaling */ + + if (scale) { + *tau *= sclinv; + } + return 0; + +/* End of DLAED6 */ + +} /* dlaed6_ */ + +/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz, + integer *tlvls, integer *curlvl, integer *curpbm, double *d__, + double *q, integer *ldq, integer *indxq, double *rho, integer + *cutpnt, double *qstore, integer *qptr, integer *prmptr, integer * + perm, integer *givptr, integer *givcol, double *givnum, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__2 = 2; + static integer c__1 = 1; + static double c_b10 = 1.; + static double c_b11 = 0.; + static integer c_n1 = -1; + + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + + /* Local variables */ + integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr; + integer indxc, indxp; + integer idlmda; + integer coltyp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAED7 computes the updated eigensystem of a diagonal */ +/* matrix after modification by a rank-one symmetric matrix. This */ +/* routine is used only for the eigenproblem which requires all */ +/* eigenvalues and optionally eigenvectors of a dense symmetric matrix */ +/* that has been reduced to tridiagonal form. DLAED1 handles */ +/* the case in which all eigenvalues and eigenvectors of a symmetric */ +/* tridiagonal matrix are desired. */ + +/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */ + +/* where Z = Q'u, u is a vector of length N with ones in the */ +/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */ + +/* The eigenvectors of the original matrix are stored in Q, and the */ +/* eigenvalues are in D. The algorithm consists of three stages: */ + +/* The first stage consists of deflating the size of the problem */ +/* when there are multiple eigenvalues or if there is a zero in */ +/* the Z vector. For each such occurence the dimension of the */ +/* secular equation problem is reduced by one. This stage is */ +/* performed by the routine DLAED8. */ + +/* The second stage consists of calculating the updated */ +/* eigenvalues. This is done by finding the roots of the secular */ +/* equation via the routine DLAED4 (as called by DLAED9). */ +/* This routine also calculates the eigenvectors of the current */ +/* problem. */ + +/* The final stage consists of computing the updated eigenvectors */ +/* directly using the updated eigenvalues. The eigenvectors for */ +/* the current problem are multiplied with the eigenvectors from */ +/* the overall problem. */ + +/* Arguments */ +/* ========= */ + +/* ICOMPQ (input) INTEGER */ +/* = 0: Compute eigenvalues only. */ +/* = 1: Compute eigenvectors of original dense symmetric matrix */ +/* also. On entry, Q contains the orthogonal matrix used */ +/* to reduce the original matrix to tridiagonal form. */ + +/* N (input) INTEGER */ +/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ + +/* QSIZ (input) INTEGER */ +/* The dimension of the orthogonal matrix used to reduce */ +/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ + +/* TLVLS (input) INTEGER */ +/* The total number of merging levels in the overall divide and */ +/* conquer tree. */ + +/* CURLVL (input) INTEGER */ +/* The current level in the overall merge routine, */ +/* 0 <= CURLVL <= TLVLS. */ + +/* CURPBM (input) INTEGER */ +/* The current problem in the current level in the overall */ +/* merge routine (counting from upper left to lower right). */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the eigenvalues of the rank-1-perturbed matrix. */ +/* On exit, the eigenvalues of the repaired matrix. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */ +/* On entry, the eigenvectors of the rank-1-perturbed matrix. */ +/* On exit, the eigenvectors of the repaired tridiagonal matrix. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N). */ + +/* INDXQ (output) INTEGER array, dimension (N) */ +/* The permutation which will reintegrate the subproblem just */ +/* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) */ +/* will be in ascending order. */ + +/* RHO (input) DOUBLE PRECISION */ +/* The subdiagonal element used to create the rank-1 */ +/* modification. */ + +/* CUTPNT (input) INTEGER */ +/* Contains the location of the last eigenvalue in the leading */ +/* sub-matrix. min(1,N) <= CUTPNT <= N. */ + +/* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1) */ +/* Stores eigenvectors of submatrices encountered during */ +/* divide and conquer, packed together. QPTR points to */ +/* beginning of the submatrices. */ + +/* QPTR (input/output) INTEGER array, dimension (N+2) */ +/* List of indices pointing to beginning of submatrices stored */ +/* in QSTORE. The submatrices are numbered starting at the */ +/* bottom left of the divide and conquer tree, from left to */ +/* right and bottom to top. */ + +/* PRMPTR (input) INTEGER array, dimension (N lg N) */ +/* Contains a list of pointers which indicate where in PERM a */ +/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */ +/* indicates the size of the permutation and also the size of */ +/* the full, non-deflated problem. */ + +/* PERM (input) INTEGER array, dimension (N lg N) */ +/* Contains the permutations (from deflation and sorting) to be */ +/* applied to each eigenblock. */ + +/* GIVPTR (input) INTEGER array, dimension (N lg N) */ +/* Contains a list of pointers which indicate where in GIVCOL a */ +/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */ +/* indicates the number of Givens rotations. */ + +/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */ +/* Each pair of numbers indicates a pair of columns to take place */ +/* in a Givens rotation. */ + +/* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */ +/* Each number indicates the S value to be used in the */ +/* corresponding Givens rotation. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N) */ + +/* IWORK (workspace) INTEGER array, dimension (4*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an eigenvalue did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --qstore; + --qptr; + --prmptr; + --perm; + --givptr; + givcol -= 3; + givnum -= 3; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*icompq == 1 && *qsiz < *n) { + *info = -4; + } else if (*ldq < std::max(1_integer,*n)) { + *info = -9; + } else if (std::min(1_integer,*n) > *cutpnt || *n < *cutpnt) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED7", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* The following values are for bookkeeping purposes only. They are */ +/* integer pointers which indicate the portion of the workspace */ +/* used by a particular array in DLAED8 and DLAED9. */ + + if (*icompq == 1) { + ldq2 = *qsiz; + } else { + ldq2 = *n; + } + + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq2 = iw + *n; + is = iq2 + *n * ldq2; + + indx = 1; + indxc = indx + *n; + coltyp = indxc + *n; + indxp = coltyp + *n; + +/* Form the z-vector which consists of the last row of Q_1 and the */ +/* first row of Q_2. */ + + ptr = pow_ii(&c__2, tlvls) + 1; + i__1 = *curlvl - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *tlvls - i__; + ptr += pow_ii(&c__2, &i__2); +/* L10: */ + } + curr = ptr + *curpbm; + dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], & + givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz + + *n], info); + +/* When solving the final problem, we no longer need the stored data, */ +/* so we will overwrite the data from this level onto the previously */ +/* used storage space. */ + + if (*curlvl == *tlvls) { + qptr[curr] = 1; + prmptr[curr] = 1; + givptr[curr] = 1; + } + +/* Sort and Deflate eigenvalues. */ + + dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho, + cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], & + perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1) + + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[ + indx], info); + prmptr[curr + 1] = prmptr[curr] + *n; + givptr[curr + 1] += givptr[curr]; + +/* Solve Secular Equation. */ + + if (k != 0) { + dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda], + &work[iw], &qstore[qptr[curr]], &k, info); + if (*info != 0) { + goto L30; + } + if (*icompq == 1) { + dgemm_("N", "N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[ + qptr[curr]], &k, &c_b11, &q[q_offset], ldq); + } +/* Computing 2nd power */ + i__1 = k; + qptr[curr + 1] = qptr[curr] + i__1 * i__1; + +/* Prepare the INDXQ sorting permutation. */ + + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + qptr[curr + 1] = qptr[curr]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; +/* L20: */ + } + } + +L30: + return 0; + +/* End of DLAED7 */ + +} /* dlaed7_ */ + +/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer + *qsiz, double *d__, double *q, integer *ldq, integer *indxq, + double *rho, integer *cutpnt, double *z__, double *dlamda, + double *q2, integer *ldq2, double *w, integer *perm, integer + *givptr, integer *givcol, double *givnum, integer *indxp, integer + *indx, integer *info) +{ + /* Table of constant values */ + static double c_b3 = -1.; + static integer c__1 = 1; + + /* System generated locals */ + integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; + double d__1; + + /* Local variables */ + double c__; + integer i__, j; + double s, t; + integer k2, n1, n2, jp, n1p1; + double eps, tau, tol; + integer jlam, imax, jmax; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAED8 merges the two sets of eigenvalues together into a single */ +/* sorted set. Then it tries to deflate the size of the problem. */ +/* There are two ways in which deflation can occur: when two or more */ +/* eigenvalues are close together or if there is a tiny element in the */ +/* Z vector. For each such occurrence the order of the related secular */ +/* equation problem is reduced by one. */ + +/* Arguments */ +/* ========= */ + +/* ICOMPQ (input) INTEGER */ +/* = 0: Compute eigenvalues only. */ +/* = 1: Compute eigenvectors of original dense symmetric matrix */ +/* also. On entry, Q contains the orthogonal matrix used */ +/* to reduce the original matrix to tridiagonal form. */ + +/* K (output) INTEGER */ +/* The number of non-deflated eigenvalues, and the order of the */ +/* related secular equation. */ + +/* N (input) INTEGER */ +/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ + +/* QSIZ (input) INTEGER */ +/* The dimension of the orthogonal matrix used to reduce */ +/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the eigenvalues of the two submatrices to be */ +/* combined. On exit, the trailing (N-K) updated eigenvalues */ +/* (those which were deflated) sorted into increasing order. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* If ICOMPQ = 0, Q is not referenced. Otherwise, */ +/* on entry, Q contains the eigenvectors of the partially solved */ +/* system which has been previously updated in matrix */ +/* multiplies with other partially solved eigensystems. */ +/* On exit, Q contains the trailing (N-K) updated eigenvectors */ +/* (those which were deflated) in its last N-K columns. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N). */ + +/* INDXQ (input) INTEGER array, dimension (N) */ +/* The permutation which separately sorts the two sub-problems */ +/* in D into ascending order. Note that elements in the second */ +/* half of this permutation must first have CUTPNT added to */ +/* their values in order to be accurate. */ + +/* RHO (input/output) DOUBLE PRECISION */ +/* On entry, the off-diagonal element associated with the rank-1 */ +/* cut which originally split the two submatrices which are now */ +/* being recombined. */ +/* On exit, RHO has been modified to the value required by */ +/* DLAED3. */ + +/* CUTPNT (input) INTEGER */ +/* The location of the last eigenvalue in the leading */ +/* sub-matrix. min(1,N) <= CUTPNT <= N. */ + +/* Z (input) DOUBLE PRECISION array, dimension (N) */ +/* On entry, Z contains the updating vector (the last row of */ +/* the first sub-eigenvector matrix and the first row of the */ +/* second sub-eigenvector matrix). */ +/* On exit, the contents of Z are destroyed by the updating */ +/* process. */ + +/* DLAMDA (output) DOUBLE PRECISION array, dimension (N) */ +/* A copy of the first K eigenvalues which will be used by */ +/* DLAED3 to form the secular equation. */ + +/* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N) */ +/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */ +/* a copy of the first K eigenvectors which will be used by */ +/* DLAED7 in a matrix multiply (DGEMM) to update the new */ +/* eigenvectors. */ + +/* LDQ2 (input) INTEGER */ +/* The leading dimension of the array Q2. LDQ2 >= max(1,N). */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first k values of the final deflation-altered z-vector and */ +/* will be passed to DLAED3. */ + +/* PERM (output) INTEGER array, dimension (N) */ +/* The permutations (from deflation and sorting) to be applied */ +/* to each eigenblock. */ + +/* GIVPTR (output) INTEGER */ +/* The number of Givens rotations which took place in this */ +/* subproblem. */ + +/* GIVCOL (output) INTEGER array, dimension (2, N) */ +/* Each pair of numbers indicates a pair of columns to take place */ +/* in a Givens rotation. */ + +/* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N) */ +/* Each number indicates the S value to be used in the */ +/* corresponding Givens rotation. */ + +/* INDXP (workspace) INTEGER array, dimension (N) */ +/* The permutation used to place deflated values of D at the end */ +/* of the array. INDXP(1:K) points to the nondeflated D-values */ +/* and INDXP(K+1:N) points to the deflated eigenvalues. */ + +/* INDX (workspace) INTEGER array, dimension (N) */ +/* The permutation used to sort the contents of D into ascending */ +/* order. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ + +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --z__; + --dlamda; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1; + q2 -= q2_offset; + --w; + --perm; + givcol -= 3; + givnum -= 3; + --indxp; + --indx; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*n < 0) { + *info = -3; + } else if (*icompq == 1 && *qsiz < *n) { + *info = -4; + } else if (*ldq < std::max(1_integer,*n)) { + *info = -7; + } else if (*cutpnt < std::min(1_integer,*n) || *cutpnt > *n) { + *info = -10; + } else if (*ldq2 < std::max(1_integer,*n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED8", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + n1 = *cutpnt; + n2 = *n - n1; + n1p1 = n1 + 1; + + if (*rho < 0.) { + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + +/* Normalize z so that norm(z) = 1 */ + + t = 1. / sqrt(2.); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + indx[j] = j; +/* L10: */ + } + dscal_(n, &t, &z__[1], &c__1); + *rho = (d__1 = *rho * 2., abs(d__1)); + +/* Sort the eigenvalues into increasing order */ + + i__1 = *n; + for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { + indxq[i__] += *cutpnt; +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; +/* L30: */ + } + i__ = 1; + j = *cutpnt + 1; + dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = dlamda[indx[i__]]; + z__[i__] = w[indx[i__]]; +/* L40: */ + } + +/* Calculate the allowable deflation tolerence */ + + imax = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_("Epsilon"); + tol = eps * 8. * (d__1 = d__[jmax], abs(d__1)); + +/* If the rank-1 modifier is small enough, no more needs to be done */ +/* except to reorganize Q so that its columns correspond with the */ +/* elements in D. */ + + if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { + *k = 0; + if (*icompq == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; +/* L50: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + + 1], &c__1); +/* L60: */ + } + dlacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq); + } + return 0; + } + +/* If there are multiple eigenvalues then the problem deflates. Here */ +/* the number of equal eigenvalues are found. As each equal */ +/* eigenvalue is found, an elementary reflector is computed to rotate */ +/* the corresponding eigensubspace so that the corresponding */ +/* components of Z are zero in this new basis. */ + + *k = 0; + *givptr = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + indxp[k2] = j; + if (j == *n) { + goto L110; + } + } else { + jlam = j; + goto L80; + } +/* L70: */ + } +L80: + ++j; + if (j > *n) { + goto L100; + } + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + indxp[k2] = j; + } else { + +/* Check if eigenvalues are close enough to allow deflation. */ + + s = z__[jlam]; + c__ = z__[j]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = dlapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + +/* Deflation is possible. */ + + z__[j] = tau; + z__[jlam] = 0.; + +/* Record the appropriate Givens rotation */ + + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + if (*icompq == 1) { + drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[ + indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s); + } + t = d__[jlam] * c__ * c__ + d__[j] * s * s; + d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; + d__[jlam] = t; + --k2; + i__ = 1; +L90: + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L90; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } + } + goto L80; +L100: + +/* Record the last eigenvalue. */ + + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + +L110: + +/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */ +/* and Q2 respectively. The eigenvalues/vectors which were not */ +/* deflated go into the first K slots of DLAMDA and Q2 respectively, */ +/* while those which were deflated go into the last N - K slots. */ + + if (*icompq == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; +/* L120: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] +, &c__1); +/* L130: */ + } + } + +/* The deflated eigenvalues and their corresponding vectors go back */ +/* into the last N - K slots of D and Q respectively. */ + + if (*k < *n) { + if (*icompq == 0) { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + } else { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = *n - *k; + dlacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* + k + 1) * q_dim1 + 1], ldq); + } + } + + return 0; + +/* End of DLAED8 */ + +} /* dlaed8_ */ + +/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop, + integer *n, double *d__, double *q, integer *ldq, double * + rho, double *dlamda, double *w, double *s, integer *lds, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j; + double temp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAED9 finds the roots of the secular equation, as defined by the */ +/* values in D, Z, and RHO, between KSTART and KSTOP. It makes the */ +/* appropriate calls to DLAED4 and then stores the new matrix of */ +/* eigenvectors for use in calculating the next level of Z vectors. */ + +/* Arguments */ +/* ========= */ + +/* K (input) INTEGER */ +/* The number of terms in the rational function to be solved by */ +/* DLAED4. K >= 0. */ + +/* KSTART (input) INTEGER */ +/* KSTOP (input) INTEGER */ +/* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP */ +/* are to be computed. 1 <= KSTART <= KSTOP <= K. */ + +/* N (input) INTEGER */ +/* The number of rows and columns in the Q matrix. */ +/* N >= K (delation may result in N > K). */ + +/* D (output) DOUBLE PRECISION array, dimension (N) */ +/* D(I) contains the updated eigenvalues */ +/* for KSTART <= I <= KSTOP. */ + +/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N) */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max( 1, N ). */ + +/* RHO (input) DOUBLE PRECISION */ +/* The value of the parameter in the rank one update equation. */ +/* RHO >= 0 required. */ + +/* DLAMDA (input) DOUBLE PRECISION array, dimension (K) */ +/* The first K elements of this array contain the old roots */ +/* of the deflated updating problem. These are the poles */ +/* of the secular equation. */ + +/* W (input) DOUBLE PRECISION array, dimension (K) */ +/* The first K elements of this array contain the components */ +/* of the deflation-adjusted updating vector. */ + +/* S (output) DOUBLE PRECISION array, dimension (LDS, K) */ +/* Will contain the eigenvectors of the repaired matrix which */ +/* will be stored for subsequent Z vector calculation and */ +/* multiplied by the previously accumulated eigenvectors */ +/* to update the system. */ + +/* LDS (input) INTEGER */ +/* The leading dimension of S. LDS >= max( 1, K ). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an eigenvalue did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --dlamda; + --w; + s_dim1 = *lds; + s_offset = 1 + s_dim1; + s -= s_offset; + + /* Function Body */ + *info = 0; + + if (*k < 0) { + *info = -1; + } else if (*kstart < 1 || *kstart > std::max(1_integer,*k)) { + *info = -2; + } else if (std::max(1_integer,*kstop) < *kstart || *kstop > std::max(1_integer,*k)) { + *info = -3; + } else if (*n < *k) { + *info = -4; + } else if (*ldq < std::max(1_integer,*k)) { + *info = -7; + } else if (*lds < std::max(1_integer,*k)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED9", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*k == 0) { + return 0; + } + +/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */ +/* be computed with high relative accuracy (barring over/underflow). */ +/* This is a problem on machines without a guard digit in */ +/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ +/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */ +/* which on any of these machines zeros out the bottommost */ +/* bit of DLAMDA(I) if it is 1; this makes the subsequent */ +/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */ +/* occurs. On binary machines with a guard digit (almost all */ +/* machines) it does not change DLAMDA(I) at all. On hexadecimal */ +/* and decimal machines with a guard digit, it slightly */ +/* changes the bottommost bits of DLAMDA(I). It does not account */ +/* for hexadecimal or decimal machines without guard digits */ +/* (we know of none). We use a subroutine call to compute */ +/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */ +/* this code. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__]; +/* L10: */ + } + + i__1 = *kstop; + for (j = *kstart; j <= i__1; ++j) { + dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j], + info); + +/* If the zero finder fails, the computation is terminated. */ + + if (*info != 0) { + goto L120; + } +/* L20: */ + } + + if (*k == 1 || *k == 2) { + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *k; + for (j = 1; j <= i__2; ++j) { + s[j + i__ * s_dim1] = q[j + i__ * q_dim1]; +/* L30: */ + } +/* L40: */ + } + goto L120; + } + +/* Compute updated W. */ + + dcopy_(k, &w[1], &c__1, &s[s_offset], &c__1); + +/* Initialize W(I) = Q(I,I) */ + + i__1 = *ldq + 1; + dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); +/* L50: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]); +/* L60: */ + } +/* L70: */ + } + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = sqrt(-w[i__]); + w[i__] = d_sign(&d__1, &s[i__ + s_dim1]); +/* L80: */ + } + +/* Compute eigenvectors of the modified rank-1 modification. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1]; +/* L90: */ + } + temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1); + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp; +/* L100: */ + } +/* L110: */ + } + +L120: + return 0; + +/* End of DLAED9 */ + +} /* dlaed9_ */ + +/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl, + integer *curpbm, integer *prmptr, integer *perm, integer *givptr, + integer *givcol, double *givnum, double *q, integer *qptr, + double *z__, double *ztemp, integer *info) +{ + /* Table of constant values */ + static integer c__2 = 2; + static integer c__1 = 1; + static double c_b24 = 1.; + static double c_b26 = 0.; + + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, k, mid, ptr; + integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAEDA computes the Z vector corresponding to the merge step in the */ +/* CURLVLth step of the merge process with TLVLS steps for the CURPBMth */ +/* problem. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ + +/* TLVLS (input) INTEGER */ +/* The total number of merging levels in the overall divide and */ +/* conquer tree. */ + +/* CURLVL (input) INTEGER */ +/* The current level in the overall merge routine, */ +/* 0 <= curlvl <= tlvls. */ + +/* CURPBM (input) INTEGER */ +/* The current problem in the current level in the overall */ +/* merge routine (counting from upper left to lower right). */ + +/* PRMPTR (input) INTEGER array, dimension (N lg N) */ +/* Contains a list of pointers which indicate where in PERM a */ +/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */ +/* indicates the size of the permutation and incidentally the */ +/* size of the full, non-deflated problem. */ + +/* PERM (input) INTEGER array, dimension (N lg N) */ +/* Contains the permutations (from deflation and sorting) to be */ +/* applied to each eigenblock. */ + +/* GIVPTR (input) INTEGER array, dimension (N lg N) */ +/* Contains a list of pointers which indicate where in GIVCOL a */ +/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */ +/* indicates the number of Givens rotations. */ + +/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */ +/* Each pair of numbers indicates a pair of columns to take place */ +/* in a Givens rotation. */ + +/* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */ +/* Each number indicates the S value to be used in the */ +/* corresponding Givens rotation. */ + +/* Q (input) DOUBLE PRECISION array, dimension (N**2) */ +/* Contains the square eigenblocks from previous levels, the */ +/* starting positions for blocks are given by QPTR. */ + +/* QPTR (input) INTEGER array, dimension (N+2) */ +/* Contains a list of pointers which indicate where in Q an */ +/* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates */ +/* the size of the block. */ + +/* Z (output) DOUBLE PRECISION array, dimension (N) */ +/* On output this vector contains the updating vector (the last */ +/* row of the first sub-eigenvector matrix and the first row of */ +/* the second sub-eigenvector matrix). */ + +/* ZTEMP (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 */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ztemp; + --z__; + --qptr; + --q; + givnum -= 3; + givcol -= 3; + --givptr; + --perm; + --prmptr; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -1; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAEDA", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine location of first number in second half. */ + + mid = *n / 2 + 1; + +/* Gather last/first rows of appropriate eigenblocks into center of Z */ + + ptr = 1; + +/* Determine location of lowest level subproblem in the full storage */ +/* scheme */ + + i__1 = *curlvl - 1; + curr = ptr + *curpbm * pow_ii(&c__2, curlvl) + pow_ii(&c__2, &i__1) - 1; + +/* Determine size of these matrices. We add HALF to the value of */ +/* the SQRT in case the machine underestimates one of these square */ +/* roots. */ + + bsiz1 = (integer) (sqrt((double) (qptr[curr + 1] - qptr[curr])) + .5); + bsiz2 = (integer) (sqrt((double) (qptr[curr + 2] - qptr[curr + 1])) + + .5); + i__1 = mid - bsiz1 - 1; + for (k = 1; k <= i__1; ++k) { + z__[k] = 0.; +/* L10: */ + } + dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], & + c__1); + dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1); + i__1 = *n; + for (k = mid + bsiz2; k <= i__1; ++k) { + z__[k] = 0.; +/* L20: */ + } + +/* Loop thru remaining levels 1 -> CURLVL applying the Givens */ +/* rotations and permutation and then multiplying the center matrices */ +/* against the current Z. */ + + ptr = pow_ii(&c__2, tlvls) + 1; + i__1 = *curlvl - 1; + for (k = 1; k <= i__1; ++k) { + i__2 = *curlvl - k; + i__3 = *curlvl - k - 1; + curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) - + 1; + psiz1 = prmptr[curr + 1] - prmptr[curr]; + psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; + zptr1 = mid - psiz1; + +/* Apply Givens at CURR and CURR+1 */ + + i__2 = givptr[curr + 1] - 1; + for (i__ = givptr[curr]; i__ <= i__2; ++i__) { + drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, & + z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[( + i__ << 1) + 1], &givnum[(i__ << 1) + 2]); +/* L30: */ + } + i__2 = givptr[curr + 2] - 1; + for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) { + drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[ + mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ << + 1) + 1], &givnum[(i__ << 1) + 2]); +/* L40: */ + } + psiz1 = prmptr[curr + 1] - prmptr[curr]; + psiz2 = prmptr[curr + 2] - prmptr[curr + 1]; + i__2 = psiz1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1]; +/* L50: */ + } + i__2 = psiz2 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] - + 1]; +/* L60: */ + } + +/* Multiply Blocks at CURR and CURR+1 */ + +/* Determine size of these matrices. We add HALF to the value of */ +/* the SQRT in case the machine underestimates one of these */ +/* square roots. */ + + bsiz1 = (integer) (sqrt((double) (qptr[curr + 1] - qptr[curr])) + + .5); + bsiz2 = (integer) (sqrt((double) (qptr[curr + 2] - qptr[curr + 1]) + ) + .5); + if (bsiz1 > 0) { + dgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, & + ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1); + } + i__2 = psiz1 - bsiz1; + dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1); + if (bsiz2 > 0) { + dgemv_("T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, & + ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1); + } + i__2 = psiz2 - bsiz2; + dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], & + c__1); + + i__2 = *tlvls - k; + ptr += pow_ii(&c__2, &i__2); +/* L70: */ + } + + return 0; + +/* End of DLAEDA */ + +} /* dlaeda_ */ + +/* Subroutine */ int dlaein_(bool *rightv, bool *noinit, integer *n, + double *h__, integer *ldh, double *wr, double *wi, + double *vr, double *vi, double *b, integer *ldb, + double *work, double *eps3, double *smlnum, double * + bignum, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, j; + double w, x, y; + integer i1, i2, i3; + double w1, ei, ej, xi, xr, rec; + integer its, ierr; + double temp, norm, vmax; + double scale; + char trans[1]; + double vcrit, rootn, vnorm; + double absbii, absbjj; + char normin[1]; + double nrmsml, growto; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAEIN uses inverse iteration to find a right or left eigenvector */ +/* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg */ +/* matrix H. */ + +/* Arguments */ +/* ========= */ + +/* RIGHTV (input) LOGICAL */ +/* = .TRUE. : compute right eigenvector; */ +/* = .FALSE.: compute left eigenvector. */ + +/* NOINIT (input) LOGICAL */ +/* = .TRUE. : no initial vector supplied in (VR,VI). */ +/* = .FALSE.: initial vector supplied in (VR,VI). */ + +/* N (input) INTEGER */ +/* The order of the matrix H. N >= 0. */ + +/* H (input) DOUBLE PRECISION array, dimension (LDH,N) */ +/* The upper Hessenberg matrix H. */ + +/* LDH (input) INTEGER */ +/* The leading dimension of the array H. LDH >= max(1,N). */ + +/* WR (input) DOUBLE PRECISION */ +/* WI (input) DOUBLE PRECISION */ +/* The real and imaginary parts of the eigenvalue of H whose */ +/* corresponding right or left eigenvector is to be computed. */ + +/* VR (input/output) DOUBLE PRECISION array, dimension (N) */ +/* VI (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */ +/* a real starting vector for inverse iteration using the real */ +/* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */ +/* must contain the real and imaginary parts of a complex */ +/* starting vector for inverse iteration using the complex */ +/* eigenvalue (WR,WI); otherwise VR and VI need not be set. */ +/* On exit, if WI = 0.0 (real eigenvalue), VR contains the */ +/* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue), */ +/* VR and VI contain the real and imaginary parts of the */ +/* computed complex eigenvector. The eigenvector is normalized */ +/* so that the component of largest magnitude has magnitude 1; */ +/* here the magnitude of a complex number (x,y) is taken to be */ +/* |x| + |y|. */ +/* VI is not referenced if WI = 0.0. */ + +/* B (workspace) DOUBLE PRECISION array, dimension (LDB,N) */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= N+1. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ + +/* EPS3 (input) DOUBLE PRECISION */ +/* A small machine-dependent value which is used to perturb */ +/* close eigenvalues, and to replace zero pivots. */ + +/* SMLNUM (input) DOUBLE PRECISION */ +/* A machine-dependent value close to the underflow threshold. */ + +/* BIGNUM (input) DOUBLE PRECISION */ +/* A machine-dependent value close to the overflow threshold. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* = 1: inverse iteration did not converge; VR is set to the */ +/* last iterate, and so is VI if WI.ne.0.0. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --vr; + --vi; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + +/* GROWTO is the threshold used in the acceptance test for an */ +/* eigenvector. */ + + rootn = sqrt((double) (*n)); + growto = .1 / rootn; +/* Computing MAX */ + d__1 = 1., d__2 = *eps3 * rootn; + nrmsml = std::max(d__1,d__2) * *smlnum; + +/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */ +/* the imaginary parts of the diagonal elements are not stored). */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = h__[i__ + j * h_dim1]; +/* L10: */ + } + b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr; +/* L20: */ + } + + if (*wi == 0.) { + +/* Real eigenvalue. */ + + if (*noinit) { + +/* Set initial vector. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + vr[i__] = *eps3; +/* L30: */ + } + } else { + +/* Scale supplied initial vector. */ + + vnorm = dnrm2_(n, &vr[1], &c__1); + d__1 = *eps3 * rootn / std::max(vnorm,nrmsml); + dscal_(n, &d__1, &vr[1], &c__1); + } + + if (*rightv) { + +/* LU decomposition with partial pivoting of B, replacing zero */ +/* pivots by EPS3. */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + ei = h__[i__ + 1 + i__ * h_dim1]; + if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) < abs(ei)) { + +/* Interchange rows and eliminate. */ + + x = b[i__ + i__ * b_dim1] / ei; + b[i__ + i__ * b_dim1] = ei; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x * + temp; + b[i__ + j * b_dim1] = temp; +/* L40: */ + } + } else { + +/* Eliminate without interchange. */ + + if (b[i__ + i__ * b_dim1] == 0.) { + b[i__ + i__ * b_dim1] = *eps3; + } + x = ei / b[i__ + i__ * b_dim1]; + if (x != 0.) { + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1] + ; +/* L50: */ + } + } + } +/* L60: */ + } + if (b[*n + *n * b_dim1] == 0.) { + b[*n + *n * b_dim1] = *eps3; + } + + *(unsigned char *)trans = 'N'; + + } else { + +/* UL decomposition with partial pivoting of B, replacing zero */ +/* pivots by EPS3. */ + + for (j = *n; j >= 2; --j) { + ej = h__[j + (j - 1) * h_dim1]; + if ((d__1 = b[j + j * b_dim1], abs(d__1)) < abs(ej)) { + +/* Interchange columns and eliminate. */ + + x = b[j + j * b_dim1] / ej; + b[j + j * b_dim1] = ej; + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = b[i__ + (j - 1) * b_dim1]; + b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x * + temp; + b[i__ + j * b_dim1] = temp; +/* L70: */ + } + } else { + +/* Eliminate without interchange. */ + + if (b[j + j * b_dim1] == 0.) { + b[j + j * b_dim1] = *eps3; + } + x = ej / b[j + j * b_dim1]; + if (x != 0.) { + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j * + b_dim1]; +/* L80: */ + } + } + } +/* L90: */ + } + if (b[b_dim1 + 1] == 0.) { + b[b_dim1 + 1] = *eps3; + } + + *(unsigned char *)trans = 'T'; + + } + + *(unsigned char *)normin = 'N'; + i__1 = *n; + for (its = 1; its <= i__1; ++its) { + +/* Solve U*x = scale*v for a right eigenvector */ +/* or U'*x = scale*v for a left eigenvector, */ +/* overwriting x on v. */ + + dlatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, & + vr[1], &scale, &work[1], &ierr); + *(unsigned char *)normin = 'Y'; + +/* Test for sufficient growth in the norm of v. */ + + vnorm = dasum_(n, &vr[1], &c__1); + if (vnorm >= growto * scale) { + goto L120; + } + +/* Choose new orthogonal starting vector and try again. */ + + temp = *eps3 / (rootn + 1.); + vr[1] = *eps3; + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + vr[i__] = temp; +/* L100: */ + } + vr[*n - its + 1] -= *eps3 * rootn; +/* L110: */ + } + +/* Failure to find eigenvector in N iterations. */ + + *info = 1; + +L120: + +/* Normalize eigenvector. */ + + i__ = idamax_(n, &vr[1], &c__1); + d__2 = 1. / (d__1 = vr[i__], abs(d__1)); + dscal_(n, &d__2, &vr[1], &c__1); + } else { + +/* Complex eigenvalue. */ + + if (*noinit) { + +/* Set initial vector. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + vr[i__] = *eps3; + vi[i__] = 0.; +/* L130: */ + } + } else { + +/* Scale supplied initial vector. */ + + d__1 = dnrm2_(n, &vr[1], &c__1); + d__2 = dnrm2_(n, &vi[1], &c__1); + norm = dlapy2_(&d__1, &d__2); + rec = *eps3 * rootn / std::max(norm,nrmsml); + dscal_(n, &rec, &vr[1], &c__1); + dscal_(n, &rec, &vi[1], &c__1); + } + + if (*rightv) { + +/* LU decomposition with partial pivoting of B, replacing zero */ +/* pivots by EPS3. */ + +/* The imaginary part of the (i,j)-th element of U is stored in */ +/* B(j+1,i). */ + + b[b_dim1 + 2] = -(*wi); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + b[i__ + 1 + b_dim1] = 0.; +/* L140: */ + } + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + absbii = dlapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * + b_dim1]); + ei = h__[i__ + 1 + i__ * h_dim1]; + if (absbii < abs(ei)) { + +/* Interchange rows and eliminate. */ + + xr = b[i__ + i__ * b_dim1] / ei; + xi = b[i__ + 1 + i__ * b_dim1] / ei; + b[i__ + i__ * b_dim1] = ei; + b[i__ + 1 + i__ * b_dim1] = 0.; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + temp = b[i__ + 1 + j * b_dim1]; + b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr * + temp; + b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ * + b_dim1] - xi * temp; + b[i__ + j * b_dim1] = temp; + b[j + 1 + i__ * b_dim1] = 0.; +/* L150: */ + } + b[i__ + 2 + i__ * b_dim1] = -(*wi); + b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi; + b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi; + } else { + +/* Eliminate without interchanging rows. */ + + if (absbii == 0.) { + b[i__ + i__ * b_dim1] = *eps3; + b[i__ + 1 + i__ * b_dim1] = 0.; + absbii = *eps3; + } + ei = ei / absbii / absbii; + xr = b[i__ + i__ * b_dim1] * ei; + xi = -b[i__ + 1 + i__ * b_dim1] * ei; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] - + xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ + * b_dim1]; + b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ * + b_dim1] - xi * b[i__ + j * b_dim1]; +/* L160: */ + } + b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi; + } + +/* Compute 1-norm of offdiagonal elements of i-th row. */ + + i__2 = *n - i__; + i__3 = *n - i__; + work[i__] = dasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb) + + dasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1); +/* L170: */ + } + if (b[*n + *n * b_dim1] == 0. && b[*n + 1 + *n * b_dim1] == 0.) { + b[*n + *n * b_dim1] = *eps3; + } + work[*n] = 0.; + + i1 = *n; + i2 = 1; + i3 = -1; + } else { + +/* UL decomposition with partial pivoting of conjg(B), */ +/* replacing zero pivots by EPS3. */ + +/* The imaginary part of the (i,j)-th element of U is stored in */ +/* B(j+1,i). */ + + b[*n + 1 + *n * b_dim1] = *wi; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + b[*n + 1 + j * b_dim1] = 0.; +/* L180: */ + } + + for (j = *n; j >= 2; --j) { + ej = h__[j + (j - 1) * h_dim1]; + absbjj = dlapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]); + if (absbjj < abs(ej)) { + +/* Interchange columns and eliminate */ + + xr = b[j + j * b_dim1] / ej; + xi = b[j + 1 + j * b_dim1] / ej; + b[j + j * b_dim1] = ej; + b[j + 1 + j * b_dim1] = 0.; + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = b[i__ + (j - 1) * b_dim1]; + b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr * + temp; + b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * + temp; + b[i__ + j * b_dim1] = temp; + b[j + 1 + i__ * b_dim1] = 0.; +/* L190: */ + } + b[j + 1 + (j - 1) * b_dim1] = *wi; + b[j - 1 + (j - 1) * b_dim1] += xi * *wi; + b[j + (j - 1) * b_dim1] -= xr * *wi; + } else { + +/* Eliminate without interchange. */ + + if (absbjj == 0.) { + b[j + j * b_dim1] = *eps3; + b[j + 1 + j * b_dim1] = 0.; + absbjj = *eps3; + } + ej = ej / absbjj / absbjj; + xr = b[j + j * b_dim1] * ej; + xi = -b[j + 1 + j * b_dim1] * ej; + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1] + - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + + i__ * b_dim1]; + b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - + xi * b[i__ + j * b_dim1]; +/* L200: */ + } + b[j + (j - 1) * b_dim1] += *wi; + } + +/* Compute 1-norm of offdiagonal elements of j-th column. */ + + i__1 = j - 1; + i__2 = j - 1; + work[j] = dasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + dasum_(& + i__2, &b[j + 1 + b_dim1], ldb); +/* L210: */ + } + if (b[b_dim1 + 1] == 0. && b[b_dim1 + 2] == 0.) { + b[b_dim1 + 1] = *eps3; + } + work[1] = 0.; + + i1 = 1; + i2 = *n; + i3 = 1; + } + + i__1 = *n; + for (its = 1; its <= i__1; ++its) { + scale = 1.; + vmax = 1.; + vcrit = *bignum; + +/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */ +/* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector, */ +/* overwriting (xr,xi) on (vr,vi). */ + + i__2 = i2; + i__3 = i3; + for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) + { + + if (work[i__] > vcrit) { + rec = 1. / vmax; + dscal_(n, &rec, &vr[1], &c__1); + dscal_(n, &rec, &vi[1], &c__1); + scale *= rec; + vmax = 1.; + vcrit = *bignum; + } + + xr = vr[i__]; + xi = vi[i__]; + if (*rightv) { + i__4 = *n; + for (j = i__ + 1; j <= i__4; ++j) { + xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__ + * b_dim1] * vi[j]; + xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__ + * b_dim1] * vr[j]; +/* L220: */ + } + } else { + i__4 = i__ - 1; + for (j = 1; j <= i__4; ++j) { + xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j + * b_dim1] * vi[j]; + xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j + * b_dim1] * vr[j]; +/* L230: */ + } + } + + w = (d__1 = b[i__ + i__ * b_dim1], abs(d__1)) + (d__2 = b[i__ + + 1 + i__ * b_dim1], abs(d__2)); + if (w > *smlnum) { + if (w < 1.) { + w1 = abs(xr) + abs(xi); + if (w1 > w * *bignum) { + rec = 1. / w1; + dscal_(n, &rec, &vr[1], &c__1); + dscal_(n, &rec, &vi[1], &c__1); + xr = vr[i__]; + xi = vi[i__]; + scale *= rec; + vmax *= rec; + } + } + +/* Divide by diagonal element of B. */ + + dladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 + + i__ * b_dim1], &vr[i__], &vi[i__]); +/* Computing MAX */ + d__3 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__], abs( + d__2)); + vmax = std::max(d__3,vmax); + vcrit = *bignum / vmax; + } else { + i__4 = *n; + for (j = 1; j <= i__4; ++j) { + vr[j] = 0.; + vi[j] = 0.; +/* L240: */ + } + vr[i__] = 1.; + vi[i__] = 1.; + scale = 0.; + vmax = 1.; + vcrit = *bignum; + } +/* L250: */ + } + +/* Test for sufficient growth in the norm of (VR,VI). */ + + vnorm = dasum_(n, &vr[1], &c__1) + dasum_(n, &vi[1], &c__1); + if (vnorm >= growto * scale) { + goto L280; + } + +/* Choose a new orthogonal starting vector and try again. */ + + y = *eps3 / (rootn + 1.); + vr[1] = *eps3; + vi[1] = 0.; + + i__3 = *n; + for (i__ = 2; i__ <= i__3; ++i__) { + vr[i__] = y; + vi[i__] = 0.; +/* L260: */ + } + vr[*n - its + 1] -= *eps3 * rootn; +/* L270: */ + } + +/* Failure to find eigenvector in N iterations */ + + *info = 1; + +L280: + +/* Normalize eigenvector. */ + + vnorm = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__3 = vnorm, d__4 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__] + , abs(d__2)); + vnorm = std::max(d__3,d__4); +/* L290: */ + } + d__1 = 1. / vnorm; + dscal_(n, &d__1, &vr[1], &c__1); + d__1 = 1. / vnorm; + dscal_(n, &d__1, &vi[1], &c__1); + + } + + return 0; + +/* End of DLAEIN */ + +} /* dlaein_ */ + +/* Subroutine */ int dlaev2_(double *a, double *b, double *c__, + double *rt1, double *rt2, double *cs1, double *sn1) +{ + /* System generated locals */ + double d__1; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + double ab, df, cs, ct, tb, sm, tn, rt, adf, acs; + integer sgn1, sgn2; + double acmn, acmx; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */ +/* [ A B ] */ +/* [ B C ]. */ +/* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */ +/* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */ +/* eigenvector for RT1, giving the decomposition */ + +/* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] */ +/* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. */ + +/* Arguments */ +/* ========= */ + +/* A (input) DOUBLE PRECISION */ +/* The (1,1) element of the 2-by-2 matrix. */ + +/* B (input) DOUBLE PRECISION */ +/* The (1,2) element and the conjugate of the (2,1) element of */ +/* the 2-by-2 matrix. */ + +/* C (input) DOUBLE PRECISION */ +/* The (2,2) element of the 2-by-2 matrix. */ + +/* RT1 (output) DOUBLE PRECISION */ +/* The eigenvalue of larger absolute value. */ + +/* RT2 (output) DOUBLE PRECISION */ +/* The eigenvalue of smaller absolute value. */ + +/* CS1 (output) DOUBLE PRECISION */ +/* SN1 (output) DOUBLE PRECISION */ +/* The vector (CS1, SN1) is a unit right eigenvector for RT1. */ + +/* Further Details */ +/* =============== */ + +/* RT1 is accurate to a few ulps barring over/underflow. */ + +/* RT2 may be inaccurate if there is massive cancellation in the */ +/* determinant A*C-B*B; higher precision or correctly rounded or */ +/* correctly truncated arithmetic would be needed to compute RT2 */ +/* accurately in all cases. */ + +/* CS1 and SN1 are accurate to a few ulps barring over/underflow. */ + +/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */ +/* Underflow is harmless if the input data is 0 or exceeds */ +/* underflow_threshold / macheps. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Compute the eigenvalues */ + + sm = *a + *c__; + df = *a - *c__; + adf = abs(df); + tb = *b + *b; + ab = abs(tb); + if (abs(*a) > abs(*c__)) { + acmx = *a; + acmn = *c__; + } else { + acmx = *c__; + acmn = *a; + } + if (adf > ab) { +/* Computing 2nd power */ + d__1 = ab / adf; + rt = adf * sqrt(d__1 * d__1 + 1.); + } else if (adf < ab) { +/* Computing 2nd power */ + d__1 = adf / ab; + rt = ab * sqrt(d__1 * d__1 + 1.); + } else { + +/* Includes case AB=ADF=0 */ + + rt = ab * sqrt(2.); + } + if (sm < 0.) { + *rt1 = (sm - rt) * .5; + sgn1 = -1; + +/* Order of execution important. */ +/* To get fully accurate smaller eigenvalue, */ +/* next line needs to be executed in higher precision. */ + + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else if (sm > 0.) { + *rt1 = (sm + rt) * .5; + sgn1 = 1; + +/* Order of execution important. */ +/* To get fully accurate smaller eigenvalue, */ +/* next line needs to be executed in higher precision. */ + + *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; + } else { + +/* Includes case RT1 = RT2 = 0 */ + + *rt1 = rt * .5; + *rt2 = rt * -.5; + sgn1 = 1; + } + +/* Compute the eigenvector */ + + if (df >= 0.) { + cs = df + rt; + sgn2 = 1; + } else { + cs = df - rt; + sgn2 = -1; + } + acs = abs(cs); + if (acs > ab) { + ct = -tb / cs; + *sn1 = 1. / sqrt(ct * ct + 1.); + *cs1 = ct * *sn1; + } else { + if (ab == 0.) { + *cs1 = 1.; + *sn1 = 0.; + } else { + tn = -cs / tb; + *cs1 = 1. / sqrt(tn * tn + 1.); + *sn1 = tn * *cs1; + } + } + if (sgn1 == sgn2) { + tn = *cs1; + *cs1 = -(*sn1); + *sn1 = tn; + } + return 0; + +/* End of DLAEV2 */ + +} /* dlaev2_ */ + +/* Subroutine */ int dlaexc_(bool *wantq, integer *n, double *t, + integer *ldt, double *q, integer *ldq, integer *j1, integer *n1, + integer *n2, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__4 = 4; + static bool c_false = false; + static integer c_n1 = -1; + static integer c__2 = 2; + static integer c__3 = 3; + + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1; + double d__1, d__2, d__3; + + /* Local variables */ + double d__[16] /* was [4][4] */; + integer k; + double u[3], x[4] /* was [2][2] */; + integer j2, j3, j4; + double u1[3], u2[3]; + integer nd; + double cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1, + tau2; + integer ierr; + double temp; + double scale, dnorm, xnorm; + double thresh, smlnum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in */ +/* an upper quasi-triangular matrix T by an orthogonal similarity */ +/* transformation. */ + +/* T must be in Schur canonical form, that is, block upper triangular */ +/* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block */ +/* has its diagonal elemnts equal and its off-diagonal elements of */ +/* opposite sign. */ + +/* Arguments */ +/* ========= */ + +/* WANTQ (input) LOGICAL */ +/* = .TRUE. : accumulate the transformation in the matrix Q; */ +/* = .FALSE.: do not accumulate the transformation. */ + +/* N (input) INTEGER */ +/* The order of the matrix T. N >= 0. */ + +/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */ +/* On entry, the upper quasi-triangular matrix T, in Schur */ +/* canonical form. */ +/* On exit, the updated matrix T, again in Schur canonical form. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the array T. LDT >= max(1,N). */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* On entry, if WANTQ is .TRUE., the orthogonal matrix Q. */ +/* On exit, if WANTQ is .TRUE., the updated matrix Q. */ +/* If WANTQ is .FALSE., Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. */ +/* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. */ + +/* J1 (input) INTEGER */ +/* The index of the first row of the first block T11. */ + +/* N1 (input) INTEGER */ +/* The order of the first block T11. N1 = 0, 1 or 2. */ + +/* N2 (input) INTEGER */ +/* The order of the second block T22. N2 = 0, 1 or 2. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* = 1: the transformed matrix T would be too far from Schur */ +/* form; the blocks are not swapped and T and Q are */ +/* unchanged. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0 || *n1 == 0 || *n2 == 0) { + return 0; + } + if (*j1 + *n1 > *n) { + return 0; + } + + j2 = *j1 + 1; + j3 = *j1 + 2; + j4 = *j1 + 3; + + if (*n1 == 1 && *n2 == 1) { + +/* Swap two 1-by-1 blocks. */ + + t11 = t[*j1 + *j1 * t_dim1]; + t22 = t[j2 + j2 * t_dim1]; + +/* Determine the transformation to perform the interchange. */ + + d__1 = t22 - t11; + dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp); + +/* Apply transformation to the matrix T. */ + + if (j3 <= *n) { + i__1 = *n - *j1 - 1; + drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1], + ldt, &cs, &sn); + } + i__1 = *j1 - 1; + drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1, + &cs, &sn); + + t[*j1 + *j1 * t_dim1] = t22; + t[j2 + j2 * t_dim1] = t11; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1, + &cs, &sn); + } + + } else { + +/* Swapping involves at least one 2-by-2 block. */ + +/* Copy the diagonal block of order N1+N2 to the local array D */ +/* and compute its norm. */ + + nd = *n1 + *n2; + dlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4); + dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]); + +/* Compute machine-dependent threshold for test for accepting */ +/* swap. */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; +/* Computing MAX */ + d__1 = eps * 10. * dnorm; + thresh = std::max(d__1,smlnum); + +/* Solve T11*X - X*T22 = scale*T12 for X. */ + + dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 + + (*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, & + scale, x, &c__2, &xnorm, &ierr); + +/* Swap the adjacent diagonal blocks. */ + + k = *n1 + *n1 + *n2 - 3; + switch (k) { + case 1: goto L10; + case 2: goto L20; + case 3: goto L30; + } + +L10: + +/* N1 = 1, N2 = 2: generate elementary reflector H so that: */ + +/* ( scale, X11, X12 ) H = ( 0, 0, * ) */ + + u[0] = scale; + u[1] = x[0]; + u[2] = x[2]; + dlarfg_(&c__3, &u[2], u, &c__1, &tau); + u[2] = 1.; + t11 = t[*j1 + *j1 * t_dim1]; + +/* Perform swap provisionally on diagonal block in D. */ + + dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = std::max(d__2,d__3), d__3 = + (d__1 = d__[10] - t11, abs(d__1)); + if (std::max(d__2,d__3) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); + + t[j3 + *j1 * t_dim1] = 0.; + t[j3 + j2 * t_dim1] = 0.; + t[j3 + j3 * t_dim1] = t11; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ + 1]); + } + goto L40; + +L20: + +/* N1 = 2, N2 = 1: generate elementary reflector H so that: */ + +/* H ( -X11 ) = ( * ) */ +/* ( -X21 ) = ( 0 ) */ +/* ( scale ) = ( 0 ) */ + + u[0] = -x[0]; + u[1] = -x[1]; + u[2] = scale; + dlarfg_(&c__3, u, &u[1], &c__1, &tau); + u[0] = 1.; + t33 = t[j3 + j3 * t_dim1]; + +/* Perform swap provisionally on diagonal block in D. */ + + dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = std::max(d__2,d__3), d__3 = + (d__1 = d__[0] - t33, abs(d__1)); + if (std::max(d__2,d__3) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + dlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]); + i__1 = *n - *j1; + dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[ + 1]); + + t[*j1 + *j1 * t_dim1] = t33; + t[j2 + *j1 * t_dim1] = 0.; + t[j3 + *j1 * t_dim1] = 0.; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[ + 1]); + } + goto L40; + +L30: + +/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so */ +/* that: */ + +/* H(2) H(1) ( -X11 -X12 ) = ( * * ) */ +/* ( -X21 -X22 ) ( 0 * ) */ +/* ( scale 0 ) ( 0 0 ) */ +/* ( 0 scale ) ( 0 0 ) */ + + u1[0] = -x[0]; + u1[1] = -x[1]; + u1[2] = scale; + dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1); + u1[0] = 1.; + + temp = -tau1 * (x[2] + u1[1] * x[3]); + u2[0] = -temp * u1[1] - x[3]; + u2[1] = -temp * u1[2]; + u2[2] = scale; + dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2); + u2[0] = 1.; + +/* Perform swap provisionally on diagonal block in D. */ + + dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1]) + ; + dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1]) + ; + dlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]); + dlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]); + +/* Test whether to reject swap. */ + +/* Computing MAX */ + d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = std::max(d__1,d__2), d__2 = + abs(d__[3]), d__1 = std::max(d__1,d__2), d__2 = abs(d__[7]); + if (std::max(d__1,d__2) > thresh) { + goto L50; + } + +/* Accept swap: apply transformation to the entire matrix T. */ + + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[ + 1]); + i__1 = *n - *j1 + 1; + dlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, & + work[1]); + dlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1] +); + + t[j3 + *j1 * t_dim1] = 0.; + t[j3 + j2 * t_dim1] = 0.; + t[j4 + *j1 * t_dim1] = 0.; + t[j4 + j2 * t_dim1] = 0.; + + if (*wantq) { + +/* Accumulate transformation in the matrix Q. */ + + dlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, & + work[1]); + dlarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[ + 1]); + } + +L40: + + if (*n2 == 2) { + +/* Standardize new 2-by-2 block T11 */ + + dlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + * + j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, & + wi2, &cs, &sn); + i__1 = *n - *j1 - 1; + drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2) + * t_dim1], ldt, &cs, &sn); + i__1 = *j1 - 1; + drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], & + c__1, &cs, &sn); + if (*wantq) { + drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], & + c__1, &cs, &sn); + } + } + + if (*n1 == 2) { + +/* Standardize new 2-by-2 block T22 */ + + j3 = *j1 + *n2; + j4 = j3 + 1; + dlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 * + t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, & + cs, &sn); + if (j3 + 2 <= *n) { + i__1 = *n - j3 - 1; + drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2) + * t_dim1], ldt, &cs, &sn); + } + i__1 = j3 - 1; + drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], & + c__1, &cs, &sn); + if (*wantq) { + drot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], & + c__1, &cs, &sn); + } + } + + } + return 0; + +/* Exit with INFO = 1 if swap was rejected. */ + +L50: + *info = 1; + return 0; + +/* End of DLAEXC */ + +} /* dlaexc_ */ + +/* Subroutine */ int dlag2_(double *a, integer *lda, double *b, + integer *ldb, double *safmin, double *scale1, double * + scale2, double *wr1, double *wr2, double *wi) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset; + double d__1, d__2, d__3, d__4, d__5, d__6; + + /* Builtin functions + double sqrt(double), d_sign(double *, double *); */ + + /* Local variables */ + double r__, c1, c2, c3, c4, c5, s1, s2, a11, a12, a21, a22, b11, b12, + b22, pp, qq, ss, as11, as12, as22, sum, abi22, diff, bmin, wbig, + wabs, wdet, binv11, binv22, discr, anorm, bnorm, bsize, shift, + rtmin, rtmax, wsize, ascale, bscale, wscale, safmax, wsmall; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue */ +/* problem A - w B, with scaling as necessary to avoid over-/underflow. */ + +/* The scaling factor "s" results in a modified eigenvalue equation */ + +/* s A - w B */ + +/* where s is a non-negative scaling factor chosen so that w, w B, */ +/* and s A do not overflow and, if possible, do not underflow, either. */ + +/* Arguments */ +/* ========= */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA, 2) */ +/* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm */ +/* is less than 1/SAFMIN. Entries less than */ +/* sqrt(SAFMIN)*norm(A) are subject to being treated as zero. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= 2. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB, 2) */ +/* On entry, the 2 x 2 upper triangular matrix B. It is */ +/* assumed that the one-norm of B is less than 1/SAFMIN. The */ +/* diagonals should be at least sqrt(SAFMIN) times the largest */ +/* element of B (in absolute value); if a diagonal is smaller */ +/* than that, then +/- sqrt(SAFMIN) will be used instead of */ +/* that diagonal. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= 2. */ + +/* SAFMIN (input) DOUBLE PRECISION */ +/* The smallest positive number s.t. 1/SAFMIN does not */ +/* overflow. (This should always be DLAMCH('S') -- it is an */ +/* argument in order to avoid having to call DLAMCH frequently.) */ + +/* SCALE1 (output) DOUBLE PRECISION */ +/* A scaling factor used to avoid over-/underflow in the */ +/* eigenvalue equation which defines the first eigenvalue. If */ +/* the eigenvalues are complex, then the eigenvalues are */ +/* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the */ +/* exponent range of the machine), SCALE1=SCALE2, and SCALE1 */ +/* will always be positive. If the eigenvalues are real, then */ +/* the first (real) eigenvalue is WR1 / SCALE1 , but this may */ +/* overflow or underflow, and in fact, SCALE1 may be zero or */ +/* less than the underflow threshhold if the exact eigenvalue */ +/* is sufficiently large. */ + +/* SCALE2 (output) DOUBLE PRECISION */ +/* A scaling factor used to avoid over-/underflow in the */ +/* eigenvalue equation which defines the second eigenvalue. If */ +/* the eigenvalues are complex, then SCALE2=SCALE1. If the */ +/* eigenvalues are real, then the second (real) eigenvalue is */ +/* WR2 / SCALE2 , but this may overflow or underflow, and in */ +/* fact, SCALE2 may be zero or less than the underflow */ +/* threshhold if the exact eigenvalue is sufficiently large. */ + +/* WR1 (output) DOUBLE PRECISION */ +/* If the eigenvalue is real, then WR1 is SCALE1 times the */ +/* eigenvalue closest to the (2,2) element of A B**(-1). If the */ +/* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real */ +/* part of the eigenvalues. */ + +/* WR2 (output) DOUBLE PRECISION */ +/* If the eigenvalue is real, then WR2 is SCALE2 times the */ +/* other eigenvalue. If the eigenvalue is complex, then */ +/* WR1=WR2 is SCALE1 times the real part of the eigenvalues. */ + +/* WI (output) DOUBLE PRECISION */ +/* If the eigenvalue is real, then WI is zero. If the */ +/* eigenvalue is complex, then WI is SCALE1 times the imaginary */ +/* part of the eigenvalues. WI will always be non-negative. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + rtmin = sqrt(*safmin); + rtmax = 1. / rtmin; + safmax = 1. / *safmin; + +/* Scale A */ + +/* Computing MAX */ + d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs( + d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 = + a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = std::max(d__5,d__6); + anorm = std::max(d__5,*safmin); + ascale = 1. / anorm; + a11 = ascale * a[a_dim1 + 1]; + a21 = ascale * a[a_dim1 + 2]; + a12 = ascale * a[(a_dim1 << 1) + 1]; + a22 = ascale * a[(a_dim1 << 1) + 2]; + +/* Perturb B if necessary to insure non-singularity */ + + b11 = b[b_dim1 + 1]; + b12 = b[(b_dim1 << 1) + 1]; + b22 = b[(b_dim1 << 1) + 2]; +/* Computing MAX */ + d__1 = abs(b11), d__2 = abs(b12), d__1 = std::max(d__1,d__2), d__2 = abs(b22), + d__1 = std::max(d__1,d__2); + bmin = rtmin * std::max(d__1,rtmin); + if (abs(b11) < bmin) { + b11 = d_sign(&bmin, &b11); + } + if (abs(b22) < bmin) { + b22 = d_sign(&bmin, &b22); + } + +/* Scale B */ + +/* Computing MAX */ + d__1 = abs(b11), d__2 = abs(b12) + abs(b22), d__1 = std::max(d__1,d__2); + bnorm = std::max(d__1,*safmin); +/* Computing MAX */ + d__1 = abs(b11), d__2 = abs(b22); + bsize = std::max(d__1,d__2); + bscale = 1. / bsize; + b11 *= bscale; + b12 *= bscale; + b22 *= bscale; + +/* Compute larger eigenvalue by method described by C. van Loan */ + +/* ( AS is A shifted by -SHIFT*B ) */ + + binv11 = 1. / b11; + binv22 = 1. / b22; + s1 = a11 * binv11; + s2 = a22 * binv22; + if (abs(s1) <= abs(s2)) { + as12 = a12 - s1 * b12; + as22 = a22 - s1 * b22; + ss = a21 * (binv11 * binv22); + abi22 = as22 * binv22 - ss * b12; + pp = abi22 * .5; + shift = s1; + } else { + as12 = a12 - s2 * b12; + as11 = a11 - s2 * b11; + ss = a21 * (binv11 * binv22); + abi22 = -ss * b12; + pp = (as11 * binv11 + abi22) * .5; + shift = s2; + } + qq = ss * as12; + if ((d__1 = pp * rtmin, abs(d__1)) >= 1.) { +/* Computing 2nd power */ + d__1 = rtmin * pp; + discr = d__1 * d__1 + qq * *safmin; + r__ = sqrt((abs(discr))) * rtmax; + } else { +/* Computing 2nd power */ + d__1 = pp; + if (d__1 * d__1 + abs(qq) <= *safmin) { +/* Computing 2nd power */ + d__1 = rtmax * pp; + discr = d__1 * d__1 + qq * safmax; + r__ = sqrt((abs(discr))) * rtmin; + } else { +/* Computing 2nd power */ + d__1 = pp; + discr = d__1 * d__1 + qq; + r__ = sqrt((abs(discr))); + } + } + +/* Note: the test of R in the following IF is to cover the case when */ +/* DISCR is small and negative and is flushed to zero during */ +/* the calculation of R. On machines which have a consistent */ +/* flush-to-zero threshhold and handle numbers above that */ +/* threshhold correctly, it would not be necessary. */ + + if (discr >= 0. || r__ == 0.) { + sum = pp + d_sign(&r__, &pp); + diff = pp - d_sign(&r__, &pp); + wbig = shift + sum; + +/* Compute smaller eigenvalue */ + + wsmall = shift + diff; +/* Computing MAX */ + d__1 = abs(wsmall); + if (abs(wbig) * .5 > std::max(d__1,*safmin)) { + wdet = (a11 * a22 - a12 * a21) * (binv11 * binv22); + wsmall = wdet / wbig; + } + +/* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) */ +/* for WR1. */ + + if (pp > abi22) { + *wr1 = std::min(wbig,wsmall); + *wr2 = std::max(wbig,wsmall); + } else { + *wr1 = std::max(wbig,wsmall); + *wr2 = std::min(wbig,wsmall); + } + *wi = 0.; + } else { + +/* Complex eigenvalues */ + + *wr1 = shift + pp; + *wr2 = *wr1; + *wi = r__; + } + +/* Further scaling to avoid underflow and overflow in computing */ +/* SCALE1 and overflow in computing w*B. */ + +/* This scale factor (WSCALE) is bounded from above using C1 and C2, */ +/* and from below using C3 and C4. */ +/* C1 implements the condition s A must never overflow. */ +/* C2 implements the condition w B must never overflow. */ +/* C3, with C2, */ +/* implement the condition that s A - w B must never overflow. */ +/* C4 implements the condition s should not underflow. */ +/* C5 implements the condition max(s,|w|) should be at least 2. */ + + c1 = bsize * (*safmin * std::max(1.,ascale)); + c2 = *safmin * std::max(1.,bnorm); + c3 = bsize * *safmin; + if (ascale <= 1. && bsize <= 1.) { +/* Computing MIN */ + d__1 = 1., d__2 = ascale / *safmin * bsize; + c4 = std::min(d__1,d__2); + } else { + c4 = 1.; + } + if (ascale <= 1. || bsize <= 1.) { +/* Computing MIN */ + d__1 = 1., d__2 = ascale * bsize; + c5 = std::min(d__1,d__2); + } else { + c5 = 1.; + } + +/* Scale first eigenvalue */ + + wabs = abs(*wr1) + abs(*wi); +/* Computing MAX */ +/* Computing MIN */ + d__3 = c4, d__4 = std::max(wabs,c5) * .5; + d__1 = std::max(*safmin,c1), d__2 = (wabs * c2 + c3) * 1.0000100000000001, + d__1 = std::max(d__1,d__2), d__2 = std::min(d__3,d__4); + wsize = std::max(d__1,d__2); + if (wsize != 1.) { + wscale = 1. / wsize; + if (wsize > 1.) { + *scale1 = std::max(ascale,bsize) * wscale * std::min(ascale,bsize); + } else { + *scale1 = std::min(ascale,bsize) * wscale * std::max(ascale,bsize); + } + *wr1 *= wscale; + if (*wi != 0.) { + *wi *= wscale; + *wr2 = *wr1; + *scale2 = *scale1; + } + } else { + *scale1 = ascale * bsize; + *scale2 = *scale1; + } + +/* Scale second eigenvalue (if real) */ + + if (*wi == 0.) { +/* Computing MAX */ +/* Computing MIN */ +/* Computing MAX */ + d__5 = abs(*wr2); + d__3 = c4, d__4 = std::max(d__5,c5) * .5; + d__1 = std::max(*safmin,c1), d__2 = (abs(*wr2) * c2 + c3) * + 1.0000100000000001, d__1 = std::max(d__1,d__2), d__2 = std::min(d__3, + d__4); + wsize = std::max(d__1,d__2); + if (wsize != 1.) { + wscale = 1. / wsize; + if (wsize > 1.) { + *scale2 = std::max(ascale,bsize) * wscale * std::min(ascale,bsize); + } else { + *scale2 = std::min(ascale,bsize) * wscale * std::max(ascale,bsize); + } + *wr2 *= wscale; + } else { + *scale2 = ascale * bsize; + } + } + +/* End of DLAG2 */ + + return 0; +} /* dlag2_ */ + +/* Subroutine */ int dlag2s_(integer *m, integer *n, double *a, integer *lda, float *sa, integer *ldsa, integer *info) +{ + /* System generated locals */ + integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + double rmax; + + +/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* August 2007 */ + +/* .. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE */ +/* PRECISION matrix, A. */ + +/* RMAX is the overflow for the SINGLE PRECISION arithmetic */ +/* DLAG2S checks that all the entries of A are between -RMAX and */ +/* RMAX. If not the convertion is aborted and a flag is raised. */ + +/* This is an auxiliary routine so there is no argument checking. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of lines of the matrix A. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N coefficient matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* SA (output) REAL array, dimension (LDSA,N) */ +/* On exit, if INFO=0, the M-by-N coefficient matrix SA; if */ +/* INFO>0, the content of SA is unspecified. */ + +/* LDSA (input) INTEGER */ +/* The leading dimension of the array SA. LDSA >= max(1,M). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* = 1: an entry of the matrix A is greater than the SINGLE */ +/* PRECISION overflow threshold, in this case, the content */ +/* of SA in exit is unspecified. */ + +/* ========= */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + sa_dim1 = *ldsa; + sa_offset = 1 + sa_dim1; + sa -= sa_offset; + + /* Function Body */ + rmax = slamch_("O"); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax) { + *info = 1; + goto L30; + } + sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + *info = 0; +L30: + return 0; + +/* End of DLAG2S */ + +} /* dlag2s_ */ + +/* Subroutine */ int dlags2_(bool *upper, double *a1, double *a2, + double *a3, double *b1, double *b2, double *b3, + double *csu, double *snu, double *csv, double *snv, + double *csq, double *snq) +{ + /* System generated locals */ + double d__1; + + /* Local variables */ + double a, b, c__, d__, r__, s1, s2, ua11, ua12, ua21, ua22, vb11, + vb12, vb21, vb22, csl, csr, snl, snr, aua11, aua12, aua21, aua22, + avb11, avb12, avb21, avb22, ua11r, ua22r, vb11r, vb22r; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such */ +/* that if ( UPPER ) then */ + +/* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) */ +/* ( 0 A3 ) ( x x ) */ +/* and */ +/* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) */ +/* ( 0 B3 ) ( x x ) */ + +/* or if ( .NOT.UPPER ) then */ + +/* U'*A*Q = U'*( A1 0 )*Q = ( x x ) */ +/* ( A2 A3 ) ( 0 x ) */ +/* and */ +/* V'*B*Q = V'*( B1 0 )*Q = ( x x ) */ +/* ( B2 B3 ) ( 0 x ) */ + +/* The rows of the transformed A and B are parallel, where */ + +/* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) */ +/* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) */ + +/* Z' denotes the transpose of Z. */ + + +/* Arguments */ +/* ========= */ + +/* UPPER (input) LOGICAL */ +/* = .TRUE.: the input matrices A and B are upper triangular. */ +/* = .FALSE.: the input matrices A and B are lower triangular. */ + +/* A1 (input) DOUBLE PRECISION */ +/* A2 (input) DOUBLE PRECISION */ +/* A3 (input) DOUBLE PRECISION */ +/* On entry, A1, A2 and A3 are elements of the input 2-by-2 */ +/* upper (lower) triangular matrix A. */ + +/* B1 (input) DOUBLE PRECISION */ +/* B2 (input) DOUBLE PRECISION */ +/* B3 (input) DOUBLE PRECISION */ +/* On entry, B1, B2 and B3 are elements of the input 2-by-2 */ +/* upper (lower) triangular matrix B. */ + +/* CSU (output) DOUBLE PRECISION */ +/* SNU (output) DOUBLE PRECISION */ +/* The desired orthogonal matrix U. */ + +/* CSV (output) DOUBLE PRECISION */ +/* SNV (output) DOUBLE PRECISION */ +/* The desired orthogonal matrix V. */ + +/* CSQ (output) DOUBLE PRECISION */ +/* SNQ (output) DOUBLE PRECISION */ +/* The desired orthogonal matrix Q. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (*upper) { + +/* Input matrices A and B are upper triangular matrices */ + +/* Form matrix C = A*adj(B) = ( a b ) */ +/* ( 0 d ) */ + + a = *a1 * *b3; + d__ = *a3 * *b1; + b = *a2 * *b1 - *a1 * *b2; + +/* The SVD of real 2-by-2 triangular C */ + +/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */ +/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */ + + dlasv2_(&a, &b, &d__, &s1, &s2, &snr, &csr, &snl, &csl); + + if (abs(csl) >= abs(snl) || abs(csr) >= abs(snr)) { + +/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */ +/* and (1,2) element of |U|'*|A| and |V|'*|B|. */ + + ua11r = csl * *a1; + ua12 = csl * *a2 + snl * *a3; + + vb11r = csr * *b1; + vb12 = csr * *b2 + snr * *b3; + + aua12 = abs(csl) * abs(*a2) + abs(snl) * abs(*a3); + avb12 = abs(csr) * abs(*b2) + abs(snr) * abs(*b3); + +/* zero (1,2) elements of U'*A and V'*B */ + + if (abs(ua11r) + abs(ua12) != 0.) { + if (aua12 / (abs(ua11r) + abs(ua12)) <= avb12 / (abs(vb11r) + + abs(vb12))) { + d__1 = -ua11r; + dlartg_(&d__1, &ua12, csq, snq, &r__); + } else { + d__1 = -vb11r; + dlartg_(&d__1, &vb12, csq, snq, &r__); + } + } else { + d__1 = -vb11r; + dlartg_(&d__1, &vb12, csq, snq, &r__); + } + + *csu = csl; + *snu = -snl; + *csv = csr; + *snv = -snr; + + } else { + +/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */ +/* and (2,2) element of |U|'*|A| and |V|'*|B|. */ + + ua21 = -snl * *a1; + ua22 = -snl * *a2 + csl * *a3; + + vb21 = -snr * *b1; + vb22 = -snr * *b2 + csr * *b3; + + aua22 = abs(snl) * abs(*a2) + abs(csl) * abs(*a3); + avb22 = abs(snr) * abs(*b2) + abs(csr) * abs(*b3); + +/* zero (2,2) elements of U'*A and V'*B, and then swap. */ + + if (abs(ua21) + abs(ua22) != 0.) { + if (aua22 / (abs(ua21) + abs(ua22)) <= avb22 / (abs(vb21) + + abs(vb22))) { + d__1 = -ua21; + dlartg_(&d__1, &ua22, csq, snq, &r__); + } else { + d__1 = -vb21; + dlartg_(&d__1, &vb22, csq, snq, &r__); + } + } else { + d__1 = -vb21; + dlartg_(&d__1, &vb22, csq, snq, &r__); + } + + *csu = snl; + *snu = csl; + *csv = snr; + *snv = csr; + + } + + } else { + +/* Input matrices A and B are lower triangular matrices */ + +/* Form matrix C = A*adj(B) = ( a 0 ) */ +/* ( c d ) */ + + a = *a1 * *b3; + d__ = *a3 * *b1; + c__ = *a2 * *b3 - *a3 * *b2; + +/* The SVD of real 2-by-2 triangular C */ + +/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */ +/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */ + + dlasv2_(&a, &c__, &d__, &s1, &s2, &snr, &csr, &snl, &csl); + + if (abs(csr) >= abs(snr) || abs(csl) >= abs(snl)) { + +/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */ +/* and (2,1) element of |U|'*|A| and |V|'*|B|. */ + + ua21 = -snr * *a1 + csr * *a2; + ua22r = csr * *a3; + + vb21 = -snl * *b1 + csl * *b2; + vb22r = csl * *b3; + + aua21 = abs(snr) * abs(*a1) + abs(csr) * abs(*a2); + avb21 = abs(snl) * abs(*b1) + abs(csl) * abs(*b2); + +/* zero (2,1) elements of U'*A and V'*B. */ + + if (abs(ua21) + abs(ua22r) != 0.) { + if (aua21 / (abs(ua21) + abs(ua22r)) <= avb21 / (abs(vb21) + + abs(vb22r))) { + dlartg_(&ua22r, &ua21, csq, snq, &r__); + } else { + dlartg_(&vb22r, &vb21, csq, snq, &r__); + } + } else { + dlartg_(&vb22r, &vb21, csq, snq, &r__); + } + + *csu = csr; + *snu = -snr; + *csv = csl; + *snv = -snl; + + } else { + +/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */ +/* and (1,1) element of |U|'*|A| and |V|'*|B|. */ + + ua11 = csr * *a1 + snr * *a2; + ua12 = snr * *a3; + + vb11 = csl * *b1 + snl * *b2; + vb12 = snl * *b3; + + aua11 = abs(csr) * abs(*a1) + abs(snr) * abs(*a2); + avb11 = abs(csl) * abs(*b1) + abs(snl) * abs(*b2); + +/* zero (1,1) elements of U'*A and V'*B, and then swap. */ + + if (abs(ua11) + abs(ua12) != 0.) { + if (aua11 / (abs(ua11) + abs(ua12)) <= avb11 / (abs(vb11) + + abs(vb12))) { + dlartg_(&ua12, &ua11, csq, snq, &r__); + } else { + dlartg_(&vb12, &vb11, csq, snq, &r__); + } + } else { + dlartg_(&vb12, &vb11, csq, snq, &r__); + } + + *csu = snr; + *snu = csr; + *csv = snl; + *snv = csl; + + } + + } + + return 0; + +/* End of DLAGS2 */ + +} /* dlags2_ */ + +/* Subroutine */ int dlagtf_(integer *n, double *a, double *lambda, + double *b, double *c__, double *tol, double *d__, + integer *in, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + integer k; + double tl, eps, piv1, piv2, temp, mult, scale1, scale2; + + + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n */ +/* tridiagonal matrix and lambda is a scalar, as */ + +/* T - lambda*I = PLU, */ + +/* where P is a permutation matrix, L is a unit lower tridiagonal matrix */ +/* with at most one non-zero sub-diagonal elements per column and U is */ +/* an upper triangular matrix with at most two non-zero super-diagonal */ +/* elements per column. */ + +/* The factorization is obtained by Gaussian elimination with partial */ +/* pivoting and implicit row scaling. */ + +/* The parameter LAMBDA is included in the routine so that DLAGTF may */ +/* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by */ +/* inverse iteration. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix T. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, A must contain the diagonal elements of T. */ + +/* On exit, A is overwritten by the n diagonal elements of the */ +/* upper triangular matrix U of the factorization of T. */ + +/* LAMBDA (input) DOUBLE PRECISION */ +/* On entry, the scalar lambda. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, B must contain the (n-1) super-diagonal elements of */ +/* T. */ + +/* On exit, B is overwritten by the (n-1) super-diagonal */ +/* elements of the matrix U of the factorization of T. */ + +/* C (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, C must contain the (n-1) sub-diagonal elements of */ +/* T. */ + +/* On exit, C is overwritten by the (n-1) sub-diagonal elements */ +/* of the matrix L of the factorization of T. */ + +/* TOL (input) DOUBLE PRECISION */ +/* On entry, a relative tolerance used to indicate whether or */ +/* not the matrix (T - lambda*I) is nearly singular. TOL should */ +/* normally be chose as approximately the largest relative error */ +/* in the elements of T. For example, if the elements of T are */ +/* correct to about 4 significant figures, then TOL should be */ +/* set to about 5*10**(-4). If TOL is supplied as less than eps, */ +/* where eps is the relative machine precision, then the value */ +/* eps is used in place of TOL. */ + +/* D (output) DOUBLE PRECISION array, dimension (N-2) */ +/* On exit, D is overwritten by the (n-2) second super-diagonal */ +/* elements of the matrix U of the factorization of T. */ + +/* IN (output) INTEGER array, dimension (N) */ +/* On exit, IN contains details of the permutation matrix P. If */ +/* an interchange occurred at the kth step of the elimination, */ +/* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) */ +/* returns the smallest positive integer j such that */ + +/* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, */ + +/* where norm( A(j) ) denotes the sum of the absolute values of */ +/* the jth row of the matrix A. If no such j exists then IN(n) */ +/* is returned as zero. If IN(n) is returned as positive, then a */ +/* diagonal element of U is small, indicating that */ +/* (T - lambda*I) is singular or nearly singular, */ + +/* INFO (output) INTEGER */ +/* = 0 : successful exit */ +/* .lt. 0: if INFO = -k, the kth argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --in; + --d__; + --c__; + --b; + --a; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("DLAGTF", &i__1); + return 0; + } + + if (*n == 0) { + return 0; + } + + a[1] -= *lambda; + in[*n] = 0; + if (*n == 1) { + if (a[1] == 0.) { + in[1] = 1; + } + return 0; + } + + eps = dlamch_("Epsilon"); + + tl = std::max(*tol,eps); + scale1 = abs(a[1]) + abs(b[1]); + i__1 = *n - 1; + for (k = 1; k <= i__1; ++k) { + a[k + 1] -= *lambda; + scale2 = (d__1 = c__[k], abs(d__1)) + (d__2 = a[k + 1], abs(d__2)); + if (k < *n - 1) { + scale2 += (d__1 = b[k + 1], abs(d__1)); + } + if (a[k] == 0.) { + piv1 = 0.; + } else { + piv1 = (d__1 = a[k], abs(d__1)) / scale1; + } + if (c__[k] == 0.) { + in[k] = 0; + piv2 = 0.; + scale1 = scale2; + if (k < *n - 1) { + d__[k] = 0.; + } + } else { + piv2 = (d__1 = c__[k], abs(d__1)) / scale2; + if (piv2 <= piv1) { + in[k] = 0; + scale1 = scale2; + c__[k] /= a[k]; + a[k + 1] -= c__[k] * b[k]; + if (k < *n - 1) { + d__[k] = 0.; + } + } else { + in[k] = 1; + mult = a[k] / c__[k]; + a[k] = c__[k]; + temp = a[k + 1]; + a[k + 1] = b[k] - mult * temp; + if (k < *n - 1) { + d__[k] = b[k + 1]; + b[k + 1] = -mult * d__[k]; + } + b[k] = temp; + c__[k] = mult; + } + } + if (std::max(piv1,piv2) <= tl && in[*n] == 0) { + in[*n] = k; + } +/* L10: */ + } + if ((d__1 = a[*n], abs(d__1)) <= scale1 * tl && in[*n] == 0) { + in[*n] = *n; + } + + return 0; + +/* End of DLAGTF */ + +} /* dlagtf_ */ + +/* Subroutine */ int dlagtm_(const char *trans, integer *n, integer *nrhs, + double *alpha, double *dl, double *d__, double *du, + double *x, integer *ldx, double *beta, double *b, integer + *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAGTM performs a matrix-vector product of the form */ + +/* B := alpha * A * X + beta * B */ + +/* where A is a tridiagonal matrix of order N, B and X are N by NRHS */ +/* matrices, and alpha and beta are real scalars, each of which may be */ +/* 0., 1., or -1. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the operation applied to A. */ +/* = 'N': No transpose, B := alpha * A * X + beta * B */ +/* = 'T': Transpose, B := alpha * A'* X + beta * B */ +/* = 'C': Conjugate transpose = Transpose */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices X and B. */ + +/* ALPHA (input) DOUBLE PRECISION */ +/* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */ +/* it is assumed to be 0. */ + +/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) sub-diagonal elements of T. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of T. */ + +/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) super-diagonal elements of T. */ + +/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* The N by NRHS matrix X. */ +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(N,1). */ + +/* BETA (input) DOUBLE PRECISION */ +/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */ +/* it is assumed to be 1. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N by NRHS matrix B. */ +/* On exit, B is overwritten by the matrix expression */ +/* B := alpha * A * X + beta * B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(N,1). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --dl; + --d__; + --du; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + if (*n == 0) { + return 0; + } + +/* Multiply B by BETA if BETA.NE.1. */ + + if (*beta == 0.) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + } else if (*beta == -1.) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = -b[i__ + j * b_dim1]; +/* L30: */ + } +/* L40: */ + } + } + + if (*alpha == 1.) { + if (lsame_(trans, "N")) { + +/* Compute B := B + A*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1]; + } else { + b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j * + x_dim1 + 1] + du[1] * x[j * x_dim1 + 2]; + b[*n + j * b_dim1] = b[*n + j * b_dim1] + dl[*n - 1] * x[* + n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1] + ; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + dl[i__ - + 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[ + i__ + j * x_dim1] + du[i__] * x[i__ + 1 + j * + x_dim1]; +/* L50: */ + } + } +/* L60: */ + } + } else { + +/* Compute B := B + A'*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1]; + } else { + b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j * + x_dim1 + 1] + dl[1] * x[j * x_dim1 + 2]; + b[*n + j * b_dim1] = b[*n + j * b_dim1] + du[*n - 1] * x[* + n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1] + ; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + du[i__ - + 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[ + i__ + j * x_dim1] + dl[i__] * x[i__ + 1 + j * + x_dim1]; +/* L70: */ + } + } +/* L80: */ + } + } + } else if (*alpha == -1.) { + if (lsame_(trans, "N")) { + +/* Compute B := B - A*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1]; + } else { + b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j * + x_dim1 + 1] - du[1] * x[j * x_dim1 + 2]; + b[*n + j * b_dim1] = b[*n + j * b_dim1] - dl[*n - 1] * x[* + n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1] + ; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - dl[i__ - + 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[ + i__ + j * x_dim1] - du[i__] * x[i__ + 1 + j * + x_dim1]; +/* L90: */ + } + } +/* L100: */ + } + } else { + +/* Compute B := B - A'*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1]; + } else { + b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j * + x_dim1 + 1] - dl[1] * x[j * x_dim1 + 2]; + b[*n + j * b_dim1] = b[*n + j * b_dim1] - du[*n - 1] * x[* + n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1] + ; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - du[i__ - + 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[ + i__ + j * x_dim1] - dl[i__] * x[i__ + 1 + j * + x_dim1]; +/* L110: */ + } + } +/* L120: */ + } + } + } + return 0; + +/* End of DLAGTM */ + +} /* dlagtm_ */ + +/* Subroutine */ int dlagts_(integer *job, integer *n, double *a, + double *b, double *c__, double *d__, integer *in, + double *y, double *tol, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + integer k; + double ak, eps, temp, pert, absak, sfmin; + + + double bignum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAGTS may be used to solve one of the systems of equations */ + +/* (T - lambda*I)*x = y or (T - lambda*I)'*x = y, */ + +/* where T is an n by n tridiagonal matrix, for x, following the */ +/* factorization of (T - lambda*I) as */ + +/* (T - lambda*I) = P*L*U , */ + +/* by routine DLAGTF. The choice of equation to be solved is */ +/* controlled by the argument JOB, and in each case there is an option */ +/* to perturb zero or very small diagonal elements of U, this option */ +/* being intended for use in applications such as inverse iteration. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) INTEGER */ +/* Specifies the job to be performed by DLAGTS as follows: */ +/* = 1: The equations (T - lambda*I)x = y are to be solved, */ +/* but diagonal elements of U are not to be perturbed. */ +/* = -1: The equations (T - lambda*I)x = y are to be solved */ +/* and, if overflow would otherwise occur, the diagonal */ +/* elements of U are to be perturbed. See argument TOL */ +/* below. */ +/* = 2: The equations (T - lambda*I)'x = y are to be solved, */ +/* but diagonal elements of U are not to be perturbed. */ +/* = -2: The equations (T - lambda*I)'x = y are to be solved */ +/* and, if overflow would otherwise occur, the diagonal */ +/* elements of U are to be perturbed. See argument TOL */ +/* below. */ + +/* N (input) INTEGER */ +/* The order of the matrix T. */ + +/* A (input) DOUBLE PRECISION array, dimension (N) */ +/* On entry, A must contain the diagonal elements of U as */ +/* returned from DLAGTF. */ + +/* B (input) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, B must contain the first super-diagonal elements of */ +/* U as returned from DLAGTF. */ + +/* C (input) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, C must contain the sub-diagonal elements of L as */ +/* returned from DLAGTF. */ + +/* D (input) DOUBLE PRECISION array, dimension (N-2) */ +/* On entry, D must contain the second super-diagonal elements */ +/* of U as returned from DLAGTF. */ + +/* IN (input) INTEGER array, dimension (N) */ +/* On entry, IN must contain details of the matrix P as returned */ +/* from DLAGTF. */ + +/* Y (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the right hand side vector y. */ +/* On exit, Y is overwritten by the solution vector x. */ + +/* TOL (input/output) DOUBLE PRECISION */ +/* On entry, with JOB .lt. 0, TOL should be the minimum */ +/* perturbation to be made to very small diagonal elements of U. */ +/* TOL should normally be chosen as about eps*norm(U), where eps */ +/* is the relative machine precision, but if TOL is supplied as */ +/* non-positive, then it is reset to eps*max( abs( u(i,j) ) ). */ +/* If JOB .gt. 0 then TOL is not referenced. */ + +/* On exit, TOL is changed as described above, only if TOL is */ +/* non-positive on entry. Otherwise TOL is unchanged. */ + +/* INFO (output) INTEGER */ +/* = 0 : successful exit */ +/* .lt. 0: if INFO = -i, the i-th argument had an illegal value */ +/* .gt. 0: overflow would occur when computing the INFO(th) */ +/* element of the solution vector x. This can only occur */ +/* when JOB is supplied as positive and either means */ +/* that a diagonal element of U is very small, or that */ +/* the elements of the right-hand side vector y are very */ +/* large. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --y; + --in; + --d__; + --c__; + --b; + --a; + + /* Function Body */ + *info = 0; + if (abs(*job) > 2 || *job == 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAGTS", &i__1); + return 0; + } + + if (*n == 0) { + return 0; + } + + eps = dlamch_("Epsilon"); + sfmin = dlamch_("Safe minimum"); + bignum = 1. / sfmin; + + if (*job < 0) { + if (*tol <= 0.) { + *tol = abs(a[1]); + if (*n > 1) { +/* Computing MAX */ + d__1 = *tol, d__2 = abs(a[2]), d__1 = std::max(d__1,d__2), d__2 = + abs(b[1]); + *tol = std::max(d__1,d__2); + } + i__1 = *n; + for (k = 3; k <= i__1; ++k) { +/* Computing MAX */ + d__4 = *tol, d__5 = (d__1 = a[k], abs(d__1)), d__4 = std::max(d__4, + d__5), d__5 = (d__2 = b[k - 1], abs(d__2)), d__4 = + std::max(d__4,d__5), d__5 = (d__3 = d__[k - 2], abs(d__3)); + *tol = std::max(d__4,d__5); +/* L10: */ + } + *tol *= eps; + if (*tol == 0.) { + *tol = eps; + } + } + } + + if (abs(*job) == 1) { + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + if (in[k - 1] == 0) { + y[k] -= c__[k - 1] * y[k - 1]; + } else { + temp = y[k - 1]; + y[k - 1] = y[k]; + y[k] = temp - c__[k - 1] * y[k]; + } +/* L20: */ + } + if (*job == 1) { + for (k = *n; k >= 1; --k) { + if (k <= *n - 2) { + temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2]; + } else if (k == *n - 1) { + temp = y[k] - b[k] * y[k + 1]; + } else { + temp = y[k]; + } + ak = a[k]; + absak = abs(ak); + if (absak < 1.) { + if (absak < sfmin) { + if (absak == 0. || abs(temp) * sfmin > absak) { + *info = k; + return 0; + } else { + temp *= bignum; + ak *= bignum; + } + } else if (abs(temp) > absak * bignum) { + *info = k; + return 0; + } + } + y[k] = temp / ak; +/* L30: */ + } + } else { + for (k = *n; k >= 1; --k) { + if (k <= *n - 2) { + temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2]; + } else if (k == *n - 1) { + temp = y[k] - b[k] * y[k + 1]; + } else { + temp = y[k]; + } + ak = a[k]; + pert = d_sign(tol, &ak); +L40: + absak = abs(ak); + if (absak < 1.) { + if (absak < sfmin) { + if (absak == 0. || abs(temp) * sfmin > absak) { + ak += pert; + pert *= 2; + goto L40; + } else { + temp *= bignum; + ak *= bignum; + } + } else if (abs(temp) > absak * bignum) { + ak += pert; + pert *= 2; + goto L40; + } + } + y[k] = temp / ak; +/* L50: */ + } + } + } else { + +/* Come to here if JOB = 2 or -2 */ + + if (*job == 2) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (k >= 3) { + temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2]; + } else if (k == 2) { + temp = y[k] - b[k - 1] * y[k - 1]; + } else { + temp = y[k]; + } + ak = a[k]; + absak = abs(ak); + if (absak < 1.) { + if (absak < sfmin) { + if (absak == 0. || abs(temp) * sfmin > absak) { + *info = k; + return 0; + } else { + temp *= bignum; + ak *= bignum; + } + } else if (abs(temp) > absak * bignum) { + *info = k; + return 0; + } + } + y[k] = temp / ak; +/* L60: */ + } + } else { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (k >= 3) { + temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2]; + } else if (k == 2) { + temp = y[k] - b[k - 1] * y[k - 1]; + } else { + temp = y[k]; + } + ak = a[k]; + pert = d_sign(tol, &ak); +L70: + absak = abs(ak); + if (absak < 1.) { + if (absak < sfmin) { + if (absak == 0. || abs(temp) * sfmin > absak) { + ak += pert; + pert *= 2; + goto L70; + } else { + temp *= bignum; + ak *= bignum; + } + } else if (abs(temp) > absak * bignum) { + ak += pert; + pert *= 2; + goto L70; + } + } + y[k] = temp / ak; +/* L80: */ + } + } + + for (k = *n; k >= 2; --k) { + if (in[k - 1] == 0) { + y[k - 1] -= c__[k - 1] * y[k]; + } else { + temp = y[k - 1]; + y[k - 1] = y[k]; + y[k] = temp - c__[k - 1] * y[k]; + } +/* L90: */ + } + } + +/* End of DLAGTS */ + + return 0; +} /* dlagts_ */ + +/* Subroutine */ int dlagv2_(double *a, integer *lda, double *b, + integer *ldb, double *alphar, double *alphai, double * + beta, double *csl, double *snl, double *csr, double * + snr) +{ + /* Table of constant values */ + static integer c__2 = 2; + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset; + double d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + double r__, t, h1, h2, h3, wi, qq, rr, wr1, wr2, ulp; + double anorm, bnorm, scale1, scale2; + double ascale, bscale; + double safmin; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 */ +/* matrix pencil (A,B) where B is upper triangular. This routine */ +/* computes orthogonal (rotation) matrices given by CSL, SNL and CSR, */ +/* SNR such that */ + +/* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 */ +/* types), then */ + +/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */ +/* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */ + +/* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */ +/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], */ + +/* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, */ +/* then */ + +/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */ +/* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */ + +/* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */ +/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] */ + +/* where b11 >= b22 > 0. */ + + +/* Arguments */ +/* ========= */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, 2) */ +/* On entry, the 2 x 2 matrix A. */ +/* On exit, A is overwritten by the ``A-part'' of the */ +/* generalized Schur form. */ + +/* LDA (input) INTEGER */ +/* THe leading dimension of the array A. LDA >= 2. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, 2) */ +/* On entry, the upper triangular 2 x 2 matrix B. */ +/* On exit, B is overwritten by the ``B-part'' of the */ +/* generalized Schur form. */ + +/* LDB (input) INTEGER */ +/* THe leading dimension of the array B. LDB >= 2. */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (2) */ +/* ALPHAI (output) DOUBLE PRECISION array, dimension (2) */ +/* BETA (output) DOUBLE PRECISION array, dimension (2) */ +/* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the */ +/* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may */ +/* be zero. */ + +/* CSL (output) DOUBLE PRECISION */ +/* The cosine of the left rotation matrix. */ + +/* SNL (output) DOUBLE PRECISION */ +/* The sine of the left rotation matrix. */ + +/* CSR (output) DOUBLE PRECISION */ +/* The cosine of the right rotation matrix. */ + +/* SNR (output) DOUBLE PRECISION */ +/* The sine of the right rotation matrix. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alphar; + --alphai; + --beta; + + /* Function Body */ + safmin = dlamch_("S"); + ulp = dlamch_("P"); + +/* Scale A */ + +/* Computing MAX */ + d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs( + d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 = + a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = std::max(d__5,d__6); + anorm = std::max(d__5,safmin); + ascale = 1. / anorm; + a[a_dim1 + 1] = ascale * a[a_dim1 + 1]; + a[(a_dim1 << 1) + 1] = ascale * a[(a_dim1 << 1) + 1]; + a[a_dim1 + 2] = ascale * a[a_dim1 + 2]; + a[(a_dim1 << 1) + 2] = ascale * a[(a_dim1 << 1) + 2]; + +/* Scale B */ + +/* Computing MAX */ + d__4 = (d__3 = b[b_dim1 + 1], abs(d__3)), d__5 = (d__1 = b[(b_dim1 << 1) + + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 2], abs(d__2)), d__4 + = std::max(d__4,d__5); + bnorm = std::max(d__4,safmin); + bscale = 1. / bnorm; + b[b_dim1 + 1] = bscale * b[b_dim1 + 1]; + b[(b_dim1 << 1) + 1] = bscale * b[(b_dim1 << 1) + 1]; + b[(b_dim1 << 1) + 2] = bscale * b[(b_dim1 << 1) + 2]; + +/* Check if A can be deflated */ + + if ((d__1 = a[a_dim1 + 2], abs(d__1)) <= ulp) { + *csl = 1.; + *snl = 0.; + *csr = 1.; + *snr = 0.; + a[a_dim1 + 2] = 0.; + b[b_dim1 + 2] = 0.; + +/* Check if B is singular */ + + } else if ((d__1 = b[b_dim1 + 1], abs(d__1)) <= ulp) { + dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__); + *csr = 1.; + *snr = 0.; + drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + a[a_dim1 + 2] = 0.; + b[b_dim1 + 1] = 0.; + b[b_dim1 + 2] = 0.; + + } else if ((d__1 = b[(b_dim1 << 1) + 2], abs(d__1)) <= ulp) { + dlartg_(&a[(a_dim1 << 1) + 2], &a[a_dim1 + 2], csr, snr, &t); + *snr = -(*snr); + drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, csr, + snr); + drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, csr, + snr); + *csl = 1.; + *snl = 0.; + a[a_dim1 + 2] = 0.; + b[b_dim1 + 2] = 0.; + b[(b_dim1 << 1) + 2] = 0.; + + } else { + +/* B is nonsingular, first compute the eigenvalues of (A,B) */ + + dlag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, & + scale2, &wr1, &wr2, &wi); + + if (wi == 0.) { + +/* two real eigenvalues, compute s*A-w*B */ + + h1 = scale1 * a[a_dim1 + 1] - wr1 * b[b_dim1 + 1]; + h2 = scale1 * a[(a_dim1 << 1) + 1] - wr1 * b[(b_dim1 << 1) + 1]; + h3 = scale1 * a[(a_dim1 << 1) + 2] - wr1 * b[(b_dim1 << 1) + 2]; + + rr = dlapy2_(&h1, &h2); + d__1 = scale1 * a[a_dim1 + 2]; + qq = dlapy2_(&d__1, &h3); + + if (rr > qq) { + +/* find right rotation matrix to zero 1,1 element of */ +/* (sA - wB) */ + + dlartg_(&h2, &h1, csr, snr, &t); + + } else { + +/* find right rotation matrix to zero 2,1 element of */ +/* (sA - wB) */ + + d__1 = scale1 * a[a_dim1 + 2]; + dlartg_(&h3, &d__1, csr, snr, &t); + + } + + *snr = -(*snr); + drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, + csr, snr); + drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, + csr, snr); + +/* compute inf norms of A and B */ + +/* Computing MAX */ + d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[(a_dim1 << 1) + + 1], abs(d__2)), d__6 = (d__3 = a[a_dim1 + 2], abs(d__3) + ) + (d__4 = a[(a_dim1 << 1) + 2], abs(d__4)); + h1 = std::max(d__5,d__6); +/* Computing MAX */ + d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], abs(d__3) + ) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4)); + h2 = std::max(d__5,d__6); + + if (scale1 * h1 >= abs(wr1) * h2) { + +/* find left rotation matrix Q to zero out B(2,1) */ + + dlartg_(&b[b_dim1 + 1], &b[b_dim1 + 2], csl, snl, &r__); + + } else { + +/* find left rotation matrix Q to zero out A(2,1) */ + + dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__); + + } + + drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + + a[a_dim1 + 2] = 0.; + b[b_dim1 + 2] = 0.; + + } else { + +/* a pair of complex conjugate eigenvalues */ +/* first compute the SVD of the matrix B */ + + dlasv2_(&b[b_dim1 + 1], &b[(b_dim1 << 1) + 1], &b[(b_dim1 << 1) + + 2], &r__, &t, snr, csr, snl, csl); + +/* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and */ +/* Z is right rotation matrix computed from DLASV2 */ + + drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl); + drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl); + drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, + csr, snr); + drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, + csr, snr); + + b[b_dim1 + 2] = 0.; + b[(b_dim1 << 1) + 1] = 0.; + + } + + } + +/* Unscaling */ + + a[a_dim1 + 1] = anorm * a[a_dim1 + 1]; + a[a_dim1 + 2] = anorm * a[a_dim1 + 2]; + a[(a_dim1 << 1) + 1] = anorm * a[(a_dim1 << 1) + 1]; + a[(a_dim1 << 1) + 2] = anorm * a[(a_dim1 << 1) + 2]; + b[b_dim1 + 1] = bnorm * b[b_dim1 + 1]; + b[b_dim1 + 2] = bnorm * b[b_dim1 + 2]; + b[(b_dim1 << 1) + 1] = bnorm * b[(b_dim1 << 1) + 1]; + b[(b_dim1 << 1) + 2] = bnorm * b[(b_dim1 << 1) + 2]; + + if (wi == 0.) { + alphar[1] = a[a_dim1 + 1]; + alphar[2] = a[(a_dim1 << 1) + 2]; + alphai[1] = 0.; + alphai[2] = 0.; + beta[1] = b[b_dim1 + 1]; + beta[2] = b[(b_dim1 << 1) + 2]; + } else { + alphar[1] = anorm * wr1 / scale1 / bnorm; + alphai[1] = anorm * wi / scale1 / bnorm; + alphar[2] = alphar[1]; + alphai[2] = -alphai[1]; + beta[1] = 1.; + beta[2] = 1.; + } + + return 0; + +/* End of DLAGV2 */ + +} /* dlagv2_ */ + +/* Subroutine */ int dlahqr_(bool *wantt, bool *wantz, integer *n, + integer *ilo, integer *ihi, double *h__, integer *ldh, double + *wr, double *wi, integer *iloz, integer *ihiz, double *z__, + integer *ldz, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, j, k, l, m; + double s, v[3]; + integer i1, i2; + double t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs; + integer nh; + double sn; + integer nr; + double tr; + integer nz; + double det, h21s; + integer its; + double ulp, sum, tst, rt1i, rt2i, rt1r, rt2r; + double safmin, safmax, rtdisc, smlnum; + + +/* -- LAPACK auxiliary routine (version 3.2.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAHQR is an auxiliary routine called by DHSEQR to update the */ +/* eigenvalues and Schur decomposition already computed by DHSEQR, by */ +/* dealing with the Hessenberg submatrix in rows and columns ILO to */ +/* IHI. */ + +/* Arguments */ +/* ========= */ + +/* WANTT (input) LOGICAL */ +/* = .TRUE. : the full Schur form T is required; */ +/* = .FALSE.: only eigenvalues are required. */ + +/* WANTZ (input) LOGICAL */ +/* = .TRUE. : the matrix of Schur vectors Z is required; */ +/* = .FALSE.: Schur vectors are not required. */ + +/* N (input) INTEGER */ +/* The order of the matrix H. N >= 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* It is assumed that H is already upper quasi-triangular in */ +/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */ +/* ILO = 1). DLAHQR works primarily with the Hessenberg */ +/* submatrix in rows and columns ILO to IHI, but applies */ +/* transformations to all of H if WANTT is .TRUE.. */ +/* 1 <= ILO <= max(1,IHI); IHI <= N. */ + +/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ +/* On entry, the upper Hessenberg matrix H. */ +/* On exit, if INFO is zero and if WANTT is .TRUE., H is upper */ +/* quasi-triangular in rows and columns ILO:IHI, with any */ +/* 2-by-2 diagonal blocks in standard form. If INFO is zero */ +/* and WANTT is .FALSE., the contents of H are unspecified on */ +/* exit. The output state of H if INFO is nonzero is given */ +/* below under the description of INFO. */ + +/* LDH (input) INTEGER */ +/* The leading dimension of the array H. LDH >= max(1,N). */ + +/* WR (output) DOUBLE PRECISION array, dimension (N) */ +/* WI (output) DOUBLE PRECISION array, dimension (N) */ +/* The real and imaginary parts, respectively, of the computed */ +/* eigenvalues ILO to IHI are stored in the corresponding */ +/* elements of WR and WI. If two eigenvalues are computed as a */ +/* complex conjugate pair, they are stored in consecutive */ +/* elements of WR and WI, say the i-th and (i+1)th, with */ +/* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */ +/* eigenvalues are stored in the same order as on the diagonal */ +/* of the Schur form returned in H, with WR(i) = H(i,i), and, if */ +/* H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */ +/* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */ + +/* ILOZ (input) INTEGER */ +/* IHIZ (input) INTEGER */ +/* Specify the rows of Z to which transformations must be */ +/* applied if WANTZ is .TRUE.. */ +/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* If WANTZ is .TRUE., on entry Z must contain the current */ +/* matrix Z of transformations accumulated by DHSEQR, and on */ +/* exit Z has been updated; transformations are applied only to */ +/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */ +/* If WANTZ is .FALSE., Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* .GT. 0: If INFO = i, DLAHQR failed to compute all the */ +/* eigenvalues ILO to IHI in a total of 30 iterations */ +/* per eigenvalue; elements i+1:ihi of WR and WI */ +/* contain those eigenvalues which have been */ +/* successfully computed. */ + +/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */ +/* the remaining unconverged eigenvalues are the */ +/* eigenvalues of the upper Hessenberg matrix rows */ +/* and columns ILO thorugh INFO of the final, output */ +/* value of H. */ + +/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */ +/* (*) (initial value of H)*U = U*(final value of H) */ +/* where U is an orthognal matrix. The final */ +/* value of H is upper Hessenberg and triangular in */ +/* rows and columns INFO+1 through IHI. */ + +/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */ +/* (final value of Z) = (initial value of Z)*U */ +/* where U is the orthogonal matrix in (*) */ +/* (regardless of the value of WANTT.) */ + +/* Further Details */ +/* =============== */ + +/* 02-96 Based on modifications by */ +/* David Day, Sandia National Laboratory, USA */ + +/* 12-04 Further modifications by */ +/* Ralph Byers, University of Kansas, USA */ + +/* This is a modified version of DLAHQR from LAPACK version 3.0. */ +/* It is (1) more robust against overflow and underflow and */ +/* (2) adopts the more conservative Ahues & Tisseur stopping */ +/* criterion (LAWN 122, 1997). */ + +/* ========================================================= */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*ilo == *ihi) { + wr[*ilo] = h__[*ilo + *ilo * h_dim1]; + wi[*ilo] = 0.; + return 0; + } + +/* ==== clear out the trash ==== */ + i__1 = *ihi - 3; + for (j = *ilo; j <= i__1; ++j) { + h__[j + 2 + j * h_dim1] = 0.; + h__[j + 3 + j * h_dim1] = 0.; +/* L10: */ + } + if (*ilo <= *ihi - 2) { + h__[*ihi + (*ihi - 2) * h_dim1] = 0.; + } + + nh = *ihi - *ilo + 1; + nz = *ihiz - *iloz + 1; + +/* Set machine-dependent constants for the stopping criterion. */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((double) nh / ulp); + +/* I1 and I2 are the indices of the first row and last column of H */ +/* to which transformations must be applied. If eigenvalues only are */ +/* being computed, I1 and I2 are set inside the main loop. */ + + if (*wantt) { + i1 = 1; + i2 = *n; + } + +/* The main loop begins here. I is the loop index and decreases from */ +/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */ +/* with the active submatrix in rows and columns L to I. */ +/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */ +/* H(L,L-1) is negligible so that the matrix splits. */ + + i__ = *ihi; +L20: + l = *ilo; + if (i__ < *ilo) { + goto L160; + } + +/* Perform QR iterations on rows and columns ILO to I until a */ +/* submatrix of order 1 or 2 splits off at the bottom because a */ +/* subdiagonal element has become negligible. */ + + for (its = 0; its <= 30; ++its) { + +/* Look for a single small subdiagonal element. */ + + i__1 = l + 1; + for (k = i__; k >= i__1; --k) { + if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) { + goto L40; + } + tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 = + h__[k + k * h_dim1], abs(d__2)); + if (tst == 0.) { + if (k - 2 >= *ilo) { + tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1)); + } + if (k + 1 <= *ihi) { + tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)); + } + } +/* ==== The following is a conservative small subdiagonal */ +/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */ +/* . 1997). It has better mathematical foundation and */ +/* . improves accuracy in some cases. ==== */ + if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) { +/* Computing MAX */ + d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = ( + d__2 = h__[k - 1 + k * h_dim1], abs(d__2)); + ab = std::max(d__3,d__4); +/* Computing MIN */ + d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = ( + d__2 = h__[k - 1 + k * h_dim1], abs(d__2)); + ba = std::min(d__3,d__4); +/* Computing MAX */ + d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 = + h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], + abs(d__2)); + aa = std::max(d__3,d__4); +/* Computing MIN */ + d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 = + h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], + abs(d__2)); + bb = std::min(d__3,d__4); + s = aa + ab; +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * (bb * (aa / s)); + if (ba * (ab / s) <= std::max(d__1,d__2)) { + goto L40; + } + } +/* L30: */ + } +L40: + l = k; + if (l > *ilo) { + +/* H(L,L-1) is negligible */ + + h__[l + (l - 1) * h_dim1] = 0.; + } + +/* Exit from loop if a submatrix of order 1 or 2 has split off. */ + + if (l >= i__ - 1) { + goto L150; + } + +/* Now the active submatrix is in rows and columns L to I. If */ +/* eigenvalues only are being computed, only the active submatrix */ +/* need be transformed. */ + + if (! (*wantt)) { + i1 = l; + i2 = i__; + } + + if (its == 10) { + +/* Exceptional shift. */ + + s = (d__1 = h__[l + 1 + l * h_dim1], abs(d__1)) + (d__2 = h__[l + + 2 + (l + 1) * h_dim1], abs(d__2)); + h11 = s * .75 + h__[l + l * h_dim1]; + h12 = s * -.4375; + h21 = s; + h22 = h11; + } else if (its == 20) { + +/* Exceptional shift. */ + + s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 = + h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2)); + h11 = s * .75 + h__[i__ + i__ * h_dim1]; + h12 = s * -.4375; + h21 = s; + h22 = h11; + } else { + +/* Prepare to use Francis' double shift */ +/* (i.e. 2nd degree generalized Rayleigh quotient) */ + h11 = h__[i__ - 1 + (i__ - 1) * h_dim1]; + h21 = h__[i__ + (i__ - 1) * h_dim1]; + h12 = h__[i__ - 1 + i__ * h_dim1]; + h22 = h__[i__ + i__ * h_dim1]; + } + s = abs(h11) + abs(h12) + abs(h21) + abs(h22); + if (s == 0.) { + rt1r = 0.; + rt1i = 0.; + rt2r = 0.; + rt2i = 0.; + } else { + h11 /= s; + h21 /= s; + h12 /= s; + h22 /= s; + tr = (h11 + h22) / 2.; + det = (h11 - tr) * (h22 - tr) - h12 * h21; + rtdisc = sqrt((abs(det))); + if (det >= 0.) { + +/* ==== complex conjugate shifts ==== */ + + rt1r = tr * s; + rt2r = rt1r; + rt1i = rtdisc * s; + rt2i = -rt1i; + } else { + +/* ==== real shifts (use only one of them) ==== */ + + rt1r = tr + rtdisc; + rt2r = tr - rtdisc; + if ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs( + d__2))) { + rt1r *= s; + rt2r = rt1r; + } else { + rt2r *= s; + rt1r = rt2r; + } + rt1i = 0.; + rt2i = 0.; + } + } + +/* Look for two consecutive small subdiagonal elements. */ + + i__1 = l; + for (m = i__ - 2; m >= i__1; --m) { +/* Determine the effect of starting the double-shift QR */ +/* iteration at row M, and see if this would make H(M,M-1) */ +/* negligible. (The following uses scaling to avoid */ +/* overflows and most underflows.) */ + + h21s = h__[m + 1 + m * h_dim1]; + s = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__1)) + abs(rt2i) + + abs(h21s); + h21s = h__[m + 1 + m * h_dim1] / s; + v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] - + rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i + / s); + v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1] + - rt1r - rt2r); + v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1]; + s = abs(v[0]) + abs(v[1]) + abs(v[2]); + v[0] /= s; + v[1] /= s; + v[2] /= s; + if (m == l) { + goto L60; + } + if ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) + + abs(v[2])) <= ulp * abs(v[0]) * ((d__2 = h__[m - 1 + (m - + 1) * h_dim1], abs(d__2)) + (d__3 = h__[m + m * h_dim1], + abs(d__3)) + (d__4 = h__[m + 1 + (m + 1) * h_dim1], abs( + d__4)))) { + goto L60; + } +/* L50: */ + } +L60: + +/* Double-shift QR step */ + + i__1 = i__ - 1; + for (k = m; k <= i__1; ++k) { + +/* The first iteration of this loop determines a reflection G */ +/* from the vector V and applies it from left and right to H, */ +/* thus creating a nonzero bulge below the subdiagonal. */ + +/* Each subsequent iteration determines a reflection G to */ +/* restore the Hessenberg form in the (K-1)th column, and thus */ +/* chases the bulge one step toward the bottom of the active */ +/* submatrix. NR is the order of G. */ + +/* Computing MIN */ + i__2 = 3, i__3 = i__ - k + 1; + nr = std::min(i__2,i__3); + if (k > m) { + dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); + } + dlarfg_(&nr, v, &v[1], &c__1, &t1); + if (k > m) { + h__[k + (k - 1) * h_dim1] = v[0]; + h__[k + 1 + (k - 1) * h_dim1] = 0.; + if (k < i__ - 1) { + h__[k + 2 + (k - 1) * h_dim1] = 0.; + } + } else if (m > l) { +/* ==== Use the following instead of */ +/* . H( K, K-1 ) = -H( K, K-1 ) to */ +/* . avoid a bug when v(2) and v(3) */ +/* . underflow. ==== */ + h__[k + (k - 1) * h_dim1] *= 1. - t1; + } + v2 = v[1]; + t2 = t1 * v2; + if (nr == 3) { + v3 = v[2]; + t3 = t1 * v3; + +/* Apply G from the left to transform the rows of the matrix */ +/* in columns K to I2. */ + + i__2 = i2; + for (j = k; j <= i__2; ++j) { + sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] + + v3 * h__[k + 2 + j * h_dim1]; + h__[k + j * h_dim1] -= sum * t1; + h__[k + 1 + j * h_dim1] -= sum * t2; + h__[k + 2 + j * h_dim1] -= sum * t3; +/* L70: */ + } + +/* Apply G from the right to transform the columns of the */ +/* matrix in rows I1 to min(K+3,I). */ + +/* Computing MIN */ + i__3 = k + 3; + i__2 = std::min(i__3,i__); + for (j = i1; j <= i__2; ++j) { + sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] + + v3 * h__[j + (k + 2) * h_dim1]; + h__[j + k * h_dim1] -= sum * t1; + h__[j + (k + 1) * h_dim1] -= sum * t2; + h__[j + (k + 2) * h_dim1] -= sum * t3; +/* L80: */ + } + + if (*wantz) { + +/* Accumulate transformations in the matrix Z */ + + i__2 = *ihiz; + for (j = *iloz; j <= i__2; ++j) { + sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * + z_dim1] + v3 * z__[j + (k + 2) * z_dim1]; + z__[j + k * z_dim1] -= sum * t1; + z__[j + (k + 1) * z_dim1] -= sum * t2; + z__[j + (k + 2) * z_dim1] -= sum * t3; +/* L90: */ + } + } + } else if (nr == 2) { + +/* Apply G from the left to transform the rows of the matrix */ +/* in columns K to I2. */ + + i__2 = i2; + for (j = k; j <= i__2; ++j) { + sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]; + h__[k + j * h_dim1] -= sum * t1; + h__[k + 1 + j * h_dim1] -= sum * t2; +/* L100: */ + } + +/* Apply G from the right to transform the columns of the */ +/* matrix in rows I1 to min(K+3,I). */ + + i__2 = i__; + for (j = i1; j <= i__2; ++j) { + sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1] + ; + h__[j + k * h_dim1] -= sum * t1; + h__[j + (k + 1) * h_dim1] -= sum * t2; +/* L110: */ + } + + if (*wantz) { + +/* Accumulate transformations in the matrix Z */ + + i__2 = *ihiz; + for (j = *iloz; j <= i__2; ++j) { + sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * + z_dim1]; + z__[j + k * z_dim1] -= sum * t1; + z__[j + (k + 1) * z_dim1] -= sum * t2; +/* L120: */ + } + } + } +/* L130: */ + } + +/* L140: */ + } + +/* Failure to converge in remaining number of iterations */ + + *info = i__; + return 0; + +L150: + + if (l == i__) { + +/* H(I,I-1) is negligible: one eigenvalue has converged. */ + + wr[i__] = h__[i__ + i__ * h_dim1]; + wi[i__] = 0.; + } else if (l == i__ - 1) { + +/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */ + +/* Transform the 2-by-2 submatrix to standard Schur form, */ +/* and compute and store the eigenvalues. */ + + dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * + h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * + h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs, + &sn); + + if (*wantt) { + +/* Apply the transformation to the rest of H. */ + + if (i2 > i__) { + i__1 = i2 - i__; + drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[ + i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn); + } + i__1 = i__ - i1 - 1; + drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ * + h_dim1], &c__1, &cs, &sn); + } + if (*wantz) { + +/* Apply the transformation to Z. */ + + drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz + + i__ * z_dim1], &c__1, &cs, &sn); + } + } + +/* return to start of the main loop with new value of I. */ + + i__ = l - 1; + goto L20; + +L160: + return 0; + +/* End of DLAHQR */ + +} /* dlahqr_ */ + +/* Subroutine */ int dlahr2_(integer *n, integer *k, integer *nb, double * + a, integer *lda, double *tau, double *t, integer *ldt, + double *y, integer *ldy) +{ + /* Table of constant values */ + static double c_b4 = -1.; + static double c_b5 = 1.; + static integer c__1 = 1; + static double c_b38 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + double d__1; + + /* Local variables */ + integer i__; + double ei; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) */ +/* matrix A so that elements below the k-th subdiagonal are zero. The */ +/* reduction is performed by an orthogonal similarity transformation */ +/* Q' * A * Q. The routine returns the matrices V and T which determine */ +/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */ + +/* This is an auxiliary routine called by DGEHRD. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. */ + +/* K (input) INTEGER */ +/* The offset for the reduction. Elements below the k-th */ +/* subdiagonal in the first NB columns are reduced to zero. */ +/* K < N. */ + +/* NB (input) INTEGER */ +/* The number of columns to be reduced. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */ +/* On entry, the n-by-(n-k+1) general matrix A. */ +/* On exit, the elements on and above the k-th subdiagonal in */ +/* the first NB columns are overwritten with the corresponding */ +/* elements of the reduced matrix; the elements below the k-th */ +/* subdiagonal, with the array TAU, represent the matrix Q as a */ +/* product of elementary reflectors. The other columns of A are */ +/* unchanged. See Further Details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* TAU (output) DOUBLE PRECISION array, dimension (NB) */ +/* The scalar factors of the elementary reflectors. See Further */ +/* Details. */ + +/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */ +/* The upper triangular matrix T. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the array T. LDT >= NB. */ + +/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */ +/* The n-by-nb matrix Y. */ + +/* LDY (input) INTEGER */ +/* The leading dimension of the array Y. LDY >= N. */ + +/* Further Details */ +/* =============== */ + +/* The matrix Q is represented as a product of nb elementary reflectors */ + +/* Q = H(1) H(2) . . . H(nb). */ + +/* 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */ +/* A(i+k+1:n,i), and tau in TAU(i). */ + +/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */ +/* V which is needed, with T and Y, to apply the transformation to the */ +/* unreduced part of the matrix, using an update of the form: */ +/* A := (I - V*T*V') * (A - Y*V'). */ + +/* The contents of A on exit are illustrated by the following example */ +/* with n = 7, k = 3 and nb = 2: */ + +/* ( a a a a a ) */ +/* ( a a a a a ) */ +/* ( a a a a a ) */ +/* ( h h a a a ) */ +/* ( v1 h a a a ) */ +/* ( v1 v2 a a a ) */ +/* ( v1 v2 a a a ) */ + +/* where a denotes an element of the original matrix A, h denotes a */ +/* modified element of the upper Hessenberg matrix H, and vi denotes an */ +/* element of the vector defining H(i). */ + +/* This file is a slight modification of LAPACK-3.0's DLAHRD */ +/* incorporating improvements proposed by Quintana-Orti and Van de */ +/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */ +/* returned by the original LAPACK routine. This function is */ +/* not backward compatible with LAPACK3.0. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1; + y -= y_offset; + + /* Function Body */ + if (*n <= 1) { + return 0; + } + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ > 1) { + +/* Update A(K+1:N,I) */ + +/* Update I-th column of A - Y * V' */ + + i__2 = *n - *k; + i__3 = i__ - 1; + dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], + ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 + + i__ * a_dim1], &c__1); + +/* Apply I - V * T' * V' to this column (call it b) from the */ +/* left, using the last column of T as workspace */ + +/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */ +/* ( V2 ) ( b2 ) */ + +/* where V1 is unit lower triangular */ + +/* w := V1' * b1 */ + + i__2 = i__ - 1; + dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + dtrmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1); + +/* w := w + V2'*b2 */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * + t_dim1 + 1], &c__1); + +/* w := T'*w */ + + i__2 = i__ - 1; + dtrmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt, + &t[*nb * t_dim1 + 1], &c__1); + +/* b2 := b2 - V2*w */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + + i__ * a_dim1], &c__1); + +/* b1 := b1 - V1*w */ + + i__2 = i__ - 1; + dtrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1] +, lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ + * a_dim1], &c__1); + + a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei; + } + +/* Generate the elementary reflector H(I) to annihilate */ +/* A(K+I+1:N,I) */ + + i__2 = *n - *k - i__ + 1; +/* Computing MIN */ + i__3 = *k + i__ + 1; + dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[std::min(i__3, *n)+ i__ * + a_dim1], &c__1, &tau[i__]); + ei = a[*k + i__ + i__ * a_dim1]; + a[*k + i__ + i__ * a_dim1] = 1.; + +/* Compute Y(K+1:N,I) */ + + i__2 = *n - *k; + i__3 = *n - *k - i__ + 1; + dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) * + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[* + k + 1 + i__ * y_dim1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, & + a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + + 1], &c__1); + i__2 = *n - *k; + i__3 = i__ - 1; + dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy, + &t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1], + &c__1); + i__2 = *n - *k; + dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1); + +/* Compute T(1:I,I) */ + + i__2 = i__ - 1; + d__1 = -tau[i__]; + dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + dtrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt, + &t[i__ * t_dim1 + 1], &c__1) + ; + t[i__ + i__ * t_dim1] = tau[i__]; + +/* L10: */ + } + a[*k + *nb + *nb * a_dim1] = ei; + +/* Compute Y(1:K,1:NB) */ + + dlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy); + dtrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1 + + a_dim1], lda, &y[y_offset], ldy); + if (*n > *k + *nb) { + i__1 = *n - *k - *nb; + dgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb + + 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5, + &y[y_offset], ldy); + } + dtrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[ + t_offset], ldt, &y[y_offset], ldy); + + return 0; + +/* End of DLAHR2 */ + +} /* dlahr2_ */ + +/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, double * + a, integer *lda, double *tau, double *t, integer *ldt, + double *y, integer *ldy) +{ + /* Table of constant values */ + static double c_b4 = -1.; + static double c_b5 = 1.; + static integer c__1 = 1; + static double c_b38 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + double d__1; + + /* Local variables */ + integer i__; + double ei; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */ +/* matrix A so that elements below the k-th subdiagonal are zero. The */ +/* reduction is performed by an orthogonal similarity transformation */ +/* Q' * A * Q. The routine returns the matrices V and T which determine */ +/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */ + +/* This is an OBSOLETE auxiliary routine. */ +/* This routine will be 'deprecated' in a future release. */ +/* Please use the new routine DLAHR2 instead. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. */ + +/* K (input) INTEGER */ +/* The offset for the reduction. Elements below the k-th */ +/* subdiagonal in the first NB columns are reduced to zero. */ + +/* NB (input) INTEGER */ +/* The number of columns to be reduced. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */ +/* On entry, the n-by-(n-k+1) general matrix A. */ +/* On exit, the elements on and above the k-th subdiagonal in */ +/* the first NB columns are overwritten with the corresponding */ +/* elements of the reduced matrix; the elements below the k-th */ +/* subdiagonal, with the array TAU, represent the matrix Q as a */ +/* product of elementary reflectors. The other columns of A are */ +/* unchanged. See Further Details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* TAU (output) DOUBLE PRECISION array, dimension (NB) */ +/* The scalar factors of the elementary reflectors. See Further */ +/* Details. */ + +/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */ +/* The upper triangular matrix T. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the array T. LDT >= NB. */ + +/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */ +/* The n-by-nb matrix Y. */ + +/* LDY (input) INTEGER */ +/* The leading dimension of the array Y. LDY >= N. */ + +/* Further Details */ +/* =============== */ + +/* The matrix Q is represented as a product of nb elementary reflectors */ + +/* Q = H(1) H(2) . . . H(nb). */ + +/* 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */ +/* A(i+k+1:n,i), and tau in TAU(i). */ + +/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */ +/* V which is needed, with T and Y, to apply the transformation to the */ +/* unreduced part of the matrix, using an update of the form: */ +/* A := (I - V*T*V') * (A - Y*V'). */ + +/* The contents of A on exit are illustrated by the following example */ +/* with n = 7, k = 3 and nb = 2: */ + +/* ( a h a a a ) */ +/* ( a h a a a ) */ +/* ( a h a a a ) */ +/* ( h h a a a ) */ +/* ( v1 h a a a ) */ +/* ( v1 v2 a a a ) */ +/* ( v1 v2 a a a ) */ + +/* where a denotes an element of the original matrix A, h denotes a */ +/* modified element of the upper Hessenberg matrix H, and vi denotes an */ +/* element of the vector defining H(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1; + y -= y_offset; + + /* Function Body */ + if (*n <= 1) { + return 0; + } + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ > 1) { + +/* Update A(1:n,i) */ + +/* Compute i-th column of A - Y * V' */ + + i__2 = i__ - 1; + dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k + + i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], & + c__1); + +/* Apply I - V * T' * V' to this column (call it b) from the */ +/* left, using the last column of T as workspace */ + +/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */ +/* ( V2 ) ( b2 ) */ + +/* where V1 is unit lower triangular */ + +/* w := V1' * b1 */ + + i__2 = i__ - 1; + dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + dtrmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1); + +/* w := w + V2'*b2 */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb * + t_dim1 + 1], &c__1); + +/* w := T'*w */ + + i__2 = i__ - 1; + dtrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[*nb * t_dim1 + 1], &c__1); + +/* b2 := b2 - V2*w */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ + + i__ * a_dim1], &c__1); + +/* b1 := b1 - V1*w */ + + i__2 = i__ - 1; + dtrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1] +, lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ + * a_dim1], &c__1); + + a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei; + } + +/* Generate the elementary reflector H(i) to annihilate */ +/* A(k+i+1:n,i) */ + + i__2 = *n - *k - i__ + 1; +/* Computing MIN */ + i__3 = *k + i__ + 1; + dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[std::min(i__3, *n)+ i__ * + a_dim1], &c__1, &tau[i__]); + ei = a[*k + i__ + i__ * a_dim1]; + a[*k + i__ + i__ * a_dim1] = 1.; + +/* Compute Y(1:n,i) */ + + i__2 = *n - *k - i__ + 1; + dgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1], + lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ * + y_dim1 + 1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, & + a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ * + t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1); + dscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1); + +/* Compute T(1:i,i) */ + + i__2 = i__ - 1; + d__1 = -tau[i__]; + dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt, + &t[i__ * t_dim1 + 1], &c__1) + ; + t[i__ + i__ * t_dim1] = tau[i__]; + +/* L10: */ + } + a[*k + *nb + *nb * a_dim1] = ei; + + return 0; + +/* End of DLAHRD */ + +} /* dlahrd_ */ + +/* Subroutine */ int dlaic1_(integer *job, integer *j, double *x, + double *sest, double *w, double *gamma, double * + sestpr, double *s, double *c__) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b5 = 1.; + + /* System generated locals */ + double d__1, d__2, d__3, d__4; + + /* Builtin functions + double sqrt(double), d_sign(double *, double *); */ + + /* Local variables */ + double b, t, s1, s2, eps, tmp; + double sine, test, zeta1, zeta2, alpha, norma; + double absgam, absalp, cosine, absest; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAIC1 applies one step of incremental condition estimation in */ +/* its simplest version: */ + +/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */ +/* lower triangular matrix L, such that */ +/* twonorm(L*x) = sest */ +/* Then DLAIC1 computes sestpr, s, c such that */ +/* the vector */ +/* [ s*x ] */ +/* xhat = [ c ] */ +/* is an approximate singular vector of */ +/* [ L 0 ] */ +/* Lhat = [ w' gamma ] */ +/* in the sense that */ +/* twonorm(Lhat*xhat) = sestpr. */ + +/* Depending on JOB, an estimate for the largest or smallest singular */ +/* value is computed. */ + +/* Note that [s c]' and sestpr**2 is an eigenpair of the system */ + +/* diag(sest*sest, 0) + [alpha gamma] * [ alpha ] */ +/* [ gamma ] */ + +/* where alpha = x'*w. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) INTEGER */ +/* = 1: an estimate for the largest singular value is computed. */ +/* = 2: an estimate for the smallest singular value is computed. */ + +/* J (input) INTEGER */ +/* Length of X and W */ + +/* X (input) DOUBLE PRECISION array, dimension (J) */ +/* The j-vector x. */ + +/* SEST (input) DOUBLE PRECISION */ +/* Estimated singular value of j by j matrix L */ + +/* W (input) DOUBLE PRECISION array, dimension (J) */ +/* The j-vector w. */ + +/* GAMMA (input) DOUBLE PRECISION */ +/* The diagonal element gamma. */ + +/* SESTPR (output) DOUBLE PRECISION */ +/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */ + +/* S (output) DOUBLE PRECISION */ +/* Sine needed in forming xhat. */ + +/* C (output) DOUBLE PRECISION */ +/* Cosine needed in forming xhat. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --w; + --x; + + /* Function Body */ + eps = dlamch_("Epsilon"); + alpha = ddot_(j, &x[1], &c__1, &w[1], &c__1); + + absalp = abs(alpha); + absgam = abs(*gamma); + absest = abs(*sest); + + if (*job == 1) { + +/* Estimating largest singular value */ + +/* special cases */ + + if (*sest == 0.) { + s1 = std::max(absgam,absalp); + if (s1 == 0.) { + *s = 0.; + *c__ = 1.; + *sestpr = 0.; + } else { + *s = alpha / s1; + *c__ = *gamma / s1; + tmp = sqrt(*s * *s + *c__ * *c__); + *s /= tmp; + *c__ /= tmp; + *sestpr = s1 * tmp; + } + return 0; + } else if (absgam <= eps * absest) { + *s = 1.; + *c__ = 0.; + tmp = std::max(absest,absalp); + s1 = absest / tmp; + s2 = absalp / tmp; + *sestpr = tmp * sqrt(s1 * s1 + s2 * s2); + return 0; + } else if (absalp <= eps * absest) { + s1 = absgam; + s2 = absest; + if (s1 <= s2) { + *s = 1.; + *c__ = 0.; + *sestpr = s2; + } else { + *s = 0.; + *c__ = 1.; + *sestpr = s1; + } + return 0; + } else if (absest <= eps * absalp || absest <= eps * absgam) { + s1 = absgam; + s2 = absalp; + if (s1 <= s2) { + tmp = s1 / s2; + *s = sqrt(tmp * tmp + 1.); + *sestpr = s2 * *s; + *c__ = *gamma / s2 / *s; + *s = d_sign(&c_b5, &alpha) / *s; + } else { + tmp = s2 / s1; + *c__ = sqrt(tmp * tmp + 1.); + *sestpr = s1 * *c__; + *s = alpha / s1 / *c__; + *c__ = d_sign(&c_b5, gamma) / *c__; + } + return 0; + } else { + +/* normal case */ + + zeta1 = alpha / absest; + zeta2 = *gamma / absest; + + b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5; + *c__ = zeta1 * zeta1; + if (b > 0.) { + t = *c__ / (b + sqrt(b * b + *c__)); + } else { + t = sqrt(b * b + *c__) - b; + } + + sine = -zeta1 / t; + cosine = -zeta2 / (t + 1.); + tmp = sqrt(sine * sine + cosine * cosine); + *s = sine / tmp; + *c__ = cosine / tmp; + *sestpr = sqrt(t + 1.) * absest; + return 0; + } + + } else if (*job == 2) { + +/* Estimating smallest singular value */ + +/* special cases */ + + if (*sest == 0.) { + *sestpr = 0.; + if (std::max(absgam,absalp) == 0.) { + sine = 1.; + cosine = 0.; + } else { + sine = -(*gamma); + cosine = alpha; + } +/* Computing MAX */ + d__1 = abs(sine), d__2 = abs(cosine); + s1 = std::max(d__1,d__2); + *s = sine / s1; + *c__ = cosine / s1; + tmp = sqrt(*s * *s + *c__ * *c__); + *s /= tmp; + *c__ /= tmp; + return 0; + } else if (absgam <= eps * absest) { + *s = 0.; + *c__ = 1.; + *sestpr = absgam; + return 0; + } else if (absalp <= eps * absest) { + s1 = absgam; + s2 = absest; + if (s1 <= s2) { + *s = 0.; + *c__ = 1.; + *sestpr = s1; + } else { + *s = 1.; + *c__ = 0.; + *sestpr = s2; + } + return 0; + } else if (absest <= eps * absalp || absest <= eps * absgam) { + s1 = absgam; + s2 = absalp; + if (s1 <= s2) { + tmp = s1 / s2; + *c__ = sqrt(tmp * tmp + 1.); + *sestpr = absest * (tmp / *c__); + *s = -(*gamma / s2) / *c__; + *c__ = d_sign(&c_b5, &alpha) / *c__; + } else { + tmp = s2 / s1; + *s = sqrt(tmp * tmp + 1.); + *sestpr = absest / *s; + *c__ = alpha / s1 / *s; + *s = -d_sign(&c_b5, gamma) / *s; + } + return 0; + } else { + +/* normal case */ + + zeta1 = alpha / absest; + zeta2 = *gamma / absest; + +/* Computing MAX */ + d__3 = zeta1 * zeta1 + 1. + (d__1 = zeta1 * zeta2, abs(d__1)), + d__4 = (d__2 = zeta1 * zeta2, abs(d__2)) + zeta2 * zeta2; + norma = std::max(d__3,d__4); + +/* See if root is closer to zero or to ONE */ + + test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.; + if (test >= 0.) { + +/* root is close to zero, compute directly */ + + b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5; + *c__ = zeta2 * zeta2; + t = *c__ / (b + sqrt((d__1 = b * b - *c__, abs(d__1)))); + sine = zeta1 / (1. - t); + cosine = -zeta2 / t; + *sestpr = sqrt(t + eps * 4. * eps * norma) * absest; + } else { + +/* root is closer to ONE, shift by that amount */ + + b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5; + *c__ = zeta1 * zeta1; + if (b >= 0.) { + t = -(*c__) / (b + sqrt(b * b + *c__)); + } else { + t = b - sqrt(b * b + *c__); + } + sine = -zeta1 / t; + cosine = -zeta2 / (t + 1.); + *sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest; + } + tmp = sqrt(sine * sine + cosine * cosine); + *s = sine / tmp; + *c__ = cosine / tmp; + return 0; + + } + } + return 0; + +/* End of DLAIC1 */ + +} /* dlaic1_ */ + +/* Subroutine */ bool dlaisnan_(double *din1, double *din2) +{ + /* System generated locals */ + bool ret_val; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This routine is not for general use. It exists solely to avoid */ +/* over-optimization in DISNAN. */ + +/* DLAISNAN checks for NaNs by comparing its two arguments for */ +/* inequality. NaN is the only floating-point value where NaN != NaN */ +/* returns .TRUE. To check for NaNs, pass the same variable as both */ +/* arguments. */ + +/* Strictly speaking, Fortran does not allow aliasing of function */ +/* arguments. So a compiler must assume that the two arguments are */ +/* not the same variable, and the test will not be optimized away. */ +/* Interprocedural or whole-program optimization may delete this */ +/* test. The ISNAN functions will be replaced by the correct */ +/* Fortran 03 intrinsic once the intrinsic is widely available. */ + +/* Arguments */ +/* ========= */ + +/* DIN1 (input) DOUBLE PRECISION */ +/* DIN2 (input) DOUBLE PRECISION */ +/* Two numbers to compare for inequality. */ + +/* ===================================================================== */ + +/* .. Executable Statements .. */ + ret_val = *din1 != *din2; + return ret_val; +} /* dlaisnan_ */ + +/* Subroutine */ int dlaln2_(bool *ltrans, integer *na, integer *nw, + double *smin, double *ca, double *a, integer *lda, + double *d1, double *d2, double *b, integer *ldb, + double *wr, double *wi, double *x, integer *ldx, + double *scale, double *xnorm, integer *info) +{ + /* Initialized data */ + + static bool zswap[4] = { false,false,true,true }; + static bool rswap[4] = { false,true,false,true }; + static integer ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2, + 4,3,2,1 }; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset; + double d__1, d__2, d__3, d__4, d__5, d__6; + static double equiv_0[4], equiv_1[4]; + + /* Local variables */ + integer j; +#define ci (equiv_0) +#define cr (equiv_1) + double bi1, bi2, br1, br2, xi1, xi2, xr1, xr2, ci21, ci22, cr21, cr22, + li21, csi, ui11, lr21, ui12, ui22; +#define civ (equiv_0) + double csr, ur11, ur12, ur22; +#define crv (equiv_1) + double bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s, u22abs; + integer icmax; + double bnorm, cnorm, smini; + double bignum, smlnum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLALN2 solves a system of the form (ca A - w D ) X = s B */ +/* or (ca A' - w D) X = s B with possible scaling ("s") and */ +/* perturbation of A. (A' means A-transpose.) */ + +/* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA */ +/* real diagonal matrix, w is a real or complex value, and X and B are */ +/* NA x 1 matrices -- real if w is real, complex if w is complex. NA */ +/* may be 1 or 2. */ + +/* If w is complex, X and B are represented as NA x 2 matrices, */ +/* the first column of each being the real part and the second */ +/* being the imaginary part. */ + +/* "s" is a scaling factor (.LE. 1), computed by DLALN2, which is */ +/* so chosen that X can be computed without overflow. X is further */ +/* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less */ +/* than overflow. */ + +/* If both singular values of (ca A - w D) are less than SMIN, */ +/* SMIN*identity will be used instead of (ca A - w D). If only one */ +/* singular value is less than SMIN, one element of (ca A - w D) will be */ +/* perturbed enough to make the smallest singular value roughly SMIN. */ +/* If both singular values are at least SMIN, (ca A - w D) will not be */ +/* perturbed. In any case, the perturbation will be at most some small */ +/* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values */ +/* are computed by infinity-norm approximations, and thus will only be */ +/* correct to a factor of 2 or so. */ + +/* Note: all input quantities are assumed to be smaller than overflow */ +/* by a reasonable factor. (See BIGNUM.) */ + +/* Arguments */ +/* ========== */ + +/* LTRANS (input) LOGICAL */ +/* =.TRUE.: A-transpose will be used. */ +/* =.FALSE.: A will be used (not transposed.) */ + +/* NA (input) INTEGER */ +/* The size of the matrix A. It may (only) be 1 or 2. */ + +/* NW (input) INTEGER */ +/* 1 if "w" is real, 2 if "w" is complex. It may only be 1 */ +/* or 2. */ + +/* SMIN (input) DOUBLE PRECISION */ +/* The desired lower bound on the singular values of A. This */ +/* should be a safe distance away from underflow or overflow, */ +/* say, between (underflow/machine precision) and (machine */ +/* precision * overflow ). (See BIGNUM and ULP.) */ + +/* CA (input) DOUBLE PRECISION */ +/* The coefficient c, which A is multiplied by. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,NA) */ +/* The NA x NA matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of A. It must be at least NA. */ + +/* D1 (input) DOUBLE PRECISION */ +/* The 1,1 element in the diagonal matrix D. */ + +/* D2 (input) DOUBLE PRECISION */ +/* The 2,2 element in the diagonal matrix D. Not used if NW=1. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NW) */ +/* The NA x NW matrix B (right-hand side). If NW=2 ("w" is */ +/* complex), column 1 contains the real part of B and column 2 */ +/* contains the imaginary part. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B. It must be at least NA. */ + +/* WR (input) DOUBLE PRECISION */ +/* The real part of the scalar "w". */ + +/* WI (input) DOUBLE PRECISION */ +/* The imaginary part of the scalar "w". Not used if NW=1. */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NW) */ +/* The NA x NW matrix X (unknowns), as computed by DLALN2. */ +/* If NW=2 ("w" is complex), on exit, column 1 will contain */ +/* the real part of X and column 2 will contain the imaginary */ +/* part. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of X. It must be at least NA. */ + +/* SCALE (output) DOUBLE PRECISION */ +/* The scale factor that B must be multiplied by to insure */ +/* that overflow does not occur when computing X. Thus, */ +/* (ca A - w D) X will be SCALE*B, not B (ignoring */ +/* perturbations of A.) It will be at most 1. */ + +/* XNORM (output) DOUBLE PRECISION */ +/* The infinity-norm of X, when X is regarded as an NA x NW */ +/* real matrix. */ + +/* INFO (output) INTEGER */ +/* An error flag. It will be set to zero if no error occurs, */ +/* a negative number if an argument is in error, or a positive */ +/* number if ca A - w D had to be perturbed. */ +/* The possible values are: */ +/* = 0: No error occurred, and (ca A - w D) did not have to be */ +/* perturbed. */ +/* = 1: (ca A - w D) had to be perturbed to make its smallest */ +/* (or only) singular value greater than SMIN. */ +/* NOTE: In the interests of speed, this routine does not */ +/* check the inputs for errors. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Equivalences .. */ +/* .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + + /* Function Body */ +/* .. */ +/* .. Executable Statements .. */ + +/* Compute BIGNUM */ + + smlnum = 2. * dlamch_("Safe minimum"); + bignum = 1. / smlnum; + smini = std::max(*smin,smlnum); + +/* Don't check for input errors */ + + *info = 0; + +/* Standard Initializations */ + + *scale = 1.; + + if (*na == 1) { + +/* 1 x 1 (i.e., scalar) system C X = B */ + + if (*nw == 1) { + +/* Real 1x1 system. */ + +/* C = ca A - w D */ + + csr = *ca * a[a_dim1 + 1] - *wr * *d1; + cnorm = abs(csr); + +/* If | C | < SMINI, use C = SMINI */ + + if (cnorm < smini) { + csr = smini; + cnorm = smini; + *info = 1; + } + +/* Check scaling for X = B / C */ + + bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)); + if (cnorm < 1. && bnorm > 1.) { + if (bnorm > bignum * cnorm) { + *scale = 1. / bnorm; + } + } + +/* Compute X */ + + x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr; + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)); + } else { + +/* Complex 1x1 system (w is complex) */ + +/* C = ca A - w D */ + + csr = *ca * a[a_dim1 + 1] - *wr * *d1; + csi = -(*wi) * *d1; + cnorm = abs(csr) + abs(csi); + +/* If | C | < SMINI, use C = SMINI */ + + if (cnorm < smini) { + csr = smini; + csi = 0.; + cnorm = smini; + *info = 1; + } + +/* Check scaling for X = B / C */ + + bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << + 1) + 1], abs(d__2)); + if (cnorm < 1. && bnorm > 1.) { + if (bnorm > bignum * cnorm) { + *scale = 1. / bnorm; + } + } + +/* Compute X */ + + d__1 = *scale * b[b_dim1 + 1]; + d__2 = *scale * b[(b_dim1 << 1) + 1]; + dladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1) + + 1]); + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << + 1) + 1], abs(d__2)); + } + + } else { + +/* 2x2 System */ + +/* Compute the real part of C = ca A - w D (or ca A' - w D ) */ + + cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1; + cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2; + if (*ltrans) { + cr[2] = *ca * a[a_dim1 + 2]; + cr[1] = *ca * a[(a_dim1 << 1) + 1]; + } else { + cr[1] = *ca * a[a_dim1 + 2]; + cr[2] = *ca * a[(a_dim1 << 1) + 1]; + } + + if (*nw == 1) { + +/* Real 2x2 system (w is real) */ + +/* Find the largest element in C */ + + cmax = 0.; + icmax = 0; + + for (j = 1; j <= 4; ++j) { + if ((d__1 = crv[j - 1], abs(d__1)) > cmax) { + cmax = (d__1 = crv[j - 1], abs(d__1)); + icmax = j; + } +/* L10: */ + } + +/* If norm(C) < SMINI, use SMINI*identity. */ + + if (cmax < smini) { +/* Computing MAX */ + d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[ + b_dim1 + 2], abs(d__2)); + bnorm = std::max(d__3,d__4); + if (smini < 1. && bnorm > 1.) { + if (bnorm > bignum * smini) { + *scale = 1. / bnorm; + } + } + temp = *scale / smini; + x[x_dim1 + 1] = temp * b[b_dim1 + 1]; + x[x_dim1 + 2] = temp * b[b_dim1 + 2]; + *xnorm = temp * bnorm; + *info = 1; + return 0; + } + +/* Gaussian elimination with complete pivoting. */ + + ur11 = crv[icmax - 1]; + cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; + ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; + cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; + ur11r = 1. / ur11; + lr21 = ur11r * cr21; + ur22 = cr22 - ur12 * lr21; + +/* If smaller pivot < SMINI, use SMINI */ + + if (abs(ur22) < smini) { + ur22 = smini; + *info = 1; + } + if (rswap[icmax - 1]) { + br1 = b[b_dim1 + 2]; + br2 = b[b_dim1 + 1]; + } else { + br1 = b[b_dim1 + 1]; + br2 = b[b_dim1 + 2]; + } + br2 -= lr21 * br1; +/* Computing MAX */ + d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2); + bbnd = std::max(d__2,d__3); + if (bbnd > 1. && abs(ur22) < 1.) { + if (bbnd >= bignum * abs(ur22)) { + *scale = 1. / bbnd; + } + } + + xr2 = br2 * *scale / ur22; + xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12); + if (zswap[icmax - 1]) { + x[x_dim1 + 1] = xr2; + x[x_dim1 + 2] = xr1; + } else { + x[x_dim1 + 1] = xr1; + x[x_dim1 + 2] = xr2; + } +/* Computing MAX */ + d__1 = abs(xr1), d__2 = abs(xr2); + *xnorm = std::max(d__1,d__2); + +/* Further scaling if norm(A) norm(X) > overflow */ + + if (*xnorm > 1. && cmax > 1.) { + if (*xnorm > bignum / cmax) { + temp = cmax / bignum; + x[x_dim1 + 1] = temp * x[x_dim1 + 1]; + x[x_dim1 + 2] = temp * x[x_dim1 + 2]; + *xnorm = temp * *xnorm; + *scale = temp * *scale; + } + } + } else { + +/* Complex 2x2 system (w is complex) */ + +/* Find the largest element in C */ + + ci[0] = -(*wi) * *d1; + ci[1] = 0.; + ci[2] = 0.; + ci[3] = -(*wi) * *d2; + cmax = 0.; + icmax = 0; + + for (j = 1; j <= 4; ++j) { + if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs( + d__2)) > cmax) { + cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1] + , abs(d__2)); + icmax = j; + } +/* L20: */ + } + +/* If norm(C) < SMINI, use SMINI*identity. */ + + if (cmax < smini) { +/* Computing MAX */ + d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 + << 1) + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], + abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4)); + bnorm = std::max(d__5,d__6); + if (smini < 1. && bnorm > 1.) { + if (bnorm > bignum * smini) { + *scale = 1. / bnorm; + } + } + temp = *scale / smini; + x[x_dim1 + 1] = temp * b[b_dim1 + 1]; + x[x_dim1 + 2] = temp * b[b_dim1 + 2]; + x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1]; + x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2]; + *xnorm = temp * bnorm; + *info = 1; + return 0; + } + +/* Gaussian elimination with complete pivoting. */ + + ur11 = crv[icmax - 1]; + ui11 = civ[icmax - 1]; + cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; + ci21 = civ[ipivot[(icmax << 2) - 3] - 1]; + ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; + ui12 = civ[ipivot[(icmax << 2) - 2] - 1]; + cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; + ci22 = civ[ipivot[(icmax << 2) - 1] - 1]; + if (icmax == 1 || icmax == 4) { + +/* Code when off-diagonals of pivoted C are real */ + + if (abs(ur11) > abs(ui11)) { + temp = ui11 / ur11; +/* Computing 2nd power */ + d__1 = temp; + ur11r = 1. / (ur11 * (d__1 * d__1 + 1.)); + ui11r = -temp * ur11r; + } else { + temp = ur11 / ui11; +/* Computing 2nd power */ + d__1 = temp; + ui11r = -1. / (ui11 * (d__1 * d__1 + 1.)); + ur11r = -temp * ui11r; + } + lr21 = cr21 * ur11r; + li21 = cr21 * ui11r; + ur12s = ur12 * ur11r; + ui12s = ur12 * ui11r; + ur22 = cr22 - ur12 * lr21; + ui22 = ci22 - ur12 * li21; + } else { + +/* Code when diagonals of pivoted C are real */ + + ur11r = 1. / ur11; + ui11r = 0.; + lr21 = cr21 * ur11r; + li21 = ci21 * ur11r; + ur12s = ur12 * ur11r; + ui12s = ui12 * ur11r; + ur22 = cr22 - ur12 * lr21 + ui12 * li21; + ui22 = -ur12 * li21 - ui12 * lr21; + } + u22abs = abs(ur22) + abs(ui22); + +/* If smaller pivot < SMINI, use SMINI */ + + if (u22abs < smini) { + ur22 = smini; + ui22 = 0.; + *info = 1; + } + if (rswap[icmax - 1]) { + br2 = b[b_dim1 + 1]; + br1 = b[b_dim1 + 2]; + bi2 = b[(b_dim1 << 1) + 1]; + bi1 = b[(b_dim1 << 1) + 2]; + } else { + br1 = b[b_dim1 + 1]; + br2 = b[b_dim1 + 2]; + bi1 = b[(b_dim1 << 1) + 1]; + bi2 = b[(b_dim1 << 1) + 2]; + } + br2 = br2 - lr21 * br1 + li21 * bi1; + bi2 = bi2 - li21 * br1 - lr21 * bi1; +/* Computing MAX */ + d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r)) + ), d__2 = abs(br2) + abs(bi2); + bbnd = std::max(d__1,d__2); + if (bbnd > 1. && u22abs < 1.) { + if (bbnd >= bignum * u22abs) { + *scale = 1. / bbnd; + br1 = *scale * br1; + bi1 = *scale * bi1; + br2 = *scale * br2; + bi2 = *scale * bi2; + } + } + + dladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2); + xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2; + xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2; + if (zswap[icmax - 1]) { + x[x_dim1 + 1] = xr2; + x[x_dim1 + 2] = xr1; + x[(x_dim1 << 1) + 1] = xi2; + x[(x_dim1 << 1) + 2] = xi1; + } else { + x[x_dim1 + 1] = xr1; + x[x_dim1 + 2] = xr2; + x[(x_dim1 << 1) + 1] = xi1; + x[(x_dim1 << 1) + 2] = xi2; + } +/* Computing MAX */ + d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2); + *xnorm = std::max(d__1,d__2); + +/* Further scaling if norm(A) norm(X) > overflow */ + + if (*xnorm > 1. && cmax > 1.) { + if (*xnorm > bignum / cmax) { + temp = cmax / bignum; + x[x_dim1 + 1] = temp * x[x_dim1 + 1]; + x[x_dim1 + 2] = temp * x[x_dim1 + 2]; + x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1]; + x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2]; + *xnorm = temp * *xnorm; + *scale = temp * *scale; + } + } + } + } + + return 0; + +/* End of DLALN2 */ + +} /* dlaln2_ */ + +#undef crv +#undef civ +#undef cr +#undef ci + +/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr, + integer *sqre, integer *nrhs, double *b, integer *ldb, double + *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, + integer *ldgcol, double *givnum, integer *ldgnum, double * + poles, double *difl, double *difr, double *z__, integer * + k, double *c__, double *s, double *work, integer *info) +{ + /* Table of constant values */ + static double c_b5 = -1.; + static integer c__1 = 1; + static double c_b11 = 1.; + static double c_b13 = 0.; + static integer c__0 = 0; + + /* System generated locals */ + integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset, + difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1, + poles_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j, m, n; + double dj; + integer nlp1; + double temp; + double diflj, difrj, dsigj; + double dsigjp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLALS0 applies back the multiplying factors of either the left or the */ +/* right singular vector matrix of a diagonal matrix appended by a row */ +/* to the right hand side matrix B in solving the least squares problem */ +/* using the divide-and-conquer SVD approach. */ + +/* For the left singular vector matrix, three types of orthogonal */ +/* matrices are involved: */ + +/* (1L) Givens rotations: the number of such rotations is GIVPTR; the */ +/* pairs of columns/rows they were applied to are stored in GIVCOL; */ +/* and the C- and S-values of these rotations are stored in GIVNUM. */ + +/* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */ +/* row, and for J=2:N, PERM(J)-th row of B is to be moved to the */ +/* J-th row. */ + +/* (3L) The left singular vector matrix of the remaining matrix. */ + +/* For the right singular vector matrix, four types of orthogonal */ +/* matrices are involved: */ + +/* (1R) The right singular vector matrix of the remaining matrix. */ + +/* (2R) If SQRE = 1, one extra Givens rotation to generate the right */ +/* null space. */ + +/* (3R) The inverse transformation of (2L). */ + +/* (4R) The inverse transformation of (1L). */ + +/* Arguments */ +/* ========= */ + +/* ICOMPQ (input) INTEGER */ +/* Specifies whether singular vectors are to be computed in */ +/* factored form: */ +/* = 0: Left singular vector matrix. */ +/* = 1: Right singular vector matrix. */ + +/* NL (input) INTEGER */ +/* The row dimension of the upper block. NL >= 1. */ + +/* NR (input) INTEGER */ +/* The row dimension of the lower block. NR >= 1. */ + +/* SQRE (input) INTEGER */ +/* = 0: the lower block is an NR-by-NR square matrix. */ +/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ + +/* The bidiagonal matrix has row dimension N = NL + NR + 1, */ +/* and column dimension M = N + SQRE. */ + +/* NRHS (input) INTEGER */ +/* The number of columns of B and BX. NRHS must be at least 1. */ + +/* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) */ +/* On input, B contains the right hand sides of the least */ +/* squares problem in rows 1 through M. On output, B contains */ +/* the solution X in rows 1 through N. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B. LDB must be at least */ +/* max(1,MAX( M, N ) ). */ + +/* BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */ + +/* LDBX (input) INTEGER */ +/* The leading dimension of BX. */ + +/* PERM (input) INTEGER array, dimension ( N ) */ +/* The permutations (from deflation and sorting) applied */ +/* to the two blocks. */ + +/* GIVPTR (input) INTEGER */ +/* The number of Givens rotations which took place in this */ +/* subproblem. */ + +/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) */ +/* Each pair of numbers indicates a pair of rows/columns */ +/* involved in a Givens rotation. */ + +/* LDGCOL (input) INTEGER */ +/* The leading dimension of GIVCOL, must be at least N. */ + +/* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ +/* Each number indicates the C or S value used in the */ +/* corresponding Givens rotation. */ + +/* LDGNUM (input) INTEGER */ +/* The leading dimension of arrays DIFR, POLES and */ +/* GIVNUM, must be at least K. */ + +/* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ +/* On entry, POLES(1:K, 1) contains the new singular */ +/* values obtained from solving the secular equation, and */ +/* POLES(1:K, 2) is an array containing the poles in the secular */ +/* equation. */ + +/* DIFL (input) DOUBLE PRECISION array, dimension ( K ). */ +/* On entry, DIFL(I) is the distance between I-th updated */ +/* (undeflated) singular value and the I-th (undeflated) old */ +/* singular value. */ + +/* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). */ +/* On entry, DIFR(I, 1) contains the distances between I-th */ +/* updated (undeflated) singular value and the I+1-th */ +/* (undeflated) old singular value. And DIFR(I, 2) is the */ +/* normalizing factor for the I-th right singular vector. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( K ) */ +/* Contain the components of the deflation-adjusted updating row */ +/* vector. */ + +/* K (input) INTEGER */ +/* Contains the dimension of the non-deflated matrix, */ +/* This is the order of the related secular equation. 1 <= K <=N. */ + +/* C (input) DOUBLE PRECISION */ +/* C contains garbage if SQRE =0 and the C-value of a Givens */ +/* rotation related to the right null space if SQRE = 1. */ + +/* S (input) DOUBLE PRECISION */ +/* S contains garbage if SQRE =0 and the S-value of a Givens */ +/* rotation related to the right null space if SQRE = 1. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension ( K ) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* California at Berkeley, USA */ +/* Osni Marques, LBNL/NERSC, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + bx_dim1 = *ldbx; + bx_offset = 1 + bx_dim1; + bx -= bx_offset; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + difr_dim1 = *ldgnum; + difr_offset = 1 + difr_dim1; + difr -= difr_offset; + poles_dim1 = *ldgnum; + poles_offset = 1 + poles_dim1; + poles -= poles_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + --difl; + --z__; + --work; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } + + n = *nl + *nr + 1; + + if (*nrhs < 1) { + *info = -5; + } else if (*ldb < n) { + *info = -7; + } else if (*ldbx < n) { + *info = -9; + } else if (*givptr < 0) { + *info = -11; + } else if (*ldgcol < n) { + *info = -13; + } else if (*ldgnum < n) { + *info = -15; + } else if (*k < 1) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLALS0", &i__1); + return 0; + } + + m = n + *sqre; + nlp1 = *nl + 1; + + if (*icompq == 0) { + +/* Apply back orthogonal transformations from the left. */ + +/* Step (1L): apply back the Givens rotations performed. */ + + i__1 = *givptr; + for (i__ = 1; i__ <= i__1; ++i__) { + drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]); +/* L10: */ + } + +/* Step (2L): permute rows of B. */ + + dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], + ldbx); +/* L20: */ + } + +/* Step (3L): apply the inverse of the left singular vector */ +/* matrix to BX. */ + + if (*k == 1) { + dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); + if (z__[1] < 0.) { + dscal_(nrhs, &c_b5, &b[b_offset], ldb); + } + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + diflj = difl[j]; + dj = poles[j + poles_dim1]; + dsigj = -poles[j + (poles_dim1 << 1)]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -poles[j + 1 + (poles_dim1 << 1)]; + } + if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) { + work[j] = 0.; + } else { + work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj / + (poles[j + (poles_dim1 << 1)] + dj); + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == + 0.) { + work[i__] = 0.; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigj) - diflj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } +/* L30: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == + 0.) { + work[i__] = 0.; + } else { + work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigjp) + difrj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } +/* L40: */ + } + work[1] = -1.; + temp = dnrm2_(k, &work[1], &c__1); + dgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], & + c__1, &c_b13, &b[j + b_dim1], ldb); + dlascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j + + b_dim1], ldb, info); +/* L50: */ + } + } + +/* Move the deflated rows of BX to B also. */ + + if (*k < std::max(m,n)) { + i__1 = n - *k; + dlacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 + + b_dim1], ldb); + } + } else { + +/* Apply back the right orthogonal transformations. */ + +/* Step (1R): apply back the new right singular vector matrix */ +/* to B. */ + + if (*k == 1) { + dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dsigj = poles[j + (poles_dim1 << 1)]; + if (z__[j] == 0.) { + work[j] = 0.; + } else { + work[j] = -z__[j] / difl[j] / (dsigj + poles[j + + poles_dim1]) / difr[j + (difr_dim1 << 1)]; + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.) { + work[i__] = 0.; + } else { + d__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; + work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[ + i__ + difr_dim1]) / (dsigj + poles[i__ + + poles_dim1]) / difr[i__ + (difr_dim1 << 1)]; + } +/* L60: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.) { + work[i__] = 0.; + } else { + d__1 = -poles[i__ + (poles_dim1 << 1)]; + work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[ + i__]) / (dsigj + poles[i__ + poles_dim1]) / + difr[i__ + (difr_dim1 << 1)]; + } +/* L70: */ + } + dgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], & + c__1, &c_b13, &bx[j + bx_dim1], ldbx); +/* L80: */ + } + } + +/* Step (2R): if SQRE = 1, apply back the rotation that is */ +/* related to the right null space of the subproblem. */ + + if (*sqre == 1) { + dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); + drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, + s); + } + if (*k < std::max(m,n)) { + i__1 = n - *k; + dlacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + + bx_dim1], ldbx); + } + +/* Step (3R): permute rows of B. */ + + dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); + if (*sqre == 1) { + dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); + } + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], + ldb); +/* L90: */ + } + +/* Step (4R): apply back the Givens rotations performed. */ + + for (i__ = *givptr; i__ >= 1; --i__) { + d__1 = -givnum[i__ + givnum_dim1]; + drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &d__1); +/* L100: */ + } + } + + return 0; + +/* End of DLALS0 */ + +} /* dlals0_ */ + +/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n, + integer *nrhs, double *b, integer *ldb, double *bx, integer * + ldbx, double *u, integer *ldu, double *vt, integer *k, + double *difl, double *difr, double *z__, double * + poles, integer *givptr, integer *givcol, integer *ldgcol, integer * + perm, double *givnum, double *c__, double *s, double * + work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static double c_b7 = 1.; + static double c_b8 = 0.; + static integer c__2 = 2; + + /* System generated locals */ + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1, + b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1, + difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset, + u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1, + i__2; + + /* Local variables */ + integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1, + nlp1, lvl2, nrp1, nlvl, sqre; + integer inode, ndiml, ndimr; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLALSA is an itermediate step in solving the least squares problem */ +/* by computing the SVD of the coefficient matrix in compact form (The */ +/* singular vectors are computed as products of simple orthorgonal */ +/* matrices.). */ + +/* If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector */ +/* matrix of an upper bidiagonal matrix to the right hand side; and if */ +/* ICOMPQ = 1, DLALSA applies the right singular vector matrix to the */ +/* right hand side. The singular vector matrices were generated in */ +/* compact form by DLALSA. */ + +/* Arguments */ +/* ========= */ + + +/* ICOMPQ (input) INTEGER */ +/* Specifies whether the left or the right singular vector */ +/* matrix is involved. */ +/* = 0: Left singular vector matrix */ +/* = 1: Right singular vector matrix */ + +/* SMLSIZ (input) INTEGER */ +/* The maximum size of the subproblems at the bottom of the */ +/* computation tree. */ + +/* N (input) INTEGER */ +/* The row and column dimensions of the upper bidiagonal matrix. */ + +/* NRHS (input) INTEGER */ +/* The number of columns of B and BX. NRHS must be at least 1. */ + +/* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) */ +/* On input, B contains the right hand sides of the least */ +/* squares problem in rows 1 through M. */ +/* On output, B contains the solution X in rows 1 through N. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B in the calling subprogram. */ +/* LDB must be at least max(1,MAX( M, N ) ). */ + +/* BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */ +/* On exit, the result of applying the left or right singular */ +/* vector matrix to B. */ + +/* LDBX (input) INTEGER */ +/* The leading dimension of BX. */ + +/* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). */ +/* On entry, U contains the left singular vector matrices of all */ +/* subproblems at the bottom level. */ + +/* LDU (input) INTEGER, LDU = > N. */ +/* The leading dimension of arrays U, VT, DIFL, DIFR, */ +/* POLES, GIVNUM, and Z. */ + +/* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). */ +/* On entry, VT' contains the right singular vector matrices of */ +/* all subproblems at the bottom level. */ + +/* K (input) INTEGER array, dimension ( N ). */ + +/* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */ +/* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */ + +/* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ +/* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */ +/* distances between singular values on the I-th level and */ +/* singular values on the (I -1)-th level, and DIFR(*, 2 * I) */ +/* record the normalizing factors of the right singular vectors */ +/* matrices of subproblems on I-th level. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */ +/* On entry, Z(1, I) contains the components of the deflation- */ +/* adjusted updating row vector for subproblems on the I-th */ +/* level. */ + +/* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ +/* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */ +/* singular values involved in the secular equations on the I-th */ +/* level. */ + +/* GIVPTR (input) INTEGER array, dimension ( N ). */ +/* On entry, GIVPTR( I ) records the number of Givens */ +/* rotations performed on the I-th problem on the computation */ +/* tree. */ + +/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */ +/* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */ +/* locations of Givens rotations performed on the I-th level on */ +/* the computation tree. */ + +/* LDGCOL (input) INTEGER, LDGCOL = > N. */ +/* The leading dimension of arrays GIVCOL and PERM. */ + +/* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). */ +/* On entry, PERM(*, I) records permutations done on the I-th */ +/* level of the computation tree. */ + +/* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ +/* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */ +/* values of Givens rotations performed on the I-th level on the */ +/* computation tree. */ + +/* C (input) DOUBLE PRECISION array, dimension ( N ). */ +/* On entry, if the I-th subproblem is not square, */ +/* C( I ) contains the C-value of a Givens rotation related to */ +/* the right null space of the I-th subproblem. */ + +/* S (input) DOUBLE PRECISION array, dimension ( N ). */ +/* On entry, if the I-th subproblem is not square, */ +/* S( I ) contains the S-value of a Givens rotation related to */ +/* the right null space of the I-th subproblem. */ + +/* WORK (workspace) DOUBLE PRECISION array. */ +/* The dimension must be at least N. */ + +/* IWORK (workspace) INTEGER array. */ +/* The dimension must be at least 3 * N */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* California at Berkeley, USA */ +/* Osni Marques, LBNL/NERSC, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + bx_dim1 = *ldbx; + bx_offset = 1 + bx_dim1; + bx -= bx_offset; + givnum_dim1 = *ldu; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + poles_dim1 = *ldu; + poles_offset = 1 + poles_dim1; + poles -= poles_offset; + z_dim1 = *ldu; + z_offset = 1 + z_dim1; + z__ -= z_offset; + difr_dim1 = *ldu; + difr_offset = 1 + difr_dim1; + difr -= difr_offset; + difl_dim1 = *ldu; + difl_offset = 1 + difl_dim1; + difl -= difl_offset; + vt_dim1 = *ldu; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + --k; + --givptr; + perm_dim1 = *ldgcol; + perm_offset = 1 + perm_dim1; + perm -= perm_offset; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + --c__; + --s; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*smlsiz < 3) { + *info = -2; + } else if (*n < *smlsiz) { + *info = -3; + } else if (*nrhs < 1) { + *info = -4; + } else if (*ldb < *n) { + *info = -6; + } else if (*ldbx < *n) { + *info = -8; + } else if (*ldu < *n) { + *info = -10; + } else if (*ldgcol < *n) { + *info = -19; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLALSA", &i__1); + return 0; + } + +/* Book-keeping and setting up the computation tree. */ + + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + + dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); + +/* The following code applies back the left singular vector factors. */ +/* For applying back the right singular vector factors, go to 50. */ + + if (*icompq == 1) { + goto L50; + } + +/* The nodes on the bottom level of the tree were solved */ +/* by DLASDQ. The corresponding left and right singular vector */ +/* matrices are in explicit form. First apply back the left */ +/* singular vector matrices. */ + + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + +/* IC : center row of each node */ +/* NL : number of rows of left subproblem */ +/* NR : number of rows of right subproblem */ +/* NLF: starting row of the left subproblem */ +/* NRF: starting row of the right subproblem */ + + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlf = ic - nl; + nrf = ic + 1; + dgemm_("T", "N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf + + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); + dgemm_("T", "N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf + + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx); +/* L10: */ + } + +/* Next copy the rows of B that correspond to unchanged rows */ +/* in the bidiagonal matrix to BX. */ + + i__1 = nd; + for (i__ = 1; i__ <= i__1; ++i__) { + ic = iwork[inode + i__ - 1]; + dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx); +/* L20: */ + } + +/* Finally go through the left singular vector matrices of all */ +/* the other subproblems bottom-up on the tree. */ + + j = pow_ii(&c__2, &nlvl); + sqre = 0; + + for (lvl = nlvl; lvl >= 1; --lvl) { + lvl2 = (lvl << 1) - 1; + +/* find the first node LF and last node LL on */ +/* the current level LVL */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + --j; + dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, & + b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], & + givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & + givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + + lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ + j], &s[j], &work[1], info); +/* L30: */ + } +/* L40: */ + } + goto L90; + +/* ICOMPQ = 1: applying back the right singular vector factors. */ + +L50: + +/* First now go through the right singular vector matrices of all */ +/* the tree nodes top-down. */ + + j = 0; + i__1 = nlvl; + for (lvl = 1; lvl <= i__1; ++lvl) { + lvl2 = (lvl << 1) - 1; + +/* Find the first node LF and last node LL on */ +/* the current level LVL. */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__2 = lvl - 1; + lf = pow_ii(&c__2, &i__2); + ll = (lf << 1) - 1; + } + i__2 = lf; + for (i__ = ll; i__ >= i__2; --i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + if (i__ == ll) { + sqre = 0; + } else { + sqre = 1; + } + ++j; + dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[ + nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], & + givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & + givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + + lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ + j], &s[j], &work[1], info); +/* L60: */ + } +/* L70: */ + } + +/* The nodes on the bottom level of the tree were solved */ +/* by DLASDQ. The corresponding right singular vector */ +/* matrices are in explicit form. Apply them back. */ + + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlp1 = nl + 1; + if (i__ == nd) { + nrp1 = nr; + } else { + nrp1 = nr + 1; + } + nlf = ic - nl; + nrf = ic + 1; + dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, & + b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx); + dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, & + b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx); +/* L80: */ + } + +L90: + + return 0; + +/* End of DLALSA */ + +} /* dlalsa_ */ + +/* Subroutine */ int dlalsd_(const char *uplo, integer *smlsiz, integer *n, integer + *nrhs, double *d__, double *e, double *b, integer *ldb, + double *rcond, integer *rank, double *work, integer *iwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b6 = 0.; + static integer c__0 = 0; + static double c_b11 = 1.; + + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer c__, i__, j, k; + double r__; + integer s, u, z__; + double cs; + integer bx; + double sn; + integer st, vt, nm1, st1; + double eps; + integer iwk; + double tol; + integer difl, difr; + double rcnd; + integer perm, nsub; + integer nlvl, sqre, bxst; + integer poles, sizei, nsize, nwork, icmpq1, icmpq2; + integer givcol; + double orgnrm; + integer givnum, givptr, smlszp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLALSD uses the singular value decomposition of A to solve the least */ +/* squares problem of finding X to minimize the Euclidean norm of each */ +/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */ +/* are N-by-NRHS. The solution X overwrites B. */ + +/* The singular values of A smaller than RCOND times the largest */ +/* singular value are treated as zero in solving the least squares */ +/* problem; in this case a minimum norm solution is returned. */ +/* The actual singular values are returned in D in ascending order. */ + +/* This code makes very mild assumptions about floating point */ +/* arithmetic. It will work on machines with a guard digit in */ +/* add/subtract, or on those binary machines without guard digits */ +/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */ +/* It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': D and E define an upper bidiagonal matrix. */ +/* = 'L': D and E define a lower bidiagonal matrix. */ + +/* SMLSIZ (input) INTEGER */ +/* The maximum size of the subproblems at the bottom of the */ +/* computation tree. */ + +/* N (input) INTEGER */ +/* The dimension of the bidiagonal matrix. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of columns of B. NRHS must be at least 1. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry D contains the main diagonal of the bidiagonal */ +/* matrix. On exit, if INFO = 0, D contains its singular values. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* Contains the super-diagonal entries of the bidiagonal matrix. */ +/* On exit, E has been destroyed. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On input, B contains the right hand sides of the least */ +/* squares problem. On output, B contains the solution X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of B in the calling subprogram. */ +/* LDB must be at least max(1,N). */ + +/* RCOND (input) DOUBLE PRECISION */ +/* The singular values of A less than or equal to RCOND times */ +/* the largest singular value are treated as zero in solving */ +/* the least squares problem. If RCOND is negative, */ +/* machine precision is used instead. */ +/* For example, if diag(S)*X=B were the least squares problem, */ +/* where diag(S) is a diagonal matrix of singular values, the */ +/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */ +/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */ +/* RCOND*max(S). */ + +/* RANK (output) INTEGER */ +/* The number of singular values of A greater than RCOND times */ +/* the largest singular value. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension at least */ +/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */ +/* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */ + +/* IWORK (workspace) INTEGER array, dimension at least */ +/* (3*N*NLVL + 11*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: The algorithm failed to compute an singular value while */ +/* working on the submatrix lying in rows and columns */ +/* INFO/(N+1) through MOD(INFO,N+1). */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* California at Berkeley, USA */ +/* Osni Marques, LBNL/NERSC, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -3; + } else if (*nrhs < 1) { + *info = -4; + } else if (*ldb < 1 || *ldb < *n) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLALSD", &i__1); + return 0; + } + + eps = dlamch_("Epsilon"); + +/* Set up the tolerance. */ + + if (*rcond <= 0. || *rcond >= 1.) { + rcnd = eps; + } else { + rcnd = *rcond; + } + + *rank = 0; + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } else if (*n == 1) { + if (d__[1] == 0.) { + dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); + } else { + *rank = 1; + dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ + b_offset], ldb, info); + d__[1] = abs(d__[1]); + } + return 0; + } + +/* Rotate the matrix if it is lower bidiagonal. */ + + if (*(unsigned char *)uplo == 'L') { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (*nrhs == 1) { + drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & + c__1, &cs, &sn); + } else { + work[(i__ << 1) - 1] = cs; + work[i__ * 2] = sn; + } +/* L10: */ + } + if (*nrhs > 1) { + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - 1; + for (j = 1; j <= i__2; ++j) { + cs = work[(j << 1) - 1]; + sn = work[j * 2]; + drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * + b_dim1], &c__1, &cs, &sn); +/* L20: */ + } +/* L30: */ + } + } + } + +/* Scale. */ + + nm1 = *n - 1; + orgnrm = dlanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.) { + dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb); + return 0; + } + + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, + info); + +/* If N is smaller than the minimum divide size SMLSIZ, then solve */ +/* the problem with another solver. */ + + if (*n <= *smlsiz) { + nwork = *n * *n + 1; + dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n); + dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, & + work[1], n, &b[b_offset], ldb, &work[nwork], info); + if (*info != 0) { + return 0; + } + tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= tol) { + dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb); + } else { + dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ + i__ + b_dim1], ldb, info); + ++(*rank); + } +/* L40: */ + } + dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & + c_b6, &work[nwork], n); + dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb); + +/* Unscale. */ + + dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, + info); + dlasrt_("D", n, &d__[1], info); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], + ldb, info); + + return 0; + } + +/* Book-keeping and setting up some constants. */ + + nlvl = (integer) (log((double) (*n) / (double) (*smlsiz + 1)) / + log(2.)) + 1; + + smlszp = *smlsiz + 1; + + u = 1; + vt = *smlsiz * *n + 1; + difl = vt + smlszp * *n; + difr = difl + nlvl * *n; + z__ = difr + (nlvl * *n << 1); + c__ = z__ + nlvl * *n; + s = c__ + *n; + poles = s + *n; + givnum = poles + (nlvl << 1) * *n; + bx = givnum + (nlvl << 1) * *n; + nwork = bx + *n * *nrhs; + + sizei = *n + 1; + k = sizei + *n; + givptr = k + *n; + perm = givptr + *n; + givcol = perm + nlvl * *n; + iwk = givcol + (nlvl * *n << 1); + + st = 1; + sqre = 0; + icmpq1 = 1; + icmpq2 = 0; + nsub = 0; + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) < eps) { + d__[i__] = d_sign(&eps, &d__[i__]); + } +/* L50: */ + } + + i__1 = nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { + ++nsub; + iwork[nsub] = st; + +/* Subproblem found. First determine its size and then */ +/* apply divide and conquer on it. */ + + if (i__ < nm1) { + +/* A subproblem with E(I) small for I < NM1. */ + + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else if ((d__1 = e[i__], abs(d__1)) >= eps) { + +/* A subproblem with E(NM1) not too small but I = NM1. */ + + nsize = *n - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else { + +/* A subproblem with E(NM1) small. This implies an */ +/* 1-by-1 subproblem at D(N), which is not solved */ +/* explicitly. */ + + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + ++nsub; + iwork[nsub] = *n; + iwork[sizei + nsub - 1] = 1; + dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n); + } + st1 = st - 1; + if (nsize == 1) { + +/* This is a 1-by-1 subproblem and is not solved */ +/* explicitly. */ + + dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); + } else if (nsize <= *smlsiz) { + +/* This is a small subproblem and is solved by DLASDQ. */ + + dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], + n); + dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[ + st], &work[vt + st1], n, &work[nwork], n, &b[st + + b_dim1], ldb, &work[nwork], info); + if (*info != 0) { + return 0; + } + dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + + st1], n); + } else { + +/* A large problem. Solve it using divide and conquer. */ + + dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & + work[u + st1], n, &work[vt + st1], &iwork[k + st1], & + work[difl + st1], &work[difr + st1], &work[z__ + st1], + &work[poles + st1], &iwork[givptr + st1], &iwork[ + givcol + st1], n, &iwork[perm + st1], &work[givnum + + st1], &work[c__ + st1], &work[s + st1], &work[nwork], + &iwork[iwk], info); + if (*info != 0) { + return 0; + } + bxst = bx + st1; + dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & + work[bxst], n, &work[u + st1], n, &work[vt + st1], & + iwork[k + st1], &work[difl + st1], &work[difr + st1], + &work[z__ + st1], &work[poles + st1], &iwork[givptr + + st1], &iwork[givcol + st1], n, &iwork[perm + st1], & + work[givnum + st1], &work[c__ + st1], &work[s + st1], + &work[nwork], &iwork[iwk], info); + if (*info != 0) { + return 0; + } + } + st = i__ + 1; + } +/* L60: */ + } + +/* Apply the singular values and treat the tiny ones as zero. */ + + tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Some of the elements in D can be negative because 1-by-1 */ +/* subproblems were not solved explicitly. */ + + if ((d__1 = d__[i__], abs(d__1)) <= tol) { + dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n); + } else { + ++(*rank); + dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ + bx + i__ - 1], n, info); + } + d__[i__] = (d__1 = d__[i__], abs(d__1)); +/* L70: */ + } + +/* Now apply back the right singular vectors. */ + + icmpq2 = 1; + i__1 = nsub; + for (i__ = 1; i__ <= i__1; ++i__) { + st = iwork[i__]; + st1 = st - 1; + nsize = iwork[sizei + i__ - 1]; + bxst = bx + st1; + if (nsize == 1) { + dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); + } else if (nsize <= *smlsiz) { + dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, + &work[bxst], n, &c_b6, &b[st + b_dim1], ldb); + } else { + dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + + b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[ + k + st1], &work[difl + st1], &work[difr + st1], &work[z__ + + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ + givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], + &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[ + iwk], info); + if (*info != 0) { + return 0; + } + } +/* L80: */ + } + +/* Unscale and sort the singular values. */ + + dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info); + dlasrt_("D", n, &d__[1], info); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, + info); + + return 0; + +/* End of DLALSD */ + +} /* dlalsd_ */ + +double dlamch_(const char *cmach) +{ + /* Table of constant values + static double c_b32 = 0.;*/ + + /* Initialized data */ + static bool first = true; + + /* System generated locals */ + integer i__1; + double ret_val; + + /* Local variables */ + static double t; + integer it; + static double rnd, eps, base; + integer beta; + static double emin, prec, emax; + integer imin, imax; + bool lrnd; + static double rmin, rmax; + double rmach; + + double small; + static double sfmin; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Save statement .. */ +/* .. */ +/* .. Data statements .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (first) { + dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); + base = (double) beta; + t = (double) it; + if (lrnd) { + rnd = 1.; + i__1 = 1 - it; + eps = pow_di(&base, &i__1) / 2; + } else { + rnd = 0.; + i__1 = 1 - it; + eps = pow_di(&base, &i__1); + } + prec = eps * base; + emin = (double) imin; + emax = (double) imax; + sfmin = rmin; + small = 1. / rmax; + if (small >= sfmin) { + +/* Use SMALL plus a bit, to avoid the possibility of rounding */ +/* causing overflow when computing 1/sfmin. */ + + sfmin = small * (eps + 1.); + } + } + + if (lsame_(cmach, "E")) { + rmach = eps; + } else if (lsame_(cmach, "S")) { + rmach = sfmin; + } else if (lsame_(cmach, "B")) { + rmach = base; + } else if (lsame_(cmach, "P")) { + rmach = prec; + } else if (lsame_(cmach, "N")) { + rmach = t; + } else if (lsame_(cmach, "R")) { + rmach = rnd; + } else if (lsame_(cmach, "M")) { + rmach = emin; + } else if (lsame_(cmach, "U")) { + rmach = rmin; + } else if (lsame_(cmach, "L")) { + rmach = emax; + } else if (lsame_(cmach, "O")) { + rmach = rmax; + } + + ret_val = rmach; + first = false; + return ret_val; + +/* End of DLAMCH */ + +} /* dlamch_ */ + + +/* *********************************************************************** */ + +/* Subroutine */ int dlamc1_(integer *beta, integer *t, bool *rnd, bool + *ieee1) +{ + /* Initialized data */ + + static bool first = true; + + /* System generated locals */ + double d__1, d__2; + + /* Local variables */ + double a, b, c__, f, t1, t2; + static integer lt; + double one, qtr; + static bool lrnd; + static integer lbeta; + double savec; + + static bool lieee1; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Save statement .. */ +/* .. */ +/* .. Data statements .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (first) { + 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 */ +L10: + if (c__ == one) { + a *= 2; + c__ = dlamc3_(&a, &one); + d__1 = -a; + c__ = dlamc3_(&c__, &d__1); + goto L10; + } +/* + 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 */ +L20: + if (c__ == a) { + b *= 2; + c__ = dlamc3_(&a, &b); + goto L20; + } +/* + 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__; + d__1 = -a; + c__ = dlamc3_(&c__, &d__1); + lbeta = (integer) (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 = (double) lbeta; + d__1 = b / 2; + d__2 = -b / 100; + f = dlamc3_(&d__1, &d__2); + c__ = dlamc3_(&f, &a); + if (c__ == a) { + lrnd = true; + } else { + lrnd = false; + } + d__1 = b / 2; + d__2 = b / 100; + f = dlamc3_(&d__1, &d__2); + c__ = dlamc3_(&f, &a); + if (lrnd && c__ == 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. */ + + d__1 = b / 2; + t1 = dlamc3_(&d__1, &a); + d__1 = b / 2; + t2 = dlamc3_(&d__1, &savec); + lieee1 = t1 == a && t2 > savec && 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 */ +L30: + if (c__ == one) { + ++lt; + a *= lbeta; + c__ = dlamc3_(&a, &one); + d__1 = -a; + c__ = dlamc3_(&c__, &d__1); + goto L30; + } +/* + END WHILE */ + + } + + *beta = lbeta; + *t = lt; + *rnd = lrnd; + *ieee1 = lieee1; + first = false; + return 0; + +/* End of DLAMC1 */ + +} /* dlamc1_ */ + + +/* *********************************************************************** */ + +/* Subroutine */ int dlamc2_(integer *beta, integer *t, bool *rnd, + double *eps, integer *emin, double *rmin, integer *emax, + double *rmax) +{ + /* Initialized data */ + + static bool first = true; + static bool iwarn = false; + + /* System generated locals */ + integer i__1; + double d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + double a, b, c__; + integer i__; + static integer lt; + double one, two; + bool ieee; + double half; + bool lrnd; + static double leps; + double zero; + static integer lbeta; + double rbase; + static integer lemin, lemax; + integer gnmin; + double small; + integer gpmin; + double third; + static double lrmin, lrmax; + double sixth; + bool lieee1; + integer ngnmin, ngpmin; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Save statement .. */ +/* .. */ +/* .. Data statements .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (first) { + 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. */ + + dlamc1_(&lbeta, <, &lrnd, &lieee1); + +/* Start to find EPS. */ + + b = (double) lbeta; + i__1 = -lt; + a = pow_di(&b, &i__1); + leps = a; + +/* Try some tricks to see whether or not this is the correct EPS. */ + + b = two / 3; + half = one / 2; + d__1 = -half; + sixth = dlamc3_(&b, &d__1); + third = dlamc3_(&sixth, &sixth); + d__1 = -half; + b = dlamc3_(&third, &d__1); + b = dlamc3_(&b, &sixth); + b = abs(b); + if (b < leps) { + b = leps; + } + + leps = 1.; + +/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ +L10: + if (leps > b && b > zero) { + leps = b; + d__1 = half * leps; +/* Computing 5th power */ + d__3 = two, d__4 = d__3, d__3 *= d__3; +/* Computing 2nd power */ + d__5 = leps; + d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5); + c__ = dlamc3_(&d__1, &d__2); + d__1 = -c__; + c__ = dlamc3_(&half, &d__1); + b = dlamc3_(&half, &c__); + d__1 = -b; + c__ = dlamc3_(&half, &d__1); + b = dlamc3_(&half, &c__); + goto L10; + } +/* + END WHILE */ + + if (a < 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; + for (i__ = 1; i__ <= 3; ++i__) { + d__1 = small * rbase; + small = dlamc3_(&d__1, &zero); +/* L20: */ + } + a = dlamc3_(&one, &small); + dlamc4_(&ngpmin, &one, &lbeta); + d__1 = -one; + dlamc4_(&ngnmin, &d__1, &lbeta); + dlamc4_(&gpmin, &a, &lbeta); + d__1 = -a; + dlamc4_(&gnmin, &d__1, &lbeta); + ieee = false; + + if (ngpmin == ngnmin && gpmin == gnmin) { + if (ngpmin == gpmin) { + lemin = ngpmin; +/* ( Non twos-complement machines, no gradual underflow; */ +/* e.g., VAX ) */ + } else if (gpmin - ngpmin == 3) { + lemin = ngpmin - 1 + lt; + ieee = true; +/* ( Non twos-complement machines, with gradual underflow; */ +/* e.g., IEEE standard followers ) */ + } else { + lemin = std::min(ngpmin,gpmin); +/* ( A guess; no known machine ) */ + iwarn = true; + } + + } else if (ngpmin == gpmin && ngnmin == gnmin) { + if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { + lemin = std::max(ngpmin,ngnmin); +/* ( Twos-complement machines, no gradual underflow; */ +/* e.g., CYBER 205 ) */ + } else { + lemin = std::min(ngpmin,ngnmin); +/* ( A guess; no known machine ) */ + iwarn = true; + } + + } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) + { + if (gpmin - std::min(ngpmin,ngnmin) == 3) { + lemin = std::max(ngpmin,ngnmin) - 1 + lt; +/* ( Twos-complement machines with gradual underflow; */ +/* no known machine ) */ + } else { + lemin = std::min(ngpmin,ngnmin); +/* ( A guess; no known machine ) */ + iwarn = true; + } + + } else { +/* Computing MIN */ + i__1 = std::min(ngpmin,ngnmin), i__1 = std::min(i__1,gpmin); + lemin = std::min(i__1,gnmin); +/* ( A guess; no known machine ) */ + iwarn = true; + } + first = false; +/* ** */ +/* Comment out this if block if EMIN is ok */ + if (iwarn) { + first = true; + Melder_warning (U"DLAMC2 WARNING. The value EMIN may be incorrect:- ", lemin); + } +/* ** */ + +/* 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 || 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.; + i__1 = 1 - lemin; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = lrmin * rbase; + lrmin = dlamc3_(&d__1, &zero); +/* L30: */ + } + +/* Finally, call DLAMC5 to compute EMAX and RMAX. */ + + dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); + } + + *beta = lbeta; + *t = lt; + *rnd = lrnd; + *eps = leps; + *emin = lemin; + *rmin = lrmin; + *emax = lemax; + *rmax = lrmax; + + return 0; + + +/* End of DLAMC2 */ + +} /* dlamc2_ */ + + +/* *********************************************************************** */ + +double dlamc3_(double *a, double *b) +{ + /* + FIX by Paul Boersma 20200418: + Some optimizers can optimize away the whole call to this function if ret_val is not declared volatile. + In case this function is optimized away, + the floating-point epsilon may be estimated (by dlamch) not as 2.2e-16 + but as 2048 times lower on i386 gcc (using an 80-bit register rather than a 64-bit memory position), + so that an iterative procedure used in our discriminant analysis did not converge on 32-bit Windows + and on 32-bit i386 Linux. + */ + volatile double ret_val; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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 (input) DOUBLE PRECISION */ +/* B (input) DOUBLE PRECISION */ +/* The values A and B. */ + +/* ===================================================================== */ + +/* .. Executable Statements .. */ + + ret_val = *a + *b; + + return ret_val; + +/* End of DLAMC3 */ + +} /* dlamc3_ */ + + +/* *********************************************************************** */ + +/* Subroutine */ int dlamc4_(integer *emin, double *start, integer *base) +{ + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + double a; + integer i__; + double b1, b2, c1, c2, d1, d2, one, zero, rbase; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAMC4 is a service routine for DLAMC2. */ + +/* Arguments */ +/* ========= */ + +/* EMIN (output) INTEGER */ +/* 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 .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + a = *start; + one = 1.; + rbase = one / *base; + zero = 0.; + *emin = 1; + d__1 = a * rbase; + b1 = dlamc3_(&d__1, &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 */ +L10: + if (c1 == a && c2 == a && d1 == a && d2 == a) { + --(*emin); + a = b1; + d__1 = a / *base; + b1 = dlamc3_(&d__1, &zero); + d__1 = b1 * *base; + c1 = dlamc3_(&d__1, &zero); + d1 = zero; + i__1 = *base; + for (i__ = 1; i__ <= i__1; ++i__) { + d1 += b1; +/* L20: */ + } + d__1 = a * rbase; + b2 = dlamc3_(&d__1, &zero); + d__1 = b2 / rbase; + c2 = dlamc3_(&d__1, &zero); + d2 = zero; + i__1 = *base; + for (i__ = 1; i__ <= i__1; ++i__) { + d2 += b2; +/* L30: */ + } + goto L10; + } +/* + END WHILE */ + + return 0; + +/* End of DLAMC4 */ + +} /* dlamc4_ */ + + +/* *********************************************************************** */ + +/* Subroutine */ int dlamc5_(integer *beta, integer *p, integer *emin, + bool *ieee, integer *emax, double *rmax) +{ + /* Table of constant values */ + static double c_b32 = 0.; + + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer i__; + double y, z__; + integer try__, lexp; + double oldy; + integer uexp, nbits; + + double recbas; + integer exbits, expsum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. 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; +L10: + try__ = lexp << 1; + if (try__ <= -(*emin)) { + lexp = try__; + ++exbits; + goto L10; + } + if (lexp == -(*emin)) { + uexp = lexp; + } else { + uexp = try__; + ++exbits; + } + +/* 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 > -lexp - *emin) { + expsum = lexp << 1; + } else { + expsum = uexp << 1; + } + +/* EXPSUM is the exponent range, approximately equal to */ +/* EMAX - EMIN + 1 . */ + + *emax = expsum + *emin - 1; + nbits = exbits + 1 + *p; + +/* NBITS is the total number of bits needed to store a */ +/* floating-point number. */ + + if (nbits % 2 == 1 && *beta == 2) { + +/* 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); + } + + if (*ieee) { + +/* Assume we are on an IEEE machine which reserves one exponent */ +/* for infinity and NaN. */ + + --(*emax); + } + +/* 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 = 1. / *beta; + z__ = *beta - 1.; + y = 0.; + i__1 = *p; + for (i__ = 1; i__ <= i__1; ++i__) { + z__ *= recbas; + if (y < 1.) { + oldy = y; + } + y = dlamc3_(&y, &z__); +/* L20: */ + } + if (y >= 1.) { + y = oldy; + } + +/* Now multiply by BETA**EMAX to get RMAX. */ + + i__1 = *emax; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = y * *beta; + y = dlamc3_(&d__1, &c_b32); +/* L30: */ + } + + *rmax = y; + return 0; + +/* End of DLAMC5 */ + +} /* dlamc5_ */ + +/* Subroutine */ int dlamrg_(integer *n1, integer *n2, double *a, integer + *dtrd1, integer *dtrd2, integer *index) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, ind1, ind2, n1sv, n2sv; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAMRG will create a permutation list which will merge the elements */ +/* of A (which is composed of two independently sorted sets) into a */ +/* single set which is sorted in ascending order. */ + +/* Arguments */ +/* ========= */ + +/* N1 (input) INTEGER */ +/* N2 (input) INTEGER */ +/* These arguements contain the respective lengths of the two */ +/* sorted lists to be merged. */ + +/* A (input) DOUBLE PRECISION array, dimension (N1+N2) */ +/* The first N1 elements of A contain a list of numbers which */ +/* are sorted in either ascending or descending order. Likewise */ +/* for the final N2 elements. */ + +/* DTRD1 (input) INTEGER */ +/* DTRD2 (input) INTEGER */ +/* These are the strides to be taken through the array A. */ +/* Allowable strides are 1 and -1. They indicate whether a */ +/* subset of A is sorted in ascending (DTRDx = 1) or descending */ +/* (DTRDx = -1) order. */ + +/* INDEX (output) INTEGER array, dimension (N1+N2) */ +/* On exit this array will contain a permutation such that */ +/* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be */ +/* sorted in ascending order. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --index; + --a; + + /* Function Body */ + n1sv = *n1; + n2sv = *n2; + if (*dtrd1 > 0) { + ind1 = 1; + } else { + ind1 = *n1; + } + if (*dtrd2 > 0) { + ind2 = *n1 + 1; + } else { + ind2 = *n1 + *n2; + } + i__ = 1; +/* while ( (N1SV > 0) & (N2SV > 0) ) */ +L10: + if (n1sv > 0 && n2sv > 0) { + if (a[ind1] <= a[ind2]) { + index[i__] = ind1; + ++i__; + ind1 += *dtrd1; + --n1sv; + } else { + index[i__] = ind2; + ++i__; + ind2 += *dtrd2; + --n2sv; + } + goto L10; + } +/* end while */ + if (n1sv == 0) { + i__1 = n2sv; + for (n1sv = 1; n1sv <= i__1; ++n1sv) { + index[i__] = ind2; + ++i__; + ind2 += *dtrd2; +/* L20: */ + } + } else { +/* N2SV .EQ. 0 */ + i__1 = n1sv; + for (n2sv = 1; n2sv <= i__1; ++n2sv) { + index[i__] = ind1; + ++i__; + ind1 += *dtrd1; +/* L30: */ + } + } + + return 0; + +/* End of DLAMRG */ + +} /* dlamrg_ */ + +/* Subroutine */ integer dlaneg_(integer *n, double *d__, double *lld, double * + sigma, double *pivmin, integer *r__) +{ + /* System generated locals */ + integer ret_val, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer j; + double p, t; + integer bj; + double tmp; + integer neg1, neg2; + double bsav, gamma, dplus; + + integer negcnt; + bool sawnan; + double dminus; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANEG computes the Sturm count, the number of negative pivots */ +/* encountered while factoring tridiagonal T - sigma I = L D L^T. */ +/* This implementation works directly on the factors without forming */ +/* the tridiagonal matrix T. The Sturm count is also the number of */ +/* eigenvalues of T less than sigma. */ + +/* This routine is called from DLARRB. */ + +/* The current routine does not use the PIVMIN parameter but rather */ +/* requires IEEE-754 propagation of Infinities and NaNs. This */ +/* routine also has no input range restrictions but does require */ +/* default exception handling such that x/0 produces Inf when x is */ +/* non-zero, and Inf/Inf produces NaN. For more information, see: */ + +/* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in */ +/* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on */ +/* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 */ +/* (Tech report version in LAWN 172 with the same title.) */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The N diagonal elements of the diagonal matrix D. */ + +/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (N-1) elements L(i)*L(i)*D(i). */ + +/* SIGMA (input) DOUBLE PRECISION */ +/* Shift amount in T - sigma I = L D L^T. */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum pivot in the Sturm sequence. May be used */ +/* when zero pivots are encountered on non-IEEE-754 */ +/* architectures. */ + +/* R (input) INTEGER */ +/* The twist index for the twisted factorization that is used */ +/* for the negcount. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ +/* Jason Riedy, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* Some architectures propagate Infinities and NaNs very slowly, so */ +/* the code computes counts in BLKLEN chunks. Then a NaN can */ +/* propagate at most BLKLEN columns before being detected. This is */ +/* not a general tuning parameter; it needs only to be just large */ +/* enough that the overhead is tiny in common cases. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --lld; + --d__; + + /* Function Body */ + negcnt = 0; +/* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T */ + t = -(*sigma); + i__1 = *r__ - 1; + for (bj = 1; bj <= i__1; bj += 128) { + neg1 = 0; + bsav = t; +/* Computing MIN */ + i__3 = bj + 127, i__4 = *r__ - 1; + i__2 = std::min(i__3,i__4); + for (j = bj; j <= i__2; ++j) { + dplus = d__[j] + t; + if (dplus < 0.) { + ++neg1; + } + tmp = t / dplus; + t = tmp * lld[j] - *sigma; +/* L21: */ + } + sawnan = disnan_(&t); +/* Run a slower version of the above loop if a NaN is detected. */ +/* A NaN should occur only with a zero pivot after an infinite */ +/* pivot. In that case, substituting 1 for T/DPLUS is the */ +/* correct limit. */ + if (sawnan) { + neg1 = 0; + t = bsav; +/* Computing MIN */ + i__3 = bj + 127, i__4 = *r__ - 1; + i__2 = std::min(i__3,i__4); + for (j = bj; j <= i__2; ++j) { + dplus = d__[j] + t; + if (dplus < 0.) { + ++neg1; + } + tmp = t / dplus; + if (disnan_(&tmp)) { + tmp = 1.; + } + t = tmp * lld[j] - *sigma; +/* L22: */ + } + } + negcnt += neg1; +/* L210: */ + } + +/* II) lower part: L D L^T - SIGMA I = U- D- U-^T */ + p = d__[*n] - *sigma; + i__1 = *r__; + for (bj = *n - 1; bj >= i__1; bj += -128) { + neg2 = 0; + bsav = p; +/* Computing MAX */ + i__3 = bj - 127; + i__2 = std::max(i__3,*r__); + for (j = bj; j >= i__2; --j) { + dminus = lld[j] + p; + if (dminus < 0.) { + ++neg2; + } + tmp = p / dminus; + p = tmp * d__[j] - *sigma; +/* L23: */ + } + sawnan = disnan_(&p); +/* As above, run a slower version that substitutes 1 for Inf/Inf. */ + + if (sawnan) { + neg2 = 0; + p = bsav; +/* Computing MAX */ + i__3 = bj - 127; + i__2 = std::max(i__3,*r__); + for (j = bj; j >= i__2; --j) { + dminus = lld[j] + p; + if (dminus < 0.) { + ++neg2; + } + tmp = p / dminus; + if (disnan_(&tmp)) { + tmp = 1.; + } + p = tmp * d__[j] - *sigma; +/* L24: */ + } + } + negcnt += neg2; +/* L230: */ + } + +/* III) Twist index */ +/* T was shifted by SIGMA initially. */ + gamma = t + *sigma + p; + if (gamma < 0.) { + ++negcnt; + } + ret_val = negcnt; + return ret_val; +} /* dlaneg_ */ + +/* Subroutine */ double dlangb_(const char *norm, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + double ret_val, d__1, d__2, d__3; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__, j, k, l; + double sum, scale; + double value; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANGB returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of an */ +/* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */ + +/* Description */ +/* =========== */ + +/* DLANGB returns the value */ + +/* DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANGB as described */ +/* above. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANGB is */ +/* set to zero. */ + +/* KL (input) INTEGER */ +/* The number of sub-diagonals of the matrix A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of super-diagonals of the matrix A. KU >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ +/* column of A is stored in the j-th column of the array AB as */ +/* follows: */ +/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* referenced. */ + +/* ===================================================================== */ + + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *ku + 2 - j; +/* Computing MIN */ + i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; + i__3 = std::min(i__4,i__5); + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(d__1)) + ; + value = std::max(d__2,d__3); +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; +/* Computing MAX */ + i__3 = *ku + 2 - j; +/* Computing MIN */ + i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; + i__2 = std::min(i__4,i__5); + for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { + sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); +/* L30: */ + } + value = std::max(value,sum); +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + k = *ku + 1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *n, i__6 = j + *kl; + i__4 = std::min(i__5,i__6); + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + work[i__] += (d__1 = ab[k + i__ + j * ab_dim1], abs(d__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; + l = std::max(i__4,i__2); + k = *ku + 1 - j + l; +/* Computing MIN */ + i__2 = *n, i__3 = j + *kl; + i__4 = std::min(i__2,i__3) - l + 1; + dlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum); +/* L90: */ + } + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANGB */ + +} /* dlangb_ */ + +/* Subroutine */ double dlange_(const char *norm, integer *m, integer *n, double *a, integer + *lda, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double ret_val, d__1, d__2, d__3; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__, j; + double sum, scale; + double value; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANGE returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* real matrix A. */ + +/* Description */ +/* =========== */ + +/* DLANGE returns the value */ + +/* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANGE as described */ +/* above. */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. M >= 0. When M = 0, */ +/* DLANGE is set to zero. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix A. N >= 0. When N = 0, */ +/* DLANGE is set to zero. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The m by n matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(M,1). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ +/* referenced. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + + /* Function Body */ + if (std::min(*m,*n) == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + value = std::max(d__2,d__3); +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L30: */ + } + value = std::max(value,sum); +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum); +/* L90: */ + } + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANGE */ + +} /* dlange_ */ + +/* Subroutine */ double dlangt_(const char *norm, integer *n, double *dl, double *d__, + double *du) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1; + double ret_val, d__1, d__2, d__3, d__4, d__5; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__; + double sum, scale; + double anorm; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANGT returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* real tridiagonal matrix A. */ + +/* Description */ +/* =========== */ + +/* DLANGT returns the value */ + +/* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANGT as described */ +/* above. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANGT is */ +/* set to zero. */ + +/* DL (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) sub-diagonal elements of A. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of A. */ + +/* DU (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) super-diagonal elements of A. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --du; + --d__; + --dl; + + /* Function Body */ + if (*n <= 0) { + anorm = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + anorm = (d__1 = d__[*n], abs(d__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = anorm, d__3 = (d__1 = dl[i__], abs(d__1)); + anorm = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1)); + anorm = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = anorm, d__3 = (d__1 = du[i__], abs(d__1)); + anorm = std::max(d__2,d__3); +/* L10: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + if (*n == 1) { + anorm = abs(d__[1]); + } else { +/* Computing MAX */ + d__3 = abs(d__[1]) + abs(dl[1]), d__4 = (d__1 = d__[*n], abs(d__1) + ) + (d__2 = du[*n - 1], abs(d__2)); + anorm = std::max(d__3,d__4); + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = + dl[i__], abs(d__2)) + (d__3 = du[i__ - 1], abs(d__3)); + anorm = std::max(d__4,d__5); +/* L20: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + if (*n == 1) { + anorm = abs(d__[1]); + } else { +/* Computing MAX */ + d__3 = abs(d__[1]) + abs(du[1]), d__4 = (d__1 = d__[*n], abs(d__1) + ) + (d__2 = dl[*n - 1], abs(d__2)); + anorm = std::max(d__3,d__4); + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = + du[i__], abs(d__2)) + (d__3 = dl[i__ - 1], abs(d__3)); + anorm = std::max(d__4,d__5); +/* L30: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + dlassq_(n, &d__[1], &c__1, &scale, &sum); + if (*n > 1) { + i__1 = *n - 1; + dlassq_(&i__1, &dl[1], &c__1, &scale, &sum); + i__1 = *n - 1; + dlassq_(&i__1, &du[1], &c__1, &scale, &sum); + } + anorm = scale * sqrt(sum); + } + + ret_val = anorm; + return ret_val; + +/* End of DLANGT */ + +} /* dlangt_ */ + +/* Subroutine */ double dlanhs_(const char *norm, integer *n, double *a, integer *lda, + double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + double ret_val, d__1, d__2, d__3; + + /* Local variables */ + integer i__, j; + double sum, scale; + double value; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANHS returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* Hessenberg matrix A. */ + +/* Description */ +/* =========== */ + +/* DLANHS returns the value */ + +/* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANHS as described */ +/* above. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANHS is */ +/* set to zero. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The n by n upper Hessenberg matrix A; the part of A below the */ +/* first sub-diagonal is not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(N,1). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* referenced. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = std::min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + value = std::max(d__2,d__3); +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = std::min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L30: */ + } + value = std::max(value,sum); +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = std::min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = std::min(i__3,i__4); + dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); +/* L90: */ + } + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANHS */ + +} /* dlanhs_ */ + +/* Subroutine */ double dlansb_(const char *norm, const char *uplo, integer *n, integer *k, double + *ab, integer *ldab, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + double ret_val, d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, l; + double sum, absa, scale; + double value; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANSB returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of an */ +/* n by n symmetric band matrix A, with k super-diagonals. */ + +/* Description */ +/* =========== */ + +/* DLANSB returns the value */ + +/* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANSB as described */ +/* above. */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* band matrix A is supplied. */ +/* = 'U': Upper triangular part is supplied */ +/* = 'L': Lower triangular part is supplied */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANSB is */ +/* set to zero. */ + +/* K (input) INTEGER */ +/* The number of super-diagonals or sub-diagonals of the */ +/* band matrix A. K >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The upper or lower triangle of the symmetric band matrix A, */ +/* stored in the first K+1 rows of AB. The j-th column of A is */ +/* stored in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= K+1. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* WORK is not referenced. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k + 1; + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs( + d__1)); + value = std::max(d__2,d__3); +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *n + 1 - j, i__4 = *k + 1; + i__3 = std::min(i__2,i__4); + for (i__ = 1; i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs( + d__1)); + value = std::max(d__2,d__3); +/* L30: */ + } +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + l = *k + 1 - j; +/* Computing MAX */ + i__3 = 1, i__2 = j - *k; + i__4 = j - 1; + for (i__ = std::max(i__3,i__2); i__ <= i__4; ++i__) { + absa = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; +/* L50: */ + } + work[j] = sum + (d__1 = ab[*k + 1 + j * ab_dim1], abs(d__1)); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (d__1 = ab[j * ab_dim1 + 1], abs(d__1)); + l = 1 - j; +/* Computing MIN */ + i__3 = *n, i__2 = j + *k; + i__4 = std::min(i__3,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + absa = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; +/* L90: */ + } + value = std::max(value,sum); +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + if (*k > 0) { + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = j - 1; + i__4 = std::min(i__3,*k); +/* Computing MAX */ + i__2 = *k + 2 - j; + dlassq_(&i__4, &ab[std::max(i__2, 1_integer)+ j * ab_dim1], &c__1, & + scale, &sum); +/* L110: */ + } + l = *k + 1; + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n - j; + i__4 = std::min(i__3,*k); + dlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum); +/* L120: */ + } + l = 1; + } + sum *= 2; + } else { + l = 1; + } + dlassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum); + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANSB */ + +} /* dlansb_ */ + +double dlansf_(const char *norm, char *transr, char *uplo, integer *n, double *a, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1, i__2; + double ret_val, d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k, l; + double s; + integer n1; + double aa; + integer lda, ifm, noe, ilu; + double scale; + double value; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANSF returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* real symmetric matrix A in RFP format. */ + +/* Description */ +/* =========== */ + +/* DLANSF returns the value */ + +/* DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER */ +/* Specifies the value to be returned in DLANSF as described */ +/* above. */ + +/* TRANSR (input) CHARACTER */ +/* Specifies whether the RFP format of A is normal or */ +/* transposed format. */ +/* = 'N': RFP format is Normal; */ +/* = 'T': RFP format is Transpose. */ + +/* UPLO (input) CHARACTER */ +/* On entry, UPLO specifies whether the RFP matrix A came from */ +/* an upper or lower triangular matrix as follows: */ +/* = 'U': RFP A came from an upper triangular matrix; */ +/* = 'L': RFP A came from a lower triangular matrix. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANSF is */ +/* set to zero. */ + +/* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); */ +/* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */ +/* part of the symmetric matrix A stored in RFP format. See the */ +/* "Notes" below for more details. */ +/* Unchanged on exit. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* WORK is not referenced. */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* Reference */ +/* ========= */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + if (*n == 0) { + ret_val = 0.; + return ret_val; + } + +/* set noe = 1 if n is odd. if n is even set noe=0 */ + + noe = 1; + if (*n % 2 == 0) { + noe = 0; + } + +/* set ifm = 0 when form='T or 't' and 1 otherwise */ + + ifm = 1; + if (lsame_(transr, "T")) { + ifm = 0; + } + +/* set ilu = 0 when uplo='U or 'u' and 1 otherwise */ + + ilu = 1; + if (lsame_(uplo, "U")) { + ilu = 0; + } + +/* set lda = (n+1)/2 when ifm = 0 */ +/* set lda = n when ifm = 1 and noe = 1 */ +/* set lda = n+1 when ifm = 1 and noe = 0 */ + + if (ifm == 1) { + if (noe == 1) { + lda = *n; + } else { +/* noe=0 */ + lda = *n + 1; + } + } else { +/* ifm=0 */ + lda = (*n + 1) / 2; + } + + if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + k = (*n + 1) / 2; + value = 0.; + if (noe == 1) { +/* n is odd */ + if (ifm == 1) { +/* A is n by k */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = 0; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(d__1)); + value = std::max(d__2,d__3); + } + } + } else { +/* xpose case; A is k by n */ + i__1 = *n - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(d__1)); + value = std::max(d__2,d__3); + } + } + } + } else { +/* n is even */ + if (ifm == 1) { +/* A is n+1 by k */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 0; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(d__1)); + value = std::max(d__2,d__3); + } + } + } else { +/* xpose case; A is k by n+1 */ + i__1 = *n; + for (j = 0; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(d__1)); + value = std::max(d__2,d__3); + } + } + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + if (ifm == 1) { + k = *n / 2; + if (noe == 1) { +/* n is odd */ + if (ilu == 0) { + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(i,j+k) */ + s += aa; + work[i__] += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,j+k) */ + work[j + k] = s + aa; + if (i__ == k + k) { + goto L10; + } + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j,j) */ + work[j] += aa; + s = 0.; + i__2 = k - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } +L10: + i__ = idamax_(n, work, &c__1); + value = work[i__ - 1]; + } else { +/* ilu = 1 */ + ++k; +/* k=(n+1)/2 for n odd and ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + for (j = k - 1; j >= 0; --j) { + s = 0.; + i__1 = j - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,i+k) */ + s += aa; + work[i__ + k] += aa; + } + if (j > 0) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,j+k) */ + s += aa; + work[i__ + k] += s; +/* i=j */ + ++i__; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j,j) */ + work[j] = aa; + s = 0.; + i__1 = *n - 1; + for (l = j + 1; l <= i__1; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + i__ = idamax_(n, work, &c__1); + value = work[i__ - 1]; + } + } else { +/* n is even */ + if (ilu == 0) { + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(i,j+k) */ + s += aa; + work[i__] += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,j+k) */ + work[j + k] = s + aa; + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j,j) */ + work[j] += aa; + s = 0.; + i__2 = k - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + i__ = idamax_(n, work, &c__1); + value = work[i__ - 1]; + } else { +/* ilu = 1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + for (j = k - 1; j >= 0; --j) { + s = 0.; + i__1 = j - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,i+k) */ + s += aa; + work[i__ + k] += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j+k,j+k) */ + s += aa; + work[i__ + k] += s; +/* i=j */ + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(j,j) */ + work[j] = aa; + s = 0.; + i__1 = *n - 1; + for (l = j + 1; l <= i__1; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + i__ = idamax_(n, work, &c__1); + value = work[i__ - 1]; + } + } + } else { +/* ifm=0 */ + k = *n / 2; + if (noe == 1) { +/* n is odd */ + if (ilu == 0) { + n1 = k; +/* n/2 */ + ++k; +/* k is the row size and lda */ + i__1 = *n - 1; + for (i__ = n1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,n1+i) */ + work[i__ + n1] += aa; + s += aa; + } + work[j] = s; + } +/* j=n1=k-1 is special */ + s = (d__1 = a[j * lda], abs(d__1)); +/* A(k-1,k-1) */ + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k-1,i+n1) */ + work[i__ + n1] += aa; + s += aa; + } + work[j] += s; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + s = 0.; + i__2 = j - k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(i,j-k) */ + work[i__] += aa; + s += aa; + } +/* i=j-k */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j-k,j-k) */ + s += aa; + work[j - k] += s; + ++i__; + s = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,j) */ + i__2 = *n - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,l) */ + work[l] += aa; + s += aa; + } + work[j] += s; + } + i__ = idamax_(n, work, &c__1); + value = work[i__ - 1]; + } else { +/* ilu=1 */ + ++k; +/* k=(n+1)/2 for n odd and ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { +/* process */ + s = 0.; + i__2 = j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,i) */ + work[i__] += aa; + s += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* i=j so process of A(j,j) */ + s += aa; + work[j] = s; +/* is initialised here */ + ++i__; +/* i=j process A(j+k,j+k) */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); + s = aa; + i__2 = *n - 1; + for (l = k + j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(l,k+j) */ + s += aa; + work[l] += aa; + } + work[k + j] += s; + } +/* j=k-1 is special :process col A(k-1,0:k-1) */ + s = 0.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k,i) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] = s; +/* done with col j=k+1 */ + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { +/* process col j of A = A(j,0:k-1) */ + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,i) */ + work[i__] += aa; + s += aa; + } + work[j] += s; + } + i__ = idamax_(n, work, &c__1); + value = work[i__ - 1]; + } + } else { +/* n is even */ + if (ilu == 0) { + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,i+k) */ + work[i__ + k] += aa; + s += aa; + } + work[j] = s; + } +/* j=k */ + aa = (d__1 = a[j * lda], abs(d__1)); +/* A(k,k) */ + s = aa; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k,k+i) */ + work[i__ + k] += aa; + s += aa; + } + work[j] += s; + i__1 = *n - 1; + for (j = k + 1; j <= i__1; ++j) { + s = 0.; + i__2 = j - 2 - k; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(i,j-k-1) */ + work[i__] += aa; + s += aa; + } +/* i=j-1-k */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j-k-1,j-k-1) */ + s += aa; + work[j - k - 1] += s; + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,j) */ + s = aa; + i__2 = *n - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j,l) */ + work[l] += aa; + s += aa; + } + work[j] += s; + } +/* j=n */ + s = 0.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(i,k-1) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] += s; + i__ = idamax_(n, work, &c__1); + value = work[i__ - 1]; + } else { +/* ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } +/* j=0 is special :process col A(k:n-1,k) */ + s = abs(a[0]); +/* A(k,k) */ + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__], abs(d__1)); +/* A(k+i,k) */ + work[i__ + k] += aa; + s += aa; + } + work[k] += s; + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { +/* process */ + s = 0.; + i__2 = j - 2; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j-1,i) */ + work[i__] += aa; + s += aa; + } + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* i=j-1 so process of A(j-1,j-1) */ + s += aa; + work[j - 1] = s; +/* is initialised here */ + ++i__; +/* i=j process A(j+k,j+k) */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); + s = aa; + i__2 = *n - 1; + for (l = k + j + 1; l <= i__2; ++l) { + ++i__; + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(l,k+j) */ + s += aa; + work[l] += aa; + } + work[k + j] += s; + } +/* j=k is special :process col A(k,0:k-1) */ + s = 0.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k,i) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] = s; +/* done with col j=k+1 */ + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { +/* process col j-1 of A = A(j-1,0:k-1) */ + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = (d__1 = a[i__ + j * lda], abs(d__1)); +/* A(j-1,i) */ + work[i__] += aa; + s += aa; + } + work[j - 1] += s; + } + i__ = idamax_(n, work, &c__1); + value = work[i__ - 1]; + } + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + k = (*n + 1) / 2; + scale = 0.; + s = 1.; + if (noe == 1) { +/* n is odd */ + if (ifm == 1) { +/* A is normal */ + if (ilu == 0) { +/* A is upper */ + i__1 = k - 3; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 2; + dlassq_(&i__2, &a[k + j + 1 + j * lda], &c__1, &scale, + &s); +/* L at A(k,0) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j - 1; + dlassq_(&i__2, &a[j * lda], &c__1, &scale, &s); +/* trap U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = k - 1; + i__2 = lda + 1; + dlassq_(&i__1, &a[k], &i__2, &scale, &s); +/* tri L at A(k,0) */ + i__1 = lda + 1; + dlassq_(&k, &a[k - 1], &i__1, &scale, &s); +/* tri U at A(k-1,0) */ + } else { +/* ilu=1 & A is lower */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - j - 1; + dlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s) + ; +/* trap L at A(0,0) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + dlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s); +/* U at A(0,1) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + dlassq_(&k, a, &i__1, &scale, &s); +/* tri L at A(0,0) */ + i__1 = k - 1; + i__2 = lda + 1; + dlassq_(&i__1, &a[lda], &i__2, &scale, &s); +/* tri U at A(0,1) */ + } + } else { +/* A is xpose */ + if (ilu == 0) { +/* A' is upper */ + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + dlassq_(&j, &a[(k + j) * lda], &c__1, &scale, &s); +/* U at A(0,k) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + dlassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k-1 rect. at A(0,0) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + dlassq_(&i__2, &a[j + 1 + (j + k - 1) * lda], &c__1, & + scale, &s); +/* L at A(0,k-1) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = k - 1; + i__2 = lda + 1; + dlassq_(&i__1, &a[k * lda], &i__2, &scale, &s); +/* tri U at A(0,k) */ + i__1 = lda + 1; + dlassq_(&k, &a[(k - 1) * lda], &i__1, &scale, &s); +/* tri L at A(0,k-1) */ + } else { +/* A' is lower */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + dlassq_(&j, &a[j * lda], &c__1, &scale, &s); +/* U at A(0,0) */ + } + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + dlassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k-1 rect. at A(0,k) */ + } + i__1 = k - 3; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 2; + dlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s) + ; +/* L at A(1,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + dlassq_(&k, a, &i__1, &scale, &s); +/* tri U at A(0,0) */ + i__1 = k - 1; + i__2 = lda + 1; + dlassq_(&i__1, &a[1], &i__2, &scale, &s); +/* tri L at A(1,0) */ + } + } + } else { +/* n is even */ + if (ifm == 1) { +/* A is normal */ + if (ilu == 0) { +/* A is upper */ + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + dlassq_(&i__2, &a[k + j + 2 + j * lda], &c__1, &scale, + &s); +/* L at A(k+1,0) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + dlassq_(&i__2, &a[j * lda], &c__1, &scale, &s); +/* trap U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + dlassq_(&k, &a[k + 1], &i__1, &scale, &s); +/* tri L at A(k+1,0) */ + i__1 = lda + 1; + dlassq_(&k, &a[k], &i__1, &scale, &s); +/* tri U at A(k,0) */ + } else { +/* ilu=1 & A is lower */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - j - 1; + dlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s) + ; +/* trap L at A(1,0) */ + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + dlassq_(&j, &a[j * lda], &c__1, &scale, &s); +/* U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + dlassq_(&k, &a[1], &i__1, &scale, &s); +/* tri L at A(1,0) */ + i__1 = lda + 1; + dlassq_(&k, a, &i__1, &scale, &s); +/* tri U at A(0,0) */ + } + } else { +/* A is xpose */ + if (ilu == 0) { +/* A' is upper */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + dlassq_(&j, &a[(k + 1 + j) * lda], &c__1, &scale, &s); +/* U at A(0,k+1) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + dlassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k rect. at A(0,0) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + dlassq_(&i__2, &a[j + 1 + (j + k) * lda], &c__1, & + scale, &s); +/* L at A(0,k) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + dlassq_(&k, &a[(k + 1) * lda], &i__1, &scale, &s); +/* tri U at A(0,k+1) */ + i__1 = lda + 1; + dlassq_(&k, &a[k * lda], &i__1, &scale, &s); +/* tri L at A(0,k) */ + } else { +/* A' is lower */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + dlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s); +/* U at A(0,1) */ + } + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + dlassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k rect. at A(0,k+1) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + dlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s) + ; +/* L at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + i__1 = lda + 1; + dlassq_(&k, &a[lda], &i__1, &scale, &s); +/* tri L at A(0,1) */ + i__1 = lda + 1; + dlassq_(&k, a, &i__1, &scale, &s); +/* tri U at A(0,0) */ + } + } + } + value = scale * sqrt(s); + } + + ret_val = value; + return ret_val; + +/* End of DLANSF */ + +} /* dlansf_ */ + +/* Subroutine */ double dlansp_(const char *norm, const char *uplo, integer *n, double *ap, + double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1, i__2; + double ret_val, d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double sum, absa, scale; + double value; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANSP returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* real symmetric matrix A, supplied in packed form. */ + +/* Description */ +/* =========== */ + +/* DLANSP returns the value */ + +/* DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANSP as described */ +/* above. */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is supplied. */ +/* = 'U': Upper triangular part of A is supplied */ +/* = 'L': Lower triangular part of A is supplied */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANSP is */ +/* set to zero. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangle of the symmetric matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* WORK is not referenced. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --work; + --ap; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); + value = std::max(d__2,d__3); +/* L10: */ + } + k += j; +/* L20: */ + } + } else { + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); + value = std::max(d__2,d__3); +/* L30: */ + } + k = k + *n - j + 1; +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.; + k = 1; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = (d__1 = ap[k], abs(d__1)); + sum += absa; + work[i__] += absa; + ++k; +/* L50: */ + } + work[j] = sum + (d__1 = ap[k], abs(d__1)); + ++k; +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (d__1 = ap[k], abs(d__1)); + ++k; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = (d__1 = ap[k], abs(d__1)); + sum += absa; + work[i__] += absa; + ++k; +/* L90: */ + } + value = std::max(value,sum); +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + k = 2; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); + k += j; +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); + k = k + *n - j + 1; +/* L120: */ + } + } + sum *= 2; + k = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ap[k] != 0.) { + absa = (d__1 = ap[k], abs(d__1)); + if (scale < absa) { +/* Computing 2nd power */ + d__1 = scale / absa; + sum = sum * (d__1 * d__1) + 1.; + scale = absa; + } else { +/* Computing 2nd power */ + d__1 = absa / scale; + sum += d__1 * d__1; + } + } + if (lsame_(uplo, "U")) { + k = k + i__ + 1; + } else { + k = k + *n - i__ + 1; + } +/* L130: */ + } + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANSP */ + +} /* dlansp_ */ + +/* Subroutine */ double dlanst_(const char *norm, integer *n, double *d__, double *e) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1; + double ret_val, d__1, d__2, d__3, d__4, d__5; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__; + double sum, scale; + double anorm; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANST returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* real symmetric tridiagonal matrix A. */ + +/* Description */ +/* =========== */ + +/* DLANST returns the value */ + +/* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANST as described */ +/* above. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANST is */ +/* set to zero. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of A. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) sub-diagonal or super-diagonal elements of A. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + if (*n <= 0) { + anorm = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + anorm = (d__1 = d__[*n], abs(d__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1)); + anorm = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = anorm, d__3 = (d__1 = e[i__], abs(d__1)); + anorm = std::max(d__2,d__3); +/* L10: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1' || lsame_(norm, "I")) { + +/* Find norm1(A). */ + + if (*n == 1) { + anorm = abs(d__[1]); + } else { +/* Computing MAX */ + d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = e[*n - 1], abs( + d__1)) + (d__2 = d__[*n], abs(d__2)); + anorm = std::max(d__3,d__4); + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[ + i__], abs(d__2)) + (d__3 = e[i__ - 1], abs(d__3)); + anorm = std::max(d__4,d__5); +/* L20: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + if (*n > 1) { + i__1 = *n - 1; + dlassq_(&i__1, &e[1], &c__1, &scale, &sum); + sum *= 2; + } + dlassq_(n, &d__[1], &c__1, &scale, &sum); + anorm = scale * sqrt(sum); + } + + ret_val = anorm; + return ret_val; + +/* End of DLANST */ + +} /* dlanst_ */ + +/* Subroutine */ double dlansy_(const char *norm, const char *uplo, integer *n, double *a, integer + *lda, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double ret_val, d__1, d__2, d__3; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__, j; + double sum, absa, scale; + double value; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANSY returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* real symmetric matrix A. */ + +/* Description */ +/* =========== */ + +/* DLANSY returns the value */ + +/* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANSY as described */ +/* above. */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is to be referenced. */ +/* = 'U': Upper triangular part of A is referenced */ +/* = 'L': Lower triangular part of A is referenced */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANSY is */ +/* set to zero. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The symmetric matrix A. If UPLO = 'U', the leading n by n */ +/* upper triangular part of A contains the upper triangular part */ +/* of the matrix A, and the strictly lower triangular part of A */ +/* is not referenced. If UPLO = 'L', the leading n by n lower */ +/* triangular part of A contains the lower triangular part of */ +/* the matrix A, and the strictly upper triangular part of A is */ +/* not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(N,1). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* WORK is not referenced. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( + d__1)); + value = std::max(d__2,d__3); +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( + d__1)); + value = std::max(d__2,d__3); +/* L30: */ + } +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; +/* L50: */ + } + work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1)); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1)); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + sum += absa; + work[i__] += absa; +/* L90: */ + } + value = std::max(value,sum); +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum); +/* L120: */ + } + } + sum *= 2; + i__1 = *lda + 1; + dlassq_(n, &a[a_offset], &i__1, &scale, &sum); + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANSY */ + +} /* dlansy_ */ + +/* Subroutine */ double dlantb_(const char *norm, const char *uplo, const char *diag, integer *n, integer *k, + double *ab, integer *ldab, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; + double ret_val, d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, l; + double sum, scale; + bool udiag; + double value; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANTB returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of an */ +/* n by n triangular band matrix A, with ( k + 1 ) diagonals. */ + +/* Description */ +/* =========== */ + +/* DLANTB returns the value */ + +/* DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANTB as described */ +/* above. */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the matrix A is upper or lower triangular. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* DIAG (input) CHARACTER*1 */ +/* Specifies whether or not the matrix A is unit triangular. */ +/* = 'N': Non-unit triangular */ +/* = 'U': Unit triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANTB is */ +/* set to zero. */ + +/* K (input) INTEGER */ +/* The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */ +/* K >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The upper or lower triangular band matrix A, stored in the */ +/* first k+1 rows of AB. The j-th column of A is stored */ +/* in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */ +/* Note that when DIAG = 'U', the elements of the array AB */ +/* corresponding to the diagonal elements of the matrix A are */ +/* not referenced, but are assumed to be one. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= K+1. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* referenced. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + if (lsame_(diag, "U")) { + value = 1.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k; + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], + abs(d__1)); + value = std::max(d__2,d__3); +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *n + 1 - j, i__4 = *k + 1; + i__3 = std::min(i__2,i__4); + for (i__ = 2; i__ <= i__3; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], + abs(d__1)); + value = std::max(d__2,d__3); +/* L30: */ + } +/* L40: */ + } + } + } else { + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = *k + 2 - j; + i__2 = *k + 1; + for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], + abs(d__1)); + value = std::max(d__2,d__3); +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = std::min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], + abs(d__1)); + value = std::max(d__2,d__3); +/* L70: */ + } +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k; + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { + sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); +/* L90: */ + } + } else { + sum = 0.; +/* Computing MAX */ + i__3 = *k + 2 - j; + i__2 = *k + 1; + for (i__ = std::max(i__3,1_integer); i__ <= i__2; ++i__) { + sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); +/* L100: */ + } + } + value = std::max(value,sum); +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = std::min(i__3,i__4); + for (i__ = 2; i__ <= i__2; ++i__) { + sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); +/* L120: */ + } + } else { + sum = 0.; +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = std::min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1)); +/* L130: */ + } + } + value = std::max(value,sum); +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + value = 0.; + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = *k + 1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs( + d__1)); +/* L160: */ + } +/* L170: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = *k + 1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j; + for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { + work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs( + d__1)); +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L210: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = std::min(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs( + d__1)); +/* L220: */ + } +/* L230: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L240: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = std::min(i__4,i__2); + for (i__ = j; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs( + d__1)); +/* L250: */ + } +/* L260: */ + } + } + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L270: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + scale = 1.; + sum = (double) (*n); + if (*k > 0) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j - 1; + i__3 = std::min(i__4,*k); +/* Computing MAX */ + i__2 = *k + 2 - j; + dlassq_(&i__3, &ab[std::max(i__2,1_integer)+ j * ab_dim1], &c__1, + &scale, &sum); +/* L280: */ + } + } + } else { + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j, i__2 = *k + 1; + i__3 = std::min(i__4,i__2); +/* Computing MAX */ + i__5 = *k + 2 - j; + dlassq_(&i__3, &ab[std::max(i__5,1_integer)+ j * ab_dim1], &c__1, & + scale, &sum); +/* L290: */ + } + } + } else { + if (lsame_(diag, "U")) { + scale = 1.; + sum = (double) (*n); + if (*k > 0) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = *n - j; + i__3 = std::min(i__4,*k); + dlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, & + sum); +/* L300: */ + } + } + } else { + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = *n - j + 1, i__2 = *k + 1; + i__3 = std::min(i__4,i__2); + dlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum); +/* L310: */ + } + } + } + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANTB */ + +} /* dlantb_ */ + +/* Subroutine */ double dlantp_(const char *norm, const char *uplo, const char *diag, integer *n, double + *ap, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1, i__2; + double ret_val, d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double sum, scale; + bool udiag; + double value; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANTP returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* triangular matrix A, supplied in packed form. */ + +/* Description */ +/* =========== */ + +/* DLANTP returns the value */ + +/* DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANTP as described */ +/* above. */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the matrix A is upper or lower triangular. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* DIAG (input) CHARACTER*1 */ +/* Specifies whether or not the matrix A is unit triangular. */ +/* = 'N': Non-unit triangular */ +/* = 'U': Unit triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. When N = 0, DLANTP is */ +/* set to zero. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangular matrix A, packed columnwise in */ +/* a linear array. The j-th column of A is stored in the array */ +/* AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* Note that when DIAG = 'U', the elements of the array AP */ +/* corresponding to the diagonal elements of the matrix A are */ +/* not referenced, but are assumed to be one. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* referenced. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --work; + --ap; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + k = 1; + if (lsame_(diag, "U")) { + value = 1.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 2; + for (i__ = k; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); + value = std::max(d__2,d__3); +/* L10: */ + } + k += j; +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k + 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); + value = std::max(d__2,d__3); +/* L30: */ + } + k = k + *n - j + 1; +/* L40: */ + } + } + } else { + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); + value = std::max(d__2,d__3); +/* L50: */ + } + k += j; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); + value = std::max(d__2,d__3); +/* L70: */ + } + k = k + *n - j + 1; +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + k = 1; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; + i__2 = k + j - 2; + for (i__ = k; i__ <= i__2; ++i__) { + sum += (d__1 = ap[i__], abs(d__1)); +/* L90: */ + } + } else { + sum = 0.; + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { + sum += (d__1 = ap[i__], abs(d__1)); +/* L100: */ + } + } + k += j; + value = std::max(value,sum); +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; + i__2 = k + *n - j; + for (i__ = k + 1; i__ <= i__2; ++i__) { + sum += (d__1 = ap[i__], abs(d__1)); +/* L120: */ + } + } else { + sum = 0.; + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { + sum += (d__1 = ap[i__], abs(d__1)); +/* L130: */ + } + } + k = k + *n - j + 1; + value = std::max(value,sum); +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + k = 1; + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = ap[k], abs(d__1)); + ++k; +/* L160: */ + } + ++k; +/* L170: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = ap[k], abs(d__1)); + ++k; +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L210: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ++k; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = ap[k], abs(d__1)); + ++k; +/* L220: */ + } +/* L230: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L240: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + work[i__] += (d__1 = ap[k], abs(d__1)); + ++k; +/* L250: */ + } +/* L260: */ + } + } + } + value = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L270: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + scale = 1.; + sum = (double) (*n); + k = 2; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); + k += j; +/* L280: */ + } + } else { + scale = 0.; + sum = 1.; + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dlassq_(&j, &ap[k], &c__1, &scale, &sum); + k += j; +/* L290: */ + } + } + } else { + if (lsame_(diag, "U")) { + scale = 1.; + sum = (double) (*n); + k = 2; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); + k = k + *n - j + 1; +/* L300: */ + } + } else { + scale = 0.; + sum = 1.; + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j + 1; + dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); + k = k + *n - j + 1; +/* L310: */ + } + } + } + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANTP */ + +} /* dlantp_ */ + +/* Subroutine */ double dlantr_(const char *norm, const char *uplo, const char *diag, integer *m, integer *n, + double *a, integer *lda, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + double ret_val, d__1, d__2, d__3; + + /* Local variables */ + integer i__, j; + double sum, scale; + bool udiag; + double value; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANTR returns the value of the one norm, or the Frobenius norm, or */ +/* the infinity norm, or the element of largest absolute value of a */ +/* trapezoidal or triangular matrix A. */ + +/* Description */ +/* =========== */ + +/* DLANTR returns the value */ + +/* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ +/* ( */ +/* ( norm1(A), NORM = '1', 'O' or 'o' */ +/* ( */ +/* ( normI(A), NORM = 'I' or 'i' */ +/* ( */ +/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ + +/* where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies the value to be returned in DLANTR as described */ +/* above. */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the matrix A is upper or lower trapezoidal. */ +/* = 'U': Upper trapezoidal */ +/* = 'L': Lower trapezoidal */ +/* Note that A is triangular instead of trapezoidal if M = N. */ + +/* DIAG (input) CHARACTER*1 */ +/* Specifies whether or not the matrix A has unit diagonal. */ +/* = 'N': Non-unit diagonal */ +/* = 'U': Unit diagonal */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. M >= 0, and if */ +/* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix A. N >= 0, and if */ +/* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The trapezoidal matrix A (A is triangular if M = N). */ +/* If UPLO = 'U', the leading m by n upper trapezoidal part of */ +/* the array A contains the upper trapezoidal matrix, and the */ +/* strictly lower triangular part of A is not referenced. */ +/* If UPLO = 'L', the leading m by n lower trapezoidal part of */ +/* the array A contains the lower trapezoidal matrix, and the */ +/* strictly upper triangular part of A is not referenced. Note */ +/* that when DIAG = 'U', the diagonal elements of A are not */ +/* referenced and are assumed to be one. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(M,1). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ +/* referenced. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + + /* Function Body */ + if (std::min(*m,*n) == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find max(abs(A(i,j))). */ + + if (lsame_(diag, "U")) { + value = 1.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = std::min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( + d__1)); + value = std::max(d__2,d__3); +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( + d__1)); + value = std::max(d__2,d__3); +/* L30: */ + } +/* L40: */ + } + } + } else { + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = std::min(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( + d__1)); + value = std::max(d__2,d__3); +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( + d__1)); + value = std::max(d__2,d__3); +/* L70: */ + } +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag && j <= *m) { + sum = 1.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L90: */ + } + } else { + sum = 0.; + i__2 = std::min(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L100: */ + } + } + value = std::max(value,sum); +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L120: */ + } + } else { + sum = 0.; + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L130: */ + } + } + value = std::max(value,sum); +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = std::min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L160: */ + } +/* L170: */ + } + } else { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = std::min(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L210: */ + } + i__1 = *m; + for (i__ = *n + 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L220: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L230: */ + } +/* L240: */ + } + } else { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L250: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); +/* L260: */ + } +/* L270: */ + } + } + } + value = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = value, d__2 = work[i__]; + value = std::max(d__1,d__2); +/* L280: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + scale = 1.; + sum = (double) std::min(*m,*n); + i__1 = *n; + for (j = 2; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = std::min(i__3,i__4); + dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); +/* L290: */ + } + } else { + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = std::min(*m,j); + dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); +/* L300: */ + } + } + } else { + if (lsame_(diag, "U")) { + scale = 1.; + sum = (double) std::min(*m,*n); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m - j; +/* Computing MIN */ + i__3 = *m, i__4 = j + 1; + dlassq_(&i__2, &a[std::min(i__3, i__4)+ j * a_dim1], &c__1, & + scale, &sum); +/* L310: */ + } + } else { + scale = 0.; + sum = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m - j + 1; + dlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum); +/* L320: */ + } + } + } + value = scale * sqrt(sum); + } + + ret_val = value; + return ret_val; + +/* End of DLANTR */ + +} /* dlantr_ */ + +/* Subroutine */ int dlanv2_(double *a, double *b, double *c__, + double *d__, double *rt1r, double *rt1i, double *rt2r, + double *rt2i, double *cs, double *sn) +{ + /* Table of constant values */ + static double c_b4 = 1.; + + /* System generated locals */ + double d__1, d__2; + + /* Builtin functions + double d_sign(double *, double *), sqrt(double); */ + + /* Local variables */ + double p, z__, aa, bb, cc, dd, cs1, sn1, sab, sac, eps, tau, temp, + scale, bcmax, bcmis, sigma; + + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric */ +/* matrix in standard form: */ + +/* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */ +/* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */ + +/* where either */ +/* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */ +/* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */ +/* conjugate eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* A (input/output) DOUBLE PRECISION */ +/* B (input/output) DOUBLE PRECISION */ +/* C (input/output) DOUBLE PRECISION */ +/* D (input/output) DOUBLE PRECISION */ +/* On entry, the elements of the input matrix. */ +/* On exit, they are overwritten by the elements of the */ +/* standardised Schur form. */ + +/* RT1R (output) DOUBLE PRECISION */ +/* RT1I (output) DOUBLE PRECISION */ +/* RT2R (output) DOUBLE PRECISION */ +/* RT2I (output) DOUBLE PRECISION */ +/* The real and imaginary parts of the eigenvalues. If the */ +/* eigenvalues are a complex conjugate pair, RT1I > 0. */ + +/* CS (output) DOUBLE PRECISION */ +/* SN (output) DOUBLE PRECISION */ +/* Parameters of the rotation matrix. */ + +/* Further Details */ +/* =============== */ + +/* Modified by V. Sima, Research Institute for Informatics, Bucharest, */ +/* Romania, to reduce the risk of cancellation errors, */ +/* when computing real eigenvalues, and to ensure, if possible, that */ +/* abs(RT1R) >= abs(RT2R). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + eps = dlamch_("P"); + if (*c__ == 0.) { + *cs = 1.; + *sn = 0.; + goto L10; + + } else if (*b == 0.) { + +/* Swap rows and columns */ + + *cs = 0.; + *sn = 1.; + temp = *d__; + *d__ = *a; + *a = temp; + *b = -(*c__); + *c__ = 0.; + goto L10; + } else if (*a - *d__ == 0. && d_sign(&c_b4, b) != d_sign(&c_b4, c__)) { + *cs = 1.; + *sn = 0.; + goto L10; + } else { + + temp = *a - *d__; + p = temp * .5; +/* Computing MAX */ + d__1 = abs(*b), d__2 = abs(*c__); + bcmax = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = abs(*b), d__2 = abs(*c__); + bcmis = std::min(d__1,d__2) * d_sign(&c_b4, b) * d_sign(&c_b4, c__); +/* Computing MAX */ + d__1 = abs(p); + scale = std::max(d__1,bcmax); + z__ = p / scale * p + bcmax / scale * bcmis; + +/* If Z is of the order of the machine accuracy, postpone the */ +/* decision on the nature of eigenvalues */ + + if (z__ >= eps * 4.) { + +/* Real eigenvalues. Compute A and D. */ + + d__1 = sqrt(scale) * sqrt(z__); + z__ = p + d_sign(&d__1, &p); + *a = *d__ + z__; + *d__ -= bcmax / z__ * bcmis; + +/* Compute B and the rotation matrix */ + + tau = dlapy2_(c__, &z__); + *cs = z__ / tau; + *sn = *c__ / tau; + *b -= *c__; + *c__ = 0.; + } else { + +/* Complex eigenvalues, or real (almost) equal eigenvalues. */ +/* Make diagonal elements equal. */ + + sigma = *b + *c__; + tau = dlapy2_(&sigma, &temp); + *cs = sqrt((abs(sigma) / tau + 1.) * .5); + *sn = -(p / (tau * *cs)) * d_sign(&c_b4, &sigma); + +/* Compute [ AA BB ] = [ A B ] [ CS -SN ] */ +/* [ CC DD ] [ C D ] [ SN CS ] */ + + aa = *a * *cs + *b * *sn; + bb = -(*a) * *sn + *b * *cs; + cc = *c__ * *cs + *d__ * *sn; + dd = -(*c__) * *sn + *d__ * *cs; + +/* Compute [ A B ] = [ CS SN ] [ AA BB ] */ +/* [ C D ] [-SN CS ] [ CC DD ] */ + + *a = aa * *cs + cc * *sn; + *b = bb * *cs + dd * *sn; + *c__ = -aa * *sn + cc * *cs; + *d__ = -bb * *sn + dd * *cs; + + temp = (*a + *d__) * .5; + *a = temp; + *d__ = temp; + + if (*c__ != 0.) { + if (*b != 0.) { + if (d_sign(&c_b4, b) == d_sign(&c_b4, c__)) { + +/* Real eigenvalues: reduce to upper triangular form */ + + sab = sqrt((abs(*b))); + sac = sqrt((abs(*c__))); + d__1 = sab * sac; + p = d_sign(&d__1, c__); + tau = 1. / sqrt((d__1 = *b + *c__, abs(d__1))); + *a = temp + p; + *d__ = temp - p; + *b -= *c__; + *c__ = 0.; + cs1 = sab * tau; + sn1 = sac * tau; + temp = *cs * cs1 - *sn * sn1; + *sn = *cs * sn1 + *sn * cs1; + *cs = temp; + } + } else { + *b = -(*c__); + *c__ = 0.; + temp = *cs; + *cs = -(*sn); + *sn = temp; + } + } + } + + } + +L10: + +/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */ + + *rt1r = *a; + *rt2r = *d__; + if (*c__ == 0.) { + *rt1i = 0.; + *rt2i = 0.; + } else { + *rt1i = sqrt((abs(*b))) * sqrt((abs(*c__))); + *rt2i = -(*rt1i); + } + return 0; + +/* End of DLANV2 */ + +} /* dlanv2_ */ + +/* Subroutine */ int dlapll_(integer *n, double *x, integer *incx, + double *y, integer *incy, double *ssmin) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + double c__, a11, a12, a22, tau; + double ssmax; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Given two column vectors X and Y, let */ + +/* A = ( X Y ). */ + +/* The subroutine first computes the QR factorization of A = Q*R, */ +/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */ +/* The smaller singular value of R is returned in SSMIN, which is used */ +/* as the measurement of the linear dependency of the vectors X and Y. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The length of the vectors X and Y. */ + +/* X (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCX) */ +/* On entry, X contains the N-vector X. */ +/* On exit, X is overwritten. */ + +/* INCX (input) INTEGER */ +/* The increment between successive elements of X. INCX > 0. */ + +/* Y (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCY) */ +/* On entry, Y contains the N-vector Y. */ +/* On exit, Y is overwritten. */ + +/* INCY (input) INTEGER */ +/* The increment between successive elements of Y. INCY > 0. */ + +/* SSMIN (output) DOUBLE PRECISION */ +/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + if (*n <= 1) { + *ssmin = 0.; + return 0; + } + +/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */ + + dlarfg_(n, &x[1], &x[*incx + 1], incx, &tau); + a11 = x[1]; + x[1] = 1.; + + c__ = -tau * ddot_(n, &x[1], incx, &y[1], incy); + daxpy_(n, &c__, &x[1], incx, &y[1], incy); + + i__1 = *n - 1; + dlarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau); + + a12 = y[1]; + a22 = y[*incy + 1]; + +/* Compute the SVD of 2-by-2 Upper triangular matrix. */ + + dlas2_(&a11, &a12, &a22, ssmin, &ssmax); + + return 0; + +/* End of DLAPLL */ + +} /* dlapll_ */ + +/* Subroutine */ int dlapmt_(bool *forwrd, integer *m, integer *n, + double *x, integer *ldx, integer *k) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, ii, in; + double temp; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAPMT rearranges the columns of the M by N matrix X as specified */ +/* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. */ +/* If FORWRD = .TRUE., forward permutation: */ + +/* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. */ + +/* If FORWRD = .FALSE., backward permutation: */ + +/* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. */ + +/* Arguments */ +/* ========= */ + +/* FORWRD (input) LOGICAL */ +/* = .TRUE., forward permutation */ +/* = .FALSE., backward permutation */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix X. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix X. N >= 0. */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */ +/* On entry, the M by N matrix X. */ +/* On exit, X contains the permuted matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X, LDX >= MAX(1,M). */ + +/* K (input/output) INTEGER array, dimension (N) */ +/* On entry, K contains the permutation vector. K is used as */ +/* internal workspace, but reset to its original value on */ +/* output. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --k; + + /* Function Body */ + if (*n <= 1) { + return 0; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + k[i__] = -k[i__]; +/* L10: */ + } + + if (*forwrd) { + +/* Forward permutation */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L40; + } + + j = i__; + k[j] = -k[j]; + in = k[j]; + +L20: + if (k[in] > 0) { + goto L40; + } + + i__2 = *m; + for (ii = 1; ii <= i__2; ++ii) { + temp = x[ii + j * x_dim1]; + x[ii + j * x_dim1] = x[ii + in * x_dim1]; + x[ii + in * x_dim1] = temp; +/* L30: */ + } + + k[in] = -k[in]; + j = in; + in = k[in]; + goto L20; + +L40: + +/* L50: */ + ; + } + + } else { + +/* Backward permutation */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L80; + } + + k[i__] = -k[i__]; + j = k[i__]; +L60: + if (j == i__) { + goto L80; + } + + i__2 = *m; + for (ii = 1; ii <= i__2; ++ii) { + temp = x[ii + i__ * x_dim1]; + x[ii + i__ * x_dim1] = x[ii + j * x_dim1]; + x[ii + j * x_dim1] = temp; +/* L70: */ + } + + k[j] = -k[j]; + j = k[j]; + goto L60; + +L80: + +/* L90: */ + ; + } + + } + + return 0; + +/* End of DLAPMT */ + +} /* dlapmt_ */ + +/* Subroutine */ double dlapy2_(double *x, double *y) +{ + /* System generated locals */ + double ret_val, d__1; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + double w, z__, xabs, yabs; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + xabs = abs(*x); + yabs = abs(*y); + w = std::max(xabs,yabs); + z__ = std::min(xabs,yabs); + if (z__ == 0.) { + ret_val = w; + } else { +/* Computing 2nd power */ + d__1 = z__ / w; + ret_val = w * sqrt(d__1 * d__1 + 1.); + } + return ret_val; + +/* End of DLAPY2 */ + +} /* dlapy2_ */ + +/* Subroutine */ double dlapy3_(double *x, double *y, double *z__) +{ + /* System generated locals */ + double ret_val, d__1, d__2, d__3; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + double w, xabs, yabs, zabs; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + xabs = abs(*x); + yabs = abs(*y); + zabs = abs(*z__); +/* Computing MAX */ + d__1 = std::max(xabs,yabs); + w = std::max(d__1,zabs); + if (w == 0.) { +/* W can be zero for max(0_integer,nan,0) */ +/* adding all three entries together will make sure */ +/* NaN will not disappear. */ + ret_val = xabs + yabs + zabs; + } else { +/* Computing 2nd power */ + d__1 = xabs / w; +/* Computing 2nd power */ + d__2 = yabs / w; +/* Computing 2nd power */ + d__3 = zabs / w; + ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3); + } + return ret_val; + +/* End of DLAPY3 */ + +} /* dlapy3_ */ + +/* Subroutine */ int dlaqgb_(integer *m, integer *n, integer *kl, integer *ku, + double *ab, integer *ldab, double *r__, double *c__, + double *rowcnd, double *colcnd, double *amax, char *equed) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + integer i__, j; + double cj, large, small; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQGB equilibrates a general M by N band matrix A with KL */ +/* subdiagonals and KU superdiagonals using the row and scaling factors */ +/* in the vectors R and C. */ + +/* 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. */ + +/* KL (input) INTEGER */ +/* The number of subdiagonals within the band of A. KL >= 0. */ + +/* KU (input) INTEGER */ +/* The number of superdiagonals within the band of A. KU >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* The j-th column of A is stored in the j-th column of the */ +/* array AB as follows: */ +/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */ + +/* On exit, the equilibrated matrix, in the same storage format */ +/* as A. See EQUED for the form of the equilibrated matrix. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDA >= KL+KU+1. */ + +/* R (input) DOUBLE PRECISION array, dimension (M) */ +/* The row scale factors for A. */ + +/* C (input) DOUBLE PRECISION array, dimension (N) */ +/* The column scale factors for A. */ + +/* ROWCND (input) DOUBLE PRECISION */ +/* Ratio of the smallest R(i) to the largest R(i). */ + +/* COLCND (input) DOUBLE PRECISION */ +/* Ratio of the smallest C(i) to the largest C(i). */ + +/* AMAX (input) DOUBLE PRECISION */ +/* Absolute value of largest matrix entry. */ + +/* EQUED (output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration */ +/* = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* diag(R). */ +/* = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* by diag(C). */ +/* = 'B': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(R) * A * diag(C). */ + +/* Internal Parameters */ +/* =================== */ + +/* THRESH is a threshold value used to decide if row or column scaling */ +/* should be done based on the ratio of the row or column scaling */ +/* factors. If ROWCND < THRESH, row scaling is done, and if */ +/* COLCND < THRESH, column scaling is done. */ + +/* LARGE and SMALL are threshold values used to decide if row scaling */ +/* should be done based on the absolute size of the largest matrix */ +/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*rowcnd >= .1 && *amax >= small && *amax <= large) { + +/* No row scaling */ + + if (*colcnd >= .1) { + +/* No column scaling */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = std::min(i__5,i__6); + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * ab[*ku + 1 + + i__ - j + j * ab_dim1]; +/* L10: */ + } +/* L20: */ + } + *(unsigned char *)equed = 'C'; + } + } else if (*colcnd >= .1) { + +/* Row scaling, no column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = std::min(i__5,i__6); + for (i__ = std::max(i__4,i__2); i__ <= i__3; ++i__) { + ab[*ku + 1 + i__ - j + j * ab_dim1] = r__[i__] * ab[*ku + 1 + + i__ - j + j * ab_dim1]; +/* L30: */ + } +/* L40: */ + } + *(unsigned char *)equed = 'R'; + } else { + +/* Row and column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = std::min(i__5,i__6); + for (i__ = std::max(i__3,i__4); i__ <= i__2; ++i__) { + ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * r__[i__] * ab[*ku + + 1 + i__ - j + j * ab_dim1]; +/* L50: */ + } +/* L60: */ + } + *(unsigned char *)equed = 'B'; + } + + return 0; + +/* End of DLAQGB */ + +} /* dlaqgb_ */ + +/* Subroutine */ int dlaqge_(integer *m, integer *n, double *a, integer * + lda, double *r__, double *c__, double *rowcnd, double + *colcnd, double *amax, char *equed) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + double cj, large, small; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQGE equilibrates a general M by N matrix A using the row and */ +/* column scaling factors in the vectors R and C. */ + +/* 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 equilibrated matrix. See EQUED for the form of */ +/* the equilibrated matrix. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(M,1). */ + +/* R (input) DOUBLE PRECISION array, dimension (M) */ +/* The row scale factors for A. */ + +/* C (input) DOUBLE PRECISION array, dimension (N) */ +/* The column scale factors for A. */ + +/* ROWCND (input) DOUBLE PRECISION */ +/* Ratio of the smallest R(i) to the largest R(i). */ + +/* COLCND (input) DOUBLE PRECISION */ +/* Ratio of the smallest C(i) to the largest C(i). */ + +/* AMAX (input) DOUBLE PRECISION */ +/* Absolute value of largest matrix entry. */ + +/* EQUED (output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration */ +/* = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* diag(R). */ +/* = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* by diag(C). */ +/* = 'B': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(R) * A * diag(C). */ + +/* Internal Parameters */ +/* =================== */ + +/* THRESH is a threshold value used to decide if row or column scaling */ +/* should be done based on the ratio of the row or column scaling */ +/* factors. If ROWCND < THRESH, row scaling is done, and if */ +/* COLCND < THRESH, column scaling is done. */ + +/* LARGE and SMALL are threshold values used to decide if row scaling */ +/* should be done based on the absolute size of the largest matrix */ +/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --r__; + --c__; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*rowcnd >= .1 && *amax >= small && *amax <= large) { + +/* No row scaling */ + + if (*colcnd >= .1) { + +/* No column scaling */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = cj * a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + *(unsigned char *)equed = 'C'; + } + } else if (*colcnd >= .1) { + +/* Row scaling, no column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = r__[i__] * a[i__ + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + *(unsigned char *)equed = 'R'; + } else { + +/* Row and column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = cj * r__[i__] * a[i__ + j * a_dim1]; +/* L50: */ + } +/* L60: */ + } + *(unsigned char *)equed = 'B'; + } + + return 0; + +/* End of DLAQGE */ + +} /* dlaqge_ */ + +/* Subroutine */ int dlaqp2_(integer *m, integer *n, integer *offset, + double *a, integer *lda, integer *jpvt, double *tau, + double *vn1, double *vn2, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1, d__2; + + /* Local variables */ + integer i__, j, mn; + double aii; + integer pvt; + double temp; + double temp2, tol3z; + integer offpi, itemp; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQP2 computes a QR factorization with column pivoting of */ +/* the block A(OFFSET+1:M,1:N). */ +/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ + +/* 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. */ + +/* OFFSET (input) INTEGER */ +/* The number of rows of the matrix A that must be pivoted */ +/* but no factorized. OFFSET >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */ +/* the triangular factor obtained; the elements in block */ +/* A(OFFSET+1:M,1:N) below the diagonal, together with the */ +/* array TAU, represent the orthogonal matrix Q as a product of */ +/* elementary reflectors. Block A(1:OFFSET,1:N) has been */ +/* accordingly pivoted, but no factorized. */ + +/* 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. */ + +/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */ +/* The vector with the partial column norms. */ + +/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */ +/* The vector with the exact column norms. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* X. Sun, Computer Science Dept., Duke University, USA */ + +/* Partial column norm updating strategy modified by */ +/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* University of Zagreb, Croatia. */ +/* June 2006. */ +/* For more details see LAPACK Working Note 176. */ +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --jpvt; + --tau; + --vn1; + --vn2; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *m - *offset; + mn = std::min(i__1,*n); + tol3z = sqrt(dlamch_("Epsilon")); + +/* Compute factorization. */ + + i__1 = mn; + for (i__ = 1; i__ <= i__1; ++i__) { + + offpi = *offset + i__; + +/* Determine ith pivot column and swap if necessary. */ + + i__2 = *n - i__ + 1; + pvt = i__ - 1 + idamax_(&i__2, &vn1[i__], &c__1); + + if (pvt != i__) { + dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[i__]; + jpvt[i__] = itemp; + vn1[pvt] = vn1[i__]; + vn2[pvt] = vn2[i__]; + } + +/* Generate elementary reflector H(i). */ + + if (offpi < *m) { + i__2 = *m - offpi + 1; + dlarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ * + a_dim1], &c__1, &tau[i__]); + } else { + dlarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], & + c__1, &tau[i__]); + } + + if (i__ <= *n) { + +/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */ + + aii = a[offpi + i__ * a_dim1]; + a[offpi + i__ * a_dim1] = 1.; + i__2 = *m - offpi + 1; + i__3 = *n - i__; + dlarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, & + tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]); + a[offpi + i__ * a_dim1] = aii; + } + +/* Update partial column norms. */ + + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + d__2 = (d__1 = a[offpi + j * a_dim1], abs(d__1)) / vn1[j]; + temp = 1. - d__2 * d__2; + temp = std::max(temp,0.); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + if (offpi < *m) { + i__3 = *m - offpi; + vn1[j] = dnrm2_(&i__3, &a[offpi + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + } else { + vn1[j] = 0.; + vn2[j] = 0.; + } + } else { + vn1[j] *= sqrt(temp); + } + } +/* L10: */ + } + +/* L20: */ + } + + return 0; + +/* End of DLAQP2 */ + +} /* dlaqp2_ */ + +/* Subroutine */ int dlaqps_(integer *m, integer *n, integer *offset, integer + *nb, integer *kb, double *a, integer *lda, integer *jpvt, + double *tau, double *vn1, double *vn2, double *auxv, + double *f, integer *ldf) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b8 = -1.; + static double c_b9 = 1.; + static double c_b16 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer j, k, rk; + double akk; + integer pvt; + double temp; + double temp2, tol3z; + integer itemp; + integer lsticc, lastrk; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQPS computes a step of QR factorization with column pivoting */ +/* of a real M-by-N matrix A by using Blas-3. It tries to factorize */ +/* NB columns from A starting from the row OFFSET+1, and updates all */ +/* of the matrix with Blas-3 xGEMM. */ + +/* In some cases, due to catastrophic cancellations, it cannot */ +/* factorize NB columns. Hence, the actual number of factorized */ +/* columns is returned in KB. */ + +/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ + +/* 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 */ + +/* OFFSET (input) INTEGER */ +/* The number of rows of A that have been factorized in */ +/* previous steps. */ + +/* NB (input) INTEGER */ +/* The number of columns to factorize. */ + +/* KB (output) INTEGER */ +/* The number of columns actually factorized. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */ +/* factor obtained and block A(1:OFFSET,1:N) has been */ +/* accordingly pivoted, but no factorized. */ +/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */ +/* been updated. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* JPVT (input/output) INTEGER array, dimension (N) */ +/* JPVT(I) = K <==> Column K of the full matrix A has been */ +/* permuted into position I in AP. */ + +/* TAU (output) DOUBLE PRECISION array, dimension (KB) */ +/* The scalar factors of the elementary reflectors. */ + +/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */ +/* The vector with the partial column norms. */ + +/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */ +/* The vector with the exact column norms. */ + +/* AUXV (input/output) DOUBLE PRECISION array, dimension (NB) */ +/* Auxiliar vector. */ + +/* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB) */ +/* Matrix F' = L*Y'*A. */ + +/* LDF (input) INTEGER */ +/* The leading dimension of the array F. LDF >= max(1,N). */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* X. Sun, Computer Science Dept., Duke University, USA */ + +/* Partial column norm updating strategy modified by */ +/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* University of Zagreb, Croatia. */ +/* June 2006. */ +/* For more details see LAPACK Working Note 176. */ +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --jpvt; + --tau; + --vn1; + --vn2; + --auxv; + f_dim1 = *ldf; + f_offset = 1 + f_dim1; + f -= f_offset; + + /* Function Body */ +/* Computing MIN */ + i__1 = *m, i__2 = *n + *offset; + lastrk = std::min(i__1,i__2); + lsticc = 0; + k = 0; + tol3z = sqrt(dlamch_("Epsilon")); + +/* Beginning of while loop. */ + +L10: + if (k < *nb && lsticc == 0) { + ++k; + rk = *offset + k; + +/* Determine ith pivot column and swap if necessary */ + + i__1 = *n - k + 1; + pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1); + if (pvt != k) { + dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + dswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[k]; + jpvt[k] = itemp; + vn1[pvt] = vn1[k]; + vn2[pvt] = vn2[k]; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */ + + if (k > 1) { + i__1 = *m - rk + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[rk + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b9, &a[rk + k * a_dim1], &c__1); + } + +/* Generate elementary reflector H(k). */ + + if (rk < *m) { + i__1 = *m - rk + 1; + dlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + dlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, & + tau[k]); + } + + akk = a[rk + k * a_dim1]; + a[rk + k * a_dim1] = 1.; + +/* Compute Kth column of F: */ + +/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */ + + if (k < *n) { + i__1 = *m - rk + 1; + i__2 = *n - k; + dgemv_("Transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 1) * + a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b16, &f[k + + 1 + k * f_dim1], &c__1); + } + +/* Padding F(1:K,K) with zeros. */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + f[j + k * f_dim1] = 0.; +/* L20: */ + } + +/* Incremental updating of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */ +/* *A(RK:M,K). */ + + if (k > 1) { + i__1 = *m - rk + 1; + i__2 = k - 1; + d__1 = -tau[k]; + dgemv_("Transpose", &i__1, &i__2, &d__1, &a[rk + a_dim1], lda, &a[ + rk + k * a_dim1], &c__1, &c_b16, &auxv[1], &c__1); + + i__1 = k - 1; + dgemv_("No transpose", n, &i__1, &c_b9, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b9, &f[k * f_dim1 + 1], &c__1); + } + +/* Update the current row of A: */ +/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("No transpose", &i__1, &k, &c_b8, &f[k + 1 + f_dim1], ldf, + &a[rk + a_dim1], lda, &c_b9, &a[rk + (k + 1) * a_dim1], + lda); + } + +/* Update partial column norms. */ + + if (rk < lastrk) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (d__1 = a[rk + j * a_dim1], abs(d__1)) / vn1[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = std::max(d__1,d__2); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + vn2[j] = (double) lsticc; + lsticc = j; + } else { + vn1[j] *= sqrt(temp); + } + } +/* L30: */ + } + } + + a[rk + k * a_dim1] = akk; + +/* End of while loop. */ + + goto L10; + } + *kb = k; + rk = *offset + *kb; + +/* Apply the block reflector to the rest of the matrix: */ +/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */ +/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */ + +/* Computing MIN */ + i__1 = *n, i__2 = *m - *offset; + if (*kb < std::min(i__1,i__2)) { + i__1 = *m - rk; + i__2 = *n - *kb; + dgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b8, &a[rk + + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b9, &a[rk + 1 + + (*kb + 1) * a_dim1], lda); + } + +/* Recomputation of difficult columns. */ + +L40: + if (lsticc > 0) { + itemp = i_dnnt(&vn2[lsticc]); + i__1 = *m - rk; + vn1[lsticc] = dnrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1); + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* SNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(DLAMCH('S')) */ + + vn2[lsticc] = vn1[lsticc]; + lsticc = itemp; + goto L40; + } + + return 0; + +/* End of DLAQPS */ + +} /* dlaqps_ */ + +/* Subroutine */ int dlaqr0_(bool *wantt, bool *wantz, integer *n, + integer *ilo, integer *ihi, double *h__, integer *ldh, double + *wr, double *wi, integer *iloz, integer *ihiz, double *z__, + integer *ldz, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__13 = 13; + static integer c__15 = 15; + static integer c_n1 = -1; + static integer c__12 = 12; + static integer c__14 = 14; + static integer c__16 = 16; + static bool c_false = false; + static integer c__1 = 1; + static integer c__3 = 3; + + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, k; + double aa, bb, cc, dd; + integer ld; + double cs; + integer nh, it, ks, kt; + double sn; + integer ku, kv, ls, ns; + double ss; + integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; + double swap; + integer ktop; + double zdum[1] /* was [1][1] */; + integer kacc22, itmax, nsmax, nwmax, kwtop; + integer nibble, nwupbd; + char jbcmpz[3]; + bool sorted; + integer lwkopt; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQR0 computes the eigenvalues of a Hessenberg matrix H */ +/* and, optionally, the matrices T and Z from the Schur decomposition */ +/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ +/* Schur form), and Z is the orthogonal matrix of Schur vectors. */ + +/* Optionally Z may be postmultiplied into an input orthogonal */ +/* matrix Q so that this routine can give the Schur factorization */ +/* of a matrix A which has been reduced to the Hessenberg form H */ +/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ + +/* Arguments */ +/* ========= */ + +/* WANTT (input) LOGICAL */ +/* = .TRUE. : the full Schur form T is required; */ +/* = .FALSE.: only eigenvalues are required. */ + +/* WANTZ (input) LOGICAL */ +/* = .TRUE. : the matrix of Schur vectors Z is required; */ +/* = .FALSE.: Schur vectors are not required. */ + +/* N (input) INTEGER */ +/* The order of the matrix H. N .GE. 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* It is assumed that H is already upper triangular in rows */ +/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */ +/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ +/* previous call to DGEBAL, and then passed to DGEHRD when the */ +/* matrix output by DGEBAL is reduced to Hessenberg form. */ +/* Otherwise, ILO and IHI should be set to 1 and N, */ +/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ +/* If N = 0, then ILO = 1 and IHI = 0. */ + +/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ +/* On entry, the upper Hessenberg matrix H. */ +/* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */ +/* the upper quasi-triangular matrix T from the Schur */ +/* decomposition (the Schur form); 2-by-2 diagonal blocks */ +/* (corresponding to complex conjugate pairs of eigenvalues) */ +/* are returned in standard form, with H(i,i) = H(i+1,i+1) */ +/* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */ +/* .FALSE., then the contents of H are unspecified on exit. */ +/* (The output value of H when INFO.GT.0 is given under the */ +/* description of INFO below.) */ + +/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */ +/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ + +/* LDH (input) INTEGER */ +/* The leading dimension of the array H. LDH .GE. max(1,N). */ + +/* WR (output) DOUBLE PRECISION array, dimension (IHI) */ +/* WI (output) DOUBLE PRECISION array, dimension (IHI) */ +/* The real and imaginary parts, respectively, of the computed */ +/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */ +/* and WI(ILO:IHI). If two eigenvalues are computed as a */ +/* complex conjugate pair, they are stored in consecutive */ +/* elements of WR and WI, say the i-th and (i+1)th, with */ +/* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */ +/* the eigenvalues are stored in the same order as on the */ +/* diagonal of the Schur form returned in H, with */ +/* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */ +/* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ +/* WI(i+1) = -WI(i). */ + +/* ILOZ (input) INTEGER */ +/* IHIZ (input) INTEGER */ +/* Specify the rows of Z to which transformations must be */ +/* applied if WANTZ is .TRUE.. */ +/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */ +/* If WANTZ is .FALSE., then Z is not referenced. */ +/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ +/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ +/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ +/* (The output value of Z when INFO.GT.0 is given under */ +/* the description of INFO below.) */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. if WANTZ is .TRUE. */ +/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK */ +/* On exit, if LWORK = -1, WORK(1) returns an estimate of */ +/* the optimal value for LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK .GE. max(1,N) */ +/* is sufficient, but LWORK typically as large as 6*N may */ +/* be required for optimal performance. A workspace query */ +/* to determine the optimal workspace size is recommended. */ + +/* If LWORK = -1, then DLAQR0 does a workspace query. */ +/* In this case, DLAQR0 checks the input parameters and */ +/* estimates the optimal workspace size for the given */ +/* values of N, ILO and IHI. The estimate is returned */ +/* in WORK(1). No error message related to LWORK is */ +/* issued by XERBLA. Neither H nor Z are accessed. */ + + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* .GT. 0: if INFO = i, DLAQR0 failed to compute all of */ +/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ +/* and WI contain those eigenvalues which have been */ +/* successfully computed. (Failures are rare.) */ + +/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */ +/* the remaining unconverged eigenvalues are the eigen- */ +/* values of the upper Hessenberg matrix rows and */ +/* columns ILO through INFO of the final, output */ +/* value of H. */ + +/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */ + +/* (*) (initial value of H)*U = U*(final value of H) */ + +/* where U is an orthogonal matrix. The final */ +/* value of H is upper Hessenberg and quasi-triangular */ +/* in rows and columns INFO+1 through IHI. */ + +/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */ + +/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */ +/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ + +/* where U is the orthogonal matrix in (*) (regard- */ +/* less of the value of WANTT.) */ + +/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */ +/* accessed. */ + +/* ================================================================ */ +/* Based on contributions by */ +/* Karen Braman and Ralph Byers, Department of Mathematics, */ +/* University of Kansas, USA */ + +/* ================================================================ */ +/* References: */ +/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* 929--947, 2002. */ + +/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* of Matrix Analysis, volume 23, pages 948--973, 2002. */ + +/* ================================================================ */ +/* .. Parameters .. */ + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . DLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== Exceptional deflation windows: try to cure rare */ +/* . slow convergence by varying the size of the */ +/* . deflation window after KEXNW iterations. ==== */ + +/* ==== Exceptional shifts: try to cure rare slow convergence */ +/* . with ad-hoc exceptional shifts every KEXSH iterations. */ +/* . ==== */ + +/* ==== The constants WILK1 and WILK2 are used to form the */ +/* . exceptional shifts. ==== */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* ==== Quick return for N = 0: nothing to do. ==== */ + + if (*n == 0) { + work[1] = 1.; + return 0; + } + + if (*n <= 11) { + +/* ==== Tiny matrices must use DLAHQR. ==== */ + + lwkopt = 1; + if (*lwork != -1) { + dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & + wi[1], iloz, ihiz, &z__[z_offset], ldz, info); + } + } else { + +/* ==== Use small bulge multi-shift QR with aggressive early */ +/* . deflation on larger-than-tiny matrices. ==== */ + +/* ==== Hope for the best. ==== */ + + *info = 0; + +/* ==== Set up job flags for ILAENV. ==== */ + + if (*wantt) { + * (unsigned char *) & jbcmpz [0] = 'S'; + } else { + * (unsigned char *) & jbcmpz [0] = 'E'; + } + if (*wantz) { + * (unsigned char *) & jbcmpz [1] = 'V'; + } else { + * (unsigned char *) & jbcmpz [1] = 'N'; + } + jbcmpz [2] = '\0'; +/* ==== NWR = recommended deflation window size. At this */ +/* . point, N .GT. NTINY = 11, so there is enough */ +/* . subdiagonal workspace for NWR.GE.2 as required. */ +/* . (In fact, there is enough subdiagonal space for */ +/* . NWR.GE.3.) ==== */ + + nwr = ilaenv_(&c__13, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + nwr = std::max(2_integer,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = std::min(i__1,i__2); + nwr = std::min(i__1,nwr); + +/* ==== NSR = recommended number of simultaneous shifts. */ +/* . At this point N .GT. NTINY = 11, so there is at */ +/* . enough subdiagonal workspace for NSR to be even */ +/* . and greater than or equal to two as required. ==== */ + + nsr = ilaenv_(&c__15, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = std::min(i__1,i__2), i__2 = *ihi - *ilo; + nsr = std::min(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = std::max(i__1,i__2); + +/* ==== Estimate optimal workspace ==== */ + +/* ==== Workspace query call to DLAQR3 ==== */ + + i__1 = nwr + 1; + dlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, + ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ + h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], + ldh, &work[1], &c_n1); + +/* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== */ + +/* Computing MAX */ + i__1 = nsr * 3 / 2, i__2 = (integer) work[1]; + lwkopt = std::max(i__1,i__2); + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + work[1] = (double) lwkopt; + return 0; + } + +/* ==== DLAHQR/DLAQR0 crossover point ==== */ + + nmin = ilaenv_(&c__12, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + nmin = std::max(11_integer,nmin); + +/* ==== Nibble crossover point ==== */ + + nibble = ilaenv_(&c__14, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + nibble = std::max(0_integer,nibble); + +/* ==== Accumulate reflections during ttswp? Use block */ +/* . 2-by-2 structure during matrix-matrix multiply? ==== */ + + kacc22 = ilaenv_(&c__16, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); + kacc22 = std::max(0_integer,kacc22); + kacc22 = std::min(2_integer,kacc22); + +/* ==== NWMAX = the largest possible deflation window for */ +/* . which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 1) / 3, i__2 = *lwork / 2; + nwmax = std::min(i__1,i__2); + nw = nwmax; + +/* ==== NSMAX = the Largest number of simultaneous shifts */ +/* . for which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3; + nsmax = std::min(i__1,i__2); + nsmax -= nsmax % 2; + +/* ==== NDFL: an iteration count restarted at deflation. ==== */ + + ndfl = 1; + +/* ==== ITMAX = iteration limit ==== */ + +/* Computing MAX */ + i__1 = 10, i__2 = *ihi - *ilo + 1; + itmax = std::max(i__1,i__2) * 30; + +/* ==== Last row and column in the active block ==== */ + + kbot = *ihi; + +/* ==== Main Loop ==== */ + + i__1 = itmax; + for (it = 1; it <= i__1; ++it) { + +/* ==== Done when KBOT falls below ILO ==== */ + + if (kbot < *ilo) { + goto L90; + } + +/* ==== Locate active block ==== */ + + i__2 = *ilo + 1; + for (k = kbot; k >= i__2; --k) { + if (h__[k + (k - 1) * h_dim1] == 0.) { + goto L20; + } +/* L10: */ + } + k = *ilo; +L20: + ktop = k; + +/* ==== Select deflation window size: */ +/* . Typical Case: */ +/* . If possible and advisable, nibble the entire */ +/* . active block. If not, use size MIN(NWR,NWMAX) */ +/* . or MIN(NWR+1,NWMAX) depending upon which has */ +/* . the smaller corresponding subdiagonal entry */ +/* . (a heuristic). */ +/* . */ +/* . Exceptional Case: */ +/* . If there have been no deflations in KEXNW or */ +/* . more iterations, then vary the deflation window */ +/* . size. At first, because, larger windows are, */ +/* . in general, more powerful than smaller ones, */ +/* . rapidly increase the window to the maximum possible. */ +/* . Then, gradually reduce the window size. ==== */ + + nh = kbot - ktop + 1; + nwupbd = std::min(nh,nwmax); + if (ndfl < 5) { + nw = std::min(nwupbd,nwr); + } else { +/* Computing MIN */ + i__2 =nwupbd, i__3 = nw << 1; + nw = std::min(i__2,i__3); + } + if (nw < nwmax) { + if (nw >= nh - 1) { + nw = nh; + } else { + kwtop = kbot - nw + 1; + if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) + > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], + abs(d__2))) { + ++nw; + } + } + } + if (ndfl < 5) { + ndec = -1; + } else if (ndec >= 0 || nw >= nwupbd) { + ++ndec; + if (nw - ndec < 2) { + ndec = 0; + } + nw -= ndec; + } + +/* ==== Aggressive early deflation: */ +/* . split workspace under the subdiagonal into */ +/* . - an nw-by-nw work array V in the lower */ +/* . left-hand-corner, */ +/* . - an NW-by-at-least-NW-but-more-is-better */ +/* . (NW-by-NHO) horizontal work array along */ +/* . the bottom edge, */ +/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ +/* . vertical work array along the left-hand-edge. */ +/* . ==== */ + + kv = *n - nw + 1; + kt = nw + 1; + nho = *n - nw - 1 - kt + 1; + kwv = nw + 2; + nve = *n - nw - kwv + 1; + +/* ==== Aggressive early deflation ==== */ + + dlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, + iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], + &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); + +/* ==== Adjust KBOT accounting for new deflations. ==== */ + + kbot -= ld; + +/* ==== KS points to the shifts. ==== */ + + ks = kbot - ls + 1; + +/* ==== Skip an expensive QR sweep if there is a (partly */ +/* . heuristic) reason to expect that many eigenvalues */ +/* . will deflate without it. Here, the QR sweep is */ +/* . skipped if many eigenvalues have just been deflated */ +/* . or if the remaining active block is small. */ + + if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > std::min( + nmin,nwmax)) { + +/* ==== NS = nominal number of simultaneous shifts. */ +/* . This may be lowered (slightly) if DLAQR3 */ +/* . did not provide that many shifts. ==== */ + +/* Computing MIN */ +/* Computing MAX */ + i__4 = 2, i__5 = kbot - ktop; + i__2 = std::min(nsmax,nsr), i__3 = std::max(i__4,i__5); + ns = std::min(i__2,i__3); + ns -= ns % 2; + +/* ==== If there have been no deflations */ +/* . in a multiple of KEXSH iterations, */ +/* . then try exceptional shifts. */ +/* . Otherwise use shifts provided by */ +/* . DLAQR3 above or from the eigenvalues */ +/* . of a trailing principal submatrix. ==== */ + + if (ndfl % 6 == 0) { + ks = kbot - ns + 1; +/* Computing MAX */ + i__3 = ks + 1, i__4 = ktop + 2; + i__2 = std::max(i__3,i__4); + for (i__ = kbot; i__ >= i__2; i__ += -2) { + ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], + abs(d__2)); + aa = ss * .75 + h__[i__ + i__ * h_dim1]; + bb = ss; + cc = ss * -.4375; + dd = aa; + dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] +, &wr[i__], &wi[i__], &cs, &sn); +/* L30: */ + } + if (ks == ktop) { + wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; + wi[ks + 1] = 0.; + wr[ks] = wr[ks + 1]; + wi[ks] = wi[ks + 1]; + } + } else { + +/* ==== Got NS/2 or fewer shifts? Use DLAQR4 or */ +/* . DLAHQR on a trailing principal submatrix to */ +/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */ +/* . there is enough space below the subdiagonal */ +/* . to fit an NS-by-NS scratch array.) ==== */ + + if (kbot - ks + 1 <= ns / 2) { + ks = kbot - ns + 1; + kt = *n - ns + 1; + dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & + h__[kt + h_dim1], ldh); + if (ns > nmin) { + dlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ + kt + h_dim1], ldh, &wr[ks], &wi[ks], & + c__1, &c__1, zdum, &c__1, &work[1], lwork, + &inf); + } else { + dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ + kt + h_dim1], ldh, &wr[ks], &wi[ks], & + c__1, &c__1, zdum, &c__1, &inf); + } + ks += inf; + +/* ==== In case of a rare QR failure use */ +/* . eigenvalues of the trailing 2-by-2 */ +/* . principal submatrix. ==== */ + + if (ks >= kbot) { + aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; + cc = h__[kbot + (kbot - 1) * h_dim1]; + bb = h__[kbot - 1 + kbot * h_dim1]; + dd = h__[kbot + kbot * h_dim1]; + dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ + kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) + ; + ks = kbot - 1; + } + } + + if (kbot - ks + 1 > ns) { + +/* ==== Sort the shifts (Helps a little) */ +/* . Bubble sort keeps complex conjugate */ +/* . pairs together. ==== */ + + sorted = false; + i__2 = ks + 1; + for (k = kbot; k >= i__2; --k) { + if (sorted) { + goto L60; + } + sorted = true; + i__3 = k - 1; + for (i__ = ks; i__ <= i__3; ++i__) { + if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[ + i__], abs(d__2)) < (d__3 = wr[i__ + 1] + , abs(d__3)) + (d__4 = wi[i__ + 1], + abs(d__4))) { + sorted = false; + + swap = wr[i__]; + wr[i__] = wr[i__ + 1]; + wr[i__ + 1] = swap; + + swap = wi[i__]; + wi[i__] = wi[i__ + 1]; + wi[i__ + 1] = swap; + } +/* L40: */ + } +/* L50: */ + } +L60: + ; + } + +/* ==== Shuffle shifts into pairs of real shifts */ +/* . and pairs of complex conjugate shifts */ +/* . assuming complex conjugate shifts are */ +/* . already adjacent to one another. (Yes, */ +/* . they are.) ==== */ + + i__2 = ks + 2; + for (i__ = kbot; i__ >= i__2; i__ += -2) { + if (wi[i__] != -wi[i__ - 1]) { + + swap = wr[i__]; + wr[i__] = wr[i__ - 1]; + wr[i__ - 1] = wr[i__ - 2]; + wr[i__ - 2] = swap; + + swap = wi[i__]; + wi[i__] = wi[i__ - 1]; + wi[i__ - 1] = wi[i__ - 2]; + wi[i__ - 2] = swap; + } +/* L70: */ + } + } + +/* ==== If there are only two shifts and both are */ +/* . real, then use only one. ==== */ + + if (kbot - ks + 1 == 2) { + if (wi[kbot] == 0.) { + if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs( + d__1)) < (d__2 = wr[kbot - 1] - h__[kbot + + kbot * h_dim1], abs(d__2))) { + wr[kbot - 1] = wr[kbot]; + } else { + wr[kbot] = wr[kbot - 1]; + } + } + } + +/* ==== Use up to NS of the the smallest magnatiude */ +/* . shifts. If there aren't NS shifts available, */ +/* . then use them all, possibly dropping one to */ +/* . make the number of shifts even. ==== */ + +/* Computing MIN */ + i__2 = ns, i__3 = kbot - ks + 1; + ns = std::min(i__2,i__3); + ns -= ns % 2; + ks = kbot - ns + 1; + +/* ==== Small-bulge multi-shift QR sweep: */ +/* . split workspace under the subdiagonal into */ +/* . - a KDU-by-KDU work array U in the lower */ +/* . left-hand-corner, */ +/* . - a KDU-by-at-least-KDU-but-more-is-better */ +/* . (KDU-by-NHo) horizontal work array WH along */ +/* . the bottom edge, */ +/* . - and an at-least-KDU-but-more-is-better-by-KDU */ +/* . (NVE-by-KDU) vertical work WV arrow along */ +/* . the left-hand-edge. ==== */ + + kdu = ns * 3 - 3; + ku = *n - kdu + 1; + kwh = kdu + 1; + nho = *n - kdu - 3 - (kdu + 1) + 1; + kwv = kdu + 4; + nve = *n - kdu - kwv + 1; + +/* ==== Small-bulge multi-shift QR sweep ==== */ + + dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], + &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ + z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + + kwh * h_dim1], ldh); + } + +/* ==== Note progress (or the lack of it). ==== */ + + if (ld > 0) { + ndfl = 1; + } else { + ++ndfl; + } + +/* ==== End of main loop ==== */ +/* L80: */ + } + +/* ==== Iteration limit exceeded. Set INFO to show where */ +/* . the problem occurred and exit. ==== */ + + *info = kbot; +L90: + ; + } + +/* ==== Return the optimal value of LWORK. ==== */ + + work[1] = (double) lwkopt; + +/* ==== End of DLAQR0 ==== */ + + return 0; +} /* dlaqr0_ */ + +/* Subroutine */ int dlaqr1_(integer *n, double *h__, integer *ldh, + double *sr1, double *si1, double *sr2, double *si2, + double *v) +{ + /* System generated locals */ + integer h_dim1, h_offset; + double d__1, d__2, d__3; + + /* Local variables */ + double s, h21s, h31s; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a */ +/* scalar multiple of the first column of the product */ + +/* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) */ + +/* scaling to avoid overflows and most underflows. It */ +/* is assumed that either */ + +/* 1) sr1 = sr2 and si1 = -si2 */ +/* or */ +/* 2) si1 = si2 = 0. */ + +/* This is useful for starting double implicit shift bulges */ +/* in the QR algorithm. */ + + +/* N (input) integer */ +/* Order of the matrix H. N must be either 2 or 3. */ + +/* H (input) DOUBLE PRECISION array of dimension (LDH,N) */ +/* The 2-by-2 or 3-by-3 matrix H in (*). */ + +/* LDH (input) integer */ +/* The leading dimension of H as declared in */ +/* the calling procedure. LDH.GE.N */ + +/* SR1 (input) DOUBLE PRECISION */ +/* SI1 The shifts in (*). */ +/* SR2 */ +/* SI2 */ + +/* V (output) DOUBLE PRECISION array of dimension N */ +/* A scalar multiple of the first column of the */ +/* matrix K in (*). */ + +/* ================================================================ */ +/* Based on contributions by */ +/* Karen Braman and Ralph Byers, Department of Mathematics, */ +/* University of Kansas, USA */ + +/* ================================================================ */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --v; + + /* Function Body */ + if (*n == 2) { + s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) + (d__2 = + h__[h_dim1 + 2], abs(d__2)); + if (s == 0.) { + v[1] = 0.; + v[2] = 0.; + } else { + h21s = h__[h_dim1 + 2] / s; + v[1] = h21s * h__[(h_dim1 << 1) + 1] + (h__[h_dim1 + 1] - *sr1) * + ((h__[h_dim1 + 1] - *sr2) / s) - *si1 * (*si2 / s); + v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - * + sr2); + } + } else { + s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) + (d__2 = + h__[h_dim1 + 2], abs(d__2)) + (d__3 = h__[h_dim1 + 3], abs( + d__3)); + if (s == 0.) { + v[1] = 0.; + v[2] = 0.; + v[3] = 0.; + } else { + h21s = h__[h_dim1 + 2] / s; + h31s = h__[h_dim1 + 3] / s; + v[1] = (h__[h_dim1 + 1] - *sr1) * ((h__[h_dim1 + 1] - *sr2) / s) + - *si1 * (*si2 / s) + h__[(h_dim1 << 1) + 1] * h21s + h__[ + h_dim1 * 3 + 1] * h31s; + v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - * + sr2) + h__[h_dim1 * 3 + 2] * h31s; + v[3] = h31s * (h__[h_dim1 + 1] + h__[h_dim1 * 3 + 3] - *sr1 - * + sr2) + h21s * h__[(h_dim1 << 1) + 3]; + } + } + return 0; +} /* dlaqr1_ */ + +/* Subroutine */ int dlaqr2_(bool *wantt, bool *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, + double *h__, integer *ldh, integer *iloz, integer *ihiz, double *z__, integer *ldz, + integer *ns, integer *nd, double *sr, double *si, double *v, integer *ldv, integer *nh, + double *t, integer *ldt, integer *nv, double *wv, integer *ldwv, double *work, integer *lwork) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b12 = 0.; + static double c_b13 = 1.; + static bool c_true = true; + + /* System generated locals */ + integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, + wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + integer i__, j, k; + double s, aa, bb, cc, dd, cs, sn; + integer jw; + double evi, evk, foo; + integer kln; + double tau, ulp; + integer lwk1, lwk2; + double beta; + integer kend, kcol, info, ifst, ilst, ltop, krow; + bool bulge; + integer infqr, kwtop; + double safmin; + double safmax; + bool sorted; + double smlnum; + integer lwkopt; + +/* -- LAPACK auxiliary routine (version 3.2.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ +/* -- April 2009 -- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* This subroutine is identical to DLAQR3 except that it avoids */ +/* recursion by calling DLAHQR instead of DLAQR4. */ + + +/* ****************************************************************** */ +/* Aggressive early deflation: */ + +/* This subroutine accepts as input an upper Hessenberg matrix */ +/* H and performs an orthogonal similarity transformation */ +/* designed to detect and deflate fully converged eigenvalues from */ +/* a trailing principal submatrix. On output H has been over- */ +/* written by a new Hessenberg matrix that is a perturbation of */ +/* an orthogonal similarity transformation of H. It is to be */ +/* hoped that the final version of H has many zero subdiagonal */ +/* entries. */ + +/* ****************************************************************** */ +/* WANTT (input) LOGICAL */ +/* If .TRUE., then the Hessenberg matrix H is fully updated */ +/* so that the quasi-triangular Schur factor may be */ +/* computed (in cooperation with the calling subroutine). */ +/* If .FALSE., then only enough of H is updated to preserve */ +/* the eigenvalues. */ + +/* WANTZ (input) LOGICAL */ +/* If .TRUE., then the orthogonal matrix Z is updated so */ +/* so that the orthogonal Schur factor may be computed */ +/* (in cooperation with the calling subroutine). */ +/* If .FALSE., then Z is not referenced. */ + +/* N (input) INTEGER */ +/* The order of the matrix H and (if WANTZ is .TRUE.) the */ +/* order of the orthogonal matrix Z. */ + +/* KTOP (input) INTEGER */ +/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ +/* KBOT and KTOP together determine an isolated block */ +/* along the diagonal of the Hessenberg matrix. */ + +/* KBOT (input) INTEGER */ +/* It is assumed without a check that either */ +/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ +/* determine an isolated block along the diagonal of the */ +/* Hessenberg matrix. */ + +/* NW (input) INTEGER */ +/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */ + +/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ +/* On input the initial N-by-N section of H stores the */ +/* Hessenberg matrix undergoing aggressive early deflation. */ +/* On output H has been transformed by an orthogonal */ +/* similarity transformation, perturbed, and the returned */ +/* to Hessenberg form that (it is to be hoped) has some */ +/* zero subdiagonal entries. */ + +/* LDH (input) integer */ +/* Leading dimension of H just as declared in the calling */ +/* subroutine. N .LE. LDH */ + +/* ILOZ (input) INTEGER */ +/* IHIZ (input) INTEGER */ +/* Specify the rows of Z to which transformations must be */ +/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* IF WANTZ is .TRUE., then on output, the orthogonal */ +/* similarity transformation mentioned above has been */ +/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */ +/* If WANTZ is .FALSE., then Z is unreferenced. */ + +/* LDZ (input) integer */ +/* The leading dimension of Z just as declared in the */ +/* calling subroutine. 1 .LE. LDZ. */ + +/* NS (output) integer */ +/* The number of unconverged (ie approximate) eigenvalues */ +/* returned in SR and SI that may be used as shifts by the */ +/* calling subroutine. */ + +/* ND (output) integer */ +/* The number of converged eigenvalues uncovered by this */ +/* subroutine. */ + +/* SR (output) DOUBLE PRECISION array, dimension KBOT */ +/* SI (output) DOUBLE PRECISION array, dimension KBOT */ +/* On output, the real and imaginary parts of approximate */ +/* eigenvalues that may be used for shifts are stored in */ +/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ +/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ +/* The real and imaginary parts of converged eigenvalues */ +/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */ +/* SI(KBOT-ND+1) through SI(KBOT), respectively. */ + +/* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) */ +/* An NW-by-NW work array. */ + +/* LDV (input) integer scalar */ +/* The leading dimension of V just as declared in the */ +/* calling subroutine. NW .LE. LDV */ + +/* NH (input) integer scalar */ +/* The number of columns of T. NH.GE.NW. */ + +/* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) */ + +/* LDT (input) integer */ +/* The leading dimension of T just as declared in the */ +/* calling subroutine. NW .LE. LDT */ + +/* NV (input) integer */ +/* The number of rows of work array WV available for */ +/* workspace. NV.GE.NW. */ + +/* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) */ + +/* LDWV (input) integer */ +/* The leading dimension of W just as declared in the */ +/* calling subroutine. NW .LE. LDV */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. */ +/* On exit, WORK(1) is set to an estimate of the optimal value */ +/* of LWORK for the given values of N, NW, KTOP and KBOT. */ + +/* LWORK (input) integer */ +/* The dimension of the work array WORK. LWORK = 2*NW */ +/* suffices, but greater efficiency may result from larger */ +/* values of LWORK. */ + +/* If LWORK = -1, then a workspace query is assumed; DLAQR2 */ +/* only estimates the optimal workspace size for the given */ +/* values of N, NW, KTOP and KBOT. The estimate is returned */ +/* in WORK(1). No error message related to LWORK is issued */ +/* by XERBLA. Neither H nor Z are accessed. */ + +/* ================================================================ */ +/* Based on contributions by */ +/* Karen Braman and Ralph Byers, Department of Mathematics, */ +/* University of Kansas, USA */ + +/* ================================================================ */ +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* ==== Estimate optimal workspace. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --sr; + --si; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1; + wv -= wv_offset; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = std::min(i__1,i__2); + if (jw <= 2) { + lwkopt = 1; + } else { + +/* ==== Workspace query call to DGEHRD ==== */ + + i__1 = jw - 1; + dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & + c_n1, &info); + lwk1 = (integer) work[1]; + +/* ==== Workspace query call to DORMHR ==== */ + + i__1 = jw - 1; + dormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[1], &c_n1, &info); + lwk2 = (integer) work[1]; + +/* ==== Optimal workspace ==== */ + + lwkopt = jw + std::max(lwk1,lwk2); + } + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + work[1] = (double) lwkopt; + return 0; + } + +/* ==== Nothing to do ... */ +/* ... for an empty active block ... ==== */ + *ns = 0; + *nd = 0; + work[1] = 1.; + if (*ktop > *kbot) { + return 0; + } +/* ... nor for an empty deflation window. ==== */ + if (*nw < 1) { + return 0; + } + +/* ==== Machine constants ==== */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((double) (*n) / ulp); + +/* ==== Setup deflation window ==== */ + +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = std::min(i__1,i__2); + kwtop = *kbot - jw + 1; + if (kwtop == *ktop) { + s = 0.; + } else { + s = h__[kwtop + (kwtop - 1) * h_dim1]; + } + + if (*kbot == kwtop) { + +/* ==== 1-by-1 deflation window: not much to do ==== */ + + sr[kwtop] = h__[kwtop + kwtop * h_dim1]; + si[kwtop] = 0.; + *ns = 1; + *nd = 0; +/* Computing MAX */ + d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs( + d__1)); + if (abs(s) <= std::max(d__2,d__3)) { + *ns = 0; + *nd = 1; + if (kwtop > *ktop) { + h__[kwtop + (kwtop - 1) * h_dim1] = 0.; + } + } + work[1] = 1.; + return 0; + } + +/* ==== Convert to spike-triangular form. (In case of a */ +/* . rare QR failure, this routine continues to do */ +/* . aggressive early deflation using that part of */ +/* . the deflation window that converged using INFQR */ +/* . here and there to keep track.) ==== */ + + dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], + ldt); + i__1 = jw - 1; + i__2 = *ldh + 1; + i__3 = *ldt + 1; + dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & + i__3); + + dlaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv); + dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], + &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); + +/* ==== DTREXC needs a clean margin near the diagonal ==== */ + + i__1 = jw - 3; + for (j = 1; j <= i__1; ++j) { + t[j + 2 + j * t_dim1] = 0.; + t[j + 3 + j * t_dim1] = 0.; +/* L10: */ + } + if (jw > 2) { + t[jw + (jw - 2) * t_dim1] = 0.; + } + +/* ==== Deflation detection loop ==== */ + + *ns = jw; + ilst = infqr + 1; +L20: + if (ilst <= *ns) { + if (*ns == 1) { + bulge = false; + } else { + bulge = t[*ns + (*ns - 1) * t_dim1] != 0.; + } + +/* ==== Small spike tip test for deflation ==== */ + + if (! bulge) { + +/* ==== Real eigenvalue ==== */ + + foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1)); + if (foo == 0.) { + foo = abs(s); + } +/* Computing MAX */ + d__2 = smlnum, d__3 = ulp * foo; + if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= std::max(d__2,d__3)) + { + +/* ==== Deflatable ==== */ + + --(*ns); + } else { + +/* ==== Undeflatable. Move it up out of the way. */ +/* . (DTREXC can not fail in this case.) ==== */ + + ifst = *ns; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ++ilst; + } + } else { + +/* ==== Complex conjugate pair ==== */ + + foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[* + ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[* + ns - 1 + *ns * t_dim1], abs(d__2))); + if (foo == 0.) { + foo = abs(s); + } +/* Computing MAX */ + d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 = + s * v[(*ns - 1) * v_dim1 + 1], abs(d__2)); +/* Computing MAX */ + d__5 = smlnum, d__6 = ulp * foo; + if (std::max(d__3,d__4) <= std::max(d__5,d__6)) { + +/* ==== Deflatable ==== */ + + *ns += -2; + } else { + +/* ==== Undflatable. Move them up out of the way. */ +/* . Fortunately, DTREXC does the right thing with */ +/* . ILST in case of a rare exchange failure. ==== */ + + ifst = *ns; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ilst += 2; + } + } + +/* ==== End deflation detection loop ==== */ + + goto L20; + } + +/* ==== Return to Hessenberg form ==== */ + + if (*ns == 0) { + s = 0.; + } + + if (*ns < jw) { + +/* ==== sorting diagonal blocks of T improves accuracy for */ +/* . graded matrices. Bubble sort deals well with */ +/* . exchange failures. ==== */ + + sorted = false; + i__ = *ns + 1; +L30: + if (sorted) { + goto L50; + } + sorted = true; + + kend = i__ - 1; + i__ = infqr + 1; + if (i__ == *ns) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { + k = i__ + 1; + } else { + k = i__ + 2; + } +L40: + if (k <= kend) { + if (k == i__ + 1) { + evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1)); + } else { + evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 = + t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 = + t[i__ + (i__ + 1) * t_dim1], abs(d__2))); + } + + if (k == kend) { + evk = (d__1 = t[k + k * t_dim1], abs(d__1)); + } else if (t[k + 1 + k * t_dim1] == 0.) { + evk = (d__1 = t[k + k * t_dim1], abs(d__1)); + } else { + evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[ + k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k + + (k + 1) * t_dim1], abs(d__2))); + } + + if (evi >= evk) { + i__ = k; + } else { + sorted = false; + ifst = i__; + ilst = k; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + if (info == 0) { + i__ = ilst; + } else { + i__ = k; + } + } + if (i__ == kend) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { + k = i__ + 1; + } else { + k = i__ + 2; + } + goto L40; + } + goto L30; +L50: + ; + } + +/* ==== Restore shift/eigenvalue array from T ==== */ + + i__ = jw; +L60: + if (i__ >= infqr + 1) { + if (i__ == infqr + 1) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.; + --i__; + } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.; + --i__; + } else { + aa = t[i__ - 1 + (i__ - 1) * t_dim1]; + cc = t[i__ + (i__ - 1) * t_dim1]; + bb = t[i__ - 1 + i__ * t_dim1]; + dd = t[i__ + i__ * t_dim1]; + dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ + - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & + sn); + i__ += -2; + } + goto L60; + } + + if (*ns < jw || s == 0.) { + if (*ns > 1 && s != 0.) { + +/* ==== Reflect spike back into lower triangle ==== */ + + dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); + beta = work[1]; + dlarfg_(ns, &beta, &work[2], &c__1, &tau); + work[1] = 1.; + + i__1 = jw - 2; + i__2 = jw - 2; + dlaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt); + + dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & + work[jw + 1]); + + i__1 = *lwork - jw; + dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] +, &i__1, &info); + } + +/* ==== Copy updated reduced window into place ==== */ + + if (kwtop > 1) { + h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; + } + dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] +, ldh); + i__1 = jw - 1; + i__2 = *ldt + 1; + i__3 = *ldh + 1; + dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], + &i__3); + +/* ==== Accumulate orthogonal matrix in order update */ +/* . H and Z, if requested. ==== */ + + if (*ns > 1 && s != 0.) { + i__1 = *lwork - jw; + dormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[jw + 1], &i__1, &info); + } + +/* ==== Update vertical slab in H ==== */ + + if (*wantt) { + ltop = 1; + } else { + ltop = *ktop; + } + i__1 = kwtop - 1; + i__2 = *nv; + for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = kwtop - krow; + kln = std::min(i__3,i__4); + dgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * + h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], + ldwv); + dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * + h_dim1], ldh); +/* L70: */ + } + +/* ==== Update horizontal slab in H ==== */ + + if (*wantt) { + i__2 = *n; + i__1 = *nh; + for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; + kcol += i__1) { +/* Computing MIN */ + i__3 = *nh, i__4 = *n - kcol + 1; + kln = std::min(i__3,i__4); + dgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & + h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], + ldt); + dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * + h_dim1], ldh); +/* L80: */ + } + } + +/* ==== Update vertical slab in Z ==== */ + + if (*wantz) { + i__1 = *ihiz; + i__2 = *nv; + for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = *ihiz - krow + 1; + kln = std::min(i__3,i__4); + dgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * + z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ + wv_offset], ldwv); + dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + + kwtop * z_dim1], ldz); +/* L90: */ + } + } + } + +/* ==== Return the number of deflations ... ==== */ + + *nd = jw - *ns; + +/* ==== ... and the number of shifts. (Subtracting */ +/* . INFQR from the spike length takes care */ +/* . of the case of a rare QR failure while */ +/* . calculating eigenvalues of the deflation */ +/* . window.) ==== */ + + *ns -= infqr; + +/* ==== Return optimal workspace. ==== */ + + work[1] = (double) lwkopt; + +/* ==== End of DLAQR2 ==== */ + + return 0; +} /* dlaqr2_ */ + +/* Subroutine */ int dlaqr3_(bool *wantt, bool *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, + double *h__, integer *ldh, integer *iloz, integer *ihiz, double *z__, integer *ldz, + integer *ns, integer *nd, double *sr, double *si, double *v, integer *ldv, integer *nh, + double *t, integer *ldt, integer *nv, double *wv, integer *ldwv, double *work, integer *lwork) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static bool c_true = true; + static double c_b17 = 0.; + static double c_b18 = 1.; + static integer c__12 = 12; + + /* System generated locals */ + integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, + wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + integer i__, j, k; + double s, aa, bb, cc, dd, cs, sn; + integer jw; + double evi, evk, foo; + integer kln; + double tau, ulp; + integer lwk1, lwk2, lwk3; + double beta; + integer kend, kcol, info, nmin, ifst, ilst, ltop, krow; + bool bulge; + integer infqr, kwtop; + double safmin; + double safmax; + bool sorted; + double smlnum; + integer lwkopt; + + +/* -- LAPACK auxiliary routine (version 3.2.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ +/* -- April 2009 -- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* ****************************************************************** */ +/* Aggressive early deflation: */ + +/* This subroutine accepts as input an upper Hessenberg matrix */ +/* H and performs an orthogonal similarity transformation */ +/* designed to detect and deflate fully converged eigenvalues from */ +/* a trailing principal submatrix. On output H has been over- */ +/* written by a new Hessenberg matrix that is a perturbation of */ +/* an orthogonal similarity transformation of H. It is to be */ +/* hoped that the final version of H has many zero subdiagonal */ +/* entries. */ + +/* ****************************************************************** */ +/* WANTT (input) LOGICAL */ +/* If .TRUE., then the Hessenberg matrix H is fully updated */ +/* so that the quasi-triangular Schur factor may be */ +/* computed (in cooperation with the calling subroutine). */ +/* If .FALSE., then only enough of H is updated to preserve */ +/* the eigenvalues. */ + +/* WANTZ (input) LOGICAL */ +/* If .TRUE., then the orthogonal matrix Z is updated so */ +/* so that the orthogonal Schur factor may be computed */ +/* (in cooperation with the calling subroutine). */ +/* If .FALSE., then Z is not referenced. */ + +/* N (input) INTEGER */ +/* The order of the matrix H and (if WANTZ is .TRUE.) the */ +/* order of the orthogonal matrix Z. */ + +/* KTOP (input) INTEGER */ +/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ +/* KBOT and KTOP together determine an isolated block */ +/* along the diagonal of the Hessenberg matrix. */ + +/* KBOT (input) INTEGER */ +/* It is assumed without a check that either */ +/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ +/* determine an isolated block along the diagonal of the */ +/* Hessenberg matrix. */ + +/* NW (input) INTEGER */ +/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */ + +/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ +/* On input the initial N-by-N section of H stores the */ +/* Hessenberg matrix undergoing aggressive early deflation. */ +/* On output H has been transformed by an orthogonal */ +/* similarity transformation, perturbed, and the returned */ +/* to Hessenberg form that (it is to be hoped) has some */ +/* zero subdiagonal entries. */ + +/* LDH (input) integer */ +/* Leading dimension of H just as declared in the calling */ +/* subroutine. N .LE. LDH */ + +/* ILOZ (input) INTEGER */ +/* IHIZ (input) INTEGER */ +/* Specify the rows of Z to which transformations must be */ +/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* IF WANTZ is .TRUE., then on output, the orthogonal */ +/* similarity transformation mentioned above has been */ +/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */ +/* If WANTZ is .FALSE., then Z is unreferenced. */ + +/* LDZ (input) integer */ +/* The leading dimension of Z just as declared in the */ +/* calling subroutine. 1 .LE. LDZ. */ + +/* NS (output) integer */ +/* The number of unconverged (ie approximate) eigenvalues */ +/* returned in SR and SI that may be used as shifts by the */ +/* calling subroutine. */ + +/* ND (output) integer */ +/* The number of converged eigenvalues uncovered by this */ +/* subroutine. */ + +/* SR (output) DOUBLE PRECISION array, dimension KBOT */ +/* SI (output) DOUBLE PRECISION array, dimension KBOT */ +/* On output, the real and imaginary parts of approximate */ +/* eigenvalues that may be used for shifts are stored in */ +/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ +/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ +/* The real and imaginary parts of converged eigenvalues */ +/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */ +/* SI(KBOT-ND+1) through SI(KBOT), respectively. */ + +/* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) */ +/* An NW-by-NW work array. */ + +/* LDV (input) integer scalar */ +/* The leading dimension of V just as declared in the */ +/* calling subroutine. NW .LE. LDV */ + +/* NH (input) integer scalar */ +/* The number of columns of T. NH.GE.NW. */ + +/* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) */ + +/* LDT (input) integer */ +/* The leading dimension of T just as declared in the */ +/* calling subroutine. NW .LE. LDT */ + +/* NV (input) integer */ +/* The number of rows of work array WV available for */ +/* workspace. NV.GE.NW. */ + +/* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) */ + +/* LDWV (input) integer */ +/* The leading dimension of W just as declared in the */ +/* calling subroutine. NW .LE. LDV */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. */ +/* On exit, WORK(1) is set to an estimate of the optimal value */ +/* of LWORK for the given values of N, NW, KTOP and KBOT. */ + +/* LWORK (input) integer */ +/* The dimension of the work array WORK. LWORK = 2*NW */ +/* suffices, but greater efficiency may result from larger */ +/* values of LWORK. */ + +/* If LWORK = -1, then a workspace query is assumed; DLAQR3 */ +/* only estimates the optimal workspace size for the given */ +/* values of N, NW, KTOP and KBOT. The estimate is returned */ +/* in WORK(1). No error message related to LWORK is issued */ +/* by XERBLA. Neither H nor Z are accessed. */ + +/* ================================================================ */ +/* Based on contributions by */ +/* Karen Braman and Ralph Byers, Department of Mathematics, */ +/* University of Kansas, USA */ + +/* ================================================================== */ +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* ==== Estimate optimal workspace. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --sr; + --si; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1; + wv -= wv_offset; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = std::min(i__1,i__2); + if (jw <= 2) { + lwkopt = 1; + } else { + +/* ==== Workspace query call to DGEHRD ==== */ + + i__1 = jw - 1; + dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & + c_n1, &info); + lwk1 = (integer) work[1]; + +/* ==== Workspace query call to DORMHR ==== */ + + i__1 = jw - 1; + dormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[1], &c_n1, &info); + lwk2 = (integer) work[1]; + +/* ==== Workspace query call to DLAQR4 ==== */ + + dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[1], + &si[1], &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, & + infqr); + lwk3 = (integer) work[1]; + +/* ==== Optimal workspace ==== */ + +/* Computing MAX */ + i__1 = jw + std::max(lwk1,lwk2); + lwkopt = std::max(i__1,lwk3); + } + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + work[1] = (double) lwkopt; + return 0; + } + +/* ==== Nothing to do ... */ +/* ... for an empty active block ... ==== */ + *ns = 0; + *nd = 0; + work[1] = 1.; + if (*ktop > *kbot) { + return 0; + } +/* ... nor for an empty deflation window. ==== */ + if (*nw < 1) { + return 0; + } + +/* ==== Machine constants ==== */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((double) (*n) / ulp); + +/* ==== Setup deflation window ==== */ + +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = std::min(i__1,i__2); + kwtop = *kbot - jw + 1; + if (kwtop == *ktop) { + s = 0.; + } else { + s = h__[kwtop + (kwtop - 1) * h_dim1]; + } + + if (*kbot == kwtop) { + +/* ==== 1-by-1 deflation window: not much to do ==== */ + + sr[kwtop] = h__[kwtop + kwtop * h_dim1]; + si[kwtop] = 0.; + *ns = 1; + *nd = 0; +/* Computing MAX */ + d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs( + d__1)); + if (abs(s) <= std::max(d__2,d__3)) { + *ns = 0; + *nd = 1; + if (kwtop > *ktop) { + h__[kwtop + (kwtop - 1) * h_dim1] = 0.; + } + } + work[1] = 1.; + return 0; + } + +/* ==== Convert to spike-triangular form. (In case of a */ +/* . rare QR failure, this routine continues to do */ +/* . aggressive early deflation using that part of */ +/* . the deflation window that converged using INFQR */ +/* . here and there to keep track.) ==== */ + + dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], + ldt); + i__1 = jw - 1; + i__2 = *ldh + 1; + i__3 = *ldt + 1; + dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & + i__3); + + dlaset_("A", &jw, &jw, &c_b17, &c_b18, &v[v_offset], ldv); + nmin = ilaenv_(&c__12, "DLAQR3", "SV", &jw, &c__1, &jw, lwork); + if (jw > nmin) { + dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[ + kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], + lwork, &infqr); + } else { + dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[ + kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); + } + +/* ==== DTREXC needs a clean margin near the diagonal ==== */ + + i__1 = jw - 3; + for (j = 1; j <= i__1; ++j) { + t[j + 2 + j * t_dim1] = 0.; + t[j + 3 + j * t_dim1] = 0.; +/* L10: */ + } + if (jw > 2) { + t[jw + (jw - 2) * t_dim1] = 0.; + } + +/* ==== Deflation detection loop ==== */ + + *ns = jw; + ilst = infqr + 1; +L20: + if (ilst <= *ns) { + if (*ns == 1) { + bulge = false; + } else { + bulge = t[*ns + (*ns - 1) * t_dim1] != 0.; + } + +/* ==== Small spike tip test for deflation ==== */ + + if (! bulge) { + +/* ==== Real eigenvalue ==== */ + + foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1)); + if (foo == 0.) { + foo = abs(s); + } +/* Computing MAX */ + d__2 = smlnum, d__3 = ulp * foo; + if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= std::max(d__2,d__3)) + { + +/* ==== Deflatable ==== */ + + --(*ns); + } else { + +/* ==== Undeflatable. Move it up out of the way. */ +/* . (DTREXC can not fail in this case.) ==== */ + + ifst = *ns; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ++ilst; + } + } else { + +/* ==== Complex conjugate pair ==== */ + + foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[* + ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[* + ns - 1 + *ns * t_dim1], abs(d__2))); + if (foo == 0.) { + foo = abs(s); + } +/* Computing MAX */ + d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 = + s * v[(*ns - 1) * v_dim1 + 1], abs(d__2)); +/* Computing MAX */ + d__5 = smlnum, d__6 = ulp * foo; + if (std::max(d__3,d__4) <= std::max(d__5,d__6)) { + +/* ==== Deflatable ==== */ + + *ns += -2; + } else { + +/* ==== Undeflatable. Move them up out of the way. */ +/* . Fortunately, DTREXC does the right thing with */ +/* . ILST in case of a rare exchange failure. ==== */ + + ifst = *ns; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ilst += 2; + } + } + +/* ==== End deflation detection loop ==== */ + + goto L20; + } + +/* ==== Return to Hessenberg form ==== */ + + if (*ns == 0) { + s = 0.; + } + + if (*ns < jw) { + +/* ==== sorting diagonal blocks of T improves accuracy for */ +/* . graded matrices. Bubble sort deals well with */ +/* . exchange failures. ==== */ + + sorted = false; + i__ = *ns + 1; +L30: + if (sorted) { + goto L50; + } + sorted = true; + + kend = i__ - 1; + i__ = infqr + 1; + if (i__ == *ns) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { + k = i__ + 1; + } else { + k = i__ + 2; + } +L40: + if (k <= kend) { + if (k == i__ + 1) { + evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1)); + } else { + evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 = + t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 = + t[i__ + (i__ + 1) * t_dim1], abs(d__2))); + } + + if (k == kend) { + evk = (d__1 = t[k + k * t_dim1], abs(d__1)); + } else if (t[k + 1 + k * t_dim1] == 0.) { + evk = (d__1 = t[k + k * t_dim1], abs(d__1)); + } else { + evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[ + k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k + + (k + 1) * t_dim1], abs(d__2))); + } + + if (evi >= evk) { + i__ = k; + } else { + sorted = false; + ifst = i__; + ilst = k; + dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + if (info == 0) { + i__ = ilst; + } else { + i__ = k; + } + } + if (i__ == kend) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { + k = i__ + 1; + } else { + k = i__ + 2; + } + goto L40; + } + goto L30; +L50: + ; + } + +/* ==== Restore shift/eigenvalue array from T ==== */ + + i__ = jw; +L60: + if (i__ >= infqr + 1) { + if (i__ == infqr + 1) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.; + --i__; + } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.; + --i__; + } else { + aa = t[i__ - 1 + (i__ - 1) * t_dim1]; + cc = t[i__ + (i__ - 1) * t_dim1]; + bb = t[i__ - 1 + i__ * t_dim1]; + dd = t[i__ + i__ * t_dim1]; + dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ + - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & + sn); + i__ += -2; + } + goto L60; + } + + if (*ns < jw || s == 0.) { + if (*ns > 1 && s != 0.) { + +/* ==== Reflect spike back into lower triangle ==== */ + + dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); + beta = work[1]; + dlarfg_(ns, &beta, &work[2], &c__1, &tau); + work[1] = 1.; + + i__1 = jw - 2; + i__2 = jw - 2; + dlaset_("L", &i__1, &i__2, &c_b17, &c_b17, &t[t_dim1 + 3], ldt); + + dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & + work[jw + 1]); + + i__1 = *lwork - jw; + dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] +, &i__1, &info); + } + +/* ==== Copy updated reduced window into place ==== */ + + if (kwtop > 1) { + h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; + } + dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] +, ldh); + i__1 = jw - 1; + i__2 = *ldt + 1; + i__3 = *ldh + 1; + dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], + &i__3); + +/* ==== Accumulate orthogonal matrix in order update */ +/* . H and Z, if requested. ==== */ + + if (*ns > 1 && s != 0.) { + i__1 = *lwork - jw; + dormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[jw + 1], &i__1, &info); + } + +/* ==== Update vertical slab in H ==== */ + + if (*wantt) { + ltop = 1; + } else { + ltop = *ktop; + } + i__1 = kwtop - 1; + i__2 = *nv; + for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = kwtop - krow; + kln = std::min(i__3,i__4); + dgemm_("N", "N", &kln, &jw, &jw, &c_b18, &h__[krow + kwtop * + h_dim1], ldh, &v[v_offset], ldv, &c_b17, &wv[wv_offset], + ldwv); + dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * + h_dim1], ldh); +/* L70: */ + } + +/* ==== Update horizontal slab in H ==== */ + + if (*wantt) { + i__2 = *n; + i__1 = *nh; + for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; + kcol += i__1) { +/* Computing MIN */ + i__3 = *nh, i__4 = *n - kcol + 1; + kln = std::min(i__3,i__4); + dgemm_("C", "N", &jw, &kln, &jw, &c_b18, &v[v_offset], ldv, & + h__[kwtop + kcol * h_dim1], ldh, &c_b17, &t[t_offset], + ldt); + dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * + h_dim1], ldh); +/* L80: */ + } + } + +/* ==== Update vertical slab in Z ==== */ + + if (*wantz) { + i__1 = *ihiz; + i__2 = *nv; + for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = *ihiz - krow + 1; + kln = std::min(i__3,i__4); + dgemm_("N", "N", &kln, &jw, &jw, &c_b18, &z__[krow + kwtop * + z_dim1], ldz, &v[v_offset], ldv, &c_b17, &wv[ + wv_offset], ldwv); + dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + + kwtop * z_dim1], ldz); +/* L90: */ + } + } + } + +/* ==== Return the number of deflations ... ==== */ + + *nd = jw - *ns; + +/* ==== ... and the number of shifts. (Subtracting */ +/* . INFQR from the spike length takes care */ +/* . of the case of a rare QR failure while */ +/* . calculating eigenvalues of the deflation */ +/* . window.) ==== */ + + *ns -= infqr; + +/* ==== Return optimal workspace. ==== */ + + work[1] = (double) lwkopt; + +/* ==== End of DLAQR3 ==== */ + + return 0; +} /* dlaqr3_ */ + +/* Subroutine */ int dlaqr4_(bool *wantt, bool *wantz, integer *n, integer *ilo, integer *ihi, double *h__, + integer *ldh, double *wr, double *wi, integer *iloz, integer *ihiz, double *z__, + integer *ldz, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__13 = 13; + static integer c__15 = 15; + static integer c_n1 = -1; + static integer c__12 = 12; + static integer c__14 = 14; + static integer c__16 = 16; + static bool c_false = false; + static integer c__1 = 1; + static integer c__3 = 3; + + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, k, ld, nh, it, ks, kt, ku, kv, ls, ns; + double aa, bb, cc, dd; + double cs, sn, ss, swap; + integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; + integer ktop, kacc22; + double zdum[1] /* was [1][1] */; + bool sorted; + integer itmax, nsmax, nwmax, kwtop, lwkopt, nibble, nwupbd; + char jbcmpz[3]; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* This subroutine implements one level of recursion for DLAQR0. */ +/* It is a complete implementation of the small bulge multi-shift */ +/* QR algorithm. It may be called by DLAQR0 and, for large enough */ +/* deflation window size, it may be called by DLAQR3. This */ +/* subroutine is identical to DLAQR0 except that it calls DLAQR2 */ +/* instead of DLAQR3. */ + +/* Purpose */ +/* ======= */ + +/* DLAQR4 computes the eigenvalues of a Hessenberg matrix H */ +/* and, optionally, the matrices T and Z from the Schur decomposition */ +/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ +/* Schur form), and Z is the orthogonal matrix of Schur vectors. */ + +/* Optionally Z may be postmultiplied into an input orthogonal */ +/* matrix Q so that this routine can give the Schur factorization */ +/* of a matrix A which has been reduced to the Hessenberg form H */ +/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ + +/* Arguments */ +/* ========= */ + +/* WANTT (input) LOGICAL */ +/* = .TRUE. : the full Schur form T is required; */ +/* = .FALSE.: only eigenvalues are required. */ + +/* WANTZ (input) LOGICAL */ +/* = .TRUE. : the matrix of Schur vectors Z is required; */ +/* = .FALSE.: Schur vectors are not required. */ + +/* N (input) INTEGER */ +/* The order of the matrix H. N .GE. 0. */ + +/* ILO (input) INTEGER */ +/* IHI (input) INTEGER */ +/* It is assumed that H is already upper triangular in rows */ +/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */ +/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ +/* previous call to DGEBAL, and then passed to DGEHRD when the */ +/* matrix output by DGEBAL is reduced to Hessenberg form. */ +/* Otherwise, ILO and IHI should be set to 1 and N, */ +/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ +/* If N = 0, then ILO = 1 and IHI = 0. */ + +/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ +/* On entry, the upper Hessenberg matrix H. */ +/* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */ +/* the upper quasi-triangular matrix T from the Schur */ +/* decomposition (the Schur form); 2-by-2 diagonal blocks */ +/* (corresponding to complex conjugate pairs of eigenvalues) */ +/* are returned in standard form, with H(i,i) = H(i+1,i+1) */ +/* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */ +/* .FALSE., then the contents of H are unspecified on exit. */ +/* (The output value of H when INFO.GT.0 is given under the */ +/* description of INFO below.) */ + +/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */ +/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ + +/* LDH (input) INTEGER */ +/* The leading dimension of the array H. LDH .GE. max(1,N). */ + +/* WR (output) DOUBLE PRECISION array, dimension (IHI) */ +/* WI (output) DOUBLE PRECISION array, dimension (IHI) */ +/* The real and imaginary parts, respectively, of the computed */ +/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */ +/* and WI(ILO:IHI). If two eigenvalues are computed as a */ +/* complex conjugate pair, they are stored in consecutive */ +/* elements of WR and WI, say the i-th and (i+1)th, with */ +/* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */ +/* the eigenvalues are stored in the same order as on the */ +/* diagonal of the Schur form returned in H, with */ +/* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */ +/* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ +/* WI(i+1) = -WI(i). */ + +/* ILOZ (input) INTEGER */ +/* IHIZ (input) INTEGER */ +/* Specify the rows of Z to which transformations must be */ +/* applied if WANTZ is .TRUE.. */ +/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */ +/* If WANTZ is .FALSE., then Z is not referenced. */ +/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ +/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ +/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ +/* (The output value of Z when INFO.GT.0 is given under */ +/* the description of INFO below.) */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. if WANTZ is .TRUE. */ +/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK */ +/* On exit, if LWORK = -1, WORK(1) returns an estimate of */ +/* the optimal value for LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK .GE. max(1,N) */ +/* is sufficient, but LWORK typically as large as 6*N may */ +/* be required for optimal performance. A workspace query */ +/* to determine the optimal workspace size is recommended. */ + +/* If LWORK = -1, then DLAQR4 does a workspace query. */ +/* In this case, DLAQR4 checks the input parameters and */ +/* estimates the optimal workspace size for the given */ +/* values of N, ILO and IHI. The estimate is returned */ +/* in WORK(1). No error message related to LWORK is */ +/* issued by XERBLA. Neither H nor Z are accessed. */ + + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* .GT. 0: if INFO = i, DLAQR4 failed to compute all of */ +/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ +/* and WI contain those eigenvalues which have been */ +/* successfully computed. (Failures are rare.) */ + +/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */ +/* the remaining unconverged eigenvalues are the eigen- */ +/* values of the upper Hessenberg matrix rows and */ +/* columns ILO through INFO of the final, output */ +/* value of H. */ + +/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */ + +/* (*) (initial value of H)*U = U*(final value of H) */ + +/* where U is an orthogonal matrix. The final */ +/* value of H is upper Hessenberg and quasi-triangular */ +/* in rows and columns INFO+1 through IHI. */ + +/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */ + +/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */ +/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ + +/* where U is the orthogonal matrix in (*) (regard- */ +/* less of the value of WANTT.) */ + +/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */ +/* accessed. */ + +/* ================================================================ */ +/* Based on contributions by */ +/* Karen Braman and Ralph Byers, Department of Mathematics, */ +/* University of Kansas, USA */ + +/* ================================================================ */ +/* References: */ +/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* 929--947, 2002. */ + +/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* of Matrix Analysis, volume 23, pages 948--973, 2002. */ + +/* ================================================================ */ +/* .. Parameters .. */ + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . DLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== Exceptional deflation windows: try to cure rare */ +/* . slow convergence by varying the size of the */ +/* . deflation window after KEXNW iterations. ==== */ + +/* ==== Exceptional shifts: try to cure rare slow convergence */ +/* . with ad-hoc exceptional shifts every KEXSH iterations. */ +/* . ==== */ + +/* ==== The constants WILK1 and WILK2 are used to form the */ +/* . exceptional shifts. ==== */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* ==== Quick return for N = 0: nothing to do. ==== */ + + if (*n == 0) { + work[1] = 1.; + return 0; + } + + if (*n <= 11) { +/* ==== Tiny matrices must use DLAHQR. ==== */ + + lwkopt = 1; + if (*lwork != -1) { + dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & + wi[1], iloz, ihiz, &z__[z_offset], ldz, info); + } + } else { + +/* ==== Use small bulge multi-shift QR with aggressive early */ +/* . deflation on larger-than-tiny matrices. ==== */ + +/* ==== Hope for the best. ==== */ + + *info = 0; + +/* ==== Set up job flags for ILAENV. ==== */ + + if (*wantt) { + * (unsigned char *) & jbcmpz [0] = 'S'; + } else { + * (unsigned char *) & jbcmpz [0] = 'E'; + } + if (*wantz) { + * (unsigned char *) & jbcmpz [1] = 'V'; + } else { + * (unsigned char *) & jbcmpz [1] = 'N'; + } + jbcmpz [2] = '\0'; +/* ==== NWR = recommended deflation window size. At this */ +/* . point, N .GT. NTINY = 11, so there is enough */ +/* . subdiagonal workspace for NWR.GE.2 as required. */ +/* . (In fact, there is enough subdiagonal space for */ +/* . NWR.GE.3.) ==== */ + + nwr = ilaenv_(&c__13, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + nwr = std::max(2_integer,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = std::min(i__1,i__2); + nwr = std::min(i__1,nwr); + +/* ==== NSR = recommended number of simultaneous shifts. */ +/* . At this point N .GT. NTINY = 11, so there is at */ +/* . enough subdiagonal workspace for NSR to be even */ +/* . and greater than or equal to two as required. ==== */ + + nsr = ilaenv_(&c__15, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = std::min(i__1,i__2), i__2 = *ihi - + *ilo; + nsr = std::min(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = std::max(i__1,i__2); + +/* ==== Estimate optimal workspace ==== */ + +/* ==== Workspace query call to DLAQR2 ==== */ + + i__1 = nwr + 1; + dlaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, + ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ + h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], + ldh, &work[1], &c_n1); + +/* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== */ + +/* Computing MAX */ + i__1 = nsr * 3 / 2, i__2 = (integer) work[1]; + lwkopt = std::max(i__1,i__2); + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + work[1] = (double) lwkopt; + return 0; + } + +/* ==== DLAHQR/DLAQR0 crossover point ==== */ + + nmin = ilaenv_(&c__12, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + nmin = std::max(11_integer,nmin); + +/* ==== Nibble crossover point ==== */ + + nibble = ilaenv_(&c__14, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + nibble = std::max(0_integer,nibble); + +/* ==== Accumulate reflections during ttswp? Use block */ +/* . 2-by-2 structure during matrix-matrix multiply? ==== */ + + kacc22 = ilaenv_(&c__16, "DLAQR4", jbcmpz, n, ilo, ihi, lwork); + kacc22 = std::max(0_integer,kacc22); + kacc22 = std::min(2_integer,kacc22); + +/* ==== NWMAX = the largest possible deflation window for */ +/* . which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 1) / 3, i__2 = *lwork / 2; + nwmax = std::min(i__1,i__2); + nw = nwmax; + +/* ==== NSMAX = the Largest number of simultaneous shifts */ +/* . for which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3; + nsmax = std::min(i__1,i__2); + nsmax -= nsmax % 2; + +/* ==== NDFL: an iteration count restarted at deflation. ==== */ + + ndfl = 1; + +/* ==== ITMAX = iteration limit ==== */ + +/* Computing MAX */ + i__1 = 10, i__2 = *ihi - *ilo + 1; + itmax = std::max(i__1,i__2) * 30; + +/* ==== Last row and column in the active block ==== */ + + kbot = *ihi; + +/* ==== Main Loop ==== */ + + i__1 = itmax; + for (it = 1; it <= i__1; ++it) { + +/* ==== Done when KBOT falls below ILO ==== */ + + if (kbot < *ilo) { + goto L90; + } + +/* ==== Locate active block ==== */ + + i__2 = *ilo + 1; + for (k = kbot; k >= i__2; --k) { + if (h__[k + (k - 1) * h_dim1] == 0.) { + goto L20; + } +/* L10: */ + } + k = *ilo; +L20: + ktop = k; + +/* ==== Select deflation window size: */ +/* . Typical Case: */ +/* . If possible and advisable, nibble the entire */ +/* . active block. If not, use size MIN(NWR,NWMAX) */ +/* . or MIN(NWR+1,NWMAX) depending upon which has */ +/* . the smaller corresponding subdiagonal entry */ +/* . (a heuristic). */ +/* . */ +/* . Exceptional Case: */ +/* . If there have been no deflations in KEXNW or */ +/* . more iterations, then vary the deflation window */ +/* . size. At first, because, larger windows are, */ +/* . in general, more powerful than smaller ones, */ +/* . rapidly increase the window to the maximum possible. */ +/* . Then, gradually reduce the window size. ==== */ + + nh = kbot - ktop + 1; + nwupbd = std::min(nh,nwmax); + if (ndfl < 5) { + nw = std::min(nwupbd,nwr); + } else { +/* Computing MIN */ + i__2 = nwupbd, i__3 = nw << 1; + nw = std::min(i__2,i__3); + } + if (nw < nwmax) { + if (nw >= nh - 1) { + nw = nh; + } else { + kwtop = kbot - nw + 1; + if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1)) + > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], + abs(d__2))) { + ++nw; + } + } + } + if (ndfl < 5) { + ndec = -1; + } else if (ndec >= 0 || nw >= nwupbd) { + ++ndec; + if (nw - ndec < 2) { + ndec = 0; + } + nw -= ndec; + } + +/* ==== Aggressive early deflation: */ +/* . split workspace under the subdiagonal into */ +/* . - an nw-by-nw work array V in the lower */ +/* . left-hand-corner, */ +/* . - an NW-by-at-least-NW-but-more-is-better */ +/* . (NW-by-NHO) horizontal work array along */ +/* . the bottom edge, */ +/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ +/* . vertical work array along the left-hand-edge. */ +/* . ==== */ + + kv = *n - nw + 1; + kt = nw + 1; + nho = *n - nw - 1 - kt + 1; + kwv = nw + 2; + nve = *n - nw - kwv + 1; + +/* ==== Aggressive early deflation ==== */ + + dlaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, + iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], + &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); + +/* ==== Adjust KBOT accounting for new deflations. ==== */ + + kbot -= ld; + +/* ==== KS points to the shifts. ==== */ + + ks = kbot - ls + 1; + +/* ==== Skip an expensive QR sweep if there is a (partly */ +/* . heuristic) reason to expect that many eigenvalues */ +/* . will deflate without it. Here, the QR sweep is */ +/* . skipped if many eigenvalues have just been deflated */ +/* . or if the remaining active block is small. */ + + if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > std::min( + nmin,nwmax)) { + +/* ==== NS = nominal number of simultaneous shifts. */ +/* . This may be lowered (slightly) if DLAQR2 */ +/* . did not provide that many shifts. ==== */ + +/* Computing MIN */ +/* Computing MAX */ + i__4 = 2, i__5 = kbot - ktop; + i__2 = std::min(nsmax,nsr), i__3 = std::max(i__4,i__5); + ns = std::min(i__2,i__3); + ns -= ns % 2; + +/* ==== If there have been no deflations */ +/* . in a multiple of KEXSH iterations, */ +/* . then try exceptional shifts. */ +/* . Otherwise use shifts provided by */ +/* . DLAQR2 above or from the eigenvalues */ +/* . of a trailing principal submatrix. ==== */ + + if (ndfl % 6 == 0) { + ks = kbot - ns + 1; +/* Computing MAX */ + i__3 = ks + 1, i__4 = ktop + 2; + i__2 = std::max(i__3,i__4); + for (i__ = kbot; i__ >= i__2; i__ += -2) { + ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], + abs(d__2)); + aa = ss * .75 + h__[i__ + i__ * h_dim1]; + bb = ss; + cc = ss * -.4375; + dd = aa; + dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] +, &wr[i__], &wi[i__], &cs, &sn); +/* L30: */ + } + if (ks == ktop) { + wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; + wi[ks + 1] = 0.; + wr[ks] = wr[ks + 1]; + wi[ks] = wi[ks + 1]; + } + } else { + +/* ==== Got NS/2 or fewer shifts? Use DLAHQR */ +/* . on a trailing principal submatrix to */ +/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */ +/* . there is enough space below the subdiagonal */ +/* . to fit an NS-by-NS scratch array.) ==== */ + + if (kbot - ks + 1 <= ns / 2) { + ks = kbot - ns + 1; + kt = *n - ns + 1; + dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & + h__[kt + h_dim1], ldh); + dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + + h_dim1], ldh, &wr[ks], &wi[ks], &c__1, & + c__1, zdum, &c__1, &inf); + ks += inf; + +/* ==== In case of a rare QR failure use */ +/* . eigenvalues of the trailing 2-by-2 */ +/* . principal submatrix. ==== */ + + if (ks >= kbot) { + aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; + cc = h__[kbot + (kbot - 1) * h_dim1]; + bb = h__[kbot - 1 + kbot * h_dim1]; + dd = h__[kbot + kbot * h_dim1]; + dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ + kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) + ; + ks = kbot - 1; + } + } + + if (kbot - ks + 1 > ns) { + +/* ==== Sort the shifts (Helps a little) */ +/* . Bubble sort keeps complex conjugate */ +/* . pairs together. ==== */ + + sorted = false; + i__2 = ks + 1; + for (k = kbot; k >= i__2; --k) { + if (sorted) { + goto L60; + } + sorted = true; + i__3 = k - 1; + for (i__ = ks; i__ <= i__3; ++i__) { + if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[ + i__], abs(d__2)) < (d__3 = wr[i__ + 1] + , abs(d__3)) + (d__4 = wi[i__ + 1], + abs(d__4))) { + sorted = false; + + swap = wr[i__]; + wr[i__] = wr[i__ + 1]; + wr[i__ + 1] = swap; + + swap = wi[i__]; + wi[i__] = wi[i__ + 1]; + wi[i__ + 1] = swap; + } +/* L40: */ + } +/* L50: */ + } +L60: + ; + } + +/* ==== Shuffle shifts into pairs of real shifts */ +/* . and pairs of complex conjugate shifts */ +/* . assuming complex conjugate shifts are */ +/* . already adjacent to one another. (Yes, */ +/* . they are.) ==== */ + + i__2 = ks + 2; + for (i__ = kbot; i__ >= i__2; i__ += -2) { + if (wi[i__] != -wi[i__ - 1]) { + + swap = wr[i__]; + wr[i__] = wr[i__ - 1]; + wr[i__ - 1] = wr[i__ - 2]; + wr[i__ - 2] = swap; + + swap = wi[i__]; + wi[i__] = wi[i__ - 1]; + wi[i__ - 1] = wi[i__ - 2]; + wi[i__ - 2] = swap; + } +/* L70: */ + } + } + +/* ==== If there are only two shifts and both are */ +/* . real, then use only one. ==== */ + + if (kbot - ks + 1 == 2) { + if (wi[kbot] == 0.) { + if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs( + d__1)) < (d__2 = wr[kbot - 1] - h__[kbot + + kbot * h_dim1], abs(d__2))) { + wr[kbot - 1] = wr[kbot]; + } else { + wr[kbot] = wr[kbot - 1]; + } + } + } + +/* ==== Use up to NS of the the smallest magnatiude */ +/* . shifts. If there aren't NS shifts available, */ +/* . then use them all, possibly dropping one to */ +/* . make the number of shifts even. ==== */ + +/* Computing MIN */ + i__2 = ns, i__3 = kbot - ks + 1; + ns = std::min(i__2,i__3); + ns -= ns % 2; + ks = kbot - ns + 1; + +/* ==== Small-bulge multi-shift QR sweep: */ +/* . split workspace under the subdiagonal into */ +/* . - a KDU-by-KDU work array U in the lower */ +/* . left-hand-corner, */ +/* . - a KDU-by-at-least-KDU-but-more-is-better */ +/* . (KDU-by-NHo) horizontal work array WH along */ +/* . the bottom edge, */ +/* . - and an at-least-KDU-but-more-is-better-by-KDU */ +/* . (NVE-by-KDU) vertical work WV arrow along */ +/* . the left-hand-edge. ==== */ + + kdu = ns * 3 - 3; + ku = *n - kdu + 1; + kwh = kdu + 1; + nho = *n - kdu - 3 - (kdu + 1) + 1; + kwv = kdu + 4; + nve = *n - kdu - kwv + 1; + +/* ==== Small-bulge multi-shift QR sweep ==== */ + + dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], + &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ + z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + + kwh * h_dim1], ldh); + } + +/* ==== Note progress (or the lack of it). ==== */ + + if (ld > 0) { + ndfl = 1; + } else { + ++ndfl; + } + +/* ==== End of main loop ==== */ +/* L80: */ + } + +/* ==== Iteration limit exceeded. Set INFO to show where */ +/* . the problem occurred and exit. ==== */ + + *info = kbot; +L90: + ; + } + +/* ==== Return the optimal value of LWORK. ==== */ + + work[1] = (double) lwkopt; + +/* ==== End of DLAQR4 ==== */ + + return 0; +} /* dlaqr4_ */ + +/* Subroutine */ int dlaqr5_(bool *wantt, bool *wantz, integer *kacc22, + integer *n, integer *ktop, integer *kbot, integer *nshfts, double + *sr, double *si, double *h__, integer *ldh, integer *iloz, + integer *ihiz, double *z__, integer *ldz, double *v, integer * + ldv, double *u, integer *ldu, integer *nv, double *wv, + integer *ldwv, integer *nh, double *wh, integer *ldwh) +{ + /* Table of constant values */ + static double c_b7 = 0.; + static double c_b8 = 1.; + static integer c__3 = 3; + static integer c__1 = 1; + static integer c__2 = 2; + + /* System generated locals */ + integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1, + wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, + i__4, i__5, i__6, i__7; + double d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + integer i__, j, k, m, i2, j2, i4, j4, k1; + double h11, h12, h21, h22; + integer m22, ns, nu; + double vt[3], scl; + integer kdu, kms; + double ulp; + integer knz, kzs; + double tst1, tst2, beta; + bool blk22, bmp22, accum; + integer mend, jcol, jlen, jbot, mbot, jtop, jrow, mtop; + integer ndcol, incol, krcol, nbmps; + double swap, alpha, safmin, safmax, refsum, smlnum; + integer mstart; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* This auxiliary subroutine called by DLAQR0 performs a */ +/* single small-bulge multi-shift QR sweep. */ + +/* WANTT (input) logical scalar */ +/* WANTT = .true. if the quasi-triangular Schur factor */ +/* is being computed. WANTT is set to .false. otherwise. */ + +/* WANTZ (input) logical scalar */ +/* WANTZ = .true. if the orthogonal Schur factor is being */ +/* computed. WANTZ is set to .false. otherwise. */ + +/* KACC22 (input) integer with value 0, 1, or 2. */ +/* Specifies the computation mode of far-from-diagonal */ +/* orthogonal updates. */ +/* = 0: DLAQR5 does not accumulate reflections and does not */ +/* use matrix-matrix multiply to update far-from-diagonal */ +/* matrix entries. */ +/* = 1: DLAQR5 accumulates reflections and uses matrix-matrix */ +/* multiply to update the far-from-diagonal matrix entries. */ +/* = 2: DLAQR5 accumulates reflections, uses matrix-matrix */ +/* multiply to update the far-from-diagonal matrix entries, */ +/* and takes advantage of 2-by-2 block structure during */ +/* matrix multiplies. */ + +/* N (input) integer scalar */ +/* N is the order of the Hessenberg matrix H upon which this */ +/* subroutine operates. */ + +/* KTOP (input) integer scalar */ +/* KBOT (input) integer scalar */ +/* These are the first and last rows and columns of an */ +/* isolated diagonal block upon which the QR sweep is to be */ +/* applied. It is assumed without a check that */ +/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */ +/* and */ +/* either KBOT = N or H(KBOT+1,KBOT) = 0. */ + +/* NSHFTS (input) integer scalar */ +/* NSHFTS gives the number of simultaneous shifts. NSHFTS */ +/* must be positive and even. */ + +/* SR (input/output) DOUBLE PRECISION array of size (NSHFTS) */ +/* SI (input/output) DOUBLE PRECISION array of size (NSHFTS) */ +/* SR contains the real parts and SI contains the imaginary */ +/* parts of the NSHFTS shifts of origin that define the */ +/* multi-shift QR sweep. On output SR and SI may be */ +/* reordered. */ + +/* H (input/output) DOUBLE PRECISION array of size (LDH,N) */ +/* On input H contains a Hessenberg matrix. On output a */ +/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */ +/* to the isolated diagonal block in rows and columns KTOP */ +/* through KBOT. */ + +/* LDH (input) integer scalar */ +/* LDH is the leading dimension of H just as declared in the */ +/* calling procedure. LDH.GE.MAX(1,N). */ + +/* ILOZ (input) INTEGER */ +/* IHIZ (input) INTEGER */ +/* Specify the rows of Z to which transformations must be */ +/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N */ + +/* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI) */ +/* If WANTZ = .TRUE., then the QR Sweep orthogonal */ +/* similarity transformation is accumulated into */ +/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */ +/* If WANTZ = .FALSE., then Z is unreferenced. */ + +/* LDZ (input) integer scalar */ +/* LDA is the leading dimension of Z just as declared in */ +/* the calling procedure. LDZ.GE.N. */ + +/* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2) */ + +/* LDV (input) integer scalar */ +/* LDV is the leading dimension of V as declared in the */ +/* calling procedure. LDV.GE.3. */ + +/* U (workspace) DOUBLE PRECISION array of size */ +/* (LDU,3*NSHFTS-3) */ + +/* LDU (input) integer scalar */ +/* LDU is the leading dimension of U just as declared in the */ +/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */ + +/* NH (input) integer scalar */ +/* NH is the number of columns in array WH available for */ +/* workspace. NH.GE.1. */ + +/* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH) */ + +/* LDWH (input) integer scalar */ +/* Leading dimension of WH just as declared in the */ +/* calling procedure. LDWH.GE.3*NSHFTS-3. */ + +/* NV (input) integer scalar */ +/* NV is the number of rows in WV agailable for workspace. */ +/* NV.GE.1. */ + +/* WV (workspace) DOUBLE PRECISION array of size */ +/* (LDWV,3*NSHFTS-3) */ + +/* LDWV (input) integer scalar */ +/* LDWV is the leading dimension of WV as declared in the */ +/* in the calling subroutine. LDWV.GE.NV. */ + +/* ================================================================ */ +/* Based on contributions by */ +/* Karen Braman and Ralph Byers, Department of Mathematics, */ +/* University of Kansas, USA */ + +/* ================================================================ */ +/* Reference: */ + +/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* Algorithm Part I: Maintaining Well Focused Shifts, and */ +/* Level 3 Performance, SIAM Journal of Matrix Analysis, */ +/* volume 23, pages 929--947, 2002. */ + +/* ================================================================ */ +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ + +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* ==== If there are no shifts, then there is nothing to do. ==== */ + + /* Parameter adjustments */ + --sr; + --si; + h_dim1 = *ldh; + h_offset = 1 + h_dim1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1; + wv -= wv_offset; + wh_dim1 = *ldwh; + wh_offset = 1 + wh_dim1; + wh -= wh_offset; + + /* Function Body */ + if (*nshfts < 2) { + return 0; + } + +/* ==== If the active block is empty or 1-by-1, then there */ +/* . is nothing to do. ==== */ + + if (*ktop >= *kbot) { + return 0; + } + +/* ==== Shuffle shifts into pairs of real shifts and pairs */ +/* . of complex conjugate shifts assuming complex */ +/* . conjugate shifts are already adjacent to one */ +/* . another. ==== */ + + i__1 = *nshfts - 2; + for (i__ = 1; i__ <= i__1; i__ += 2) { + if (si[i__] != -si[i__ + 1]) { + + swap = sr[i__]; + sr[i__] = sr[i__ + 1]; + sr[i__ + 1] = sr[i__ + 2]; + sr[i__ + 2] = swap; + + swap = si[i__]; + si[i__] = si[i__ + 1]; + si[i__ + 1] = si[i__ + 2]; + si[i__ + 2] = swap; + } +/* L10: */ + } + +/* ==== NSHFTS is supposed to be even, but if it is odd, */ +/* . then simply reduce it by one. The shuffle above */ +/* . ensures that the dropped shift is real and that */ +/* . the remaining shifts are paired. ==== */ + + ns = *nshfts - *nshfts % 2; + +/* ==== Machine constants for deflation ==== */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((double) (*n) / ulp); + +/* ==== Use accumulated reflections to update far-from-diagonal */ +/* . entries ? ==== */ + + accum = *kacc22 == 1 || *kacc22 == 2; + +/* ==== If so, exploit the 2-by-2 block structure? ==== */ + + blk22 = ns > 2 && *kacc22 == 2; + +/* ==== clear trash ==== */ + + if (*ktop + 2 <= *kbot) { + h__[*ktop + 2 + *ktop * h_dim1] = 0.; + } + +/* ==== NBMPS = number of 2-shift bulges in the chain ==== */ + + nbmps = ns / 2; + +/* ==== KDU = width of slab ==== */ + + kdu = nbmps * 6 - 3; + +/* ==== Create and chase chains of NBMPS bulges ==== */ + + i__1 = *kbot - 2; + i__2 = nbmps * 3 - 2; + for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 : + incol <= i__1; incol += i__2) { + ndcol = incol + kdu; + if (accum) { + dlaset_("ALL", &kdu, &kdu, &c_b7, &c_b8, &u[u_offset], ldu); + } + +/* ==== Near-the-diagonal bulge chase. The following loop */ +/* . performs the near-the-diagonal part of a small bulge */ +/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */ +/* . chunk extends from column INCOL to column NDCOL */ +/* . (including both column INCOL and column NDCOL). The */ +/* . following loop chases a 3*NBMPS column long chain of */ +/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */ +/* . may be less than KTOP and and NDCOL may be greater than */ +/* . KBOT indicating phantom columns from which to chase */ +/* . bulges before they are actually introduced or to which */ +/* . to chase bulges beyond column KBOT.) ==== */ + +/* Computing MIN */ + i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2; + i__3 = std::min(i__4,i__5); + for (krcol = incol; krcol <= i__3; ++krcol) { + +/* ==== Bulges number MTOP to MBOT are active double implicit */ +/* . shift bulges. There may or may not also be small */ +/* . 2-by-2 bulge, if there is room. The inactive bulges */ +/* . (if any) must wait until the active bulges have moved */ +/* . down the diagonal to make room. The phantom matrix */ +/* . paradigm described above helps keep track. ==== */ + +/* Computing MAX */ + i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1; + mtop = std::max(i__4,i__5); +/* Computing MIN */ + i__4 = nbmps, i__5 = (*kbot - krcol) / 3; + mbot = std::min(i__4,i__5); + m22 = mbot + 1; + bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2; + +/* ==== Generate reflections to chase the chain right */ +/* . one column. (The minimum value of K is KTOP-1.) ==== */ + + i__4 = mbot; + for (m = mtop; m <= i__4; ++m) { + k = krcol + (m - 1) * 3; + if (k == *ktop - 1) { + dlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &sr[(m + << 1) - 1], &si[(m << 1) - 1], &sr[m * 2], &si[m * + 2], &v[m * v_dim1 + 1]); + alpha = v[m * v_dim1 + 1]; + dlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m * + v_dim1 + 1]); + } else { + beta = h__[k + 1 + k * h_dim1]; + v[m * v_dim1 + 2] = h__[k + 2 + k * h_dim1]; + v[m * v_dim1 + 3] = h__[k + 3 + k * h_dim1]; + dlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m * + v_dim1 + 1]); + +/* ==== A Bulge may collapse because of vigilant */ +/* . deflation or destructive underflow. In the */ +/* . underflow case, try the two-small-subdiagonals */ +/* . trick to try to reinflate the bulge. ==== */ + + if (h__[k + 3 + k * h_dim1] != 0. || h__[k + 3 + (k + 1) * + h_dim1] != 0. || h__[k + 3 + (k + 2) * h_dim1] == + 0.) { + +/* ==== Typical case: not collapsed (yet). ==== */ + + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.; + h__[k + 3 + k * h_dim1] = 0.; + } else { + +/* ==== Atypical case: collapsed. Attempt to */ +/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */ +/* . If the fill resulting from the new */ +/* . reflector is too large, then abandon it. */ +/* . Otherwise, use the new one. ==== */ + + dlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, & + sr[(m << 1) - 1], &si[(m << 1) - 1], &sr[m * + 2], &si[m * 2], vt); + alpha = vt[0]; + dlarfg_(&c__3, &alpha, &vt[1], &c__1, vt); + refsum = vt[0] * (h__[k + 1 + k * h_dim1] + vt[1] * + h__[k + 2 + k * h_dim1]); + + if ((d__1 = h__[k + 2 + k * h_dim1] - refsum * vt[1], + abs(d__1)) + (d__2 = refsum * vt[2], abs(d__2) + ) > ulp * ((d__3 = h__[k + k * h_dim1], abs( + d__3)) + (d__4 = h__[k + 1 + (k + 1) * h_dim1] + , abs(d__4)) + (d__5 = h__[k + 2 + (k + 2) * + h_dim1], abs(d__5)))) { + +/* ==== Starting a new bulge here would */ +/* . create non-negligible fill. Use */ +/* . the old one with trepidation. ==== */ + + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.; + h__[k + 3 + k * h_dim1] = 0.; + } else { + +/* ==== Stating a new bulge here would */ +/* . create only negligible fill. */ +/* . Replace the old reflector with */ +/* . the new one. ==== */ + + h__[k + 1 + k * h_dim1] -= refsum; + h__[k + 2 + k * h_dim1] = 0.; + h__[k + 3 + k * h_dim1] = 0.; + v[m * v_dim1 + 1] = vt[0]; + v[m * v_dim1 + 2] = vt[1]; + v[m * v_dim1 + 3] = vt[2]; + } + } + } +/* L20: */ + } + +/* ==== Generate a 2-by-2 reflection, if needed. ==== */ + + k = krcol + (m22 - 1) * 3; + if (bmp22) { + if (k == *ktop - 1) { + dlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[( + m22 << 1) - 1], &si[(m22 << 1) - 1], &sr[m22 * 2], + &si[m22 * 2], &v[m22 * v_dim1 + 1]); + beta = v[m22 * v_dim1 + 1]; + dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 + * v_dim1 + 1]); + } else { + beta = h__[k + 1 + k * h_dim1]; + v[m22 * v_dim1 + 2] = h__[k + 2 + k * h_dim1]; + dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 + * v_dim1 + 1]); + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.; + } + } + +/* ==== Multiply H by reflections from the left ==== */ + + if (accum) { + jbot = std::min(ndcol,*kbot); + } else if (*wantt) { + jbot = *n; + } else { + jbot = *kbot; + } + i__4 = jbot; + for (j = std::max(*ktop,krcol); j <= i__4; ++j) { +/* Computing MIN */ + i__5 = mbot, i__6 = (j - krcol + 2) / 3; + mend = std::min(i__5,i__6); + i__5 = mend; + for (m = mtop; m <= i__5; ++m) { + k = krcol + (m - 1) * 3; + refsum = v[m * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + v[ + m * v_dim1 + 2] * h__[k + 2 + j * h_dim1] + v[m * + v_dim1 + 3] * h__[k + 3 + j * h_dim1]); + h__[k + 1 + j * h_dim1] -= refsum; + h__[k + 2 + j * h_dim1] -= refsum * v[m * v_dim1 + 2]; + h__[k + 3 + j * h_dim1] -= refsum * v[m * v_dim1 + 3]; +/* L30: */ + } +/* L40: */ + } + if (bmp22) { + k = krcol + (m22 - 1) * 3; +/* Computing MAX */ + i__4 = k + 1; + i__5 = jbot; + for (j = std::max(i__4,*ktop); j <= i__5; ++j) { + refsum = v[m22 * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + + v[m22 * v_dim1 + 2] * h__[k + 2 + j * h_dim1]); + h__[k + 1 + j * h_dim1] -= refsum; + h__[k + 2 + j * h_dim1] -= refsum * v[m22 * v_dim1 + 2]; +/* L50: */ + } + } + +/* ==== Multiply H by reflections from the right. */ +/* . Delay filling in the last row until the */ +/* . vigilant deflation check is complete. ==== */ + + if (accum) { + jtop = std::max(*ktop,incol); + } else if (*wantt) { + jtop = 1; + } else { + jtop = *ktop; + } + i__5 = mbot; + for (m = mtop; m <= i__5; ++m) { + if (v[m * v_dim1 + 1] != 0.) { + k = krcol + (m - 1) * 3; +/* Computing MIN */ + i__6 = *kbot, i__7 = k + 3; + i__4 = std::min(i__6,i__7); + for (j = jtop; j <= i__4; ++j) { + refsum = v[m * v_dim1 + 1] * (h__[j + (k + 1) * + h_dim1] + v[m * v_dim1 + 2] * h__[j + (k + 2) + * h_dim1] + v[m * v_dim1 + 3] * h__[j + (k + + 3) * h_dim1]); + h__[j + (k + 1) * h_dim1] -= refsum; + h__[j + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 + + 2]; + h__[j + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + + 3]; +/* L60: */ + } + + if (accum) { + +/* ==== Accumulate U. (If necessary, update Z later */ +/* . with with an efficient matrix-matrix */ +/* . multiply.) ==== */ + + kms = k - incol; +/* Computing MAX */ + i__4 = 1, i__6 = *ktop - incol; + i__7 = kdu; + for (j = std::max(i__4,i__6); j <= i__7; ++j) { + refsum = v[m * v_dim1 + 1] * (u[j + (kms + 1) * + u_dim1] + v[m * v_dim1 + 2] * u[j + (kms + + 2) * u_dim1] + v[m * v_dim1 + 3] * u[j + + (kms + 3) * u_dim1]); + u[j + (kms + 1) * u_dim1] -= refsum; + u[j + (kms + 2) * u_dim1] -= refsum * v[m * + v_dim1 + 2]; + u[j + (kms + 3) * u_dim1] -= refsum * v[m * + v_dim1 + 3]; +/* L70: */ + } + } else if (*wantz) { + +/* ==== U is not accumulated, so update Z */ +/* . now by multiplying by reflections */ +/* . from the right. ==== */ + + i__7 = *ihiz; + for (j = *iloz; j <= i__7; ++j) { + refsum = v[m * v_dim1 + 1] * (z__[j + (k + 1) * + z_dim1] + v[m * v_dim1 + 2] * z__[j + (k + + 2) * z_dim1] + v[m * v_dim1 + 3] * z__[ + j + (k + 3) * z_dim1]); + z__[j + (k + 1) * z_dim1] -= refsum; + z__[j + (k + 2) * z_dim1] -= refsum * v[m * + v_dim1 + 2]; + z__[j + (k + 3) * z_dim1] -= refsum * v[m * + v_dim1 + 3]; +/* L80: */ + } + } + } +/* L90: */ + } + +/* ==== Special case: 2-by-2 reflection (if needed) ==== */ + + k = krcol + (m22 - 1) * 3; + if (bmp22 && v[m22 * v_dim1 + 1] != 0.) { +/* Computing MIN */ + i__7 = *kbot, i__4 = k + 3; + i__5 = std::min(i__7,i__4); + for (j = jtop; j <= i__5; ++j) { + refsum = v[m22 * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1] + + v[m22 * v_dim1 + 2] * h__[j + (k + 2) * h_dim1]) + ; + h__[j + (k + 1) * h_dim1] -= refsum; + h__[j + (k + 2) * h_dim1] -= refsum * v[m22 * v_dim1 + 2]; +/* L100: */ + } + + if (accum) { + kms = k - incol; +/* Computing MAX */ + i__5 = 1, i__7 = *ktop - incol; + i__4 = kdu; + for (j = std::max(i__5,i__7); j <= i__4; ++j) { + refsum = v[m22 * v_dim1 + 1] * (u[j + (kms + 1) * + u_dim1] + v[m22 * v_dim1 + 2] * u[j + (kms + + 2) * u_dim1]); + u[j + (kms + 1) * u_dim1] -= refsum; + u[j + (kms + 2) * u_dim1] -= refsum * v[m22 * v_dim1 + + 2]; +/* L110: */ + } + } else if (*wantz) { + i__4 = *ihiz; + for (j = *iloz; j <= i__4; ++j) { + refsum = v[m22 * v_dim1 + 1] * (z__[j + (k + 1) * + z_dim1] + v[m22 * v_dim1 + 2] * z__[j + (k + + 2) * z_dim1]); + z__[j + (k + 1) * z_dim1] -= refsum; + z__[j + (k + 2) * z_dim1] -= refsum * v[m22 * v_dim1 + + 2]; +/* L120: */ + } + } + } + +/* ==== Vigilant deflation check ==== */ + + mstart = mtop; + if (krcol + (mstart - 1) * 3 < *ktop) { + ++mstart; + } + mend = mbot; + if (bmp22) { + ++mend; + } + if (krcol == *kbot - 2) { + ++mend; + } + i__4 = mend; + for (m = mstart; m <= i__4; ++m) { +/* Computing MIN */ + i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3; + k = std::min(i__5,i__7); + +/* ==== The following convergence test requires that */ +/* . the tradition small-compared-to-nearby-diagonals */ +/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */ +/* . criteria both be satisfied. The latter improves */ +/* . accuracy in some examples. Falling back on an */ +/* . alternate convergence criterion when TST1 or TST2 */ +/* . is zero (as done here) is traditional but probably */ +/* . unnecessary. ==== */ + + if (h__[k + 1 + k * h_dim1] != 0.) { + tst1 = (d__1 = h__[k + k * h_dim1], abs(d__1)) + (d__2 = + h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); + if (tst1 == 0.) { + if (k >= *ktop + 1) { + tst1 += (d__1 = h__[k + (k - 1) * h_dim1], abs( + d__1)); + } + if (k >= *ktop + 2) { + tst1 += (d__1 = h__[k + (k - 2) * h_dim1], abs( + d__1)); + } + if (k >= *ktop + 3) { + tst1 += (d__1 = h__[k + (k - 3) * h_dim1], abs( + d__1)); + } + if (k <= *kbot - 2) { + tst1 += (d__1 = h__[k + 2 + (k + 1) * h_dim1], + abs(d__1)); + } + if (k <= *kbot - 3) { + tst1 += (d__1 = h__[k + 3 + (k + 1) * h_dim1], + abs(d__1)); + } + if (k <= *kbot - 4) { + tst1 += (d__1 = h__[k + 4 + (k + 1) * h_dim1], + abs(d__1)); + } + } +/* Computing MAX */ + d__2 = smlnum, d__3 = ulp * tst1; + if ((d__1 = h__[k + 1 + k * h_dim1], abs(d__1)) <= std::max( + d__2,d__3)) { +/* Computing MAX */ + d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)), + d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs( + d__2)); + h12 = std::max(d__3,d__4); +/* Computing MIN */ + d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)), + d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs( + d__2)); + h21 = std::min(d__3,d__4); +/* Computing MAX */ + d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs( + d__1)), d__4 = (d__2 = h__[k + k * h_dim1] - + h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); + h11 = std::max(d__3,d__4); +/* Computing MIN */ + d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs( + d__1)), d__4 = (d__2 = h__[k + k * h_dim1] - + h__[k + 1 + (k + 1) * h_dim1], abs(d__2)); + h22 = std::min(d__3,d__4); + scl = h11 + h12; + tst2 = h22 * (h11 / scl); + +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * tst2; + if (tst2 == 0. || h21 * (h12 / scl) <= std::max(d__1,d__2)) + { + h__[k + 1 + k * h_dim1] = 0.; + } + } + } +/* L130: */ + } + +/* ==== Fill in the last row of each bulge. ==== */ + +/* Computing MIN */ + i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3; + mend = std::min(i__4,i__5); + i__4 = mend; + for (m = mtop; m <= i__4; ++m) { + k = krcol + (m - 1) * 3; + refsum = v[m * v_dim1 + 1] * v[m * v_dim1 + 3] * h__[k + 4 + ( + k + 3) * h_dim1]; + h__[k + 4 + (k + 1) * h_dim1] = -refsum; + h__[k + 4 + (k + 2) * h_dim1] = -refsum * v[m * v_dim1 + 2]; + h__[k + 4 + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3]; +/* L140: */ + } + +/* ==== End of near-the-diagonal bulge chase. ==== */ + +/* L150: */ + } + +/* ==== Use U (if accumulated) to update far-from-diagonal */ +/* . entries in H. If required, use U to update Z as */ +/* . well. ==== */ + + if (accum) { + if (*wantt) { + jtop = 1; + jbot = *n; + } else { + jtop = *ktop; + jbot = *kbot; + } + if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) { + +/* ==== Updates not exploiting the 2-by-2 block */ +/* . structure of U. K1 and NU keep track of */ +/* . the location and size of U in the special */ +/* . cases of introducing bulges and chasing */ +/* . bulges off the bottom. In these special */ +/* . cases and in case the number of shifts */ +/* . is NS = 2, there is no 2-by-2 block */ +/* . structure to exploit. ==== */ + +/* Computing MAX */ + i__3 = 1, i__4 = *ktop - incol; + k1 = std::max(i__3,i__4); +/* Computing MAX */ + i__3 = 0, i__4 = ndcol - *kbot; + nu = kdu - std::max(i__3,i__4) - k1 + 1; + +/* ==== Horizontal Multiply ==== */ + + i__3 = jbot; + i__4 = *nh; + for (jcol = std::min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 : + jcol <= i__3; jcol += i__4) { +/* Computing MIN */ + i__5 = *nh, i__7 = jbot - jcol + 1; + jlen = std::min(i__5,i__7); + dgemm_("C", "N", &nu, &jlen, &nu, &c_b8, &u[k1 + k1 * + u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1], + ldh, &c_b7, &wh[wh_offset], ldwh); + dlacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[ + incol + k1 + jcol * h_dim1], ldh); +/* L160: */ + } + +/* ==== Vertical multiply ==== */ + + i__4 = std::max(*ktop,incol) - 1; + i__3 = *nv; + for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4; + jrow += i__3) { +/* Computing MIN */ + i__5 = *nv, i__7 = std::max(*ktop,incol) - jrow; + jlen = std::min(i__5,i__7); + dgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &h__[jrow + ( + incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1], + ldu, &c_b7, &wv[wv_offset], ldwv); + dlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[ + jrow + (incol + k1) * h_dim1], ldh); +/* L170: */ + } + +/* ==== Z multiply (also vertical) ==== */ + + if (*wantz) { + i__3 = *ihiz; + i__4 = *nv; + for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3; + jrow += i__4) { +/* Computing MIN */ + i__5 = *nv, i__7 = *ihiz - jrow + 1; + jlen = std::min(i__5,i__7); + dgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &z__[jrow + ( + incol + k1) * z_dim1], ldz, &u[k1 + k1 * + u_dim1], ldu, &c_b7, &wv[wv_offset], ldwv); + dlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[ + jrow + (incol + k1) * z_dim1], ldz) + ; +/* L180: */ + } + } + } else { + +/* ==== Updates exploiting U's 2-by-2 block structure. */ +/* . (I2, I4, J2, J4 are the last rows and columns */ +/* . of the blocks.) ==== */ + + i2 = (kdu + 1) / 2; + i4 = kdu; + j2 = i4 - i2; + j4 = kdu; + +/* ==== KZS and KNZ deal with the band of zeros */ +/* . along the diagonal of one of the triangular */ +/* . blocks. ==== */ + + kzs = j4 - j2 - (ns + 1); + knz = ns + 1; + +/* ==== Horizontal multiply ==== */ + + i__4 = jbot; + i__3 = *nh; + for (jcol = std::min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 : + jcol <= i__4; jcol += i__3) { +/* Computing MIN */ + i__5 = *nh, i__7 = jbot - jcol + 1; + jlen = std::min(i__5,i__7); + +/* ==== Copy bottom of H to top+KZS of scratch ==== */ +/* (The first KZS rows get multiplied by zero.) ==== */ + + dlacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol * + h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh); + +/* ==== Multiply by U21' ==== */ + + dlaset_("ALL", &kzs, &jlen, &c_b7, &c_b7, &wh[wh_offset], + ldwh); + dtrmm_("L", "U", "C", "N", &knz, &jlen, &c_b8, &u[j2 + 1 + + (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1] +, ldwh); + +/* ==== Multiply top of H by U11' ==== */ + + dgemm_("C", "N", &i2, &jlen, &j2, &c_b8, &u[u_offset], + ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b8, + &wh[wh_offset], ldwh); + +/* ==== Copy top of H to bottom of WH ==== */ + + dlacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1] +, ldh, &wh[i2 + 1 + wh_dim1], ldwh); + +/* ==== Multiply by U21' ==== */ + + dtrmm_("L", "L", "C", "N", &j2, &jlen, &c_b8, &u[(i2 + 1) + * u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh); + +/* ==== Multiply by U22 ==== */ + + i__5 = i4 - i2; + i__7 = j4 - j2; + dgemm_("C", "N", &i__5, &jlen, &i__7, &c_b8, &u[j2 + 1 + ( + i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 + + jcol * h_dim1], ldh, &c_b8, &wh[i2 + 1 + wh_dim1], + ldwh); + +/* ==== Copy it back ==== */ + + dlacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[ + incol + 1 + jcol * h_dim1], ldh); +/* L190: */ + } + +/* ==== Vertical multiply ==== */ + + i__3 = std::max(incol,*ktop) - 1; + i__4 = *nv; + for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3; + jrow += i__4) { +/* Computing MIN */ + i__5 = *nv, i__7 = std::max(incol,*ktop) - jrow; + jlen = std::min(i__5,i__7); + +/* ==== Copy right of H to scratch (the first KZS */ +/* . columns get multiplied by zero) ==== */ + + dlacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) * + h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv); + +/* ==== Multiply by U21 ==== */ + + dlaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[wv_offset], + ldwv); + dtrmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 + 1 + + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) * + wv_dim1 + 1], ldwv); + +/* ==== Multiply by U11 ==== */ + + dgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &h__[jrow + ( + incol + 1) * h_dim1], ldh, &u[u_offset], ldu, & + c_b8, &wv[wv_offset], ldwv); + +/* ==== Copy left of H to right of scratch ==== */ + + dlacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) * + h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv); + +/* ==== Multiply by U21 ==== */ + + i__5 = i4 - i2; + dtrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(i2 + + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1] +, ldwv); + +/* ==== Multiply by U22 ==== */ + + i__5 = i4 - i2; + i__7 = j4 - j2; + dgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &h__[jrow + ( + incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 + + 1) * u_dim1], ldu, &c_b8, &wv[(i2 + 1) * wv_dim1 + + 1], ldwv); + +/* ==== Copy it back ==== */ + + dlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[ + jrow + (incol + 1) * h_dim1], ldh); +/* L200: */ + } + +/* ==== Multiply Z (also vertical) ==== */ + + if (*wantz) { + i__4 = *ihiz; + i__3 = *nv; + for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4; + jrow += i__3) { +/* Computing MIN */ + i__5 = *nv, i__7 = *ihiz - jrow + 1; + jlen = std::min(i__5,i__7); + +/* ==== Copy right of Z to left of scratch (first */ +/* . KZS columns get multiplied by zero) ==== */ + + dlacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 + + j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 + + 1], ldwv); + +/* ==== Multiply by U12 ==== */ + + dlaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[ + wv_offset], ldwv); + dtrmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 + + 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) + * wv_dim1 + 1], ldwv); + +/* ==== Multiply by U11 ==== */ + + dgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &z__[jrow + ( + incol + 1) * z_dim1], ldz, &u[u_offset], ldu, + &c_b8, &wv[wv_offset], ldwv); + +/* ==== Copy left of Z to right of scratch ==== */ + + dlacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) * + z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1], + ldwv); + +/* ==== Multiply by U21 ==== */ + + i__5 = i4 - i2; + dtrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[( + i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * + wv_dim1 + 1], ldwv); + +/* ==== Multiply by U22 ==== */ + + i__5 = i4 - i2; + i__7 = j4 - j2; + dgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &z__[ + jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2 + + 1 + (i2 + 1) * u_dim1], ldu, &c_b8, &wv[(i2 + + 1) * wv_dim1 + 1], ldwv); + +/* ==== Copy the result back to Z ==== */ + + dlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, & + z__[jrow + (incol + 1) * z_dim1], ldz); +/* L210: */ + } + } + } + } +/* L220: */ + } + +/* ==== End of DLAQR5 ==== */ + + return 0; +} /* dlaqr5_ */ + +/* Subroutine */ int dlaqsb_(const char *uplo, integer *n, integer *kd, double * + ab, integer *ldab, double *s, double *scond, double *amax, + const char *equed) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j; + double cj, large; + + double small; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQSB equilibrates a symmetric band matrix A using the scaling */ +/* factors in the vector S. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* On exit, if INFO = 0, the triangular factor U or L from the */ +/* Cholesky factorization A = U'*U or A = L*L' of the band */ +/* matrix A, in the same storage format as A. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* S (input) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A. */ + +/* SCOND (input) DOUBLE PRECISION */ +/* Ratio of the smallest S(i) to the largest S(i). */ + +/* AMAX (input) DOUBLE PRECISION */ +/* Absolute value of largest matrix entry. */ + +/* EQUED (output) CHARACTER*1 */ +/* Specifies whether or not equilibration was done. */ +/* = 'N': No equilibration. */ +/* = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* diag(S) * A * diag(S). */ + +/* Internal Parameters */ +/* =================== */ + +/* THRESH is a threshold value used to decide if scaling should be done */ +/* based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* scaling is done. */ + +/* LARGE and SMALL are threshold values used to decide if scaling should */ +/* be done based on the absolute size of the largest matrix element. */ +/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored in band format. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *kd; + i__4 = j; + for (i__ = std::max(i__2,i__3); i__ <= i__4; ++i__) { + ab[*kd + 1 + i__ - j + j * ab_dim1] = cj * s[i__] * ab[* + kd + 1 + i__ - j + j * ab_dim1]; +/* L10: */ + } +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; +/* Computing MIN */ + i__2 = *n, i__3 = j + *kd; + i__4 = std::min(i__2,i__3); + for (i__ = j; i__ <= i__4; ++i__) { + ab[i__ + 1 - j + j * ab_dim1] = cj * s[i__] * ab[i__ + 1 + - j + j * ab_dim1]; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of DLAQSB */ + +} /* dlaqsb_ */ + +/* Subroutine */ int dlaqsp_(const char *uplo, integer *n, double *ap, + double *s, double *scond, double *amax, char *equed) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j, jc; + double cj, large; + + double small; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQSP equilibrates a symmetric matrix A using the scaling factors */ +/* in the vector S. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */ +/* the same storage format as A. */ + +/* S (input) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A. */ + +/* SCOND (input) DOUBLE PRECISION */ +/* Ratio of the smallest S(i) to the largest S(i). */ + +/* AMAX (input) DOUBLE PRECISION */ +/* Absolute value of largest matrix entry. */ + +/* EQUED (output) CHARACTER*1 */ +/* Specifies whether or not equilibration was done. */ +/* = 'N': No equilibration. */ +/* = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* diag(S) * A * diag(S). */ + +/* Internal Parameters */ +/* =================== */ + +/* THRESH is a threshold value used to decide if scaling should be done */ +/* based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* scaling is done. */ + +/* LARGE and SMALL are threshold values used to decide if scaling should */ +/* be done based on the absolute size of the largest matrix element. */ +/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + --s; + --ap; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ap[jc + i__ - 1] = cj * s[i__] * ap[jc + i__ - 1]; +/* L10: */ + } + jc += j; +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[jc + i__ - j] = cj * s[i__] * ap[jc + i__ - j]; +/* L30: */ + } + jc = jc + *n - j + 1; +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of DLAQSP */ + +} /* dlaqsp_ */ + +/* Subroutine */ int dlaqsy_(const char *uplo, integer *n, double *a, integer * + lda, double *s, double *scond, double *amax, char *equed) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + double cj, large; + + double small; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQSY equilibrates a symmetric matrix A using the scaling factors */ +/* in the vector S. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n by n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n by n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if EQUED = 'Y', the equilibrated matrix: */ +/* diag(S) * A * diag(S). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(N,1). */ + +/* S (input) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A. */ + +/* SCOND (input) DOUBLE PRECISION */ +/* Ratio of the smallest S(i) to the largest S(i). */ + +/* AMAX (input) DOUBLE PRECISION */ +/* Absolute value of largest matrix entry. */ + +/* EQUED (output) CHARACTER*1 */ +/* Specifies whether or not equilibration was done. */ +/* = 'N': No equilibration. */ +/* = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* diag(S) * A * diag(S). */ + +/* Internal Parameters */ +/* =================== */ + +/* THRESH is a threshold value used to decide if scaling should be done */ +/* based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* scaling is done. */ + +/* LARGE and SMALL are threshold values used to decide if scaling should */ +/* be done based on the absolute size of the largest matrix element. */ +/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of DLAQSY */ + +} /* dlaqsy_ */ + +/* Subroutine */ int dlaqtr_(bool *ltran, bool *lreal, integer *n, + double *t, integer *ldt, double *b, double *w, double + *scale, double *x, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static bool c_false = false; + static integer c__2 = 2; + static double c_b21 = 1.; + static double c_b25 = 0.; + static bool c_true = true; + + /* System generated locals */ + integer t_dim1, t_offset, i__1, i__2; + double d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + double d__[4] /* was [2][2] */; + integer i__, j, k; + double v[4] /* was [2][2] */, z__; + integer j1, j2, n1, n2; + double si, xj, sr, rec, eps, tjj, tmp; + integer ierr; + double smin, xmax; + integer jnext; + double sminw, xnorm; + double scaloc; + double bignum; + bool notran; + double smlnum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAQTR solves the real quasi-triangular system */ + +/* op(T)*p = scale*c, if LREAL = .TRUE. */ + +/* or the complex quasi-triangular systems */ + +/* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */ + +/* in real arithmetic, where T is upper quasi-triangular. */ +/* If LREAL = .FALSE., then the first diagonal block of T must be */ +/* 1 by 1, B is the specially structured matrix */ + +/* B = [ b(1) b(2) ... b(n) ] */ +/* [ w ] */ +/* [ w ] */ +/* [ . ] */ +/* [ w ] */ + +/* op(A) = A or A', A' denotes the conjugate transpose of */ +/* matrix A. */ + +/* On input, X = [ c ]. On output, X = [ p ]. */ +/* [ d ] [ q ] */ + +/* This subroutine is designed for the condition number estimation */ +/* in routine DTRSNA. */ + +/* Arguments */ +/* ========= */ + +/* LTRAN (input) LOGICAL */ +/* On entry, LTRAN specifies the option of conjugate transpose: */ +/* = .FALSE., op(T+i*B) = T+i*B, */ +/* = .TRUE., op(T+i*B) = (T+i*B)'. */ + +/* LREAL (input) LOGICAL */ +/* On entry, LREAL specifies the input matrix structure: */ +/* = .FALSE., the input is complex */ +/* = .TRUE., the input is real */ + +/* N (input) INTEGER */ +/* On entry, N specifies the order of T+i*B. N >= 0. */ + +/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */ +/* On entry, T contains a matrix in Schur canonical form. */ +/* If LREAL = .FALSE., then the first diagonal block of T mu */ +/* be 1 by 1. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the matrix T. LDT >= max(1,N). */ + +/* B (input) DOUBLE PRECISION array, dimension (N) */ +/* On entry, B contains the elements to form the matrix */ +/* B as described above. */ +/* If LREAL = .TRUE., B is not referenced. */ + +/* W (input) DOUBLE PRECISION */ +/* On entry, W is the diagonal element of the matrix B. */ +/* If LREAL = .TRUE., W is not referenced. */ + +/* SCALE (output) DOUBLE PRECISION */ +/* On exit, SCALE is the scale factor. */ + +/* X (input/output) DOUBLE PRECISION array, dimension (2*N) */ +/* On entry, X contains the right hand side of the system. */ +/* On exit, X is overwritten by the solution. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* On exit, INFO is set to */ +/* 0: successful exit. */ +/* 1: the some diagonal 1 by 1 block has been perturbed by */ +/* a small number SMIN to keep nonsingularity. */ +/* 2: the some diagonal 2 by 2 block has been perturbed by */ +/* a small number in DLALN2 to keep nonsingularity. */ +/* NOTE: In the interests of speed, this routine does not */ +/* check the inputs for errors. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Do not test the input parameters for errors */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + --b; + --x; + --work; + + /* Function Body */ + notran = ! (*ltran); + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Set constants to control overflow */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + bignum = 1. / smlnum; + + xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__); + if (! (*lreal)) { +/* Computing MAX */ + d__1 = xnorm, d__2 = abs(*w), d__1 = std::max(d__1,d__2), d__2 = dlange_( + "M", n, &c__1, &b[1], n, d__); + xnorm = std::max(d__1,d__2); + } +/* Computing MAX */ + d__1 = smlnum, d__2 = eps * xnorm; + smin = std::max(d__1,d__2); + +/* Compute 1-norm of each column of strictly upper triangular */ +/* part of T to control overflow in triangular solver. */ + + work[1] = 0.; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + work[j] = dasum_(&i__2, &t[j * t_dim1 + 1], &c__1); +/* L10: */ + } + + if (! (*lreal)) { + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + work[i__] += (d__1 = b[i__], abs(d__1)); +/* L20: */ + } + } + + n2 = *n << 1; + n1 = *n; + if (! (*lreal)) { + n1 = n2; + } + k = idamax_(&n1, &x[1], &c__1); + xmax = (d__1 = x[k], abs(d__1)); + *scale = 1.; + + if (xmax > bignum) { + *scale = bignum / xmax; + dscal_(&n1, scale, &x[1], &c__1); + xmax = bignum; + } + + if (*lreal) { + + if (notran) { + +/* Solve T*p = scale*c */ + + jnext = *n; + for (j = *n; j >= 1; --j) { + if (j > jnext) { + goto L30; + } + j1 = j; + j2 = j; + jnext = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnext = j - 2; + } + } + + if (j1 == j2) { + +/* Meet 1 by 1 diagonal block */ + +/* Scale to avoid overflow when computing */ +/* x(j) = b(j)/T(j,j) */ + + xj = (d__1 = x[j1], abs(d__1)); + tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)); + tmp = t[j1 + j1 * t_dim1]; + if (tjj < smin) { + tmp = smin; + tjj = smin; + *info = 1; + } + + if (xj == 0.) { + goto L30; + } + + if (tjj < 1.) { + if (xj > bignum * tjj) { + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j1] /= tmp; + xj = (d__1 = x[j1], abs(d__1)); + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j1 of T. */ + + if (xj > 1.) { + rec = 1. / xj; + if (work[j1] > (bignum - xmax) * rec) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } + if (j1 > 1) { + i__1 = j1 - 1; + d__1 = -x[j1]; + daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] +, &c__1); + i__1 = j1 - 1; + k = idamax_(&i__1, &x[1], &c__1); + xmax = (d__1 = x[k], abs(d__1)); + } + + } else { + +/* Meet 2 by 2 diagonal block */ + +/* Call 2 by 2 linear system solve, to take */ +/* care of possible overflow by scaling factor. */ + + d__[0] = x[j1]; + d__[1] = x[j2]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 + * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & + c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 2; + } + + if (scaloc != 1.) { + dscal_(n, &scaloc, &x[1], &c__1); + *scale *= scaloc; + } + x[j1] = v[0]; + x[j2] = v[1]; + +/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */ +/* to avoid overflow in updating right-hand side. */ + +/* Computing MAX */ + d__1 = abs(v[0]), d__2 = abs(v[1]); + xj = std::max(d__1,d__2); + if (xj > 1.) { + rec = 1. / xj; +/* Computing MAX */ + d__1 = work[j1], d__2 = work[j2]; + if (std::max(d__1,d__2) > (bignum - xmax) * rec) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } + +/* Update right-hand side */ + + if (j1 > 1) { + i__1 = j1 - 1; + d__1 = -x[j1]; + daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] +, &c__1); + i__1 = j1 - 1; + d__1 = -x[j2]; + daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] +, &c__1); + i__1 = j1 - 1; + k = idamax_(&i__1, &x[1], &c__1); + xmax = (d__1 = x[k], abs(d__1)); + } + + } + +L30: + ; + } + + } else { + +/* Solve T'*p = scale*c */ + + jnext = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (j < jnext) { + goto L40; + } + j1 = j; + j2 = j; + jnext = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnext = j + 2; + } + } + + if (j1 == j2) { + +/* 1 by 1 diagonal block */ + +/* Scale if necessary to avoid overflow in forming the */ +/* right-hand side element by inner product. */ + + xj = (d__1 = x[j1], abs(d__1)); + if (xmax > 1.) { + rec = 1. / xmax; + if (work[j1] > (bignum - xj) * rec) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + i__2 = j1 - 1; + x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & + c__1); + + xj = (d__1 = x[j1], abs(d__1)); + tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)); + tmp = t[j1 + j1 * t_dim1]; + if (tjj < smin) { + tmp = smin; + tjj = smin; + *info = 1; + } + + if (tjj < 1.) { + if (xj > bignum * tjj) { + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j1] /= tmp; +/* Computing MAX */ + d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1)); + xmax = std::max(d__2,d__3); + + } else { + +/* 2 by 2 diagonal block */ + +/* Scale if necessary to avoid overflow in forming the */ +/* right-hand side elements by inner product. */ + +/* Computing MAX */ + d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2], + abs(d__2)); + xj = std::max(d__3,d__4); + if (xmax > 1.) { + rec = 1. / xmax; +/* Computing MAX */ + d__1 = work[j2], d__2 = work[j1]; + if (std::max(d__1,d__2) > (bignum - xj) * rec) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + i__2 = j1 - 1; + d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, + &x[1], &c__1); + i__2 = j1 - 1; + d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, + &x[1], &c__1); + + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 * + t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, + &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 2; + } + + if (scaloc != 1.) { + dscal_(n, &scaloc, &x[1], &c__1); + *scale *= scaloc; + } + x[j1] = v[0]; + x[j2] = v[1]; +/* Computing MAX */ + d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2], + abs(d__2)), d__3 = std::max(d__3,d__4); + xmax = std::max(d__3,xmax); + + } +L40: + ; + } + } + + } else { + +/* Computing MAX */ + d__1 = eps * abs(*w); + sminw = std::max(d__1,smin); + if (notran) { + +/* Solve (T + iB)*(p+iq) = c+id */ + + jnext = *n; + for (j = *n; j >= 1; --j) { + if (j > jnext) { + goto L70; + } + j1 = j; + j2 = j; + jnext = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnext = j - 2; + } + } + + if (j1 == j2) { + +/* 1 by 1 diagonal block */ + +/* Scale if necessary to avoid overflow in division */ + + z__ = *w; + if (j1 == 1) { + z__ = b[1]; + } + xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs( + d__2)); + tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__); + tmp = t[j1 + j1 * t_dim1]; + if (tjj < sminw) { + tmp = sminw; + tjj = sminw; + *info = 1; + } + + if (xj == 0.) { + goto L70; + } + + if (tjj < 1.) { + if (xj > bignum * tjj) { + rec = 1. / xj; + dscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si); + x[j1] = sr; + x[*n + j1] = si; + xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs( + d__2)); + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j1 of T. */ + + if (xj > 1.) { + rec = 1. / xj; + if (work[j1] > (bignum - xmax) * rec) { + dscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + } + } + + if (j1 > 1) { + i__1 = j1 - 1; + d__1 = -x[j1]; + daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] +, &c__1); + i__1 = j1 - 1; + d__1 = -x[*n + j1]; + daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[* + n + 1], &c__1); + + x[1] += b[j1] * x[*n + j1]; + x[*n + 1] -= b[j1] * x[j1]; + + xmax = 0.; + i__1 = j1 - 1; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + ( + d__2 = x[k + *n], abs(d__2)); + xmax = std::max(d__3,d__4); +/* L50: */ + } + } + + } else { + +/* Meet 2 by 2 diagonal block */ + + d__[0] = x[j1]; + d__[1] = x[j2]; + d__[2] = x[*n + j1]; + d__[3] = x[*n + j2]; + d__1 = -(*w); + dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 + + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & + c_b25, &d__1, v, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 2; + } + + if (scaloc != 1.) { + i__1 = *n << 1; + dscal_(&i__1, &scaloc, &x[1], &c__1); + *scale = scaloc * *scale; + } + x[j1] = v[0]; + x[j2] = v[1]; + x[*n + j1] = v[2]; + x[*n + j2] = v[3]; + +/* Scale X(J1), .... to avoid overflow in */ +/* updating right hand side. */ + +/* Computing MAX */ + d__1 = abs(v[0]) + abs(v[2]), d__2 = abs(v[1]) + abs(v[3]) + ; + xj = std::max(d__1,d__2); + if (xj > 1.) { + rec = 1. / xj; +/* Computing MAX */ + d__1 = work[j1], d__2 = work[j2]; + if (std::max(d__1,d__2) > (bignum - xmax) * rec) { + dscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + } + } + +/* Update the right-hand side. */ + + if (j1 > 1) { + i__1 = j1 - 1; + d__1 = -x[j1]; + daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] +, &c__1); + i__1 = j1 - 1; + d__1 = -x[j2]; + daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] +, &c__1); + + i__1 = j1 - 1; + d__1 = -x[*n + j1]; + daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[* + n + 1], &c__1); + i__1 = j1 - 1; + d__1 = -x[*n + j2]; + daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[* + n + 1], &c__1); + + x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2]; + x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2]; + + xmax = 0.; + i__1 = j1 - 1; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + * + n], abs(d__2)); + xmax = std::max(d__3,xmax); +/* L60: */ + } + } + + } +L70: + ; + } + + } else { + +/* Solve (T + iB)'*(p+iq) = c+id */ + + jnext = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (j < jnext) { + goto L80; + } + j1 = j; + j2 = j; + jnext = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnext = j + 2; + } + } + + if (j1 == j2) { + +/* 1 by 1 diagonal block */ + +/* Scale if necessary to avoid overflow in forming the */ +/* right-hand side element by inner product. */ + + xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs( + d__2)); + if (xmax > 1.) { + rec = 1. / xmax; + if (work[j1] > (bignum - xj) * rec) { + dscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + i__2 = j1 - 1; + x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & + c__1); + i__2 = j1 - 1; + x[*n + j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[ + *n + 1], &c__1); + if (j1 > 1) { + x[j1] -= b[j1] * x[*n + 1]; + x[*n + j1] += b[j1] * x[1]; + } + xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs( + d__2)); + + z__ = *w; + if (j1 == 1) { + z__ = b[1]; + } + +/* Scale if necessary to avoid overflow in */ +/* complex division */ + + tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__); + tmp = t[j1 + j1 * t_dim1]; + if (tjj < sminw) { + tmp = sminw; + tjj = sminw; + *info = 1; + } + + if (tjj < 1.) { + if (xj > bignum * tjj) { + rec = 1. / xj; + dscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + d__1 = -z__; + dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si); + x[j1] = sr; + x[j1 + *n] = si; +/* Computing MAX */ + d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], + abs(d__2)); + xmax = std::max(d__3,xmax); + + } else { + +/* 2 by 2 diagonal block */ + +/* Scale if necessary to avoid overflow in forming the */ +/* right-hand side element by inner product. */ + +/* Computing MAX */ + d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], + abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + ( + d__4 = x[*n + j2], abs(d__4)); + xj = std::max(d__5,d__6); + if (xmax > 1.) { + rec = 1. / xmax; +/* Computing MAX */ + d__1 = work[j1], d__2 = work[j2]; + if (std::max(d__1,d__2) > (bignum - xj) / xmax) { + dscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + i__2 = j1 - 1; + d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, + &x[1], &c__1); + i__2 = j1 - 1; + d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, + &x[1], &c__1); + i__2 = j1 - 1; + d__[2] = x[*n + j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], & + c__1, &x[*n + 1], &c__1); + i__2 = j1 - 1; + d__[3] = x[*n + j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], & + c__1, &x[*n + 1], &c__1); + d__[0] -= b[j1] * x[*n + 1]; + d__[1] -= b[j2] * x[*n + 1]; + d__[2] += b[j1] * x[1]; + d__[3] += b[j2] * x[1]; + + dlaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1 + * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & + c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 2; + } + + if (scaloc != 1.) { + dscal_(&n2, &scaloc, &x[1], &c__1); + *scale = scaloc * *scale; + } + x[j1] = v[0]; + x[j2] = v[1]; + x[*n + j1] = v[2]; + x[*n + j2] = v[3]; +/* Computing MAX */ + d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], + abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + ( + d__4 = x[*n + j2], abs(d__4)), d__5 = std::max(d__5, + d__6); + xmax = std::max(d__5,xmax); + + } + +L80: + ; + } + + } + + } + + return 0; + +/* End of DLAQTR */ + +} /* dlaqtr_ */ diff --git a/external/clapack/lapack_dlar.cpp b/external/clapack/lapack_dlar.cpp new file mode 100644 index 00000000..b722d9d2 --- /dev/null +++ b/external/clapack/lapack_dlar.cpp @@ -0,0 +1,22561 @@ +#include "clapack.h" +#include "f2cP.h" + +/* Subroutine */ int dlar1v_(integer *n, integer *b1, integer *bn, double + *lambda, double *d__, double *l, double *ld, double * + lld, double *pivmin, double *gaptol, double *z__, bool + *wantnc, integer *negcnt, double *ztz, double *mingma, + integer *r__, integer *isuppz, double *nrminv, double *resid, + double *rqcorr, double *work) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2, d__3; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__; + double s; + integer r1, r2; + double eps, tmp; + integer neg1, neg2, indp, inds; + double dplus; + + + integer indlpl, indumn; + double dminus; + bool sawnan1, sawnan2; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAR1V computes the (scaled) r-th column of the inverse of */ +/* the sumbmatrix in rows B1 through BN of the tridiagonal matrix */ +/* L D L^T - sigma I. When sigma is close to an eigenvalue, the */ +/* computed vector is an accurate eigenvector. Usually, r corresponds */ +/* to the index where the eigenvector is largest in magnitude. */ +/* The following steps accomplish this computation : */ +/* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T, */ +/* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, */ +/* (c) Computation of the diagonal elements of the inverse of */ +/* L D L^T - sigma I by combining the above transforms, and choosing */ +/* r as the index where the diagonal of the inverse is (one of the) */ +/* largest in magnitude. */ +/* (d) Computation of the (scaled) r-th column of the inverse using the */ +/* twisted factorization obtained by combining the top part of the */ +/* the stationary and the bottom part of the progressive transform. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix L D L^T. */ + +/* B1 (input) INTEGER */ +/* First index of the submatrix of L D L^T. */ + +/* BN (input) INTEGER */ +/* Last index of the submatrix of L D L^T. */ + +/* LAMBDA (input) DOUBLE PRECISION */ +/* The shift. In order to compute an accurate eigenvector, */ +/* LAMBDA should be a good approximation to an eigenvalue */ +/* of L D L^T. */ + +/* L (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */ +/* L, in elements 1 to N-1. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the diagonal matrix D. */ + +/* LD (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The n-1 elements L(i)*D(i). */ + +/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The n-1 elements L(i)*L(i)*D(i). */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum pivot in the Sturm sequence. */ + +/* GAPTOL (input) DOUBLE PRECISION */ +/* Tolerance that indicates when eigenvector entries are negligible */ +/* w.r.t. their contribution to the residual. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On input, all entries of Z must be set to 0. */ +/* On output, Z contains the (scaled) r-th column of the */ +/* inverse. The scaling is such that Z(R) equals 1. */ + +/* WANTNC (input) LOGICAL */ +/* Specifies whether NEGCNT has to be computed. */ + +/* NEGCNT (output) INTEGER */ +/* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */ +/* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise. */ + +/* ZTZ (output) DOUBLE PRECISION */ +/* The square of the 2-norm of Z. */ + +/* MINGMA (output) DOUBLE PRECISION */ +/* The reciprocal of the largest (in magnitude) diagonal */ +/* element of the inverse of L D L^T - sigma I. */ + +/* R (input/output) INTEGER */ +/* The twist index for the twisted factorization used to */ +/* compute Z. */ +/* On input, 0 <= R <= N. If R is input as 0, R is set to */ +/* the index where (L D L^T - sigma I)^{-1} is largest */ +/* in magnitude. If 1 <= R <= N, R is unchanged. */ +/* On output, R contains the twist index used to compute Z. */ +/* Ideally, R designates the position of the maximum entry in the */ +/* eigenvector. */ + +/* ISUPPZ (output) INTEGER array, dimension (2) */ +/* The support of the vector in Z, i.e., the vector Z is */ +/* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */ + +/* NRMINV (output) DOUBLE PRECISION */ +/* NRMINV = 1/SQRT( ZTZ ) */ + +/* RESID (output) DOUBLE PRECISION */ +/* The residual of the FP vector. */ +/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */ + +/* RQCORR (output) DOUBLE PRECISION */ +/* The Rayleigh Quotient correction to LAMBDA. */ +/* RQCORR = MINGMA*TMP */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --work; + --isuppz; + --z__; + --lld; + --ld; + --l; + --d__; + + /* Function Body */ + eps = dlamch_("Precision"); + if (*r__ == 0) { + r1 = *b1; + r2 = *bn; + } else { + r1 = *r__; + r2 = *r__; + } +/* Storage for LPLUS */ + indlpl = 0; +/* Storage for UMINUS */ + indumn = *n; + inds = (*n << 1) + 1; + indp = *n * 3 + 1; + if (*b1 == 1) { + work[inds] = 0.; + } else { + work[inds + *b1 - 1] = lld[*b1 - 1]; + } + +/* Compute the stationary transform (using the differential form) */ +/* until the index R2. */ + + sawnan1 = false; + neg1 = 0; + s = work[inds + *b1 - 1] - *lambda; + i__1 = r1 - 1; + for (i__ = *b1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + work[indlpl + i__] = ld[i__] / dplus; + if (dplus < 0.) { + ++neg1; + } + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + s = work[inds + i__] - *lambda; +/* L50: */ + } + sawnan1 = disnan_(&s); + if (sawnan1) { + goto L60; + } + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + work[indlpl + i__] = ld[i__] / dplus; + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + s = work[inds + i__] - *lambda; +/* L51: */ + } + sawnan1 = disnan_(&s); + +L60: + if (sawnan1) { +/* Runs a slower version of the above loop if a NaN is detected */ + neg1 = 0; + s = work[inds + *b1 - 1] - *lambda; + i__1 = r1 - 1; + for (i__ = *b1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + if (abs(dplus) < *pivmin) { + dplus = -(*pivmin); + } + work[indlpl + i__] = ld[i__] / dplus; + if (dplus < 0.) { + ++neg1; + } + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + if (work[indlpl + i__] == 0.) { + work[inds + i__] = lld[i__]; + } + s = work[inds + i__] - *lambda; +/* L70: */ + } + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + if (abs(dplus) < *pivmin) { + dplus = -(*pivmin); + } + work[indlpl + i__] = ld[i__] / dplus; + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + if (work[indlpl + i__] == 0.) { + work[inds + i__] = lld[i__]; + } + s = work[inds + i__] - *lambda; +/* L71: */ + } + } + +/* Compute the progressive transform (using the differential form) */ +/* until the index R1 */ + + sawnan2 = false; + neg2 = 0; + work[indp + *bn - 1] = d__[*bn] - *lambda; + i__1 = r1; + for (i__ = *bn - 1; i__ >= i__1; --i__) { + dminus = lld[i__] + work[indp + i__]; + tmp = d__[i__] / dminus; + if (dminus < 0.) { + ++neg2; + } + work[indumn + i__] = l[i__] * tmp; + work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; +/* L80: */ + } + tmp = work[indp + r1 - 1]; + sawnan2 = disnan_(&tmp); + if (sawnan2) { +/* Runs a slower version of the above loop if a NaN is detected */ + neg2 = 0; + i__1 = r1; + for (i__ = *bn - 1; i__ >= i__1; --i__) { + dminus = lld[i__] + work[indp + i__]; + if (abs(dminus) < *pivmin) { + dminus = -(*pivmin); + } + tmp = d__[i__] / dminus; + if (dminus < 0.) { + ++neg2; + } + work[indumn + i__] = l[i__] * tmp; + work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; + if (tmp == 0.) { + work[indp + i__ - 1] = d__[i__] - *lambda; + } +/* L100: */ + } + } + +/* Find the index (from R1 to R2) of the largest (in magnitude) */ +/* diagonal element of the inverse */ + + *mingma = work[inds + r1 - 1] + work[indp + r1 - 1]; + if (*mingma < 0.) { + ++neg1; + } + if (*wantnc) { + *negcnt = neg1 + neg2; + } else { + *negcnt = -1; + } + if (abs(*mingma) == 0.) { + *mingma = eps * work[inds + r1 - 1]; + } + *r__ = r1; + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + tmp = work[inds + i__] + work[indp + i__]; + if (tmp == 0.) { + tmp = eps * work[inds + i__]; + } + if (abs(tmp) <= abs(*mingma)) { + *mingma = tmp; + *r__ = i__ + 1; + } +/* L110: */ + } + +/* Compute the FP vector: solve N^T v = e_r */ + + isuppz[1] = *b1; + isuppz[2] = *bn; + z__[*r__] = 1.; + *ztz = 1.; + +/* Compute the FP vector upwards from R */ + + if (! sawnan1 && ! sawnan2) { + i__1 = *b1; + for (i__ = *r__ - 1; i__ >= i__1; --i__) { + z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]); + if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs( + d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) { + z__[i__] = 0.; + isuppz[1] = i__ + 1; + goto L220; + } + *ztz += z__[i__] * z__[i__]; +/* L210: */ + } +L220: + ; + } else { +/* Run slower loop if NaN occurred. */ + i__1 = *b1; + for (i__ = *r__ - 1; i__ >= i__1; --i__) { + if (z__[i__ + 1] == 0.) { + z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2]; + } else { + z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]); + } + if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs( + d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) { + z__[i__] = 0.; + isuppz[1] = i__ + 1; + goto L240; + } + *ztz += z__[i__] * z__[i__]; +/* L230: */ + } +L240: + ; + } +/* Compute the FP vector downwards from R in blocks of size BLKSIZ */ + if (! sawnan1 && ! sawnan2) { + i__1 = *bn - 1; + for (i__ = *r__; i__ <= i__1; ++i__) { + z__[i__ + 1] = -(work[indumn + i__] * z__[i__]); + if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs( + d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) { + z__[i__ + 1] = 0.; + isuppz[2] = i__; + goto L260; + } + *ztz += z__[i__ + 1] * z__[i__ + 1]; +/* L250: */ + } +L260: + ; + } else { +/* Run slower loop if NaN occurred. */ + i__1 = *bn - 1; + for (i__ = *r__; i__ <= i__1; ++i__) { + if (z__[i__] == 0.) { + z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1]; + } else { + z__[i__ + 1] = -(work[indumn + i__] * z__[i__]); + } + if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs( + d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) { + z__[i__ + 1] = 0.; + isuppz[2] = i__; + goto L280; + } + *ztz += z__[i__ + 1] * z__[i__ + 1]; +/* L270: */ + } +L280: + ; + } + +/* Compute quantities for convergence test */ + + tmp = 1. / *ztz; + *nrminv = sqrt(tmp); + *resid = abs(*mingma) * *nrminv; + *rqcorr = *mingma * tmp; + + + return 0; + +/* End of DLAR1V */ + +} /* dlar1v_ */ + +/* Subroutine */ int dlar2v_(integer *n, double *x, double *y, + double *z__, integer *incx, double *c__, double *s, + integer *incc) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__; + double t1, t2, t3, t4, t5, t6; + integer ic; + double ci, si; + integer ix; + double xi, yi, zi; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAR2V applies a vector of real plane rotations from both sides to */ +/* a sequence of 2-by-2 real symmetric matrices, defined by the elements */ +/* of the vectors x, y and z. For i = 1,2,...,n */ + +/* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) */ +/* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of plane rotations to be applied. */ + +/* X (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCX) */ +/* The vector x. */ + +/* Y (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCX) */ +/* The vector y. */ + +/* Z (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCX) */ +/* The vector z. */ + +/* INCX (input) INTEGER */ +/* The increment between elements of X, Y and Z. INCX > 0. */ + +/* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ +/* The cosines of the plane rotations. */ + +/* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ +/* The sines of the plane rotations. */ + +/* INCC (input) INTEGER */ +/* The increment between elements of C and S. INCC > 0. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --s; + --c__; + --z__; + --y; + --x; + + /* Function Body */ + ix = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + xi = x[ix]; + yi = y[ix]; + zi = z__[ix]; + ci = c__[ic]; + si = s[ic]; + t1 = si * zi; + t2 = ci * zi; + t3 = t2 - si * xi; + t4 = t2 + si * yi; + t5 = ci * xi + t1; + t6 = ci * yi - t1; + x[ix] = ci * t5 + si * t4; + y[ix] = ci * t6 - si * t3; + z__[ix] = ci * t4 - si * t5; + ix += *incx; + ic += *incc; +/* L10: */ + } + +/* End of DLAR2V */ + + return 0; +} /* dlar2v_ */ + +/* Subroutine */ int dlarf_(const char *side, integer *m, integer *n, double *v, integer *incv, double *tau, double *c__, + integer *ldc, double *work) +{ + /* Table of constant values */ + static double c_b4 = 1.; + static double c_b5 = 0.; + static integer c__1 = 1; + + /* System generated locals */ + integer c_dim1, c_offset; + double d__1; + + /* Local variables */ + integer i__; + bool applyleft; + integer lastc, lastv; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + applyleft = lsame_(side, "L"); + lastv = 0; + lastc = 0; + if (*tau != 0.) { +/* Set up variables for scanning V. LASTV begins pointing to the end */ +/* of V. */ + if (applyleft) { + lastv = *m; + } else { + lastv = *n; + } + if (*incv > 0) { + i__ = (lastv - 1) * *incv + 1; + } else { + i__ = 1; + } +/* Look for the last non-zero row in V. */ + while(lastv > 0 && v[i__] == 0.) { + --lastv; + i__ -= *incv; + } + if (applyleft) { +/* Scan for the last non-zero column in C(1:lastv,:). */ + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + } else { +/* Scan for the last non-zero row in C(:,1:lastv). */ + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + } + } +/* Note that lastc.eq.0 renders the BLAS operations null; no special */ +/* case is needed at this level. */ + if (applyleft) { + +/* Form H * C */ + + if (lastv > 0) { + +/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */ + + dgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, & + v[1], incv, &c_b5, &work[1], &c__1); + +/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */ + + d__1 = -(*tau); + dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[ + c_offset], ldc); + } + } else { + +/* Form C * H */ + + if (lastv > 0) { + +/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */ + + dgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, + &v[1], incv, &c_b5, &work[1], &c__1); + +/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */ + + d__1 = -(*tau); + dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[ + c_offset], ldc); + } + } + return 0; + +/* End of DLARF */ + +} /* dlarf_ */ + +/* Subroutine */ int dlarfb_(const char *side, const char *trans, const char *direct, const char *storev, integer *m, + integer *n, integer *k, double *v, integer *ldv, double *t, integer *ldt, double *c__, + integer *ldc, double *work, integer *ldwork) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b14 = 1.; + static double c_b25 = -1.; + + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + integer lastc; + integer lastv; + char transt[1]; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + + if (lsame_(storev, "C")) { + + if (lsame_(direct, "F")) { + +/* Let V = ( V1 ) (first K rows) */ +/* ( V2 ) */ +/* where V1 is unit lower triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H' * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* Computing MAX */ + i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv); + lastv = std::max(i__1,i__2); + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + +/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + +/* W := C1' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + + 1], &c__1); +/* L10: */ + } + +/* W := W * V1 */ + + dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & + c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + if (lastv > *k) { + +/* W := W + C2'*V2 */ + + i__1 = lastv - *k; + dgemm_("Transpose", "No transpose", &lastc, k, &i__1, & + c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + + v_dim1], ldv, &c_b14, &work[work_offset], ldwork); + } + +/* W := W * T' or W * T */ + + dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, & + c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V * W' */ + + if (lastv > *k) { + +/* C2 := C2 - V2 * W' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &i__1, &lastc, k, & + c_b25, &v[*k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork, &c_b14, &c__[*k + 1 + + c_dim1], ldc); + } + +/* W := W * V1' */ + + dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & + c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; +/* L20: */ + } +/* L30: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H' where C = ( C1 C2 ) */ + +/* Computing MAX */ + i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv); + lastv = std::max(i__1,i__2); + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + +/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + +/* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); +/* L40: */ + } + +/* W := W * V1 */ + + dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & + c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + if (lastv > *k) { + +/* W := W + C2 * V2 */ + + i__1 = lastv - *k; + dgemm_("No transpose", "No transpose", &lastc, k, &i__1, & + c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + + 1 + v_dim1], ldv, &c_b14, &work[work_offset], + ldwork); + } + +/* W := W * T or W * T' */ + + dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, + &t[t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V' */ + + if (lastv > *k) { + +/* C2 := C2 - W * V2' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &lastc, &i__1, k, & + c_b25, &work[work_offset], ldwork, &v[*k + 1 + + v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], + ldc); + } + +/* W := W * V1' */ + + dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & + c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; +/* L50: */ + } +/* L60: */ + } + } + + } else { + +/* Let V = ( V1 ) */ +/* ( V2 ) (last K rows) */ +/* where V2 is unit upper triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H' * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* Computing MAX */ + i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv); + lastv = std::max(i__1,i__2); + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + +/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */ + +/* W := C2' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ + j * work_dim1 + 1], &c__1); +/* L70: */ + } + +/* W := W * V2 */ + + dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & + c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork); + if (lastv > *k) { + +/* W := W + C1'*V1 */ + + i__1 = lastv - *k; + dgemm_("Transpose", "No transpose", &lastc, k, &i__1, & + c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b14, &work[work_offset], ldwork); + } + +/* W := W * T' or W * T */ + + dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, & + c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V * W' */ + + if (lastv > *k) { + +/* C1 := C1 - V1 * W' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &i__1, &lastc, k, & + c_b25, &v[v_offset], ldv, &work[work_offset], + ldwork, &c_b14, &c__[c_offset], ldc); + } + +/* W := W * V2' */ + + dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & + c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork); + +/* C2 := C2 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * + work_dim1]; +/* L80: */ + } +/* L90: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H' where C = ( C1 C2 ) */ + +/* Computing MAX */ + i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv); + lastv = std::max(i__1,i__2); + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + +/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + +/* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, & + work[j * work_dim1 + 1], &c__1); +/* L100: */ + } + +/* W := W * V2 */ + + dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & + c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork); + if (lastv > *k) { + +/* W := W + C1 * V1 */ + + i__1 = lastv - *k; + dgemm_("No transpose", "No transpose", &lastc, k, &i__1, & + c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b14, &work[work_offset], ldwork); + } + +/* W := W * T or W * T' */ + + dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, + &t[t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V' */ + + if (lastv > *k) { + +/* C1 := C1 - W * V1' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &lastc, &i__1, k, & + c_b25, &work[work_offset], ldwork, &v[v_offset], + ldv, &c_b14, &c__[c_offset], ldc); + } + +/* W := W * V2' */ + + dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & + c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork); + +/* C2 := C2 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * + work_dim1]; +/* L110: */ + } +/* L120: */ + } + } + } + + } else if (lsame_(storev, "R")) { + + if (lsame_(direct, "F")) { + +/* Let V = ( V1 V2 ) (V1: first K columns) */ +/* where V1 is unit upper triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H' * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* Computing MAX */ + i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv); + lastv = std::max(i__1,i__2); + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + +/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ + +/* W := C1' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 + + 1], &c__1); +/* L130: */ + } + +/* W := W * V1' */ + + dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & + c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + if (lastv > *k) { + +/* W := W + C2'*V2' */ + + i__1 = lastv - *k; + dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, + &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + + 1], ldv, &c_b14, &work[work_offset], ldwork); + } + +/* W := W * T' or W * T */ + + dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, & + c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V' * W' */ + + if (lastv > *k) { + +/* C2 := C2 - V2' * W' */ + + i__1 = lastv - *k; + dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, + &v[(*k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, &c_b14, &c__[*k + 1 + + c_dim1], ldc); + } + +/* W := W * V1 */ + + dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & + c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; +/* L140: */ + } +/* L150: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H' where C = ( C1 C2 ) */ + +/* Computing MAX */ + i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv); + lastv = std::max(i__1,i__2); + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + +/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ + +/* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); +/* L160: */ + } + +/* W := W * V1' */ + + dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, & + c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + if (lastv > *k) { + +/* W := W + C2 * V2' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &lastc, k, &i__1, & + c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + + 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], + ldwork); + } + +/* W := W * T or W * T' */ + + dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, + &t[t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V */ + + if (lastv > *k) { + +/* C2 := C2 - W * V2 */ + + i__1 = lastv - *k; + dgemm_("No transpose", "No transpose", &lastc, &i__1, k, & + c_b25, &work[work_offset], ldwork, &v[(*k + 1) * + v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + + 1], ldc); + } + +/* W := W * V1 */ + + dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, & + c_b14, &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; +/* L170: */ + } +/* L180: */ + } + + } + + } else { + +/* Let V = ( V1 V2 ) (V2: last K columns) */ +/* where V2 is unit lower triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H' * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* Computing MAX */ + i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv); + lastv = std::max(i__1,i__2); + lastc = iladlc_(&lastv, n, &c__[c_offset], ldc); + +/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */ + +/* W := C2' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[ + j * work_dim1 + 1], &c__1); +/* L190: */ + } + +/* W := W * V2' */ + + dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & + c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + if (lastv > *k) { + +/* W := W + C1'*V1' */ + + i__1 = lastv - *k; + dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, + &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork); + } + +/* W := W * T' or W * T */ + + dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, & + c_b14, &t[t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V' * W' */ + + if (lastv > *k) { + +/* C1 := C1 - V1' * W' */ + + i__1 = lastv - *k; + dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, + &v[v_offset], ldv, &work[work_offset], ldwork, & + c_b14, &c__[c_offset], ldc); + } + +/* W := W * V2 */ + + dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & + c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + +/* C2 := C2 - W' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * + work_dim1]; +/* L200: */ + } +/* L210: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H' where C = ( C1 C2 ) */ + +/* Computing MAX */ + i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv); + lastv = std::max(i__1,i__2); + lastc = iladlr_(m, &lastv, &c__[c_offset], ldc); + +/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */ + +/* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, + &work[j * work_dim1 + 1], &c__1); +/* L220: */ + } + +/* W := W * V2' */ + + dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, & + c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + if (lastv > *k) { + +/* W := W + C1 * V1' */ + + i__1 = lastv - *k; + dgemm_("No transpose", "Transpose", &lastc, k, &i__1, & + c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b14, &work[work_offset], ldwork); + } + +/* W := W * T or W * T' */ + + dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, + &t[t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V */ + + if (lastv > *k) { + +/* C1 := C1 - W * V1 */ + + i__1 = lastv - *k; + dgemm_("No transpose", "No transpose", &lastc, &i__1, k, & + c_b25, &work[work_offset], ldwork, &v[v_offset], + ldv, &c_b14, &c__[c_offset], ldc); + } + +/* W := W * V2 */ + + dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, & + c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = lastc; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j * + work_dim1]; +/* L230: */ + } +/* L240: */ + } + + } + + } + } + + return 0; + +/* End of DLARFB */ + +} /* dlarfb_ */ + +/* Subroutine */ int dlarfg_(integer *n, double *alpha, double *x, integer *incx, double *tau) +{ + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer j, knt; + double beta, xnorm, safmin, rsafmn; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n <= 1) { + *tau = 0.; + return 0; + } + + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + + if (xnorm == 0.) { + +/* H = I */ + + *tau = 0.; + } else { + +/* general case */ + + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_sign(&d__1, alpha); + safmin = dlamch_("S") / dlamch_("E"); + knt = 0; + if (abs(beta) < safmin) { + +/* XNORM, BETA may be inaccurate; scale X and recompute them */ + + rsafmn = 1. / safmin; +L10: + ++knt; + i__1 = *n - 1; + dscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + *alpha *= rsafmn; + if (abs(beta) < safmin) { + goto L10; + } + +/* New BETA is at most 1, at least SAFMIN */ + + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + d__1 = dlapy2_(alpha, &xnorm); + beta = -d_sign(&d__1, alpha); + } + *tau = (beta - *alpha) / beta; + i__1 = *n - 1; + d__1 = 1. / (*alpha - beta); + dscal_(&i__1, &d__1, &x[1], incx); + +/* If ALPHA is subnormal, it may lose relative accuracy */ + + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; +/* L20: */ + } + *alpha = beta; + } + + return 0; + +/* End of DLARFG */ + +} /* dlarfg_ */ + +/* Subroutine */ int dlarfp_(integer *n, double *alpha, double *x, integer *incx, double *tau) +{ + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer j, knt; + double beta; + double xnorm; + double safmin, rsafmn; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARFP 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, beta is non-negative, 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n <= 0) { + *tau = 0.; + return 0; + } + + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + + if (xnorm == 0.) { + +/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0 */ + + if (*alpha >= 0.) { +/* When TAU.eq.ZERO, the vector is special-cased to be */ +/* all zeros in the application routines. We do not need */ +/* to clear it. */ + *tau = 0.; + } else { +/* However, the application routines rely on explicit */ +/* zero checks when TAU.ne.ZERO, and we must clear X. */ + *tau = 2.; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + x[(j - 1) * *incx + 1] = 0.; + } + *alpha = -(*alpha); + } + } else { + +/* general case */ + + d__1 = dlapy2_(alpha, &xnorm); + beta = d_sign(&d__1, alpha); + safmin = dlamch_("S") / dlamch_("E"); + knt = 0; + if (abs(beta) < safmin) { + +/* XNORM, BETA may be inaccurate; scale X and recompute them */ + + rsafmn = 1. / safmin; +L10: + ++knt; + i__1 = *n - 1; + dscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + *alpha *= rsafmn; + if (abs(beta) < safmin) { + goto L10; + } + +/* New BETA is at most 1, at least SAFMIN */ + + i__1 = *n - 1; + xnorm = dnrm2_(&i__1, &x[1], incx); + d__1 = dlapy2_(alpha, &xnorm); + beta = d_sign(&d__1, alpha); + } + *alpha += beta; + if (beta < 0.) { + beta = -beta; + *tau = -(*alpha) / beta; + } else { + *alpha = xnorm * (xnorm / *alpha); + *tau = *alpha / beta; + *alpha = -(*alpha); + } + i__1 = *n - 1; + d__1 = 1. / *alpha; + dscal_(&i__1, &d__1, &x[1], incx); + +/* If BETA is subnormal, it may lose relative accuracy */ + + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; +/* L20: */ + } + *alpha = beta; + } + + return 0; + +/* End of DLARFP */ + +} /* dlarfp_ */ + +/* Subroutine */ int dlarft_(const char *direct, const char *storev, integer *n, integer *k, double *v, integer *ldv, + double *tau, double *t, integer *ldt) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b8 = 0.; + + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + integer i__, j, prevlastv; + double vii; + integer lastv; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + + /* Function Body */ + if (*n == 0) { + return 0; + } + + if (lsame_(direct, "F")) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = std::max(i__,prevlastv); + if (tau[i__] == 0.) { + +/* H(i) = I */ + + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = 0.; +/* L10: */ + } + } else { + +/* general case */ + + vii = v[i__ + i__ * v_dim1]; + v[i__ + i__ * v_dim1] = 1.; + if (lsame_(storev, "C")) { +/* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + break; + } + } + j = std::min(lastv,prevlastv); + +/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */ + + i__2 = j - i__ + 1; + i__3 = i__ - 1; + d__1 = -tau[i__]; + dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1], + ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[ + i__ * t_dim1 + 1], &c__1); + } else { +/* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + break; + } + } + j = std::min(lastv,prevlastv); + +/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */ + + i__2 = i__ - 1; + i__3 = j - i__ + 1; + d__1 = -tau[i__]; + dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ * + v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, & + c_b8, &t[i__ * t_dim1 + 1], &c__1); + } + v[i__ + i__ * v_dim1] = vii; + +/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ + + i__2 = i__ - 1; + dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ + t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); + t[i__ + i__ * t_dim1] = tau[i__]; + if (i__ > 1) { + prevlastv = std::max(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } +/* L20: */ + } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + if (tau[i__] == 0.) { + +/* H(i) = I */ + + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + t[j + i__ * t_dim1] = 0.; +/* L30: */ + } + } else { + +/* general case */ + + if (i__ < *k) { + if (lsame_(storev, "C")) { + vii = v[*n - *k + i__ + i__ * v_dim1]; + v[*n - *k + i__ + i__ * v_dim1] = 1.; +/* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[lastv + i__ * v_dim1] != 0.) { + break; + } + } + j = std::max(lastv,prevlastv); + +/* T(i+1:k,i) := */ +/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */ + + i__1 = *n - *k + i__ - j + 1; + i__2 = *k - i__; + d__1 = -tau[i__]; + dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__ + + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & + c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], & + c__1); + v[*n - *k + i__ + i__ * v_dim1] = vii; + } else { + vii = v[i__ + (*n - *k + i__) * v_dim1]; + v[i__ + (*n - *k + i__) * v_dim1] = 1.; +/* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[i__ + lastv * v_dim1] != 0.) { + break; + } + } + j = std::max(lastv,prevlastv); + +/* T(i+1:k,i) := */ +/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */ + + i__1 = *k - i__; + i__2 = *n - *k + i__ - j + 1; + d__1 = -tau[i__]; + dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], + ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1); + v[i__ + (*n - *k + i__) * v_dim1] = vii; + } + +/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ + + i__1 = *k - i__; + dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * + t_dim1], &c__1) + ; + if (i__ > 1) { + prevlastv = std::min(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + t[i__ + i__ * t_dim1] = tau[i__]; + } +/* L40: */ + } + } + return 0; + +/* End of DLARFT */ + +} /* dlarft_ */ + +/* Subroutine */ int dlarfx_(const char *side, integer *m, integer *n, double *v, double *tau, double *c__, integer *ldc, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer c_dim1, c_offset, i__1; + + /* Local variables */ + integer j; + double t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7, + v8, v9, t10, v10, sum; + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* 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 .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + if (*tau == 0.) { + return 0; + } + if (lsame_(side, "L")) { + +/* Form H * C, where H has order m. */ + + switch (*m) { + case 1: goto L10; + case 2: goto L30; + case 3: goto L50; + case 4: goto L70; + case 5: goto L90; + case 6: goto L110; + case 7: goto L130; + case 8: goto L150; + case 9: goto L170; + case 10: goto L190; + } + +/* Code for general M */ + + dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); + goto L410; +L10: + +/* Special code for 1 x 1 Householder */ + + t1 = 1. - *tau * v[1] * v[1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1]; +/* L20: */ + } + goto L410; +L30: + +/* Special code for 2 x 2 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; +/* L40: */ + } + goto L410; +L50: + +/* 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; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; +/* L60: */ + } + goto L410; +L70: + +/* 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; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; +/* L80: */ + } + goto L410; +L90: + +/* 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; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; +/* L100: */ + } + goto L410; +L110: + +/* 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; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; +/* L120: */ + } + goto L410; +L130: + +/* 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; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; +/* L140: */ + } + goto L410; +L150: + +/* 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; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; +/* L160: */ + } + goto L410; +L170: + +/* 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; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * + c_dim1 + 9]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; + c__[j * c_dim1 + 9] -= sum * t9; +/* L180: */ + } + goto L410; +L190: + +/* 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; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * + c_dim1 + 9] + v10 * c__[j * c_dim1 + 10]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; + c__[j * c_dim1 + 9] -= sum * t9; + c__[j * c_dim1 + 10] -= sum * t10; +/* L200: */ + } + goto L410; + } else { + +/* Form C * H, where H has order n. */ + + switch (*n) { + case 1: goto L210; + case 2: goto L230; + case 3: goto L250; + case 4: goto L270; + case 5: goto L290; + case 6: goto L310; + case 7: goto L330; + case 8: goto L350; + case 9: goto L370; + case 10: goto L390; + } + +/* Code for general N */ + + dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); + goto L410; +L210: + +/* Special code for 1 x 1 Householder */ + + t1 = 1. - *tau * v[1] * v[1]; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + c__[j + c_dim1] = t1 * c__[j + c_dim1]; +/* L220: */ + } + goto L410; +L230: + +/* Special code for 2 x 2 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; +/* L240: */ + } + goto L410; +L250: + +/* 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; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; +/* L260: */ + } + goto L410; +L270: + +/* 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; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; +/* L280: */ + } + goto L410; +L290: + +/* 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; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; +/* L300: */ + } + goto L410; +L310: + +/* 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; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; +/* L320: */ + } + goto L410; +L330: + +/* 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; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; +/* L340: */ + } + goto L410; +L350: + +/* 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; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; +/* L360: */ + } + goto L410; +L370: + +/* 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; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[ + j + c_dim1 * 9]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; + c__[j + c_dim1 * 9] -= sum * t9; +/* L380: */ + } + goto L410; +L390: + +/* 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; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[ + j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; + c__[j + c_dim1 * 9] -= sum * t9; + c__[j + c_dim1 * 10] -= sum * t10; +/* L400: */ + } + goto L410; + } +L410: + return 0; + +/* End of DLARFX */ + +} /* dlarfx_ */ + +/* Subroutine */ int dlargv_(integer *n, double *x, integer *incx, + double *y, integer *incy, double *c__, integer *incc) +{ + /* System generated locals */ + integer i__1; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + double f, g; + integer i__; + double t; + integer ic, ix, iy; + double tt; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARGV generates a vector of real plane rotations, determined by */ +/* elements of the real vectors x and y. For i = 1,2,...,n */ + +/* ( c(i) s(i) ) ( x(i) ) = ( a(i) ) */ +/* ( -s(i) c(i) ) ( y(i) ) = ( 0 ) */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of plane rotations to be generated. */ + +/* X (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCX) */ +/* On entry, the vector x. */ +/* On exit, x(i) is overwritten by a(i), for i = 1,...,n. */ + +/* INCX (input) INTEGER */ +/* The increment between elements of X. INCX > 0. */ + +/* Y (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCY) */ +/* On entry, the vector y. */ +/* On exit, the sines of the plane rotations. */ + +/* INCY (input) INTEGER */ +/* The increment between elements of Y. INCY > 0. */ + +/* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ +/* The cosines of the plane rotations. */ + +/* INCC (input) INTEGER */ +/* The increment between elements of C. INCC > 0. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --c__; + --y; + --x; + + /* Function Body */ + ix = 1; + iy = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f = x[ix]; + g = y[iy]; + if (g == 0.) { + c__[ic] = 1.; + } else if (f == 0.) { + c__[ic] = 0.; + y[iy] = 1.; + x[ix] = g; + } else if (abs(f) > abs(g)) { + t = g / f; + tt = sqrt(t * t + 1.); + c__[ic] = 1. / tt; + y[iy] = t * c__[ic]; + x[ix] = f * tt; + } else { + t = f / g; + tt = sqrt(t * t + 1.); + y[iy] = 1. / tt; + c__[ic] = t * y[iy]; + x[ix] = g * tt; + } + ic += *incc; + iy += *incy; + ix += *incx; +/* L10: */ + } + return 0; + +/* End of DLARGV */ + +} /* dlargv_ */ + +/* Subroutine */ int dlarnv_(integer *idist, integer *iseed, integer *n, + double *x) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Builtin functions + double log(double), sqrt(double), cos(double); */ + + /* Local variables */ + integer i__; + double u[128]; + integer il, iv, il2; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARNV returns a vector of n random real numbers from a uniform or */ +/* normal distribution. */ + +/* Arguments */ +/* ========= */ + +/* IDIST (input) INTEGER */ +/* Specifies the distribution of the random numbers: */ +/* = 1: uniform (0,1) */ +/* = 2: uniform (-1,1) */ +/* = 3: normal (0,1) */ + +/* ISEED (input/output) INTEGER array, dimension (4) */ +/* On entry, the seed of the random number generator; the array */ +/* elements must be between 0 and 4095, and ISEED(4) must be */ +/* odd. */ +/* On exit, the seed is updated. */ + +/* N (input) INTEGER */ +/* The number of random numbers to be generated. */ + +/* X (output) DOUBLE PRECISION array, dimension (N) */ +/* The generated random numbers. */ + +/* Further Details */ +/* =============== */ + +/* This routine calls the auxiliary routine DLARUV to generate random */ +/* real numbers from a uniform (0,1) distribution, in batches of up to */ +/* 128 using vectorisable code. The Box-Muller method is used to */ +/* transform numbers from a uniform to a normal distribution. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --x; + --iseed; + + /* Function Body */ + i__1 = *n; + for (iv = 1; iv <= i__1; iv += 64) { +/* Computing MIN */ + i__2 = 64, i__3 = *n - iv + 1; + il = std::min(i__2,i__3); + if (*idist == 3) { + il2 = il << 1; + } else { + il2 = il; + } + +/* Call DLARUV to generate IL2 numbers from a uniform (0,1) */ +/* distribution (IL2 <= LV) */ + + dlaruv_(&iseed[1], &il2, u); + + if (*idist == 1) { + +/* Copy generated numbers */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + x[iv + i__ - 1] = u[i__ - 1]; +/* L10: */ + } + } else if (*idist == 2) { + +/* Convert generated numbers to uniform (-1,1) distribution */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + x[iv + i__ - 1] = u[i__ - 1] * 2. - 1.; +/* L20: */ + } + } else if (*idist == 3) { + +/* Convert generated numbers to normal (0,1) distribution */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + x[iv + i__ - 1] = sqrt(log(u[(i__ << 1) - 2]) * -2.) * cos(u[( + i__ << 1) - 1] * 6.2831853071795864769252867663); +/* L30: */ + } + } +/* L40: */ + } + return 0; + +/* End of DLARNV */ + +} /* dlarnv_ */ + +/* Subroutine */ int dlarra_(integer *n, double *d__, double *e, + double *e2, double *spltol, double *tnrm, integer *nsplit, + integer *isplit, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + integer i__; + double tmp1, eabs; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Compute the splitting points with threshold SPLTOL. */ +/* DLARRA sets any "small" off-diagonal elements to zero. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. N > 0. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the N diagonal elements of the tridiagonal */ +/* matrix T. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the first (N-1) entries contain the subdiagonal */ +/* elements of the tridiagonal matrix T; E(N) need not be set. */ +/* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, */ +/* are set to zero, the other entries of E are untouched. */ + +/* E2 (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the first (N-1) entries contain the SQUARES of the */ +/* subdiagonal elements of the tridiagonal matrix T; */ +/* E2(N) need not be set. */ +/* On exit, the entries E2( ISPLIT( I ) ), */ +/* 1 <= I <= NSPLIT, have been set to zero */ + +/* SPLTOL (input) DOUBLE PRECISION */ +/* The threshold for splitting. Two criteria can be used: */ +/* SPLTOL<0 : criterion based on absolute off-diagonal value */ +/* SPLTOL>0 : criterion that preserves relative accuracy */ + +/* TNRM (input) DOUBLE PRECISION */ +/* The norm of the matrix. */ + +/* NSPLIT (output) INTEGER */ +/* The number of blocks T splits into. 1 <= NSPLIT <= N. */ + +/* ISPLIT (output) INTEGER array, dimension (N) */ +/* The splitting points, at which T breaks up into blocks. */ +/* The first block consists of rows/columns 1 to ISPLIT(1), */ +/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ +/* etc., and the NSPLIT-th consists of rows/columns */ +/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ + + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --isplit; + --e2; + --e; + --d__; + + /* Function Body */ + *info = 0; +/* Compute splitting points */ + *nsplit = 1; + if (*spltol < 0.) { +/* Criterion based on absolute off-diagonal value */ + tmp1 = abs(*spltol) * *tnrm; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + eabs = (d__1 = e[i__], abs(d__1)); + if (eabs <= tmp1) { + e[i__] = 0.; + e2[i__] = 0.; + isplit[*nsplit] = i__; + ++(*nsplit); + } +/* L9: */ + } + } else { +/* Criterion that guarantees relative accuracy */ + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + eabs = (d__1 = e[i__], abs(d__1)); + if (eabs <= *spltol * sqrt((d__1 = d__[i__], abs(d__1))) * sqrt(( + d__2 = d__[i__ + 1], abs(d__2)))) { + e[i__] = 0.; + e2[i__] = 0.; + isplit[*nsplit] = i__; + ++(*nsplit); + } +/* L10: */ + } + } + isplit[*nsplit] = *n; + return 0; + +/* End of DLARRA */ + +} /* dlarra_ */ + +/* Subroutine */ int dlarrb_(integer *n, double *d__, double *lld, + integer *ifirst, integer *ilast, double *rtol1, double *rtol2, + integer *offset, double *w, double *wgap, double *werr, + double *work, integer *iwork, double *pivmin, double * + spdiam, integer *twist, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + integer i__, k, r__, i1, ii, ip; + double gap, mid, tmp, back, lgap, rgap, left; + integer iter, nint, prev, next; + double cvrgd, right, width; + integer negcnt; + double mnwdth; + integer olnint, maxitr; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Given the relatively robust representation(RRR) L D L^T, DLARRB */ +/* does "limited" bisection to refine the eigenvalues of L D L^T, */ +/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */ +/* guesses for these eigenvalues are input in W, the corresponding estimate */ +/* of the error in these guesses and their gaps are input in WERR */ +/* and WGAP, respectively. During bisection, intervals */ +/* [left, right] are maintained by storing their mid-points and */ +/* semi-widths in the arrays W and WERR respectively. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The N diagonal elements of the diagonal matrix D. */ + +/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (N-1) elements L(i)*L(i)*D(i). */ + +/* IFIRST (input) INTEGER */ +/* The index of the first eigenvalue to be computed. */ + +/* ILAST (input) INTEGER */ +/* The index of the last eigenvalue to be computed. */ + +/* RTOL1 (input) DOUBLE PRECISION */ +/* RTOL2 (input) DOUBLE PRECISION */ +/* Tolerance for the convergence of the bisection intervals. */ +/* An interval [LEFT,RIGHT] has converged if */ +/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ +/* where GAP is the (estimated) distance to the nearest */ +/* eigenvalue. */ + +/* OFFSET (input) INTEGER */ +/* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET */ +/* through ILAST-OFFSET elements of these arrays are to be used. */ + +/* W (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */ +/* estimates of the eigenvalues of L D L^T indexed IFIRST throug */ +/* ILAST. */ +/* On output, these estimates are refined. */ + +/* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On input, the (estimated) gaps between consecutive */ +/* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between */ +/* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST */ +/* then WGAP(IFIRST-OFFSET) must be set to ZERO. */ +/* On output, these gaps are refined. */ + +/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */ +/* the errors in the estimates of the corresponding elements in W. */ +/* On output, these errors are refined. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ +/* Workspace. */ + +/* IWORK (workspace) INTEGER array, dimension (2*N) */ +/* Workspace. */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum pivot in the Sturm sequence. */ + +/* SPDIAM (input) DOUBLE PRECISION */ +/* The spectral diameter of the matrix. */ + +/* TWIST (input) INTEGER */ +/* The twist index for the twisted factorization that is used */ +/* for the negcount. */ +/* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T */ +/* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T */ +/* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) */ + +/* INFO (output) INTEGER */ +/* Error flag. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ + +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --iwork; + --work; + --werr; + --wgap; + --w; + --lld; + --d__; + + /* Function Body */ + *info = 0; + + maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.)) + + 2; + mnwdth = *pivmin * 2.; + + r__ = *twist; + if (r__ < 1 || r__ > *n) { + r__ = *n; + } + +/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */ +/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */ +/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */ +/* for an unconverged interval is set to the index of the next unconverged */ +/* interval, and is -1 or 0 for a converged interval. Thus a linked */ +/* list of unconverged intervals is set up. */ + + i1 = *ifirst; +/* The number of unconverged intervals */ + nint = 0; +/* The last unconverged interval found */ + prev = 0; + rgap = wgap[i1 - *offset]; + i__1 = *ilast; + for (i__ = i1; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; + left = w[ii] - werr[ii]; + right = w[ii] + werr[ii]; + lgap = rgap; + rgap = wgap[ii]; + gap = std::min(lgap,rgap); +/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */ +/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT */ + +/* Do while( NEGCNT(LEFT).GT.I-1 ) */ + + back = werr[ii]; +L20: + negcnt = dlaneg_(n, &d__[1], &lld[1], &left, pivmin, &r__); + if (negcnt > i__ - 1) { + left -= back; + back *= 2.; + goto L20; + } + +/* Do while( NEGCNT(RIGHT).LT.I ) */ +/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT */ + + back = werr[ii]; +L50: + negcnt = dlaneg_(n, &d__[1], &lld[1], &right, pivmin, &r__); + if (negcnt < i__) { + right += back; + back *= 2.; + goto L50; + } + width = (d__1 = left - right, abs(d__1)) * .5; +/* Computing MAX */ + d__1 = abs(left), d__2 = abs(right); + tmp = std::max(d__1,d__2); +/* Computing MAX */ + d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp; + cvrgd = std::max(d__1,d__2); + if (width <= cvrgd || width <= mnwdth) { +/* This interval has already converged and does not need refinement. */ +/* (Note that the gaps might change through refining the */ +/* eigenvalues, however, they can only get bigger.) */ +/* Remove it from the list. */ + iwork[k - 1] = -1; +/* Make sure that I1 always points to the first unconverged interval */ + if (i__ == i1 && i__ < *ilast) { + i1 = i__ + 1; + } + if (prev >= i1 && i__ <= *ilast) { + iwork[(prev << 1) - 1] = i__ + 1; + } + } else { +/* unconverged interval found */ + prev = i__; + ++nint; + iwork[k - 1] = i__ + 1; + iwork[k] = negcnt; + } + work[k - 1] = left; + work[k] = right; +/* L75: */ + } + +/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */ +/* and while (ITER.LT.MAXITR) */ + + iter = 0; +L80: + prev = i1 - 1; + i__ = i1; + olnint = nint; + i__1 = olnint; + for (ip = 1; ip <= i__1; ++ip) { + k = i__ << 1; + ii = i__ - *offset; + rgap = wgap[ii]; + lgap = rgap; + if (ii > 1) { + lgap = wgap[ii - 1]; + } + gap = std::min(lgap,rgap); + next = iwork[k - 1]; + left = work[k - 1]; + right = work[k]; + mid = (left + right) * .5; +/* semiwidth of interval */ + width = right - mid; +/* Computing MAX */ + d__1 = abs(left), d__2 = abs(right); + tmp = std::max(d__1,d__2); +/* Computing MAX */ + d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp; + cvrgd = std::max(d__1,d__2); + if (width <= cvrgd || width <= mnwdth || iter == maxitr) { +/* reduce number of unconverged intervals */ + --nint; +/* Mark interval as converged. */ + iwork[k - 1] = 0; + if (i1 == i__) { + i1 = next; + } else { +/* Prev holds the last unconverged interval previously examined */ + if (prev >= i1) { + iwork[(prev << 1) - 1] = next; + } + } + i__ = next; + goto L100; + } + prev = i__; + +/* Perform one bisection step */ + + negcnt = dlaneg_(n, &d__[1], &lld[1], &mid, pivmin, &r__); + if (negcnt <= i__ - 1) { + work[k - 1] = mid; + } else { + work[k] = mid; + } + i__ = next; +L100: + ; + } + ++iter; +/* do another loop if there are still unconverged intervals */ +/* However, in the last iteration, all intervals are accepted */ +/* since this is the best we can do. */ + if (nint > 0 && iter <= maxitr) { + goto L80; + } + + +/* At this point, all the intervals have converged */ + i__1 = *ilast; + for (i__ = *ifirst; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; +/* All intervals marked by '0' have been refined. */ + if (iwork[k - 1] == 0) { + w[ii] = (work[k - 1] + work[k]) * .5; + werr[ii] = work[k] - w[ii]; + } +/* L110: */ + } + + i__1 = *ilast; + for (i__ = *ifirst + 1; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; +/* Computing MAX */ + d__1 = 0., d__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1]; + wgap[ii - 1] = std::max(d__1,d__2); +/* L111: */ + } + return 0; + +/* End of DLARRB */ + +} /* dlarrb_ */ + +/* Subroutine */ int dlarrc_(const char *jobt, integer *n, double *vl, + double *vu, double *d__, double *e, double *pivmin, + integer *eigcnt, integer *lcnt, integer *rcnt, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer i__; + double sl, su, tmp, tmp2; + bool matt; + + double lpivot, rpivot; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Find the number of eigenvalues of the symmetric tridiagonal matrix T */ +/* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T */ +/* if JOBT = 'L'. */ + +/* Arguments */ +/* ========= */ + +/* JOBT (input) CHARACTER*1 */ +/* = 'T': Compute Sturm count for matrix T. */ +/* = 'L': Compute Sturm count for matrix L D L^T. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N > 0. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* The lower and upper bounds for the eigenvalues. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. */ +/* JOBT = 'L': The N diagonal elements of the diagonal matrix D. */ + +/* E (input) DOUBLE PRECISION array, dimension (N) */ +/* JOBT = 'T': The N-1 offdiagonal elements of the matrix T. */ +/* JOBT = 'L': The N-1 offdiagonal elements of the matrix L. */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum pivot in the Sturm sequence for T. */ + +/* EIGCNT (output) INTEGER */ +/* The number of eigenvalues of the symmetric tridiagonal matrix T */ +/* that are in the interval (VL,VU] */ + +/* LCNT (output) INTEGER */ +/* RCNT (output) INTEGER */ +/* The left and right negcounts of the interval. */ + +/* INFO (output) INTEGER */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + *info = 0; + *lcnt = 0; + *rcnt = 0; + *eigcnt = 0; + matt = lsame_(jobt, "T"); + if (matt) { +/* Sturm sequence count on T */ + lpivot = d__[1] - *vl; + rpivot = d__[1] - *vu; + if (lpivot <= 0.) { + ++(*lcnt); + } + if (rpivot <= 0.) { + ++(*rcnt); + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing 2nd power */ + d__1 = e[i__]; + tmp = d__1 * d__1; + lpivot = d__[i__ + 1] - *vl - tmp / lpivot; + rpivot = d__[i__ + 1] - *vu - tmp / rpivot; + if (lpivot <= 0.) { + ++(*lcnt); + } + if (rpivot <= 0.) { + ++(*rcnt); + } +/* L10: */ + } + } else { +/* Sturm sequence count on L D L^T */ + sl = -(*vl); + su = -(*vu); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + lpivot = d__[i__] + sl; + rpivot = d__[i__] + su; + if (lpivot <= 0.) { + ++(*lcnt); + } + if (rpivot <= 0.) { + ++(*rcnt); + } + tmp = e[i__] * d__[i__] * e[i__]; + + tmp2 = tmp / lpivot; + if (tmp2 == 0.) { + sl = tmp - *vl; + } else { + sl = sl * tmp2 - *vl; + } + + tmp2 = tmp / rpivot; + if (tmp2 == 0.) { + su = tmp - *vu; + } else { + su = su * tmp2 - *vu; + } +/* L20: */ + } + lpivot = d__[*n] + sl; + rpivot = d__[*n] + su; + if (lpivot <= 0.) { + ++(*lcnt); + } + if (rpivot <= 0.) { + ++(*rcnt); + } + } + *eigcnt = *rcnt - *lcnt; + return 0; + +/* end of DLARRC */ + +} /* dlarrc_ */ + +/* Subroutine */ int dlarrd_(const char *range, const char *order, integer *n, double *vl, double *vu, integer *il, + integer *iu, double *gers, double *reltol, double *d__, double *e, double *e2, double *pivmin, + integer *nsplit, integer *isplit, integer *m, double *w, double *werr, double *wl, double *wu, + integer *iblock, integer *indexw, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + static integer c__0 = 0; + + /* System generated locals */ + integer i__1, i__2, i__3; + double d__1, d__2; + + /* Local variables */ + integer i__, j, ib, ie, je, nb; + double gl; + integer im, in; + double gu; + integer iw, jee; + double eps; + integer nwl; + double wlu, wul; + integer nwu; + double tmp1, tmp2; + integer iend, jblk, ioff, iout, itmp1, itmp2, jdisc, iinfo; + double atoli; + integer iwoff, itmax; + double wkill, rtoli, uflow, tnorm; + integer ibegin,irange, idiscl, idumma[1], idiscu; + bool ncnvrg, toofew; + + +/* -- LAPACK auxiliary routine (version 3.2.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* -- April 2009 -- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARRD computes the eigenvalues of a symmetric tridiagonal */ +/* matrix T to suitable accuracy. This is an auxiliary code to be */ +/* called from DSTEMR. */ +/* The user may ask for all eigenvalues, all eigenvalues */ +/* in the half-open interval (VL, VU], or the IL-th through IU-th */ +/* eigenvalues. */ + +/* To avoid overflow, the matrix must be scaled so that its */ +/* largest element is no greater than overflow**(1/2) * */ +/* underflow**(1/4) in absolute value, and for greatest */ +/* accuracy, it should not be much smaller than that. */ + +/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ +/* Matrix", Report CS41, Computer Science Dept., Stanford */ +/* University, July 21, 1966. */ + +/* Arguments */ +/* ========= */ + +/* RANGE (input) CHARACTER */ +/* = 'A': ("All") all eigenvalues will be found. */ +/* = 'V': ("Value") all eigenvalues in the half-open interval */ +/* (VL, VU] will be found. */ +/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ +/* entire matrix) will be found. */ + +/* ORDER (input) CHARACTER */ +/* = 'B': ("By Block") the eigenvalues will be grouped by */ +/* split-off block (see IBLOCK, ISPLIT) and */ +/* ordered from smallest to largest within */ +/* the block. */ +/* = 'E': ("Entire matrix") */ +/* the eigenvalues for the entire matrix */ +/* will be ordered from smallest to */ +/* largest. */ + +/* N (input) INTEGER */ +/* The order of the tridiagonal matrix T. N >= 0. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. Eigenvalues less than or equal */ +/* to VL, or greater than VU, will not be returned. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */ +/* The N Gerschgorin intervals (the i-th Gerschgorin interval */ +/* is (GERS(2*i-1), GERS(2*i)). */ + +/* RELTOL (input) DOUBLE PRECISION */ +/* The minimum relative width of an interval. When an interval */ +/* is narrower than RELTOL times the larger (in */ +/* magnitude) endpoint, then it is considered to be */ +/* sufficiently small, i.e., converged. Note: this should */ +/* always be at least radix*machine epsilon. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the tridiagonal matrix T. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */ + +/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum pivot allowed in the Sturm sequence for T. */ + +/* NSPLIT (input) INTEGER */ +/* The number of diagonal blocks in the matrix T. */ +/* 1 <= NSPLIT <= N. */ + +/* ISPLIT (input) INTEGER array, dimension (N) */ +/* The splitting points, at which T breaks up into submatrices. */ +/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */ +/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ +/* etc., and the NSPLIT-th consists of rows/columns */ +/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ +/* (Only the first NSPLIT elements will actually be used, but */ +/* since the user cannot know a priori what value NSPLIT will */ +/* have, N words must be reserved for ISPLIT.) */ + +/* M (output) INTEGER */ +/* The actual number of eigenvalues found. 0 <= M <= N. */ +/* (See also the description of INFO=2,3.) */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, the first M elements of W will contain the */ +/* eigenvalue approximations. DLARRD computes an interval */ +/* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue */ +/* approximation is given as the interval midpoint */ +/* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by */ +/* WERR(j) = abs( a_j - b_j)/2 */ + +/* WERR (output) DOUBLE PRECISION array, dimension (N) */ +/* The error bound on the corresponding eigenvalue approximation */ +/* in W. */ + +/* WL (output) DOUBLE PRECISION */ +/* WU (output) DOUBLE PRECISION */ +/* The interval (WL, WU] contains all the wanted eigenvalues. */ +/* If RANGE='V', then WL=VL and WU=VU. */ +/* If RANGE='A', then WL and WU are the global Gerschgorin bounds */ +/* on the spectrum. */ +/* If RANGE='I', then WL and WU are computed by DLAEBZ from the */ +/* index range specified. */ + +/* IBLOCK (output) INTEGER array, dimension (N) */ +/* At each row/column j where E(j) is zero or small, the */ +/* matrix T is considered to split into a block diagonal */ +/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */ +/* block (from 1 to the number of blocks) the eigenvalue W(i) */ +/* belongs. (DLARRD may use the remaining N-M elements as */ +/* workspace.) */ + +/* INDEXW (output) INTEGER array, dimension (N) */ +/* The indices of the eigenvalues within each block (submatrix); */ +/* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the */ +/* i-th eigenvalue W(i) is the j-th eigenvalue in block k. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* IWORK (workspace) INTEGER array, dimension (3*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: some or all of the eigenvalues failed to converge or */ +/* were not computed: */ +/* =1 or 3: Bisection failed to converge for some */ +/* eigenvalues; these eigenvalues are flagged by a */ +/* negative block number. The effect is that the */ +/* eigenvalues may not be as accurate as the */ +/* absolute and relative tolerances. This is */ +/* generally caused by unexpectedly inaccurate */ +/* arithmetic. */ +/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */ +/* IL:IU were found. */ +/* Effect: M < IU+1-IL */ +/* Cause: non-monotonic arithmetic, causing the */ +/* Sturm sequence to be non-monotonic. */ +/* Cure: recalculate, using RANGE='A', and pick */ +/* out eigenvalues IL:IU. In some cases, */ +/* increasing the PARAMETER "FUDGE" may */ +/* make things work. */ +/* = 4: RANGE='I', and the Gershgorin interval */ +/* initially used was too small. No eigenvalues */ +/* were computed. */ +/* Probable cause: your machine has sloppy */ +/* floating-point arithmetic. */ +/* Cure: Increase the PARAMETER "FUDGE", */ +/* recompile, and try again. */ + +/* Internal Parameters */ +/* =================== */ + +/* FUDGE DOUBLE PRECISION, default = 2 */ +/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */ +/* a value of 1 should work, but on machines with sloppy */ +/* arithmetic, this needs to be larger. The default for */ +/* publicly released versions should be large enough to handle */ +/* the worst machine around. Note that this has no effect */ +/* on accuracy of the solution. */ + +/* Based on contributions by */ +/* W. Kahan, University of California, Berkeley, USA */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --iwork; + --work; + --indexw; + --iblock; + --werr; + --w; + --isplit; + --e2; + --e; + --d__; + --gers; + + /* Function Body */ + *info = 0; + +/* Decode RANGE */ + + if (lsame_(range, "A")) { + irange = 1; + } else if (lsame_(range, "V")) { + irange = 2; + } else if (lsame_(range, "I")) { + irange = 3; + } else { + irange = 0; + } + +/* Check for Errors */ + + if (irange <= 0) { + *info = -1; + } else if (! (lsame_(order, "B") || lsame_(order, + "E"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (irange == 2) { + if (*vl >= *vu) { + *info = -5; + } + } else if (irange == 3 && (*il < 1 || *il > std::max(1_integer,*n))) { + *info = -6; + } else if (irange == 3 && (*iu < std::min(*n,*il) || *iu > *n)) { + *info = -7; + } + + if (*info != 0) { + return 0; + } +/* Initialize error flags */ + *info = 0; + ncnvrg = false; + toofew = false; +/* Quick return if possible */ + *m = 0; + if (*n == 0) { + return 0; + } +/* Simplification: */ + if (irange == 3 && *il == 1 && *iu == *n) { + irange = 1; + } +/* Get machine constants */ + eps = dlamch_("P"); + uflow = dlamch_("U"); +/* Special Case when N=1 */ +/* Treat case of 1x1 matrix for quick return */ + if (*n == 1) { + if (irange == 1 || irange == 2 && d__[1] > *vl && d__[1] <= *vu || + irange == 3 && *il == 1 && *iu == 1) { + *m = 1; + w[1] = d__[1]; +/* The computation error of the eigenvalue is zero */ + werr[1] = 0.; + iblock[1] = 1; + indexw[1] = 1; + } + return 0; + } +/* NB is the minimum vector length for vector bisection, or 0 */ +/* if only scalar is to be done. */ + nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1); + if (nb <= 1) { + nb = 0; + } +/* Find global spectral radius */ + gl = d__[1]; + gu = d__[1]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ + d__1 = gl, d__2 = gers[(i__ << 1) - 1]; + gl = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = gu, d__2 = gers[i__ * 2]; + gu = std::max(d__1,d__2); +/* L5: */ + } +/* Compute global Gerschgorin bounds and spectral diameter */ +/* Computing MAX */ + d__1 = abs(gl), d__2 = abs(gu); + tnorm = std::max(d__1,d__2); + gl = gl - tnorm * 2. * eps * *n - *pivmin * 4.; + gu = gu + tnorm * 2. * eps * *n + *pivmin * 4.; +/* [JAN/28/2009] remove the line below since SPDIAM variable not use */ +/* SPDIAM = GU - GL */ +/* Input arguments for DLAEBZ: */ +/* The relative tolerance. An interval (a,b] lies within */ +/* "relative tolerance" if b-a < RELTOL*max(|a|,|b|), */ + rtoli = *reltol; +/* Set the absolute tolerance for interval convergence to zero to force */ +/* interval convergence based on relative size of the interval. */ +/* This is dangerous because intervals might not converge when RELTOL is */ +/* small. But at least a very small number should be selected so that for */ +/* strongly graded matrices, the code can get relatively accurate */ +/* eigenvalues. */ + atoli = uflow * 4. + *pivmin * 4.; + if (irange == 3) { +/* RANGE='I': Compute an interval containing eigenvalues */ +/* IL through IU. The initial interval [GL,GU] from the global */ +/* Gerschgorin bounds GL and GU is refined by DLAEBZ. */ + itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.)) + + 2; + work[*n + 1] = gl; + work[*n + 2] = gl; + work[*n + 3] = gu; + work[*n + 4] = gu; + work[*n + 5] = gl; + work[*n + 6] = gu; + iwork[1] = -1; + iwork[2] = -1; + iwork[3] = *n + 1; + iwork[4] = *n + 1; + iwork[5] = *il - 1; + iwork[6] = *iu; + + dlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, pivmin, & + d__[1], &e[1], &e2[1], &iwork[5], &work[*n + 1], &work[*n + 5] +, &iout, &iwork[1], &w[1], &iblock[1], &iinfo); + if (iinfo != 0) { + *info = iinfo; + return 0; + } +/* On exit, output intervals may not be ordered by ascending negcount */ + if (iwork[6] == *iu) { + *wl = work[*n + 1]; + wlu = work[*n + 3]; + nwl = iwork[1]; + *wu = work[*n + 4]; + wul = work[*n + 2]; + nwu = iwork[4]; + } else { + *wl = work[*n + 2]; + wlu = work[*n + 4]; + nwl = iwork[2]; + *wu = work[*n + 3]; + wul = work[*n + 1]; + nwu = iwork[3]; + } +/* On exit, the interval [WL, WLU] contains a value with negcount NWL, */ +/* and [WUL, WU] contains a value with negcount NWU. */ + if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) { + *info = 4; + return 0; + } + } else if (irange == 2) { + *wl = *vl; + *wu = *vu; + } else if (irange == 1) { + *wl = gl; + *wu = gu; + } +/* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. */ +/* NWL accumulates the number of eigenvalues .le. WL, */ +/* NWU accumulates the number of eigenvalues .le. WU */ + *m = 0; + iend = 0; + *info = 0; + nwl = 0; + nwu = 0; + + i__1 = *nsplit; + for (jblk = 1; jblk <= i__1; ++jblk) { + ioff = iend; + ibegin = ioff + 1; + iend = isplit[jblk]; + in = iend - ioff; + + if (in == 1) { +/* 1x1 block */ + if (*wl >= d__[ibegin] - *pivmin) { + ++nwl; + } + if (*wu >= d__[ibegin] - *pivmin) { + ++nwu; + } + if (irange == 1 || *wl < d__[ibegin] - *pivmin && *wu >= d__[ + ibegin] - *pivmin) { + ++(*m); + w[*m] = d__[ibegin]; + werr[*m] = 0.; +/* The gap for a single block doesn't matter for the later */ +/* algorithm and is assigned an arbitrary large value */ + iblock[*m] = jblk; + indexw[*m] = 1; + } +/* Disabled 2x2 case because of a failure on the following matrix */ +/* RANGE = 'I', IL = IU = 4 */ +/* Original Tridiagonal, d = [ */ +/* -0.150102010615740E+00 */ +/* -0.849897989384260E+00 */ +/* -0.128208148052635E-15 */ +/* 0.128257718286320E-15 */ +/* ]; */ +/* e = [ */ +/* -0.357171383266986E+00 */ +/* -0.180411241501588E-15 */ +/* -0.175152352710251E-15 */ +/* ]; */ + +/* ELSE IF( IN.EQ.2 ) THEN */ +/* * 2x2 block */ +/* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) */ +/* TMP1 = HALF*(D(IBEGIN)+D(IEND)) */ +/* L1 = TMP1 - DISC */ +/* IF( WL.GE. L1-PIVMIN ) */ +/* $ NWL = NWL + 1 */ +/* IF( WU.GE. L1-PIVMIN ) */ +/* $ NWU = NWU + 1 */ +/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. */ +/* $ L1-PIVMIN ) ) THEN */ +/* M = M + 1 */ +/* W( M ) = L1 */ +/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */ +/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */ +/* IBLOCK( M ) = JBLK */ +/* INDEXW( M ) = 1 */ +/* ENDIF */ +/* L2 = TMP1 + DISC */ +/* IF( WL.GE. L2-PIVMIN ) */ +/* $ NWL = NWL + 1 */ +/* IF( WU.GE. L2-PIVMIN ) */ +/* $ NWU = NWU + 1 */ +/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. */ +/* $ L2-PIVMIN ) ) THEN */ +/* M = M + 1 */ +/* W( M ) = L2 */ +/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */ +/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */ +/* IBLOCK( M ) = JBLK */ +/* INDEXW( M ) = 2 */ +/* ENDIF */ + } else { +/* General Case - block of size IN >= 2 */ +/* Compute local Gerschgorin interval and use it as the initial */ +/* interval for DLAEBZ */ + gu = d__[ibegin]; + gl = d__[ibegin]; + tmp1 = 0.; + i__2 = iend; + for (j = ibegin; j <= i__2; ++j) { +/* Computing MIN */ + d__1 = gl, d__2 = gers[(j << 1) - 1]; + gl = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = gu, d__2 = gers[j * 2]; + gu = std::max(d__1,d__2); +/* L40: */ + } +/* [JAN/28/2009] */ +/* change SPDIAM by TNORM in lines 2 and 3 thereafter */ +/* line 1: remove computation of SPDIAM (not useful anymore) */ +/* SPDIAM = GU - GL */ +/* GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN */ +/* GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN */ + gl = gl - tnorm * 2. * eps * in - *pivmin * 2.; + gu = gu + tnorm * 2. * eps * in + *pivmin * 2.; + + if (irange > 1) { + if (gu < *wl) { +/* the local block contains none of the wanted eigenvalues */ + nwl += in; + nwu += in; + goto L70; + } +/* refine search interval if possible, only range (WL,WU] matters */ + gl = std::max(gl,*wl); + gu = std::min(gu,*wu); + if (gl >= gu) { + goto L70; + } + } +/* Find negcount of initial interval boundaries GL and GU */ + work[*n + 1] = gl; + work[*n + in + 1] = gu; + dlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, + pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, & + work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], & + w[*m + 1], &iblock[*m + 1], &iinfo); + if (iinfo != 0) { + *info = iinfo; + return 0; + } + + nwl += iwork[1]; + nwu += iwork[in + 1]; + iwoff = *m - iwork[1]; +/* Compute Eigenvalues */ + itmax = (integer) ((log(gu - gl + *pivmin) - log(*pivmin)) / log( + 2.)) + 2; + dlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, + pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, & + work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], + &w[*m + 1], &iblock[*m + 1], &iinfo); + if (iinfo != 0) { + *info = iinfo; + return 0; + } + +/* Copy eigenvalues into W and IBLOCK */ +/* Use -JBLK for block number for unconverged eigenvalues. */ +/* Loop over the number of output intervals from DLAEBZ */ + i__2 = iout; + for (j = 1; j <= i__2; ++j) { +/* eigenvalue approximation is middle point of interval */ + tmp1 = (work[j + *n] + work[j + in + *n]) * .5; +/* semi length of error interval */ + tmp2 = (d__1 = work[j + *n] - work[j + in + *n], abs(d__1)) * + .5; + if (j > iout - iinfo) { +/* Flag non-convergence. */ + ncnvrg = true; + ib = -jblk; + } else { + ib = jblk; + } + i__3 = iwork[j + in] + iwoff; + for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) { + w[je] = tmp1; + werr[je] = tmp2; + indexw[je] = je - iwoff; + iblock[je] = ib; +/* L50: */ + } +/* L60: */ + } + + *m += im; + } +L70: + ; + } +/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */ +/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */ + if (irange == 3) { + idiscl = *il - 1 - nwl; + idiscu = nwu - *iu; + + if (idiscl > 0) { + im = 0; + i__1 = *m; + for (je = 1; je <= i__1; ++je) { +/* Remove some of the smallest eigenvalues from the left so that */ +/* at the end IDISCL =0. Move all eigenvalues up to the left. */ + if (w[je] <= wlu && idiscl > 0) { + --idiscl; + } else { + ++im; + w[im] = w[je]; + werr[im] = werr[je]; + indexw[im] = indexw[je]; + iblock[im] = iblock[je]; + } +/* L80: */ + } + *m = im; + } + if (idiscu > 0) { +/* Remove some of the largest eigenvalues from the right so that */ +/* at the end IDISCU =0. Move all eigenvalues up to the left. */ + im = *m + 1; + for (je = *m; je >= 1; --je) { + if (w[je] >= wul && idiscu > 0) { + --idiscu; + } else { + --im; + w[im] = w[je]; + werr[im] = werr[je]; + indexw[im] = indexw[je]; + iblock[im] = iblock[je]; + } +/* L81: */ + } + jee = 0; + i__1 = *m; + for (je = im; je <= i__1; ++je) { + ++jee; + w[jee] = w[je]; + werr[jee] = werr[je]; + indexw[jee] = indexw[je]; + iblock[jee] = iblock[je]; +/* L82: */ + } + *m = *m - im + 1; + } + if (idiscl > 0 || idiscu > 0) { +/* Code to deal with effects of bad arithmetic. (If N(w) is */ +/* monotone non-decreasing, this should never happen.) */ +/* Some low eigenvalues to be discarded are not in (WL,WLU], */ +/* or high eigenvalues to be discarded are not in (WUL,WU] */ +/* so just kill off the smallest IDISCL/largest IDISCU */ +/* eigenvalues, by marking the corresponding IBLOCK = 0 */ + if (idiscl > 0) { + wkill = *wu; + i__1 = idiscl; + for (jdisc = 1; jdisc <= i__1; ++jdisc) { + iw = 0; + i__2 = *m; + for (je = 1; je <= i__2; ++je) { + if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) { + iw = je; + wkill = w[je]; + } +/* L90: */ + } + iblock[iw] = 0; +/* L100: */ + } + } + if (idiscu > 0) { + wkill = *wl; + i__1 = idiscu; + for (jdisc = 1; jdisc <= i__1; ++jdisc) { + iw = 0; + i__2 = *m; + for (je = 1; je <= i__2; ++je) { + if (iblock[je] != 0 && (w[je] >= wkill || iw == 0)) { + iw = je; + wkill = w[je]; + } +/* L110: */ + } + iblock[iw] = 0; +/* L120: */ + } + } +/* Now erase all eigenvalues with IBLOCK set to zero */ + im = 0; + i__1 = *m; + for (je = 1; je <= i__1; ++je) { + if (iblock[je] != 0) { + ++im; + w[im] = w[je]; + werr[im] = werr[je]; + indexw[im] = indexw[je]; + iblock[im] = iblock[je]; + } +/* L130: */ + } + *m = im; + } + if (idiscl < 0 || idiscu < 0) { + toofew = true; + } + } + + if (irange == 1 && *m != *n || irange == 3 && *m != *iu - *il + 1) { + toofew = true; + } +/* If ORDER='B', do nothing the eigenvalues are already sorted by */ +/* block. */ +/* If ORDER='E', sort the eigenvalues from smallest to largest */ + if (lsame_(order, "E") && *nsplit > 1) { + i__1 = *m - 1; + for (je = 1; je <= i__1; ++je) { + ie = 0; + tmp1 = w[je]; + i__2 = *m; + for (j = je + 1; j <= i__2; ++j) { + if (w[j] < tmp1) { + ie = j; + tmp1 = w[j]; + } +/* L140: */ + } + if (ie != 0) { + tmp2 = werr[ie]; + itmp1 = iblock[ie]; + itmp2 = indexw[ie]; + w[ie] = w[je]; + werr[ie] = werr[je]; + iblock[ie] = iblock[je]; + indexw[ie] = indexw[je]; + w[je] = tmp1; + werr[je] = tmp2; + iblock[je] = itmp1; + indexw[je] = itmp2; + } +/* L150: */ + } + } + + *info = 0; + if (ncnvrg) { + ++(*info); + } + if (toofew) { + *info += 2; + } + return 0; + +/* End of DLARRD */ + +} /* dlarrd_ */ + +/* Subroutine */ int dlarre_(const char *range, integer *n, double *vl, + double *vu, integer *il, integer *iu, double *d__, double + *e, double *e2, double *rtol1, double *rtol2, double * + spltol, integer *nsplit, integer *isplit, integer *m, double *w, + double *werr, double *wgap, integer *iblock, integer *indexw, + double *gers, double *pivmin, double *work, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__2 = 2; + + /* System generated locals */ + integer i__1, i__2; + double d__1, d__2, d__3; + + /* Builtin functions + double sqrt(double), log(double); */ + + /* Local variables */ + integer i__, j; + double s1, s2; + integer mb; + double gl; + integer in, mm; + double gu; + integer cnt; + double eps, tau, tmp, rtl; + integer cnt1, cnt2; + double tmp1, eabs; + integer iend, jblk; + double eold; + integer indl; + double dmax__, emax; + integer wend, idum, indu; + double rtol; + integer iseed[4]; + double avgap, sigma; + integer iinfo; + bool norep; + integer ibegin; + bool forceb; + integer irange; + double sgndef; + integer wbegin; + double safmin, spdiam; + bool usedqd; + double clwdth, isleft; + double isrght, bsrtol, dpivot; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* To find the desired eigenvalues of a given real symmetric */ +/* tridiagonal matrix T, DLARRE sets any "small" off-diagonal */ +/* elements to zero, and for each unreduced block T_i, it finds */ +/* (a) a suitable shift at one end of the block's spectrum, */ +/* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */ +/* (c) eigenvalues of each L_i D_i L_i^T. */ +/* The representations and eigenvalues found are then used by */ +/* DSTEMR to compute the eigenvectors of T. */ +/* The accuracy varies depending on whether bisection is used to */ +/* find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to */ +/* conpute all and then discard any unwanted one. */ +/* As an added benefit, DLARRE also outputs the n */ +/* Gerschgorin intervals for the matrices L_i D_i L_i^T. */ + +/* Arguments */ +/* ========= */ + +/* RANGE (input) CHARACTER */ +/* = 'A': ("All") all eigenvalues will be found. */ +/* = 'V': ("Value") all eigenvalues in the half-open interval */ +/* (VL, VU] will be found. */ +/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ +/* entire matrix) will be found. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N > 0. */ + +/* VL (input/output) DOUBLE PRECISION */ +/* VU (input/output) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds for the eigenvalues. */ +/* Eigenvalues less than or equal to VL, or greater than VU, */ +/* will not be returned. VL < VU. */ +/* If RANGE='I' or ='A', DLARRE computes bounds on the desired */ +/* part of the spectrum. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the N diagonal elements of the tridiagonal */ +/* matrix T. */ +/* On exit, the N diagonal elements of the diagonal */ +/* matrices D_i. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the first (N-1) entries contain the subdiagonal */ +/* elements of the tridiagonal matrix T; E(N) need not be set. */ +/* On exit, E contains the subdiagonal elements of the unit */ +/* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */ +/* 1 <= I <= NSPLIT, contain the base points sigma_i on output. */ + +/* E2 (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the first (N-1) entries contain the SQUARES of the */ +/* subdiagonal elements of the tridiagonal matrix T; */ +/* E2(N) need not be set. */ +/* On exit, the entries E2( ISPLIT( I ) ), */ +/* 1 <= I <= NSPLIT, have been set to zero */ + +/* RTOL1 (input) DOUBLE PRECISION */ +/* RTOL2 (input) DOUBLE PRECISION */ +/* Parameters for bisection. */ +/* An interval [LEFT,RIGHT] has converged if */ +/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ + +/* SPLTOL (input) DOUBLE PRECISION */ +/* The threshold for splitting. */ + +/* NSPLIT (output) INTEGER */ +/* The number of blocks T splits into. 1 <= NSPLIT <= N. */ + +/* ISPLIT (output) INTEGER array, dimension (N) */ +/* The splitting points, at which T breaks up into blocks. */ +/* The first block consists of rows/columns 1 to ISPLIT(1), */ +/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ +/* etc., and the NSPLIT-th consists of rows/columns */ +/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues (of all L_i D_i L_i^T) */ +/* found. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements contain the eigenvalues. The */ +/* eigenvalues of each of the blocks, L_i D_i L_i^T, are */ +/* sorted in ascending order ( DLARRE may use the */ +/* remaining N-M elements as workspace). */ + +/* WERR (output) DOUBLE PRECISION array, dimension (N) */ +/* The error bound on the corresponding eigenvalue in W. */ + +/* WGAP (output) DOUBLE PRECISION array, dimension (N) */ +/* The separation from the right neighbor eigenvalue in W. */ +/* The gap is only with respect to the eigenvalues of the same block */ +/* as each block has its own representation tree. */ +/* Exception: at the right end of a block we store the left gap */ + +/* IBLOCK (output) INTEGER array, dimension (N) */ +/* The indices of the blocks (submatrices) associated with the */ +/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */ +/* W(i) belongs to the first block from the top, =2 if W(i) */ +/* belongs to the second block, etc. */ + +/* INDEXW (output) INTEGER array, dimension (N) */ +/* The indices of the eigenvalues within each block (submatrix); */ +/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */ +/* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */ + +/* GERS (output) DOUBLE PRECISION array, dimension (2*N) */ +/* The N Gerschgorin intervals (the i-th Gerschgorin interval */ +/* is (GERS(2*i-1), GERS(2*i)). */ + +/* PIVMIN (output) DOUBLE PRECISION */ +/* The minimum pivot in the Sturm sequence for T. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) */ +/* Workspace. */ + +/* IWORK (workspace) INTEGER array, dimension (5*N) */ +/* Workspace. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* > 0: A problem occured in DLARRE. */ +/* < 0: One of the called subroutines signaled an internal problem. */ +/* Needs inspection of the corresponding parameter IINFO */ +/* for further information. */ + +/* =-1: Problem in DLARRD. */ +/* = 2: No base representation could be found in MAXTRY iterations. */ +/* Increasing MAXTRY and recompilation might be a remedy. */ +/* =-3: Problem in DLARRB when computing the refined root */ +/* representation for DLASQ2. */ +/* =-4: Problem in DLARRB when preforming bisection on the */ +/* desired part of the spectrum. */ +/* =-5: Problem in DLASQ2. */ +/* =-6: Problem in DLASQ2. */ + +/* Further Details */ +/* The base representations are required to suffer very little */ +/* element growth and consequently define all their eigenvalues to */ +/* high relative accuracy. */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --iwork; + --work; + --gers; + --indexw; + --iblock; + --wgap; + --werr; + --w; + --isplit; + --e2; + --e; + --d__; + + /* Function Body */ + *info = 0; + +/* Decode RANGE */ + + if (lsame_(range, "A")) { + irange = 1; + } else if (lsame_(range, "V")) { + irange = 3; + } else if (lsame_(range, "I")) { + irange = 2; + } + *m = 0; +/* Get machine constants */ + safmin = dlamch_("S"); + eps = dlamch_("P"); +/* Set parameters */ + rtl = sqrt(eps); + bsrtol = sqrt(eps); +/* Treat case of 1x1 matrix for quick return */ + if (*n == 1) { + if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu || + irange == 2 && *il == 1 && *iu == 1) { + *m = 1; + w[1] = d__[1]; +/* The computation error of the eigenvalue is zero */ + werr[1] = 0.; + wgap[1] = 0.; + iblock[1] = 1; + indexw[1] = 1; + gers[1] = d__[1]; + gers[2] = d__[1]; + } +/* store the shift for the initial RRR, which is zero in this case */ + e[1] = 0.; + return 0; + } +/* General case: tridiagonal matrix of order > 1 */ + +/* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */ +/* Compute maximum off-diagonal entry and pivmin. */ + gl = d__[1]; + gu = d__[1]; + eold = 0.; + emax = 0.; + e[*n] = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + werr[i__] = 0.; + wgap[i__] = 0.; + eabs = (d__1 = e[i__], abs(d__1)); + if (eabs >= emax) { + emax = eabs; + } + tmp1 = eabs + eold; + gers[(i__ << 1) - 1] = d__[i__] - tmp1; +/* Computing MIN */ + d__1 = gl, d__2 = gers[(i__ << 1) - 1]; + gl = std::min(d__1,d__2); + gers[i__ * 2] = d__[i__] + tmp1; +/* Computing MAX */ + d__1 = gu, d__2 = gers[i__ * 2]; + gu = std::max(d__1,d__2); + eold = eabs; +/* L5: */ + } +/* The minimum pivot allowed in the Sturm sequence for T */ +/* Computing MAX */ +/* Computing 2nd power */ + d__3 = emax; + d__1 = 1., d__2 = d__3 * d__3; + *pivmin = safmin * std::max(d__1,d__2); +/* Compute spectral diameter. The Gerschgorin bounds give an */ +/* estimate that is wrong by at most a factor of SQRT(2) */ + spdiam = gu - gl; +/* Compute splitting points */ + dlarra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], & + iinfo); +/* Can force use of bisection instead of faster DQDS. */ +/* Option left in the code for future multisection work. */ + forceb = false; + if (irange == 1 && ! forceb) { +/* Set interval [VL,VU] that contains all eigenvalues */ + *vl = gl; + *vu = gu; + } else { +/* We call DLARRD to find crude approximations to the eigenvalues */ +/* in the desired range. In case IRANGE = INDRNG, we also obtain the */ +/* interval (VL,VU] that contains all the wanted eigenvalues. */ +/* An interval [LEFT,RIGHT] has converged if */ +/* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */ +/* DLARRD needs a WORK of size 4*N, IWORK of size 3*N */ + dlarrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[ + 1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1], + vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */ + i__1 = *n; + for (i__ = mm + 1; i__ <= i__1; ++i__) { + w[i__] = 0.; + werr[i__] = 0.; + iblock[i__] = 0; + indexw[i__] = 0; +/* L14: */ + } + } +/* ** */ +/* Loop over unreduced blocks */ + ibegin = 1; + wbegin = 1; + i__1 = *nsplit; + for (jblk = 1; jblk <= i__1; ++jblk) { + iend = isplit[jblk]; + in = iend - ibegin + 1; +/* 1 X 1 block */ + if (in == 1) { + if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin] + <= *vu || irange == 2 && iblock[wbegin] == jblk) { + ++(*m); + w[*m] = d__[ibegin]; + werr[*m] = 0.; +/* The gap for a single block doesn't matter for the later */ +/* algorithm and is assigned an arbitrary large value */ + wgap[*m] = 0.; + iblock[*m] = jblk; + indexw[*m] = 1; + ++wbegin; + } +/* E( IEND ) holds the shift for the initial RRR */ + e[iend] = 0.; + ibegin = iend + 1; + goto L170; + } + +/* Blocks of size larger than 1x1 */ + +/* E( IEND ) will hold the shift for the initial RRR, for now set it =0 */ + e[iend] = 0.; + +/* Find local outer bounds GL,GU for the block */ + gl = d__[ibegin]; + gu = d__[ibegin]; + i__2 = iend; + for (i__ = ibegin; i__ <= i__2; ++i__) { +/* Computing MIN */ + d__1 = gers[(i__ << 1) - 1]; + gl = std::min(d__1,gl); +/* Computing MAX */ + d__1 = gers[i__ * 2]; + gu = std::max(d__1,gu); +/* L15: */ + } + spdiam = gu - gl; + if (! (irange == 1 && ! forceb)) { +/* Count the number of eigenvalues in the current block. */ + mb = 0; + i__2 = mm; + for (i__ = wbegin; i__ <= i__2; ++i__) { + if (iblock[i__] == jblk) { + ++mb; + } else { + goto L21; + } +/* L20: */ + } +L21: + if (mb == 0) { +/* No eigenvalue in the current block lies in the desired range */ +/* E( IEND ) holds the shift for the initial RRR */ + e[iend] = 0.; + ibegin = iend + 1; + goto L170; + } else { +/* Decide whether dqds or bisection is more efficient */ + usedqd = (double) mb > in * .5 && ! forceb; + wend = wbegin + mb - 1; +/* Calculate gaps for the current block */ +/* In later stages, when representations for individual */ +/* eigenvalues are different, we use SIGMA = E( IEND ). */ + sigma = 0.; + i__2 = wend - 1; + for (i__ = wbegin; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + + werr[i__]); + wgap[i__] = std::max(d__1,d__2); +/* L30: */ + } +/* Computing MAX */ + d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]); + wgap[wend] = std::max(d__1,d__2); +/* Find local index of the first and last desired evalue. */ + indl = indexw[wbegin]; + indu = indexw[wend]; + } + } + if (irange == 1 && ! forceb || usedqd) { +/* Case of DQDS */ +/* Find approximations to the extremal eigenvalues of the block */ + dlarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & + rtl, &tmp, &tmp1, &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* Computing MAX */ + d__2 = gl, d__3 = tmp - tmp1 - eps * 100. * (d__1 = tmp - tmp1, + abs(d__1)); + isleft = std::max(d__2,d__3); + dlarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & + rtl, &tmp, &tmp1, &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* Computing MIN */ + d__2 = gu, d__3 = tmp + tmp1 + eps * 100. * (d__1 = tmp + tmp1, + abs(d__1)); + isrght = std::min(d__2,d__3); +/* Improve the estimate of the spectral diameter */ + spdiam = isrght - isleft; + } else { +/* Case of bisection */ +/* Find approximations to the wanted extremal eigenvalues */ +/* Computing MAX */ + d__2 = gl, d__3 = w[wbegin] - werr[wbegin] - eps * 100. * (d__1 = + w[wbegin] - werr[wbegin], abs(d__1)); + isleft = std::max(d__2,d__3); +/* Computing MIN */ + d__2 = gu, d__3 = w[wend] + werr[wend] + eps * 100. * (d__1 = w[ + wend] + werr[wend], abs(d__1)); + isrght = std::min(d__2,d__3); + } +/* Decide whether the base representation for the current block */ +/* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */ +/* should be on the left or the right end of the current block. */ +/* The strategy is to shift to the end which is "more populated" */ +/* Furthermore, decide whether to use DQDS for the computation of */ +/* the eigenvalue approximations at the end of DLARRE or bisection. */ +/* dqds is chosen if all eigenvalues are desired or the number of */ +/* eigenvalues to be computed is large compared to the blocksize. */ + if (irange == 1 && ! forceb) { +/* If all the eigenvalues have to be computed, we use dqd */ + usedqd = true; +/* INDL is the local index of the first eigenvalue to compute */ + indl = 1; + indu = in; +/* MB = number of eigenvalues to compute */ + mb = in; + wend = wbegin + mb - 1; +/* Define 1/4 and 3/4 points of the spectrum */ + s1 = isleft + spdiam * .25; + s2 = isrght - spdiam * .25; + } else { +/* DLARRD has computed IBLOCK and INDEXW for each eigenvalue */ +/* approximation. */ +/* choose sigma */ + if (usedqd) { + s1 = isleft + spdiam * .25; + s2 = isrght - spdiam * .25; + } else { + tmp = std::min(isrght,*vu) - std::max(isleft,*vl); + s1 = std::max(isleft,*vl) + tmp * .25; + s2 = std::min(isrght,*vu) - tmp * .25; + } + } +/* Compute the negcount at the 1/4 and 3/4 points */ + if (mb > 1) { + dlarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, & + cnt, &cnt1, &cnt2, &iinfo); + } + if (mb == 1) { + sigma = gl; + sgndef = 1.; + } else if (cnt1 - indl >= indu - cnt2) { + if (irange == 1 && ! forceb) { + sigma = std::max(isleft,gl); + } else if (usedqd) { +/* use Gerschgorin bound as shift to get pos def matrix */ +/* for dqds */ + sigma = isleft; + } else { +/* use approximation of the first desired eigenvalue of the */ +/* block as shift */ + sigma = std::max(isleft,*vl); + } + sgndef = 1.; + } else { + if (irange == 1 && ! forceb) { + sigma = std::min(isrght,gu); + } else if (usedqd) { +/* use Gerschgorin bound as shift to get neg def matrix */ +/* for dqds */ + sigma = isrght; + } else { +/* use approximation of the first desired eigenvalue of the */ +/* block as shift */ + sigma = std::min(isrght,*vu); + } + sgndef = -1.; + } +/* An initial SIGMA has been chosen that will be used for computing */ +/* T - SIGMA I = L D L^T */ +/* Define the increment TAU of the shift in case the initial shift */ +/* needs to be refined to obtain a factorization with not too much */ +/* element growth. */ + if (usedqd) { +/* The initial SIGMA was to the outer end of the spectrum */ +/* the matrix is definite and we need not retreat. */ + tau = spdiam * eps * *n + *pivmin * 2.; + } else { + if (mb > 1) { + clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin]; + avgap = (d__1 = clwdth / (double) (wend - wbegin), abs( + d__1)); + if (sgndef == 1.) { +/* Computing MAX */ + d__1 = wgap[wbegin]; + tau = std::max(d__1,avgap) * .5; +/* Computing MAX */ + d__1 = tau, d__2 = werr[wbegin]; + tau = std::max(d__1,d__2); + } else { +/* Computing MAX */ + d__1 = wgap[wend - 1]; + tau = std::max(d__1,avgap) * .5; +/* Computing MAX */ + d__1 = tau, d__2 = werr[wend]; + tau = std::max(d__1,d__2); + } + } else { + tau = werr[wbegin]; + } + } + + for (idum = 1; idum <= 6; ++idum) { +/* Compute L D L^T factorization of tridiagonal matrix T - sigma I. */ +/* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */ +/* pivots in WORK(2*IN+1:3*IN) */ + dpivot = d__[ibegin] - sigma; + work[1] = dpivot; + dmax__ = abs(work[1]); + j = ibegin; + i__2 = in - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[(in << 1) + i__] = 1. / work[i__]; + tmp = e[j] * work[(in << 1) + i__]; + work[in + i__] = tmp; + dpivot = d__[j + 1] - sigma - tmp * e[j]; + work[i__ + 1] = dpivot; +/* Computing MAX */ + d__1 = dmax__, d__2 = abs(dpivot); + dmax__ = std::max(d__1,d__2); + ++j; +/* L70: */ + } +/* check for element growth */ + if (dmax__ > spdiam * 64.) { + norep = true; + } else { + norep = false; + } + if (usedqd && ! norep) { +/* Ensure the definiteness of the representation */ +/* All entries of D (of L D L^T) must have the same sign */ + i__2 = in; + for (i__ = 1; i__ <= i__2; ++i__) { + tmp = sgndef * work[i__]; + if (tmp < 0.) { + norep = true; + } +/* L71: */ + } + } + if (norep) { +/* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */ +/* shift which makes the matrix definite. So we should end up */ +/* here really only in the case of IRANGE = VALRNG or INDRNG. */ + if (idum == 5) { + if (sgndef == 1.) { +/* The fudged Gerschgorin shift should succeed */ + sigma = gl - spdiam * 2. * eps * *n - *pivmin * 4.; + } else { + sigma = gu + spdiam * 2. * eps * *n + *pivmin * 4.; + } + } else { + sigma -= sgndef * tau; + tau *= 2.; + } + } else { +/* an initial RRR is found */ + goto L83; + } +/* L80: */ + } +/* if the program reaches this point, no base representation could be */ +/* found in MAXTRY iterations. */ + *info = 2; + return 0; +L83: +/* At this point, we have found an initial base representation */ +/* T - SIGMA I = L D L^T with not too much element growth. */ +/* Store the shift. */ + e[iend] = sigma; +/* Store D and L. */ + dcopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1); + i__2 = in - 1; + dcopy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1); + if (mb > 1) { + +/* Perturb each entry of the base representation by a small */ +/* (but random) relative amount to overcome difficulties with */ +/* glued matrices. */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__ - 1] = 1; +/* L122: */ + } + i__2 = (in << 1) - 1; + dlarnv_(&c__2, iseed, &i__2, &work[1]); + i__2 = in - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + d__[ibegin + i__ - 1] *= eps * 8. * work[i__] + 1.; + e[ibegin + i__ - 1] *= eps * 8. * work[in + i__] + 1.; +/* L125: */ + } + d__[iend] *= eps * 4. * work[in] + 1.; + + } + +/* Don't update the Gerschgorin intervals because keeping track */ +/* of the updates would be too much work in DLARRV. */ +/* We update W instead and use it to locate the proper Gerschgorin */ +/* intervals. */ +/* Compute the required eigenvalues of L D L' by bisection or dqds */ + if (! usedqd) { +/* If DLARRD has been used, shift the eigenvalue approximations */ +/* according to their representation. This is necessary for */ +/* a uniform DLARRV since dqds computes eigenvalues of the */ +/* shifted representation. In DLARRV, W will always hold the */ +/* UNshifted eigenvalue approximation. */ + i__2 = wend; + for (j = wbegin; j <= i__2; ++j) { + w[j] -= sigma; + werr[j] += (d__1 = w[j], abs(d__1)) * eps; +/* L134: */ + } +/* call DLARRB to reduce eigenvalue error of the approximations */ +/* from DLARRD */ + i__2 = iend - 1; + for (i__ = ibegin; i__ <= i__2; ++i__) { +/* Computing 2nd power */ + d__1 = e[i__]; + work[i__] = d__[i__] * (d__1 * d__1); +/* L135: */ + } +/* use bisection to find EV from INDL to INDU */ + i__2 = indl - 1; + dlarrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1, + rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], & + work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, & + iinfo); + if (iinfo != 0) { + *info = -4; + return 0; + } +/* DLARRB computes all gaps correctly except for the last one */ +/* Record distance to VU/GU */ +/* Computing MAX */ + d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]); + wgap[wend] = std::max(d__1,d__2); + i__2 = indu; + for (i__ = indl; i__ <= i__2; ++i__) { + ++(*m); + iblock[*m] = jblk; + indexw[*m] = i__; +/* L138: */ + } + } else { +/* Call dqds to get all eigs (and then possibly delete unwanted */ +/* eigenvalues). */ +/* Note that dqds finds the eigenvalues of the L D L^T representation */ +/* of T to high relative accuracy. High relative accuracy */ +/* might be lost when the shift of the RRR is subtracted to obtain */ +/* the eigenvalues of T. However, T is not guaranteed to define its */ +/* eigenvalues to high relative accuracy anyway. */ +/* Set RTOL to the order of the tolerance used in DLASQ2 */ +/* This is an ESTIMATED error, the worst case bound is 4*N*EPS */ +/* which is usually too large and requires unnecessary work to be */ +/* done by bisection when computing the eigenvectors */ + rtol = log((double) in) * 4. * eps; + j = ibegin; + i__2 = in - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[(i__ << 1) - 1] = (d__1 = d__[j], abs(d__1)); + work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1]; + ++j; +/* L140: */ + } + work[(in << 1) - 1] = (d__1 = d__[iend], abs(d__1)); + work[in * 2] = 0.; + dlasq2_(&in, &work[1], &iinfo); + if (iinfo != 0) { +/* If IINFO = -5 then an index is part of a tight cluster */ +/* and should be changed. The index is in IWORK(1) and the */ +/* gap is in WORK(N+1) */ + *info = -5; + return 0; + } else { +/* Test that all eigenvalues are positive as expected */ + i__2 = in; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] < 0.) { + *info = -6; + return 0; + } +/* L149: */ + } + } + if (sgndef > 0.) { + i__2 = indu; + for (i__ = indl; i__ <= i__2; ++i__) { + ++(*m); + w[*m] = work[in - i__ + 1]; + iblock[*m] = jblk; + indexw[*m] = i__; +/* L150: */ + } + } else { + i__2 = indu; + for (i__ = indl; i__ <= i__2; ++i__) { + ++(*m); + w[*m] = -work[i__]; + iblock[*m] = jblk; + indexw[*m] = i__; +/* L160: */ + } + } + i__2 = *m; + for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { +/* the value of RTOL below should be the tolerance in DLASQ2 */ + werr[i__] = rtol * (d__1 = w[i__], abs(d__1)); +/* L165: */ + } + i__2 = *m - 1; + for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { +/* compute the right gap between the intervals */ +/* Computing MAX */ + d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + werr[ + i__]); + wgap[i__] = std::max(d__1,d__2); +/* L166: */ + } +/* Computing MAX */ + d__1 = 0., d__2 = *vu - sigma - (w[*m] + werr[*m]); + wgap[*m] = std::max(d__1,d__2); + } +/* proceed with next block */ + ibegin = iend + 1; + wbegin = wend + 1; +L170: + ; + } + + return 0; + +/* end of DLARRE */ + +} /* dlarre_ */ + +/* Subroutine */ int dlarrf_(integer *n, double *d__, double *l, + double *ld, integer *clstrt, integer *clend, double *w, + double *wgap, double *werr, double *spdiam, double * + clgapl, double *clgapr, double *pivmin, double *sigma, + double *dplus, double *lplus, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__; + double s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2, + znm2, growthbound, fail, fact, oldp; + integer indx; + double prod; + integer ktry; + double fail2, avgap, ldmax, rdmax; + integer shift; + bool dorrr1; + double ldelta; + bool nofail; + double mingap, lsigma, rdelta; + bool forcer; + double rsigma, clwdth; + bool sawnan1, sawnan2, tryrrr1; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ +/* * */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Given the initial representation L D L^T and its cluster of close */ +/* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... */ +/* W( CLEND ), DLARRF finds a new relatively robust representation */ +/* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the */ +/* eigenvalues of L(+) D(+) L(+)^T is relatively isolated. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix (subblock, if the matrix splitted). */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The N diagonal elements of the diagonal matrix D. */ + +/* L (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (N-1) subdiagonal elements of the unit bidiagonal */ +/* matrix L. */ + +/* LD (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (N-1) elements L(i)*D(i). */ + +/* CLSTRT (input) INTEGER */ +/* The index of the first eigenvalue in the cluster. */ + +/* CLEND (input) INTEGER */ +/* The index of the last eigenvalue in the cluster. */ + +/* W (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */ +/* The eigenvalue APPROXIMATIONS of L D L^T in ascending order. */ +/* W( CLSTRT ) through W( CLEND ) form the cluster of relatively */ +/* close eigenalues. */ + +/* WGAP (input/output) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */ +/* The separation from the right neighbor eigenvalue in W. */ + +/* WERR (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */ +/* WERR contain the semiwidth of the uncertainty */ +/* interval of the corresponding eigenvalue APPROXIMATION in W */ + +/* SPDIAM (input) estimate of the spectral diameter obtained from the */ +/* Gerschgorin intervals */ + +/* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster. */ +/* Set by the calling routine to protect against shifts too close */ +/* to eigenvalues outside the cluster. */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum pivot allowed in the Sturm sequence. */ + +/* SIGMA (output) DOUBLE PRECISION */ +/* The shift used to form L(+) D(+) L(+)^T. */ + +/* DPLUS (output) DOUBLE PRECISION array, dimension (N) */ +/* The N diagonal elements of the diagonal matrix D(+). */ + +/* LPLUS (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The first (N-1) elements of LPLUS contain the subdiagonal */ +/* elements of the unit bidiagonal matrix L(+). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ +/* Workspace. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --work; + --lplus; + --dplus; + --werr; + --wgap; + --w; + --ld; + --l; + --d__; + + /* Function Body */ + *info = 0; + fact = 2.; + eps = dlamch_("Precision"); + shift = 0; + forcer = false; +/* Note that we cannot guarantee that for any of the shifts tried, */ +/* the factorization has a small or even moderate element growth. */ +/* There could be Ritz values at both ends of the cluster and despite */ +/* backing off, there are examples where all factorizations tried */ +/* (in IEEE mode, allowing zero pivots & infinities) have INFINITE */ +/* element growth. */ +/* For this reason, we should use PIVMIN in this subroutine so that at */ +/* least the L D L^T factorization exists. It can be checked afterwards */ +/* whether the element growth caused bad residuals/orthogonality. */ +/* Decide whether the code should accept the best among all */ +/* representations despite large element growth or signal INFO=1 */ + nofail = true; + +/* Compute the average gap length of the cluster */ + clwdth = (d__1 = w[*clend] - w[*clstrt], abs(d__1)) + werr[*clend] + werr[ + *clstrt]; + avgap = clwdth / (double) (*clend - *clstrt); + mingap = std::min(*clgapl,*clgapr); +/* Initial values for shifts to both ends of cluster */ +/* Computing MIN */ + d__1 = w[*clstrt], d__2 = w[*clend]; + lsigma = std::min(d__1,d__2) - werr[*clstrt]; +/* Computing MAX */ + d__1 = w[*clstrt], d__2 = w[*clend]; + rsigma = std::max(d__1,d__2) + werr[*clend]; +/* Use a small fudge to make sure that we really shift to the outside */ + lsigma -= abs(lsigma) * 4. * eps; + rsigma += abs(rsigma) * 4. * eps; +/* Compute upper bounds for how much to back off the initial shifts */ + ldmax = mingap * .25 + *pivmin * 2.; + rdmax = mingap * .25 + *pivmin * 2.; +/* Computing MAX */ + d__1 = avgap, d__2 = wgap[*clstrt]; + ldelta = std::max(d__1,d__2) / fact; +/* Computing MAX */ + d__1 = avgap, d__2 = wgap[*clend - 1]; + rdelta = std::max(d__1,d__2) / fact; + +/* Initialize the record of the best representation found */ + + s = dlamch_("S"); + smlgrowth = 1. / s; + fail = (double) (*n - 1) * mingap / (*spdiam * eps); + fail2 = (double) (*n - 1) * mingap / (*spdiam * sqrt(eps)); + bestshift = lsigma; + +/* while (KTRY <= KTRYMAX) */ + ktry = 0; + growthbound = *spdiam * 8.; +L5: + sawnan1 = false; + sawnan2 = false; +/* Ensure that we do not back off too much of the initial shifts */ + ldelta = std::min(ldmax,ldelta); + rdelta = std::min(rdmax,rdelta); +/* Compute the element growth when shifting to both ends of the cluster */ +/* accept the shift if there is no element growth at one of the two ends */ +/* Left end */ + s = -lsigma; + dplus[1] = d__[1] + s; + if (abs(dplus[1]) < *pivmin) { + dplus[1] = -(*pivmin); +/* Need to set SAWNAN1 because refined RRR test should not be used */ +/* in this case */ + sawnan1 = true; + } + max1 = abs(dplus[1]); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + lplus[i__] = ld[i__] / dplus[i__]; + s = s * lplus[i__] * l[i__] - lsigma; + dplus[i__ + 1] = d__[i__ + 1] + s; + if ((d__1 = dplus[i__ + 1], abs(d__1)) < *pivmin) { + dplus[i__ + 1] = -(*pivmin); +/* Need to set SAWNAN1 because refined RRR test should not be used */ +/* in this case */ + sawnan1 = true; + } +/* Computing MAX */ + d__2 = max1, d__3 = (d__1 = dplus[i__ + 1], abs(d__1)); + max1 = std::max(d__2,d__3); +/* L6: */ + } + sawnan1 = sawnan1 || disnan_(&max1); + if (forcer || max1 <= growthbound && ! sawnan1) { + *sigma = lsigma; + shift = 1; + goto L100; + } +/* Right end */ + s = -rsigma; + work[1] = d__[1] + s; + if (abs(work[1]) < *pivmin) { + work[1] = -(*pivmin); +/* Need to set SAWNAN2 because refined RRR test should not be used */ +/* in this case */ + sawnan2 = true; + } + max2 = abs(work[1]); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[*n + i__] = ld[i__] / work[i__]; + s = s * work[*n + i__] * l[i__] - rsigma; + work[i__ + 1] = d__[i__ + 1] + s; + if ((d__1 = work[i__ + 1], abs(d__1)) < *pivmin) { + work[i__ + 1] = -(*pivmin); +/* Need to set SAWNAN2 because refined RRR test should not be used */ +/* in this case */ + sawnan2 = true; + } +/* Computing MAX */ + d__2 = max2, d__3 = (d__1 = work[i__ + 1], abs(d__1)); + max2 = std::max(d__2,d__3); +/* L7: */ + } + sawnan2 = sawnan2 || disnan_(&max2); + if (forcer || max2 <= growthbound && ! sawnan2) { + *sigma = rsigma; + shift = 2; + goto L100; + } +/* If we are at this point, both shifts led to too much element growth */ +/* Record the better of the two shifts (provided it didn't lead to NaN) */ + if (sawnan1 && sawnan2) { +/* both MAX1 and MAX2 are NaN */ + goto L50; + } else { + if (! sawnan1) { + indx = 1; + if (max1 <= smlgrowth) { + smlgrowth = max1; + bestshift = lsigma; + } + } + if (! sawnan2) { + if (sawnan1 || max2 <= max1) { + indx = 2; + } + if (max2 <= smlgrowth) { + smlgrowth = max2; + bestshift = rsigma; + } + } + } +/* If we are here, both the left and the right shift led to */ +/* element growth. If the element growth is moderate, then */ +/* we may still accept the representation, if it passes a */ +/* refined test for RRR. This test supposes that no NaN occurred. */ +/* Moreover, we use the refined RRR test only for isolated clusters. */ + if (clwdth < mingap / 128. && std::min(max1,max2) < fail2 && ! sawnan1 && ! + sawnan2) { + dorrr1 = true; + } else { + dorrr1 = false; + } + tryrrr1 = true; + if (tryrrr1 && dorrr1) { + if (indx == 1) { + tmp = (d__1 = dplus[*n], abs(d__1)); + znm2 = 1.; + prod = 1.; + oldp = 1.; + for (i__ = *n - 1; i__ >= 1; --i__) { + if (prod <= eps) { + prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] * + work[*n + i__]) * oldp; + } else { + prod *= (d__1 = work[*n + i__], abs(d__1)); + } + oldp = prod; +/* Computing 2nd power */ + d__1 = prod; + znm2 += d__1 * d__1; +/* Computing MAX */ + d__2 = tmp, d__3 = (d__1 = dplus[i__] * prod, abs(d__1)); + tmp = std::max(d__2,d__3); +/* L15: */ + } + rrr1 = tmp / (*spdiam * sqrt(znm2)); + if (rrr1 <= 8.) { + *sigma = lsigma; + shift = 1; + goto L100; + } + } else if (indx == 2) { + tmp = (d__1 = work[*n], abs(d__1)); + znm2 = 1.; + prod = 1.; + oldp = 1.; + for (i__ = *n - 1; i__ >= 1; --i__) { + if (prod <= eps) { + prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] * + lplus[i__]) * oldp; + } else { + prod *= (d__1 = lplus[i__], abs(d__1)); + } + oldp = prod; +/* Computing 2nd power */ + d__1 = prod; + znm2 += d__1 * d__1; +/* Computing MAX */ + d__2 = tmp, d__3 = (d__1 = work[i__] * prod, abs(d__1)); + tmp = std::max(d__2,d__3); +/* L16: */ + } + rrr2 = tmp / (*spdiam * sqrt(znm2)); + if (rrr2 <= 8.) { + *sigma = rsigma; + shift = 2; + goto L100; + } + } + } +L50: + if (ktry < 1) { +/* If we are here, both shifts failed also the RRR test. */ +/* Back off to the outside */ +/* Computing MAX */ + d__1 = lsigma - ldelta, d__2 = lsigma - ldmax; + lsigma = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = rsigma + rdelta, d__2 = rsigma + rdmax; + rsigma = std::min(d__1,d__2); + ldelta *= 2.; + rdelta *= 2.; + ++ktry; + goto L5; + } else { +/* None of the representations investigated satisfied our */ +/* criteria. Take the best one we found. */ + if (smlgrowth < fail || nofail) { + lsigma = bestshift; + rsigma = bestshift; + forcer = true; + goto L5; + } else { + *info = 1; + return 0; + } + } +L100: + if (shift == 1) { + } else if (shift == 2) { +/* store new L and D back into DPLUS, LPLUS */ + dcopy_(n, &work[1], &c__1, &dplus[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1); + } + return 0; + +/* End of DLARRF */ + +} /* dlarrf_ */ + +/* Subroutine */ int dlarrj_(integer *n, double *d__, double *e2, + integer *ifirst, integer *ilast, double *rtol, integer *offset, + double *w, double *werr, double *work, integer *iwork, + double *pivmin, double *spdiam, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + double d__1, d__2; + + /* Builtin functions + double log(double); */ + + /* Local variables */ + integer i__, j, k, p; + double s; + integer i1, i2, ii; + double fac, mid; + integer cnt; + double tmp, left; + integer iter, nint, prev, next, savi1; + double right, width, dplus; + integer olnint, maxitr; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Given the initial eigenvalue approximations of T, DLARRJ */ +/* does bisection to refine the eigenvalues of T, */ +/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */ +/* guesses for these eigenvalues are input in W, the corresponding estimate */ +/* of the error in these guesses in WERR. During bisection, intervals */ +/* [left, right] are maintained by storing their mid-points and */ +/* semi-widths in the arrays W and WERR respectively. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The N diagonal elements of T. */ + +/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The Squares of the (N-1) subdiagonal elements of T. */ + +/* IFIRST (input) INTEGER */ +/* The index of the first eigenvalue to be computed. */ + +/* ILAST (input) INTEGER */ +/* The index of the last eigenvalue to be computed. */ + +/* RTOL (input) DOUBLE PRECISION */ +/* Tolerance for the convergence of the bisection intervals. */ +/* An interval [LEFT,RIGHT] has converged if */ +/* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|). */ + +/* OFFSET (input) INTEGER */ +/* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET */ +/* through ILAST-OFFSET elements of these arrays are to be used. */ + +/* W (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */ +/* estimates of the eigenvalues of L D L^T indexed IFIRST through */ +/* ILAST. */ +/* On output, these estimates are refined. */ + +/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */ +/* the errors in the estimates of the corresponding elements in W. */ +/* On output, these errors are refined. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ +/* Workspace. */ + +/* IWORK (workspace) INTEGER array, dimension (2*N) */ +/* Workspace. */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum pivot in the Sturm sequence for T. */ + +/* SPDIAM (input) DOUBLE PRECISION */ +/* The spectral diameter of T. */ + +/* INFO (output) INTEGER */ +/* Error flag. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ + +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --iwork; + --work; + --werr; + --w; + --e2; + --d__; + + /* Function Body */ + *info = 0; + + maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.)) + + 2; + +/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */ +/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */ +/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */ +/* for an unconverged interval is set to the index of the next unconverged */ +/* interval, and is -1 or 0 for a converged interval. Thus a linked */ +/* list of unconverged intervals is set up. */ + + i1 = *ifirst; + i2 = *ilast; +/* The number of unconverged intervals */ + nint = 0; +/* The last unconverged interval found */ + prev = 0; + i__1 = i2; + for (i__ = i1; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; + left = w[ii] - werr[ii]; + mid = w[ii]; + right = w[ii] + werr[ii]; + width = right - mid; +/* Computing MAX */ + d__1 = abs(left), d__2 = abs(right); + tmp = std::max(d__1,d__2); +/* The following test prevents the test of converged intervals */ + if (width < *rtol * tmp) { +/* This interval has already converged and does not need refinement. */ +/* (Note that the gaps might change through refining the */ +/* eigenvalues, however, they can only get bigger.) */ +/* Remove it from the list. */ + iwork[k - 1] = -1; +/* Make sure that I1 always points to the first unconverged interval */ + if (i__ == i1 && i__ < i2) { + i1 = i__ + 1; + } + if (prev >= i1 && i__ <= i2) { + iwork[(prev << 1) - 1] = i__ + 1; + } + } else { +/* unconverged interval found */ + prev = i__; +/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */ + +/* Do while( CNT(LEFT).GT.I-1 ) */ + + fac = 1.; +L20: + cnt = 0; + s = left; + dplus = d__[1] - s; + if (dplus < 0.) { + ++cnt; + } + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + dplus = d__[j] - s - e2[j - 1] / dplus; + if (dplus < 0.) { + ++cnt; + } +/* L30: */ + } + if (cnt > i__ - 1) { + left -= werr[ii] * fac; + fac *= 2.; + goto L20; + } + +/* Do while( CNT(RIGHT).LT.I ) */ + + fac = 1.; +L50: + cnt = 0; + s = right; + dplus = d__[1] - s; + if (dplus < 0.) { + ++cnt; + } + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + dplus = d__[j] - s - e2[j - 1] / dplus; + if (dplus < 0.) { + ++cnt; + } +/* L60: */ + } + if (cnt < i__) { + right += werr[ii] * fac; + fac *= 2.; + goto L50; + } + ++nint; + iwork[k - 1] = i__ + 1; + iwork[k] = cnt; + } + work[k - 1] = left; + work[k] = right; +/* L75: */ + } + savi1 = i1; + +/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */ +/* and while (ITER.LT.MAXITR) */ + + iter = 0; +L80: + prev = i1 - 1; + i__ = i1; + olnint = nint; + i__1 = olnint; + for (p = 1; p <= i__1; ++p) { + k = i__ << 1; + ii = i__ - *offset; + next = iwork[k - 1]; + left = work[k - 1]; + right = work[k]; + mid = (left + right) * .5; +/* semiwidth of interval */ + width = right - mid; +/* Computing MAX */ + d__1 = abs(left), d__2 = abs(right); + tmp = std::max(d__1,d__2); + if (width < *rtol * tmp || iter == maxitr) { +/* reduce number of unconverged intervals */ + --nint; +/* Mark interval as converged. */ + iwork[k - 1] = 0; + if (i1 == i__) { + i1 = next; + } else { +/* Prev holds the last unconverged interval previously examined */ + if (prev >= i1) { + iwork[(prev << 1) - 1] = next; + } + } + i__ = next; + goto L100; + } + prev = i__; + +/* Perform one bisection step */ + + cnt = 0; + s = mid; + dplus = d__[1] - s; + if (dplus < 0.) { + ++cnt; + } + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + dplus = d__[j] - s - e2[j - 1] / dplus; + if (dplus < 0.) { + ++cnt; + } +/* L90: */ + } + if (cnt <= i__ - 1) { + work[k - 1] = mid; + } else { + work[k] = mid; + } + i__ = next; +L100: + ; + } + ++iter; +/* do another loop if there are still unconverged intervals */ +/* However, in the last iteration, all intervals are accepted */ +/* since this is the best we can do. */ + if (nint > 0 && iter <= maxitr) { + goto L80; + } + + +/* At this point, all the intervals have converged */ + i__1 = *ilast; + for (i__ = savi1; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; +/* All intervals marked by '0' have been refined. */ + if (iwork[k - 1] == 0) { + w[ii] = (work[k - 1] + work[k]) * .5; + werr[ii] = work[k] - w[ii]; + } +/* L110: */ + } + + return 0; + +/* End of DLARRJ */ + +} /* dlarrj_ */ + +/* Subroutine */ int dlarrk_(integer *n, integer *iw, double *gl, + double *gu, double *d__, double *e2, double *pivmin, + double *reltol, double *w, double *werr, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Builtin functions + double log(double); */ + + /* Local variables */ + integer i__, it; + double mid, eps, tmp1, tmp2, left, atoli, right; + integer itmax; + double rtoli, tnorm; + + integer negcnt; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARRK computes one eigenvalue of a symmetric tridiagonal */ +/* matrix T to suitable accuracy. This is an auxiliary code to be */ +/* called from DSTEMR. */ + +/* To avoid overflow, the matrix must be scaled so that its */ +/* largest element is no greater than overflow**(1/2) * */ +/* underflow**(1/4) in absolute value, and for greatest */ +/* accuracy, it should not be much smaller than that. */ + +/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ +/* Matrix", Report CS41, Computer Science Dept., Stanford */ +/* University, July 21, 1966. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the tridiagonal matrix T. N >= 0. */ + +/* IW (input) INTEGER */ +/* The index of the eigenvalues to be returned. */ + +/* GL (input) DOUBLE PRECISION */ +/* GU (input) DOUBLE PRECISION */ +/* An upper and a lower bound on the eigenvalue. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the tridiagonal matrix T. */ + +/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ + +/* PIVMIN (input) DOUBLE PRECISION */ +/* The minimum pivot allowed in the Sturm sequence for T. */ + +/* RELTOL (input) DOUBLE PRECISION */ +/* The minimum relative width of an interval. When an interval */ +/* is narrower than RELTOL times the larger (in */ +/* magnitude) endpoint, then it is considered to be */ +/* sufficiently small, i.e., converged. Note: this should */ +/* always be at least radix*machine epsilon. */ + +/* W (output) DOUBLE PRECISION */ + +/* WERR (output) DOUBLE PRECISION */ +/* The error bound on the corresponding eigenvalue approximation */ +/* in W. */ + +/* INFO (output) INTEGER */ +/* = 0: Eigenvalue converged */ +/* = -1: Eigenvalue did NOT converge */ + +/* Internal Parameters */ +/* =================== */ + +/* FUDGE DOUBLE PRECISION, default = 2 */ +/* A "fudge factor" to widen the Gershgorin intervals. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Get machine constants */ + /* Parameter adjustments */ + --e2; + --d__; + + /* Function Body */ + eps = dlamch_("P"); +/* Computing MAX */ + d__1 = abs(*gl), d__2 = abs(*gu); + tnorm = std::max(d__1,d__2); + rtoli = *reltol; + atoli = *pivmin * 4.; + itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.)) + 2; + *info = -1; + left = *gl - tnorm * 2. * eps * *n - *pivmin * 4.; + right = *gu + tnorm * 2. * eps * *n + *pivmin * 4.; + it = 0; +L10: + +/* Check if interval converged or maximum number of iterations reached */ + + tmp1 = (d__1 = right - left, abs(d__1)); +/* Computing MAX */ + d__1 = abs(right), d__2 = abs(left); + tmp2 = std::max(d__1,d__2); +/* Computing MAX */ + d__1 = std::max(atoli,*pivmin), d__2 = rtoli * tmp2; + if (tmp1 < std::max(d__1,d__2)) { + *info = 0; + goto L30; + } + if (it > itmax) { + goto L30; + } + +/* Count number of negative pivots for mid-point */ + + ++it; + mid = (left + right) * .5; + negcnt = 0; + tmp1 = d__[1] - mid; + if (abs(tmp1) < *pivmin) { + tmp1 = -(*pivmin); + } + if (tmp1 <= 0.) { + ++negcnt; + } + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + tmp1 = d__[i__] - e2[i__ - 1] / tmp1 - mid; + if (abs(tmp1) < *pivmin) { + tmp1 = -(*pivmin); + } + if (tmp1 <= 0.) { + ++negcnt; + } +/* L20: */ + } + if (negcnt >= *iw) { + right = mid; + } else { + left = mid; + } + goto L10; +L30: + +/* Converged or maximum number of iterations reached */ + + *w = (left + right) * .5; + *werr = (d__1 = right - left, abs(d__1)) * .5; + return 0; + +/* End of DLARRK */ + +} /* dlarrk_ */ + +/* Subroutine */ int dlarrr_(integer *n, double *d__, double *e, + integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer i__; + double eps, tmp, tmp2, rmin; + + double offdig, safmin; + bool yesrel; + double smlnum, offdig2; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + + +/* Purpose */ +/* ======= */ + +/* Perform tests to decide whether the symmetric tridiagonal matrix T */ +/* warrants expensive computations which guarantee high relative accuracy */ +/* in the eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. N > 0. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The N diagonal elements of the tridiagonal matrix T. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the first (N-1) entries contain the subdiagonal */ +/* elements of the tridiagonal matrix T; E(N) is set to ZERO. */ + +/* INFO (output) INTEGER */ +/* INFO = 0(default) : the matrix warrants computations preserving */ +/* relative accuracy. */ +/* INFO = 1 : the matrix warrants computations guaranteeing */ +/* only absolute accuracy. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* As a default, do NOT go for relative-accuracy preserving computations. */ + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + *info = 1; + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + rmin = sqrt(smlnum); +/* Tests for relative accuracy */ + +/* Test for scaled diagonal dominance */ +/* Scale the diagonal entries to one and check whether the sum of the */ +/* off-diagonals is less than one */ + +/* The sdd relative error bounds have a 1/(1- 2*x) factor in them, */ +/* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative */ +/* accuracy is promised. In the notation of the code fragment below, */ +/* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number. */ +/* We don't think it is worth going into "sdd mode" unless the relative */ +/* condition number is reasonable, not 1/macheps. */ +/* The threshold should be compatible with other thresholds used in the */ +/* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds */ +/* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000 */ +/* instead of the current OFFDIG + OFFDIG2 < 1 */ + + yesrel = true; + offdig = 0.; + tmp = sqrt((abs(d__[1]))); + if (tmp < rmin) { + yesrel = false; + } + if (! yesrel) { + goto L11; + } + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + tmp2 = sqrt((d__1 = d__[i__], abs(d__1))); + if (tmp2 < rmin) { + yesrel = false; + } + if (! yesrel) { + goto L11; + } + offdig2 = (d__1 = e[i__ - 1], abs(d__1)) / (tmp * tmp2); + if (offdig + offdig2 >= .999) { + yesrel = false; + } + if (! yesrel) { + goto L11; + } + tmp = tmp2; + offdig = offdig2; +/* L10: */ + } +L11: + if (yesrel) { + *info = 0; + return 0; + } else { + } + + +/* *** MORE TO BE IMPLEMENTED *** */ + + +/* Test if the lower bidiagonal matrix L from T = L D L^T */ +/* (zero shift facto) is well conditioned */ + + +/* Test if the upper bidiagonal matrix U from T = U D U^T */ +/* (zero shift facto) is well conditioned. */ +/* In this case, the matrix needs to be flipped and, at the end */ +/* of the eigenvector computation, the flip needs to be applied */ +/* to the computed eigenvectors (and the support) */ + + + return 0; + +/* END OF DLARRR */ + +} /* dlarrr_ */ + +/* Subroutine */ int dlarrv_(integer *n, double *vl, double *vu, + double *d__, double *l, double *pivmin, integer *isplit, + integer *m, integer *dol, integer *dou, double *minrgp, + double *rtol1, double *rtol2, double *w, double *werr, + double *wgap, integer *iblock, integer *indexw, double *gers, + double *z__, integer *ldz, integer *isuppz, double *work, + integer *iwork, integer *info) +{ + /* Table of constant values */ + static double c_b5 = 0.; + static integer c__1 = 1; + static integer c__2 = 2; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2; + bool L__1; + + /* Builtin functions + double log(double); */ + + /* Local variables */ + integer minwsize, i__, j, k, p, q, miniwsize, ii; + double gl; + integer im, in; + double gu, gap, eps, tau, tol, tmp; + integer zto; + double ztz; + integer iend, jblk; + double lgap; + integer done; + double rgap, left; + integer wend, iter; + double bstw; + integer itmp1; + integer indld; + double fudge; + integer idone; + double sigma; + integer iinfo, iindr; + double resid; + bool eskip; + double right; + integer nclus, zfrom; + double rqtol; + integer iindc1, iindc2; + bool stp2ii; + double lambda; + integer ibegin, indeig; + bool needbs; + integer indlld; + double sgndef, mingma; + integer oldien, oldncl, wbegin; + double spdiam; + integer negcnt; + integer oldcls; + double savgap; + integer ndepth; + double ssigma; + bool usedbs; + integer iindwk, offset; + double gaptol; + integer newcls, oldfst, indwrk, windex, oldlst; + bool usedrq; + integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl; + double bstres; + integer newsiz, zusedu, zusedw; + double nrminv, rqcorr; + bool tryrqc; + integer isupmx; + + +/* -- LAPACK auxiliary routine (version 3.1.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARRV computes the eigenvectors of the tridiagonal matrix */ +/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */ +/* The input eigenvalues should have been computed by DLARRE. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* Lower and upper bounds of the interval that contains the desired */ +/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */ +/* end of the extremal eigenvalues in the desired RANGE. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the N diagonal elements of the diagonal matrix D. */ +/* On exit, D may be overwritten. */ + +/* L (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the (N-1) subdiagonal elements of the unit */ +/* bidiagonal matrix L are in elements 1 to N-1 of L */ +/* (if the matrix is not splitted.) At the end of each block */ +/* is stored the corresponding shift as given by DLARRE. */ +/* On exit, L is overwritten. */ + +/* PIVMIN (in) DOUBLE PRECISION */ +/* The minimum pivot allowed in the Sturm sequence. */ + +/* ISPLIT (input) INTEGER array, dimension (N) */ +/* The splitting points, at which T breaks up into blocks. */ +/* The first block consists of rows/columns 1 to */ +/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */ +/* through ISPLIT( 2 ), etc. */ + +/* M (input) INTEGER */ +/* The total number of input eigenvalues. 0 <= M <= N. */ + +/* DOL (input) INTEGER */ +/* DOU (input) INTEGER */ +/* If the user wants to compute only selected eigenvectors from all */ +/* the eigenvalues supplied, he can specify an index range DOL:DOU. */ +/* Or else the setting DOL=1, DOU=M should be applied. */ +/* Note that DOL and DOU refer to the order in which the eigenvalues */ +/* are stored in W. */ +/* If the user wants to compute only selected eigenpairs, then */ +/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */ +/* computed eigenvectors. All other columns of Z are set to zero. */ + +/* MINRGP (input) DOUBLE PRECISION */ + +/* RTOL1 (input) DOUBLE PRECISION */ +/* RTOL2 (input) DOUBLE PRECISION */ +/* Parameters for bisection. */ +/* An interval [LEFT,RIGHT] has converged if */ +/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ + +/* W (input/output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements of W contain the APPROXIMATE eigenvalues for */ +/* which eigenvectors are to be computed. The eigenvalues */ +/* should be grouped by split-off block and ordered from */ +/* smallest to largest within the block ( The output array */ +/* W from DLARRE is expected here ). Furthermore, they are with */ +/* respect to the shift of the corresponding root representation */ +/* for their block. On exit, W holds the eigenvalues of the */ +/* UNshifted matrix. */ + +/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements contain the semiwidth of the uncertainty */ +/* interval of the corresponding eigenvalue in W */ + +/* WGAP (input/output) DOUBLE PRECISION array, dimension (N) */ +/* The separation from the right neighbor eigenvalue in W. */ + +/* IBLOCK (input) INTEGER array, dimension (N) */ +/* The indices of the blocks (submatrices) associated with the */ +/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */ +/* W(i) belongs to the first block from the top, =2 if W(i) */ +/* belongs to the second block, etc. */ + +/* INDEXW (input) INTEGER array, dimension (N) */ +/* The indices of the eigenvalues within each block (submatrix); */ +/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */ +/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */ + +/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */ +/* The N Gerschgorin intervals (the i-th Gerschgorin interval */ +/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */ +/* be computed from the original UNshifted matrix. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ +/* If INFO = 0, the first M columns of Z contain the */ +/* orthonormal eigenvectors of the matrix T */ +/* corresponding to the input eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */ +/* The support of the eigenvectors in Z, i.e., the indices */ +/* indicating the nonzero elements in Z. The I-th eigenvector */ +/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */ +/* ISUPPZ( 2*I ). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (12*N) */ + +/* IWORK (workspace) INTEGER array, dimension (7*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ + +/* > 0: A problem occured in DLARRV. */ +/* < 0: One of the called subroutines signaled an internal problem. */ +/* Needs inspection of the corresponding parameter IINFO */ +/* for further information. */ + +/* =-1: Problem in DLARRB when refining a child's eigenvalues. */ +/* =-2: Problem in DLARRF when computing the RRR of a child. */ +/* When a child is inside a tight cluster, it can be difficult */ +/* to find an RRR. A partial remedy from the user's point of */ +/* view is to make the parameter MINRGP smaller and recompile. */ +/* However, as the orthogonality of the computed vectors is */ +/* proportional to 1/MINRGP, the user should be aware that */ +/* he might be trading in precision when he decreases MINRGP. */ +/* =-3: Problem in DLARRB when refining a single eigenvalue */ +/* after the Rayleigh correction was rejected. */ +/* = 5: The Rayleigh Quotient Iteration failed to converge to */ +/* full accuracy in MAXITR steps. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ +/* .. */ +/* The first N entries of WORK are reserved for the eigenvalues */ + /* Parameter adjustments */ + --d__; + --l; + --isplit; + --w; + --werr; + --wgap; + --iblock; + --indexw; + --gers; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + indld = *n + 1; + indlld = (*n << 1) + 1; + indwrk = *n * 3 + 1; + minwsize = *n * 12; + i__1 = minwsize; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L5: */ + } +/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */ +/* factorization used to compute the FP vector */ + iindr = 0; +/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */ +/* layer and the one above. */ + iindc1 = *n; + iindc2 = *n << 1; + iindwk = *n * 3 + 1; + miniwsize = *n * 7; + i__1 = miniwsize; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + zusedl = 1; + if (*dol > 1) { +/* Set lower bound for use of Z */ + zusedl = *dol - 1; + } + zusedu = *m; + if (*dou < *m) { +/* Set lower bound for use of Z */ + zusedu = *dou + 1; + } +/* The width of the part of Z that is used */ + zusedw = zusedu - zusedl + 1; + dlaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz); + eps = dlamch_("Precision"); + rqtol = eps * 2.; + +/* Set expert flags for standard code. */ + tryrqc = true; + if (*dol == 1 && *dou == *m) { + } else { +/* Only selected eigenpairs are computed. Since the other evalues */ +/* are not refined by RQ iteration, bisection has to compute to full */ +/* accuracy. */ + *rtol1 = eps * 4.; + *rtol2 = eps * 4.; + } +/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */ +/* desired eigenvalues. The support of the nonzero eigenvector */ +/* entries is contained in the interval IBEGIN:IEND. */ +/* Remark that if k eigenpairs are desired, then the eigenvectors */ +/* are stored in k contiguous columns of Z. */ +/* DONE is the number of eigenvectors already computed */ + done = 0; + ibegin = 1; + wbegin = 1; + i__1 = iblock[*m]; + for (jblk = 1; jblk <= i__1; ++jblk) { + iend = isplit[jblk]; + sigma = l[iend]; +/* Find the eigenvectors of the submatrix indexed IBEGIN */ +/* through IEND. */ + wend = wbegin - 1; +L15: + if (wend < *m) { + if (iblock[wend + 1] == jblk) { + ++wend; + goto L15; + } + } + if (wend < wbegin) { + ibegin = iend + 1; + goto L170; + } else if (wend < *dol || wbegin > *dou) { + ibegin = iend + 1; + wbegin = wend + 1; + goto L170; + } +/* Find local spectral diameter of the block */ + gl = gers[(ibegin << 1) - 1]; + gu = gers[ibegin * 2]; + i__2 = iend; + for (i__ = ibegin + 1; i__ <= i__2; ++i__) { +/* Computing MIN */ + d__1 = gers[(i__ << 1) - 1]; + gl = std::min(d__1,gl); +/* Computing MAX */ + d__1 = gers[i__ * 2]; + gu = std::max(d__1,gu); +/* L20: */ + } + spdiam = gu - gl; +/* OLDIEN is the last index of the previous block */ + oldien = ibegin - 1; +/* Calculate the size of the current block */ + in = iend - ibegin + 1; +/* The number of eigenvalues in the current block */ + im = wend - wbegin + 1; +/* This is for a 1x1 block */ + if (ibegin == iend) { + ++done; + z__[ibegin + wbegin * z_dim1] = 1.; + isuppz[(wbegin << 1) - 1] = ibegin; + isuppz[wbegin * 2] = ibegin; + w[wbegin] += sigma; + work[wbegin] = w[wbegin]; + ibegin = iend + 1; + ++wbegin; + goto L170; + } +/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */ +/* Note that these can be approximations, in this case, the corresp. */ +/* entries of WERR give the size of the uncertainty interval. */ +/* The eigenvalue approximations will be refined when necessary as */ +/* high relative accuracy is required for the computation of the */ +/* corresponding eigenvectors. */ + dcopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1); +/* We store in W the eigenvalue approximations w.r.t. the original */ +/* matrix T. */ + i__2 = im; + for (i__ = 1; i__ <= i__2; ++i__) { + w[wbegin + i__ - 1] += sigma; +/* L30: */ + } +/* NDEPTH is the current depth of the representation tree */ + ndepth = 0; +/* PARITY is either 1 or 0 */ + parity = 1; +/* NCLUS is the number of clusters for the next level of the */ +/* representation tree, we start with NCLUS = 1 for the root */ + nclus = 1; + iwork[iindc1 + 1] = 1; + iwork[iindc1 + 2] = im; +/* IDONE is the number of eigenvectors already computed in the current */ +/* block */ + idone = 0; +/* loop while( IDONE.LT.IM ) */ +/* generate the representation tree for the current block and */ +/* compute the eigenvectors */ +L40: + if (idone < im) { +/* This is a crude protection against infinitely deep trees */ + if (ndepth > *m) { + *info = -2; + return 0; + } +/* breadth first processing of the current level of the representation */ +/* tree: OLDNCL = number of clusters on current level */ + oldncl = nclus; +/* reset NCLUS to count the number of child clusters */ + nclus = 0; + + parity = 1 - parity; + if (parity == 0) { + oldcls = iindc1; + newcls = iindc2; + } else { + oldcls = iindc2; + newcls = iindc1; + } +/* Process the clusters on the current level */ + i__2 = oldncl; + for (i__ = 1; i__ <= i__2; ++i__) { + j = oldcls + (i__ << 1); +/* OLDFST, OLDLST = first, last index of current cluster. */ +/* cluster indices start with 1 and are relative */ +/* to WBEGIN when accessing W, WGAP, WERR, Z */ + oldfst = iwork[j - 1]; + oldlst = iwork[j]; + if (ndepth > 0) { +/* Retrieve relatively robust representation (RRR) of cluster */ +/* that has been computed at the previous level */ +/* The RRR is stored in Z and overwritten once the eigenvectors */ +/* have been computed or when the cluster is refined */ + if (*dol == 1 && *dou == *m) { +/* Get representation from location of the leftmost evalue */ +/* of the cluster */ + j = wbegin + oldfst - 1; + } else { + if (wbegin + oldfst - 1 < *dol) { +/* Get representation from the left end of Z array */ + j = *dol - 1; + } else if (wbegin + oldfst - 1 > *dou) { +/* Get representation from the right end of Z array */ + j = *dou; + } else { + j = wbegin + oldfst - 1; + } + } + dcopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin] +, &c__1); + i__3 = in - 1; + dcopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[ + ibegin], &c__1); + sigma = z__[iend + (j + 1) * z_dim1]; +/* Set the corresponding entries in Z to zero */ + dlaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j + * z_dim1], ldz); + } +/* Compute DL and DLL of current RRR */ + i__3 = iend - 1; + for (j = ibegin; j <= i__3; ++j) { + tmp = d__[j] * l[j]; + work[indld - 1 + j] = tmp; + work[indlld - 1 + j] = tmp * l[j]; +/* L50: */ + } + if (ndepth > 0) { +/* P and Q are index of the first and last eigenvalue to compute */ +/* within the current block */ + p = indexw[wbegin - 1 + oldfst]; + q = indexw[wbegin - 1 + oldlst]; +/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */ +/* thru' Q-OFFSET elements of these arrays are to be used. */ +/* OFFSET = P-OLDFST */ + offset = indexw[wbegin] - 1; +/* perform limited bisection (if necessary) to get approximate */ +/* eigenvalues to the precision needed. */ + dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p, + &q, rtol1, rtol2, &offset, &work[wbegin], &wgap[ + wbegin], &werr[wbegin], &work[indwrk], &iwork[ + iindwk], pivmin, &spdiam, &in, &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* We also recompute the extremal gaps. W holds all eigenvalues */ +/* of the unshifted matrix and must be used for computation */ +/* of WGAP, the entries of WORK might stem from RRRs with */ +/* different shifts. The gaps from WBEGIN-1+OLDFST to */ +/* WBEGIN-1+OLDLST are correctly computed in DLARRB. */ +/* However, we only allow the gaps to become greater since */ +/* this is what should happen when we decrease WERR */ + if (oldfst > 1) { +/* Computing MAX */ + d__1 = wgap[wbegin + oldfst - 2], d__2 = w[wbegin + + oldfst - 1] - werr[wbegin + oldfst - 1] - w[ + wbegin + oldfst - 2] - werr[wbegin + oldfst - + 2]; + wgap[wbegin + oldfst - 2] = std::max(d__1,d__2); + } + if (wbegin + oldlst - 1 < wend) { +/* Computing MAX */ + d__1 = wgap[wbegin + oldlst - 1], d__2 = w[wbegin + + oldlst] - werr[wbegin + oldlst] - w[wbegin + + oldlst - 1] - werr[wbegin + oldlst - 1]; + wgap[wbegin + oldlst - 1] = std::max(d__1,d__2); + } +/* Each time the eigenvalues in WORK get refined, we store */ +/* the newly found approximation with all shifts applied in W */ + i__3 = oldlst; + for (j = oldfst; j <= i__3; ++j) { + w[wbegin + j - 1] = work[wbegin + j - 1] + sigma; +/* L53: */ + } + } +/* Process the current node. */ + newfst = oldfst; + i__3 = oldlst; + for (j = oldfst; j <= i__3; ++j) { + if (j == oldlst) { +/* we are at the right end of the cluster, this is also the */ +/* boundary of the child cluster */ + newlst = j; + } else if (wgap[wbegin + j - 1] >= *minrgp * (d__1 = work[ + wbegin + j - 1], abs(d__1))) { +/* the right relative gap is big enough, the child cluster */ +/* (NEWFST,..,NEWLST) is well separated from the following */ + newlst = j; + } else { +/* inside a child cluster, the relative gap is not */ +/* big enough. */ + goto L140; + } +/* Compute size of child cluster found */ + newsiz = newlst - newfst + 1; +/* NEWFTT is the place in Z where the new RRR or the computed */ +/* eigenvector is to be stored */ + if (*dol == 1 && *dou == *m) { +/* Store representation at location of the leftmost evalue */ +/* of the cluster */ + newftt = wbegin + newfst - 1; + } else { + if (wbegin + newfst - 1 < *dol) { +/* Store representation at the left end of Z array */ + newftt = *dol - 1; + } else if (wbegin + newfst - 1 > *dou) { +/* Store representation at the right end of Z array */ + newftt = *dou; + } else { + newftt = wbegin + newfst - 1; + } + } + if (newsiz > 1) { + +/* Current child is not a singleton but a cluster. */ +/* Compute and store new representation of child. */ + + +/* Compute left and right cluster gap. */ + +/* LGAP and RGAP are not computed from WORK because */ +/* the eigenvalue approximations may stem from RRRs */ +/* different shifts. However, W hold all eigenvalues */ +/* of the unshifted matrix. Still, the entries in WGAP */ +/* have to be computed from WORK since the entries */ +/* in W might be of the same order so that gaps are not */ +/* exhibited correctly for very close eigenvalues. */ + if (newfst == 1) { +/* Computing MAX */ + d__1 = 0., d__2 = w[wbegin] - werr[wbegin] - *vl; + lgap = std::max(d__1,d__2); + } else { + lgap = wgap[wbegin + newfst - 2]; + } + rgap = wgap[wbegin + newlst - 1]; + +/* Compute left- and rightmost eigenvalue of child */ +/* to high precision in order to shift as close */ +/* as possible and obtain as large relative gaps */ +/* as possible */ + + for (k = 1; k <= 2; ++k) { + if (k == 1) { + p = indexw[wbegin - 1 + newfst]; + } else { + p = indexw[wbegin - 1 + newlst]; + } + offset = indexw[wbegin] - 1; + dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin + - 1], &p, &p, &rqtol, &rqtol, &offset, & + work[wbegin], &wgap[wbegin], &werr[wbegin] +, &work[indwrk], &iwork[iindwk], pivmin, & + spdiam, &in, &iinfo); +/* L55: */ + } + + if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1 + > *dou) { +/* if the cluster contains no desired eigenvalues */ +/* skip the computation of that branch of the rep. tree */ + +/* We could skip before the refinement of the extremal */ +/* eigenvalues of the child, but then the representation */ +/* tree could be different from the one when nothing is */ +/* skipped. For this reason we skip at this place. */ + idone = idone + newlst - newfst + 1; + goto L139; + } + +/* Compute RRR of child cluster. */ +/* Note that the new RRR is stored in Z */ + +/* DLARRF needs LWORK = 2*N */ + dlarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld + + ibegin - 1], &newfst, &newlst, &work[wbegin], + &wgap[wbegin], &werr[wbegin], &spdiam, &lgap, + &rgap, pivmin, &tau, &z__[ibegin + newftt * + z_dim1], &z__[ibegin + (newftt + 1) * z_dim1], + &work[indwrk], &iinfo); + if (iinfo == 0) { +/* a new RRR for the cluster was found by DLARRF */ +/* update shift and store it */ + ssigma = sigma + tau; + z__[iend + (newftt + 1) * z_dim1] = ssigma; +/* WORK() are the midpoints and WERR() the semi-width */ +/* Note that the entries in W are unchanged. */ + i__4 = newlst; + for (k = newfst; k <= i__4; ++k) { + fudge = eps * 3. * (d__1 = work[wbegin + k - + 1], abs(d__1)); + work[wbegin + k - 1] -= tau; + fudge += eps * 4. * (d__1 = work[wbegin + k - + 1], abs(d__1)); +/* Fudge errors */ + werr[wbegin + k - 1] += fudge; +/* Gaps are not fudged. Provided that WERR is small */ +/* when eigenvalues are close, a zero gap indicates */ +/* that a new representation is needed for resolving */ +/* the cluster. A fudge could lead to a wrong decision */ +/* of judging eigenvalues 'separated' which in */ +/* reality are not. This could have a negative impact */ +/* on the orthogonality of the computed eigenvectors. */ +/* L116: */ + } + ++nclus; + k = newcls + (nclus << 1); + iwork[k - 1] = newfst; + iwork[k] = newlst; + } else { + *info = -2; + return 0; + } + } else { + +/* Compute eigenvector of singleton */ + + iter = 0; + + tol = log((double) in) * 4. * eps; + + k = newfst; + windex = wbegin + k - 1; +/* Computing MAX */ + i__4 = windex - 1; + windmn = std::max(i__4,1_integer); +/* Computing MIN */ + i__4 = windex + 1; + windpl = std::min(i__4,*m); + lambda = work[windex]; + ++done; +/* Check if eigenvector computation is to be skipped */ + if (windex < *dol || windex > *dou) { + eskip = true; + goto L125; + } else { + eskip = false; + } + left = work[windex] - werr[windex]; + right = work[windex] + werr[windex]; + indeig = indexw[windex]; +/* Note that since we compute the eigenpairs for a child, */ +/* all eigenvalue approximations are w.r.t the same shift. */ +/* In this case, the entries in WORK should be used for */ +/* computing the gaps since they exhibit even very small */ +/* differences in the eigenvalues, as opposed to the */ +/* entries in W which might "look" the same. */ + if (k == 1) { +/* In the case RANGE='I' and with not much initial */ +/* accuracy in LAMBDA and VL, the formula */ +/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */ +/* can lead to an overestimation of the left gap and */ +/* thus to inadequately early RQI 'convergence'. */ +/* Prevent this by forcing a small left gap. */ +/* Computing MAX */ + d__1 = abs(left), d__2 = abs(right); + lgap = eps * std::max(d__1,d__2); + } else { + lgap = wgap[windmn]; + } + if (k == im) { +/* In the case RANGE='I' and with not much initial */ +/* accuracy in LAMBDA and VU, the formula */ +/* can lead to an overestimation of the right gap and */ +/* thus to inadequately early RQI 'convergence'. */ +/* Prevent this by forcing a small right gap. */ +/* Computing MAX */ + d__1 = abs(left), d__2 = abs(right); + rgap = eps * std::max(d__1,d__2); + } else { + rgap = wgap[windex]; + } + gap = std::min(lgap,rgap); + if (k == 1 || k == im) { +/* The eigenvector support can become wrong */ +/* because significant entries could be cut off due to a */ +/* large GAPTOL parameter in LAR1V. Prevent this. */ + gaptol = 0.; + } else { + gaptol = gap * eps; + } + isupmn = in; + isupmx = 1; +/* Update WGAP so that it holds the minimum gap */ +/* to the left or the right. This is crucial in the */ +/* case where bisection is used to ensure that the */ +/* eigenvalue is refined up to the required precision. */ +/* The correct value is restored afterwards. */ + savgap = wgap[windex]; + wgap[windex] = gap; +/* We want to use the Rayleigh Quotient Correction */ +/* as often as possible since it converges quadratically */ +/* when we are close enough to the desired eigenvalue. */ +/* However, the Rayleigh Quotient can have the wrong sign */ +/* and lead us away from the desired eigenvalue. In this */ +/* case, the best we can do is to use bisection. */ + usedbs = false; + usedrq = false; +/* Bisection is initially turned off unless it is forced */ + needbs = ! tryrqc; +L120: +/* Check if bisection should be used to refine eigenvalue */ + if (needbs) { +/* Take the bisection as new iterate */ + usedbs = true; + itmp1 = iwork[iindr + windex]; + offset = indexw[wbegin] - 1; + d__1 = eps * 2.; + dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin + - 1], &indeig, &indeig, &c_b5, &d__1, & + offset, &work[wbegin], &wgap[wbegin], & + werr[wbegin], &work[indwrk], &iwork[ + iindwk], pivmin, &spdiam, &itmp1, &iinfo); + if (iinfo != 0) { + *info = -3; + return 0; + } + lambda = work[windex]; +/* Reset twist index from inaccurate LAMBDA to */ +/* force computation of true MINGMA */ + iwork[iindr + windex] = 0; + } +/* Given LAMBDA, compute the eigenvector. */ + L__1 = ! usedbs; + dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[ + ibegin], &work[indld + ibegin - 1], &work[ + indlld + ibegin - 1], pivmin, &gaptol, &z__[ + ibegin + windex * z_dim1], &L__1, &negcnt, & + ztz, &mingma, &iwork[iindr + windex], &isuppz[ + (windex << 1) - 1], &nrminv, &resid, &rqcorr, + &work[indwrk]); + if (iter == 0) { + bstres = resid; + bstw = lambda; + } else if (resid < bstres) { + bstres = resid; + bstw = lambda; + } +/* Computing MIN */ + i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1]; + isupmn = std::min(i__4,i__5); +/* Computing MAX */ + i__4 = isupmx, i__5 = isuppz[windex * 2]; + isupmx = std::max(i__4,i__5); + ++iter; +/* sin alpha <= |resid|/gap */ +/* Note that both the residual and the gap are */ +/* proportional to the matrix, so ||T|| doesn't play */ +/* a role in the quotient */ + +/* Convergence test for Rayleigh-Quotient iteration */ +/* (omitted when Bisection has been used) */ + + if (resid > tol * gap && abs(rqcorr) > rqtol * abs( + lambda) && ! usedbs) { +/* We need to check that the RQCORR update doesn't */ +/* move the eigenvalue away from the desired one and */ +/* towards a neighbor. -> protection with bisection */ + if (indeig <= negcnt) { +/* The wanted eigenvalue lies to the left */ + sgndef = -1.; + } else { +/* The wanted eigenvalue lies to the right */ + sgndef = 1.; + } +/* We only use the RQCORR if it improves the */ +/* the iterate reasonably. */ + if (rqcorr * sgndef >= 0. && lambda + rqcorr <= + right && lambda + rqcorr >= left) { + usedrq = true; +/* Store new midpoint of bisection interval in WORK */ + if (sgndef == 1.) { +/* The current LAMBDA is on the left of the true */ +/* eigenvalue */ + left = lambda; +/* We prefer to assume that the error estimate */ +/* is correct. We could make the interval not */ +/* as a bracket but to be modified if the RQCORR */ +/* chooses to. In this case, the RIGHT side should */ +/* be modified as follows: */ +/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */ + } else { +/* The current LAMBDA is on the right of the true */ +/* eigenvalue */ + right = lambda; +/* See comment about assuming the error estimate is */ +/* correct above. */ +/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */ + } + work[windex] = (right + left) * .5; +/* Take RQCORR since it has the correct sign and */ +/* improves the iterate reasonably */ + lambda += rqcorr; +/* Update width of error interval */ + werr[windex] = (right - left) * .5; + } else { + needbs = true; + } + if (right - left < rqtol * abs(lambda)) { +/* The eigenvalue is computed to bisection accuracy */ +/* compute eigenvector and stop */ + usedbs = true; + goto L120; + } else if (iter < 10) { + goto L120; + } else if (iter == 10) { + needbs = true; + goto L120; + } else { + *info = 5; + return 0; + } + } else { + stp2ii = false; + if (usedrq && usedbs && bstres <= resid) { + lambda = bstw; + stp2ii = true; + } + if (stp2ii) { +/* improve error angle by second step */ + L__1 = ! usedbs; + dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin] +, &l[ibegin], &work[indld + ibegin - + 1], &work[indlld + ibegin - 1], + pivmin, &gaptol, &z__[ibegin + windex + * z_dim1], &L__1, &negcnt, &ztz, & + mingma, &iwork[iindr + windex], & + isuppz[(windex << 1) - 1], &nrminv, & + resid, &rqcorr, &work[indwrk]); + } + work[windex] = lambda; + } + +/* Compute FP-vector support w.r.t. whole matrix */ + + isuppz[(windex << 1) - 1] += oldien; + isuppz[windex * 2] += oldien; + zfrom = isuppz[(windex << 1) - 1]; + zto = isuppz[windex * 2]; + isupmn += oldien; + isupmx += oldien; +/* Ensure vector is ok if support in the RQI has changed */ + if (isupmn < zfrom) { + i__4 = zfrom - 1; + for (ii = isupmn; ii <= i__4; ++ii) { + z__[ii + windex * z_dim1] = 0.; +/* L122: */ + } + } + if (isupmx > zto) { + i__4 = isupmx; + for (ii = zto + 1; ii <= i__4; ++ii) { + z__[ii + windex * z_dim1] = 0.; +/* L123: */ + } + } + i__4 = zto - zfrom + 1; + dscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1], + &c__1); +L125: +/* Update W */ + w[windex] = lambda + sigma; +/* Recompute the gaps on the left and right */ +/* But only allow them to become larger and not */ +/* smaller (which can only happen through "bad" */ +/* cancellation and doesn't reflect the theory */ +/* where the initial gaps are underestimated due */ +/* to WERR being too crude.) */ + if (! eskip) { + if (k > 1) { +/* Computing MAX */ + d__1 = wgap[windmn], d__2 = w[windex] - werr[ + windex] - w[windmn] - werr[windmn]; + wgap[windmn] = std::max(d__1,d__2); + } + if (windex < wend) { +/* Computing MAX */ + d__1 = savgap, d__2 = w[windpl] - werr[windpl] + - w[windex] - werr[windex]; + wgap[windex] = std::max(d__1,d__2); + } + } + ++idone; + } +/* here ends the code for the current child */ + +L139: +/* Proceed to any remaining child nodes */ + newfst = j + 1; +L140: + ; + } +/* L150: */ + } + ++ndepth; + goto L40; + } + ibegin = iend + 1; + wbegin = wend + 1; +L170: + ; + } + + return 0; + +/* End of DLARRV */ + +} /* dlarrv_ */ + +int dlarscl2_(integer *m, integer *n, double *d__, double *x, integer *ldx) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARSCL2 performs a reciprocal diagonal scaling on an vector: */ +/* x <-- inv(D) * x */ +/* where the diagonal matrix D is stored as a vector. */ + +/* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS */ +/* standard. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of D and X. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of D and X. N >= 0. */ + +/* D (input) DOUBLE PRECISION array, length M */ +/* Diagonal matrix D, stored as a vector of length M. */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */ +/* On entry, the vector X to be scaled by D. */ +/* On exit, the scaled vector. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the vector X. LDX >= 0. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --d__; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + + /* Function Body */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] /= d__[i__]; + } + } + return 0; +} /* dlarscl2_ */ + +/* Subroutine */ int dlartg_(double *f, double *g, double *cs, + double *sn, double *r__) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + integer i__; + double f1, g1, eps, scale; + integer count; + double safmn2, safmx2; + + double safmin; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARTG generate a plane rotation so that */ + +/* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */ +/* [ -SN CS ] [ G ] [ 0 ] */ + +/* This is a slower, more accurate version of the BLAS1 routine DROTG, */ +/* with the following other differences: */ +/* F and G are unchanged on return. */ +/* If G=0, then CS=1 and SN=0. */ +/* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */ +/* floating point operations (saves work in DBDSQR when */ +/* there are zeros on the diagonal). */ + +/* If F exceeds G in magnitude, CS will be positive. */ + +/* Arguments */ +/* ========= */ + +/* F (input) DOUBLE PRECISION */ +/* The first component of vector to be rotated. */ + +/* G (input) DOUBLE PRECISION */ +/* The second component of vector to be rotated. */ + +/* CS (output) DOUBLE PRECISION */ +/* The cosine of the rotation. */ + +/* SN (output) DOUBLE PRECISION */ +/* The sine of the rotation. */ + +/* R (output) DOUBLE PRECISION */ +/* The nonzero component of the rotated vector. */ + +/* This version has a few statements commented out for thread safety */ +/* (machine parameters are computed on each entry). 10 feb 03, SJH. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* LOGICAL FIRST */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Save statement .. */ +/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */ +/* .. */ +/* .. Data statements .. */ +/* DATA FIRST / .TRUE. / */ +/* .. */ +/* .. Executable Statements .. */ + +/* IF( FIRST ) THEN */ + safmin = dlamch_("S"); + eps = dlamch_("E"); + d__1 = dlamch_("B"); + i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.); + safmn2 = pow_di(&d__1, &i__1); + safmx2 = 1. / safmn2; +/* FIRST = .FALSE. */ +/* END IF */ + if (*g == 0.) { + *cs = 1.; + *sn = 0.; + *r__ = *f; + } else if (*f == 0.) { + *cs = 0.; + *sn = 1.; + *r__ = *g; + } else { + f1 = *f; + g1 = *g; +/* Computing MAX */ + d__1 = abs(f1), d__2 = abs(g1); + scale = std::max(d__1,d__2); + if (scale >= safmx2) { + count = 0; +L10: + ++count; + f1 *= safmn2; + g1 *= safmn2; +/* Computing MAX */ + d__1 = abs(f1), d__2 = abs(g1); + scale = std::max(d__1,d__2); + if (scale >= safmx2) { + goto L10; + } +/* Computing 2nd power */ + d__1 = f1; +/* Computing 2nd power */ + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmx2; +/* L20: */ + } + } else if (scale <= safmn2) { + count = 0; +L30: + ++count; + f1 *= safmx2; + g1 *= safmx2; +/* Computing MAX */ + d__1 = abs(f1), d__2 = abs(g1); + scale = std::max(d__1,d__2); + if (scale <= safmn2) { + goto L30; + } +/* Computing 2nd power */ + d__1 = f1; +/* Computing 2nd power */ + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmn2; +/* L40: */ + } + } else { +/* Computing 2nd power */ + d__1 = f1; +/* Computing 2nd power */ + d__2 = g1; + *r__ = sqrt(d__1 * d__1 + d__2 * d__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + } + if (abs(*f) > abs(*g) && *cs < 0.) { + *cs = -(*cs); + *sn = -(*sn); + *r__ = -(*r__); + } + } + return 0; + +/* End of DLARTG */ + +} /* dlartg_ */ + +/* Subroutine */ int dlartv_(integer *n, double *x, integer *incx, + double *y, integer *incy, double *c__, double *s, integer + *incc) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, ic, ix, iy; + double xi, yi; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARTV applies a vector of real plane rotations to elements of the */ +/* real vectors x and y. For i = 1,2,...,n */ + +/* ( x(i) ) := ( c(i) s(i) ) ( x(i) ) */ +/* ( y(i) ) ( -s(i) c(i) ) ( y(i) ) */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of plane rotations to be applied. */ + +/* X (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCX) */ +/* The vector x. */ + +/* INCX (input) INTEGER */ +/* The increment between elements of X. INCX > 0. */ + +/* Y (input/output) DOUBLE PRECISION array, */ +/* dimension (1+(N-1)*INCY) */ +/* The vector y. */ + +/* INCY (input) INTEGER */ +/* The increment between elements of Y. INCY > 0. */ + +/* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ +/* The cosines of the plane rotations. */ + +/* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ +/* The sines of the plane rotations. */ + +/* INCC (input) INTEGER */ +/* The increment between elements of C and S. INCC > 0. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --s; + --c__; + --y; + --x; + + /* Function Body */ + ix = 1; + iy = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + xi = x[ix]; + yi = y[iy]; + x[ix] = c__[ic] * xi + s[ic] * yi; + y[iy] = c__[ic] * yi - s[ic] * xi; + ix += *incx; + iy += *incy; + ic += *incc; +/* L10: */ + } + return 0; + +/* End of DLARTV */ + +} /* dlartv_ */ + +/* Subroutine */ int dlaruv_(integer *iseed, integer *n, double *x) +{ + /* Initialized data */ + static integer mm[512] /* was [128][4] */ = { 494,2637,255,2008,1253, + 3344,4084,1739,3143,3468,688,1657,1238,3166,1292,3422,1270,2016, + 154,2862,697,1706,491,931,1444,444,3577,3944,2184,1661,3482,657, + 3023,3618,1267,1828,164,3798,3087,2400,2870,3876,1905,1593,1797, + 1234,3460,328,2861,1950,617,2070,3331,769,1558,2412,2800,189,287, + 2045,1227,2838,209,2770,3654,3993,192,2253,3491,2889,2857,2094, + 1818,688,1407,634,3231,815,3524,1914,516,164,303,2144,3480,119, + 3357,837,2826,2332,2089,3780,1700,3712,150,2000,3375,1621,3090, + 3765,1149,3146,33,3082,2741,359,3316,1749,185,2784,2202,2199,1364, + 1244,2020,3160,2785,2772,1217,1822,1245,2252,3904,2774,997,2573, + 1148,545,322,789,1440,752,2859,123,1848,643,2405,2638,2344,46, + 3814,913,3649,339,3808,822,2832,3078,3633,2970,637,2249,2081,4019, + 1478,242,481,2075,4058,622,3376,812,234,641,4005,1122,3135,2640, + 2302,40,1832,2247,2034,2637,1287,1691,496,1597,2394,2584,1843,336, + 1472,2407,433,2096,1761,2810,566,442,41,1238,1086,603,840,3168, + 1499,1084,3438,2408,1589,2391,288,26,512,1456,171,1677,2657,2270, + 2587,2961,1970,1817,676,1410,3723,2803,3185,184,663,499,3784,1631, + 1925,3912,1398,1349,1441,2224,2411,1907,3192,2786,382,37,759,2948, + 1862,3802,2423,2051,2295,1332,1832,2405,3638,3661,327,3660,716, + 1842,3987,1368,1848,2366,2508,3754,1766,3572,2893,307,1297,3966, + 758,2598,3406,2922,1038,2934,2091,2451,1580,1958,2055,1507,1078, + 3273,17,854,2916,3971,2889,3831,2621,1541,893,736,3992,787,2125, + 2364,2460,257,1574,3912,1216,3248,3401,2124,2762,149,2245,166,466, + 4018,1399,190,2879,153,2320,18,712,2159,2318,2091,3443,1510,449, + 1956,2201,3137,3399,1321,2271,3667,2703,629,2365,2431,1113,3922, + 2554,184,2099,3228,4012,1921,3452,3901,572,3309,3171,817,3039, + 1696,1256,3715,2077,3019,1497,1101,717,51,981,1978,1813,3881,76, + 3846,3694,1682,124,1660,3997,479,1141,886,3514,1301,3604,1888, + 1836,1990,2058,692,1194,20,3285,2046,2107,3508,3525,3801,2549, + 1145,2253,305,3301,1065,3133,2913,3285,1241,1197,3729,2501,1673, + 541,2753,949,2361,1165,4081,2725,3305,3069,3617,3733,409,2157, + 1361,3973,1865,2525,1409,3445,3577,77,3761,2149,1449,3005,225,85, + 3673,3117,3089,1349,2057,413,65,1845,697,3085,3441,1573,3689,2941, + 929,533,2841,4077,721,2821,2249,2397,2817,245,1913,1997,3121,997, + 1833,2877,1633,981,2009,941,2449,197,2441,285,1473,2741,3129,909, + 2801,421,4073,2813,2337,1429,1177,1901,81,1669,2633,2269,129,1141, + 249,3917,2481,3941,2217,2749,3041,1877,345,2861,1809,3141,2825, + 157,2881,3637,1465,2829,2161,3365,361,2685,3745,2325,3609,3821, + 3537,517,3017,2141,1537 }; + + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, i1, i2, i3, i4, it1, it2, it3, it4; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARUV returns a vector of n random real numbers from a uniform (0,1) */ +/* distribution (n <= 128). */ + +/* This is an auxiliary routine called by DLARNV and ZLARNV. */ + +/* Arguments */ +/* ========= */ + +/* ISEED (input/output) INTEGER array, dimension (4) */ +/* On entry, the seed of the random number generator; the array */ +/* elements must be between 0 and 4095, and ISEED(4) must be */ +/* odd. */ +/* On exit, the seed is updated. */ + +/* N (input) INTEGER */ +/* The number of random numbers to be generated. N <= 128. */ + +/* X (output) DOUBLE PRECISION array, dimension (N) */ +/* The generated random numbers. */ + +/* Further Details */ +/* =============== */ + +/* This routine uses a multiplicative congruential method with modulus */ +/* 2**48 and multiplier 33952834046453 (see G.S.Fishman, */ +/* 'Multiplicative congruential random number generators with modulus */ +/* 2**b: an exhaustive analysis for b = 32 and a partial analysis for */ +/* b = 48', Math. Comp. 189, pp 331-344, 1990). */ + +/* 48-bit integers are stored in 4 integer array elements with 12 bits */ +/* per element. Hence the routine is portable across machines with */ +/* integers of 32 bits or more. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + --iseed; + --x; + + /* Function Body */ +/* .. */ +/* .. Executable Statements .. */ + + i1 = iseed[1]; + i2 = iseed[2]; + i3 = iseed[3]; + i4 = iseed[4]; + + i__1 = std::min(*n,128_integer); + for (i__ = 1; i__ <= i__1; ++i__) { + +L20: + +/* Multiply the seed by i-th power of the multiplier modulo 2**48 */ + + it4 = i4 * mm[i__ + 383]; + it3 = it4 / 4096; + it4 -= it3 << 12; + it3 = it3 + i3 * mm[i__ + 383] + i4 * mm[i__ + 255]; + it2 = it3 / 4096; + it3 -= it2 << 12; + it2 = it2 + i2 * mm[i__ + 383] + i3 * mm[i__ + 255] + i4 * mm[i__ + + 127]; + it1 = it2 / 4096; + it2 -= it1 << 12; + it1 = it1 + i1 * mm[i__ + 383] + i2 * mm[i__ + 255] + i3 * mm[i__ + + 127] + i4 * mm[i__ - 1]; + it1 %= 4096; + +/* Convert 48-bit integer to a real number in the interval (0,1) */ + + x[i__] = ((double) it1 + ((double) it2 + ((double) it3 + ( + double) it4 * 2.44140625e-4) * 2.44140625e-4) * + 2.44140625e-4) * 2.44140625e-4; + + if (x[i__] == 1.) { +/* If a real number has n bits of precision, and the first */ +/* n bits of the 48-bit integer above happen to be all 1 (which */ +/* will occur about once every 2**n calls), then X( I ) will */ +/* be rounded to exactly 1.0. */ +/* Since X( I ) is not supposed to return exactly 0.0 or 1.0, */ +/* the statistically correct thing to do in this situation is */ +/* simply to iterate again. */ +/* N.B. the case X( I ) = 0.0 should not be possible. */ + i1 += 2; + i2 += 2; + i3 += 2; + i4 += 2; + goto L20; + } + +/* L10: */ + } + +/* Return final value of seed */ + + iseed[1] = it1; + iseed[2] = it2; + iseed[3] = it3; + iseed[4] = it4; + return 0; + +/* End of DLARUV */ + +} /* dlaruv_ */ + +/* Subroutine */ int dlarz_(const char *side, integer *m, integer *n, integer *l, + double *v, integer *incv, double *tau, double *c__, + integer *ldc, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b5 = 1.; + + /* System generated locals */ + integer c_dim1, c_offset; + double d__1; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARZ 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. */ + + +/* H is a product of k elementary reflectors as returned by DTZRZF. */ + +/* 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. */ + +/* L (input) INTEGER */ +/* The number of entries of the vector V containing */ +/* the meaningful part of the Householder vectors. */ +/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ + +/* V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV)) */ +/* The vector v in the representation of H as returned by */ +/* DTZRZF. 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' */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + if (lsame_(side, "L")) { + +/* Form H * C */ + + if (*tau != 0.) { + +/* w( 1:n ) = C( 1, 1:n ) */ + + dcopy_(n, &c__[c_offset], ldc, &work[1], &c__1); + +/* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) */ + + dgemv_("Transpose", l, n, &c_b5, &c__[*m - *l + 1 + c_dim1], ldc, + &v[1], incv, &c_b5, &work[1], &c__1); + +/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */ + + d__1 = -(*tau); + daxpy_(n, &d__1, &work[1], &c__1, &c__[c_offset], ldc); + +/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */ +/* tau * v( 1:l ) * w( 1:n )' */ + + d__1 = -(*tau); + dger_(l, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l + 1 + + c_dim1], ldc); + } + + } else { + +/* Form C * H */ + + if (*tau != 0.) { + +/* w( 1:m ) = C( 1:m, 1 ) */ + + dcopy_(m, &c__[c_offset], &c__1, &work[1], &c__1); + +/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */ + + dgemv_("No transpose", m, l, &c_b5, &c__[(*n - *l + 1) * c_dim1 + + 1], ldc, &v[1], incv, &c_b5, &work[1], &c__1); + +/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */ + + d__1 = -(*tau); + daxpy_(m, &d__1, &work[1], &c__1, &c__[c_offset], &c__1); + +/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */ +/* tau * w( 1:m ) * v( 1:l )' */ + + d__1 = -(*tau); + dger_(m, l, &d__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l + + 1) * c_dim1 + 1], ldc); + + } + + } + + return 0; + +/* End of DLARZ */ + +} /* dlarz_ */ + +/* Subroutine */ int dlarzb_(const char *side, const char *trans, const char *direct, const char * + storev, integer *m, integer *n, integer *k, integer *l, double *v, + integer *ldv, double *t, integer *ldt, double *c__, integer * + ldc, double *work, integer *ldwork) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b13 = 1.; + static double c_b23 = -1.; + + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, info; + char transt[1]; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARZB applies a real block reflector H or its transpose H**T to */ +/* a real distributed M-by-N C from the left or the right. */ + +/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */ + +/* 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) */ +/* = 'C': 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, not supported yet) */ +/* = '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 (not supported yet) */ +/* = '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). */ + +/* L (input) INTEGER */ +/* The number of columns of the matrix V containing the */ +/* meaningful part of the Householder reflectors. */ +/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ + +/* V (input) DOUBLE PRECISION array, dimension (LDV,NV). */ +/* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */ + +/* LDV (input) INTEGER */ +/* The leading dimension of the array V. */ +/* If STOREV = 'C', LDV >= L; 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. LDC >= 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). */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + +/* Check for currently supported options */ + + info = 0; + if (! lsame_(direct, "B")) { + info = -3; + } else if (! lsame_(storev, "R")) { + info = -4; + } + if (info != 0) { + i__1 = -info; + xerbla_("DLARZB", &i__1); + return 0; + } + + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + + if (lsame_(side, "L")) { + +/* Form H * C or H' * C */ + +/* W( 1:n, 1:k ) = C( 1:k, 1:n )' */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); +/* L10: */ + } + +/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */ +/* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )' */ + + if (*l > 0) { + dgemm_("Transpose", "Transpose", n, k, l, &c_b13, &c__[*m - *l + + 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b13, &work[ + work_offset], ldwork); + } + +/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T */ + + dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b13, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )' */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[j + i__ * work_dim1]; +/* L20: */ + } +/* L30: */ + } + +/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */ +/* V( 1:k, 1:l )' * W( 1:n, 1:k )' */ + + if (*l > 0) { + dgemm_("Transpose", "Transpose", l, n, k, &c_b23, &v[v_offset], + ldv, &work[work_offset], ldwork, &c_b13, &c__[*m - *l + 1 + + c_dim1], ldc); + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H' */ + +/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], & + c__1); +/* L40: */ + } + +/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */ +/* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )' */ + + if (*l > 0) { + dgemm_("No transpose", "Transpose", m, k, l, &c_b13, &c__[(*n - * + l + 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b13, & + work[work_offset], ldwork); + } + +/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T' */ + + dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b13, &t[t_offset] +, ldt, &work[work_offset], ldwork); + +/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; +/* L50: */ + } +/* L60: */ + } + +/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */ +/* W( 1:m, 1:k ) * V( 1:k, 1:l ) */ + + if (*l > 0) { + dgemm_("No transpose", "No transpose", m, l, k, &c_b23, &work[ + work_offset], ldwork, &v[v_offset], ldv, &c_b13, &c__[(*n + - *l + 1) * c_dim1 + 1], ldc); + } + + } + + return 0; + +/* End of DLARZB */ + +} /* dlarzb_ */ + +/* Subroutine */ int dlarzt_(const char *direct, const char *storev, integer *n, integer * + k, double *v, integer *ldv, double *tau, double *t, + integer *ldt) +{ + /* Table of constant values */ + static double c_b8 = 0.; + static integer c__1 = 1; + + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1; + double d__1; + + /* Local variables */ + integer i__, j, info; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLARZT 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 */ + +/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */ + +/* 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, not supported yet) */ +/* = '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 (not supported yet) */ +/* = '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 */ +/* =============== */ + +/* Based on contributions by */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* 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_____ */ +/* ( v1 v2 v3 ) / \ */ +/* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */ +/* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */ +/* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */ +/* ( v1 v2 v3 ) */ +/* . . . */ +/* . . . */ +/* 1 . . */ +/* 1 . */ +/* 1 */ + +/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ + +/* ______V_____ */ +/* 1 / \ */ +/* . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */ +/* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */ +/* . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */ +/* . . . */ +/* ( v1 v2 v3 ) */ +/* ( v1 v2 v3 ) */ +/* V = ( v1 v2 v3 ) */ +/* ( v1 v2 v3 ) */ +/* ( v1 v2 v3 ) */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Check for currently supported options */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + + /* Function Body */ + info = 0; + if (! lsame_(direct, "B")) { + info = -1; + } else if (! lsame_(storev, "R")) { + info = -2; + } + if (info != 0) { + i__1 = -info; + xerbla_("DLARZT", &i__1); + return 0; + } + + for (i__ = *k; i__ >= 1; --i__) { + if (tau[i__] == 0.) { + +/* H(i) = I */ + + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + t[j + i__ * t_dim1] = 0.; +/* L10: */ + } + } else { + +/* general case */ + + if (i__ < *k) { + +/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' */ + + i__1 = *k - i__; + d__1 = -tau[i__]; + dgemv_("No transpose", &i__1, n, &d__1, &v[i__ + 1 + v_dim1], + ldv, &v[i__ + v_dim1], ldv, &c_b8, &t[i__ + 1 + i__ * + t_dim1], &c__1); + +/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */ + + i__1 = *k - i__; + dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1] +, &c__1); + } + t[i__ + i__ * t_dim1] = tau[i__]; + } +/* L20: */ + } + return 0; + +/* End of DLARZT */ + +} /* dlarzt_ */ + +/* Subroutine */ int dlas2_(double *f, double *g, double *h__, + double *ssmin, double *ssmax) +{ + /* System generated locals */ + double d__1, d__2; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + double c__, fa, ga, ha, as, at, au, fhmn, fhmx; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAS2 computes the singular values of the 2-by-2 matrix */ +/* [ F G ] */ +/* [ 0 H ]. */ +/* On return, SSMIN is the smaller singular value and SSMAX is the */ +/* larger singular value. */ + +/* Arguments */ +/* ========= */ + +/* F (input) DOUBLE PRECISION */ +/* The (1,1) element of the 2-by-2 matrix. */ + +/* G (input) DOUBLE PRECISION */ +/* The (1,2) element of the 2-by-2 matrix. */ + +/* H (input) DOUBLE PRECISION */ +/* The (2,2) element of the 2-by-2 matrix. */ + +/* SSMIN (output) DOUBLE PRECISION */ +/* The smaller singular value. */ + +/* SSMAX (output) DOUBLE PRECISION */ +/* The larger singular value. */ + +/* Further Details */ +/* =============== */ + +/* Barring over/underflow, all output quantities are correct to within */ +/* a few units in the last place (ulps), even in the absence of a guard */ +/* digit in addition/subtraction. */ + +/* In IEEE arithmetic, the code works correctly if one matrix element is */ +/* infinite. */ + +/* Overflow will not occur unless the largest singular value itself */ +/* overflows, or is within a few ulps of overflow. (On machines with */ +/* partial overflow, like the Cray, overflow may occur if the largest */ +/* singular value is within a factor of 2 of overflow.) */ + +/* Underflow is harmless if underflow is gradual. Otherwise, results */ +/* may correspond to a matrix modified by perturbations of size near */ +/* the underflow threshold. */ + +/* ==================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + fa = abs(*f); + ga = abs(*g); + ha = abs(*h__); + fhmn = std::min(fa,ha); + fhmx = std::max(fa,ha); + if (fhmn == 0.) { + *ssmin = 0.; + if (fhmx == 0.) { + *ssmax = ga; + } else { +/* Computing 2nd power */ + d__1 = std::min(fhmx,ga) / std::max(fhmx,ga); + *ssmax = std::max(fhmx,ga) * sqrt(d__1 * d__1 + 1.); + } + } else { + if (ga < fhmx) { + as = fhmn / fhmx + 1.; + at = (fhmx - fhmn) / fhmx; +/* Computing 2nd power */ + d__1 = ga / fhmx; + au = d__1 * d__1; + c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au)); + *ssmin = fhmn * c__; + *ssmax = fhmx / c__; + } else { + au = fhmx / ga; + if (au == 0.) { + +/* Avoid possible harmful underflow if exponent range */ +/* asymmetric (true SSMIN may not underflow even if */ +/* AU underflows) */ + + *ssmin = fhmn * fhmx / ga; + *ssmax = ga; + } else { + as = fhmn / fhmx + 1.; + at = (fhmx - fhmn) / fhmx; +/* Computing 2nd power */ + d__1 = as * au; +/* Computing 2nd power */ + d__2 = at * au; + c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.)); + *ssmin = fhmn * c__ * au; + *ssmin += *ssmin; + *ssmax = ga / (c__ + c__); + } + } + } + return 0; + +/* End of DLAS2 */ + +} /* dlas2_ */ + +/* Subroutine */ int dlascl_(const char *type__, integer *kl, integer *ku, double *cfrom, double *cto, + integer *m, integer *n, double *a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, j, k1, k2, k3, k4; + double mul, cto1; + bool done; + double ctoc; + integer itype; + double cfrom1; + double cfromc; + double bignum, smlnum; + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASCL multiplies the M by N real matrix A by the real scalar */ +/* CTO/CFROM. This is done without over/underflow as long as the final */ +/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */ +/* A may be full, upper triangular, lower triangular, upper Hessenberg, */ +/* or banded. */ + +/* Arguments */ +/* ========= */ + +/* TYPE (input) CHARACTER*1 */ +/* TYPE indices the storage type of the input matrix. */ +/* = 'G': A is a full matrix. */ +/* = 'L': A is a lower triangular matrix. */ +/* = 'U': A is an upper triangular matrix. */ +/* = 'H': A is an upper Hessenberg matrix. */ +/* = 'B': A is a symmetric band matrix with lower bandwidth KL */ +/* and upper bandwidth KU and with the only the lower */ +/* half stored. */ +/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */ +/* and upper bandwidth KU and with the only the upper */ +/* half stored. */ +/* = 'Z': A is a band matrix with lower bandwidth KL and upper */ +/* bandwidth KU. */ + +/* KL (input) INTEGER */ +/* The lower bandwidth of A. Referenced only if TYPE = 'B', */ +/* 'Q' or 'Z'. */ + +/* KU (input) INTEGER */ +/* The upper bandwidth of A. Referenced only if TYPE = 'B', */ +/* 'Q' or 'Z'. */ + +/* CFROM (input) DOUBLE PRECISION */ +/* CTO (input) DOUBLE PRECISION */ +/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */ +/* without over/underflow if the final result CTO*A(I,J)/CFROM */ +/* can be represented without over/underflow. CFROM must be */ +/* nonzero. */ + +/* 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) */ +/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */ +/* storage type. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* INFO (output) INTEGER */ +/* 0 - successful exit */ +/* <0 - if INFO = -i, the i-th argument had an illegal value. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + + if (lsame_(type__, "G")) { + itype = 0; + } else if (lsame_(type__, "L")) { + itype = 1; + } else if (lsame_(type__, "U")) { + itype = 2; + } else if (lsame_(type__, "H")) { + itype = 3; + } else if (lsame_(type__, "B")) { + itype = 4; + } else if (lsame_(type__, "Q")) { + itype = 5; + } else if (lsame_(type__, "Z")) { + itype = 6; + } else { + itype = -1; + } + + if (itype == -1) { + *info = -1; + } else if (*cfrom == 0. || disnan_(cfrom)) { + *info = -4; + } else if (disnan_(cto)) { + *info = -5; + } else if (*m < 0) { + *info = -6; + } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { + *info = -7; + } else if (itype <= 3 && *lda < std::max(1_integer,*m)) { + *info = -9; + } else if (itype >= 4) { +/* Computing MAX */ + i__1 = *m - 1; + if (*kl < 0 || *kl > std::max(i__1,0_integer)) { + *info = -2; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = *n - 1; + if (*ku < 0 || *ku > std::max(i__1,0_integer) || (itype == 4 || itype == 5) && + *kl != *ku) { + *info = -3; + } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * + ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { + *info = -9; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASCL", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + + cfromc = *cfrom; + ctoc = *cto; + +L10: + cfrom1 = cfromc * smlnum; + if (cfrom1 == cfromc) { +/* CFROMC is an inf. Multiply by a correctly signed zero for */ +/* finite CTOC, or a NaN if CTOC is infinite. */ + mul = ctoc / cfromc; + done = true; + cto1 = ctoc; + } else { + cto1 = ctoc / bignum; + if (cto1 == ctoc) { +/* CTOC is either 0 or an inf. In both cases, CTOC itself */ +/* serves as the correct multiplication factor. */ + mul = ctoc; + done = true; + cfromc = 1.; + } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { + mul = smlnum; + done = false; + cfromc = cfrom1; + } else if (abs(cto1) > abs(cfromc)) { + mul = bignum; + done = false; + ctoc = cto1; + } else { + mul = ctoc / cfromc; + done = true; + } + } + + if (itype == 0) { + +/* Full matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L20: */ + } +/* L30: */ + } + + } else if (itype == 1) { + +/* Lower triangular matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L40: */ + } +/* L50: */ + } + + } else if (itype == 2) { + +/* Upper triangular matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = std::min(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L60: */ + } +/* L70: */ + } + + } else if (itype == 3) { + +/* Upper Hessenberg matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = j + 1; + i__2 = std::min(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L80: */ + } +/* L90: */ + } + + } else if (itype == 4) { + +/* Lower half of a symmetric band matrix */ + + k3 = *kl + 1; + k4 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = k3, i__4 = k4 - j; + i__2 = std::min(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L100: */ + } +/* L110: */ + } + + } else if (itype == 5) { + +/* Upper half of a symmetric band matrix */ + + k1 = *ku + 2; + k3 = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = k1 - j; + i__3 = k3; + for (i__ = std::max(i__2,1_integer); i__ <= i__3; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L120: */ + } +/* L130: */ + } + + } else if (itype == 6) { + +/* Band matrix */ + + k1 = *kl + *ku + 2; + k2 = *kl + 1; + k3 = (*kl << 1) + *ku + 1; + k4 = *kl + *ku + 1 + *m; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = k1 - j; +/* Computing MIN */ + i__4 = k3, i__5 = k4 - j; + i__2 = std::min(i__4,i__5); + for (i__ = std::max(i__3,k2); i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L140: */ + } +/* L150: */ + } + + } + + if (! done) { + goto L10; + } + + return 0; + +/* End of DLASCL */ + +} /* dlascl_ */ + +int dlascl2_(integer *m, integer *n, double *d__, double *x, integer *ldx) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASCL2 performs a diagonal scaling on a vector: */ +/* x <-- D * x */ +/* where the diagonal matrix D is stored as a vector. */ + +/* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS */ +/* standard. */ + +/* Arguments */ +/* ========= */ + +/* M (input) INTEGER */ +/* The number of rows of D and X. M >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of D and X. N >= 0. */ + +/* D (input) DOUBLE PRECISION array, length M */ +/* Diagonal matrix D, stored as a vector of length M. */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */ +/* On entry, the vector X to be scaled by D. */ +/* On exit, the scaled vector. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the vector X. LDX >= 0. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --d__; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + + /* Function Body */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] *= d__[i__]; + } + } + return 0; +} /* dlascl2_ */ + +/* Subroutine */ int dlasd0_(integer *n, integer *sqre, double *d__, + double *e, double *u, integer *ldu, double *vt, integer * + ldvt, integer *smlsiz, integer *iwork, double *work, integer * + info) +{ + /* Table of constant values */ + static integer c__0 = 0; + static integer c__2 = 2; + + /* System generated locals */ + integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, m, i1, ic, lf, nd, ll, nl, nr, im1, ncc, nlf, nrf, iwk, + lvl, ndb1, nlp1, nrp1; + double beta; + integer idxq, nlvl; + double alpha; + integer inode, ndiml, idxqc, ndimr, itemp, sqrei; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Using a divide and conquer approach, DLASD0 computes the singular */ +/* value decomposition (SVD) of a real upper bidiagonal N-by-M */ +/* matrix B with diagonal D and offdiagonal E, where M = N + SQRE. */ +/* The algorithm computes orthogonal matrices U and VT such that */ +/* B = U * S * VT. The singular values S are overwritten on D. */ + +/* A related subroutine, DLASDA, computes only the singular values, */ +/* and optionally, the singular vectors in compact form. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* On entry, the row dimension of the upper bidiagonal matrix. */ +/* This is also the dimension of the main diagonal array D. */ + +/* SQRE (input) INTEGER */ +/* Specifies the column dimension of the bidiagonal matrix. */ +/* = 0: The bidiagonal matrix has column dimension M = N; */ +/* = 1: The bidiagonal matrix has column dimension M = N+1; */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry D contains the main diagonal of the bidiagonal */ +/* matrix. */ +/* On exit D, if INFO = 0, contains its singular values. */ + +/* E (input) DOUBLE PRECISION array, dimension (M-1) */ +/* Contains the subdiagonal entries of the bidiagonal matrix. */ +/* On exit, E has been destroyed. */ + +/* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N) */ +/* On exit, U contains the left singular vectors. */ + +/* LDU (input) INTEGER */ +/* On entry, leading dimension of U. */ + +/* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M) */ +/* On exit, VT' contains the right singular vectors. */ + +/* LDVT (input) INTEGER */ +/* On entry, leading dimension of VT. */ + +/* SMLSIZ (input) INTEGER */ +/* On entry, maximum size of the subproblems at the */ +/* bottom of the computation tree. */ + +/* IWORK (workspace) INTEGER work array. */ +/* Dimension must be at least (8 * N) */ + +/* WORK (workspace) DOUBLE PRECISION work array. */ +/* Dimension must be at least (3 * M**2 + 2 * M) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an singular value did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + --iwork; + --work; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -1; + } else if (*sqre < 0 || *sqre > 1) { + *info = -2; + } + + m = *n + *sqre; + + if (*ldu < *n) { + *info = -6; + } else if (*ldvt < m) { + *info = -8; + } else if (*smlsiz < 3) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASD0", &i__1); + return 0; + } + +/* If the input matrix is too small, call DLASDQ to find the SVD. */ + + if (*n <= *smlsiz) { + dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset], + ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], info); + return 0; + } + +/* Set up the computation tree. */ + + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + idxq = ndimr + *n; + iwk = idxq + *n; + dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); + +/* For the nodes on bottom level of the tree, solve */ +/* their subproblems by DLASDQ. */ + + ndb1 = (nd + 1) / 2; + ncc = 0; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + +/* IC : center row of each node */ +/* NL : number of rows of left subproblem */ +/* NR : number of rows of right subproblem */ +/* NLF: starting row of the left subproblem */ +/* NRF: starting row of the right subproblem */ + + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nlp1 = nl + 1; + nr = iwork[ndimr + i1]; + nrp1 = nr + 1; + nlf = ic - nl; + nrf = ic + 1; + sqrei = 1; + dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[ + nlf + nlf * vt_dim1], ldvt, &u[nlf + nlf * u_dim1], ldu, &u[ + nlf + nlf * u_dim1], ldu, &work[1], info); + if (*info != 0) { + return 0; + } + itemp = idxq + nlf - 2; + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + iwork[itemp + j] = j; +/* L10: */ + } + if (i__ == nd) { + sqrei = *sqre; + } else { + sqrei = 1; + } + nrp1 = nr + sqrei; + dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[ + nrf + nrf * vt_dim1], ldvt, &u[nrf + nrf * u_dim1], ldu, &u[ + nrf + nrf * u_dim1], ldu, &work[1], info); + if (*info != 0) { + return 0; + } + itemp = idxq + ic; + i__2 = nr; + for (j = 1; j <= i__2; ++j) { + iwork[itemp + j - 1] = j; +/* L20: */ + } +/* L30: */ + } + +/* Now conquer each subproblem bottom-up. */ + + for (lvl = nlvl; lvl >= 1; --lvl) { + +/* Find the first node LF and last node LL on the */ +/* current level LVL. */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + if (*sqre == 0 && i__ == ll) { + sqrei = *sqre; + } else { + sqrei = 1; + } + idxqc = idxq + nlf - 1; + alpha = d__[ic]; + beta = e[ic]; + dlasd1_(&nl, &nr, &sqrei, &d__[nlf], &alpha, &beta, &u[nlf + nlf * + u_dim1], ldu, &vt[nlf + nlf * vt_dim1], ldvt, &iwork[ + idxqc], &iwork[iwk], &work[1], info); + if (*info != 0) { + return 0; + } +/* L40: */ + } +/* L50: */ + } + + return 0; + +/* End of DLASD0 */ + +} /* dlasd0_ */ + +/* Subroutine */ int dlasd1_(integer *nl, integer *nr, integer *sqre, + double *d__, double *alpha, double *beta, double *u, + integer *ldu, double *vt, integer *ldvt, integer *idxq, integer * + iwork, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__0 = 0; + static double c_b7 = 1.; + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer u_dim1, u_offset, vt_dim1, vt_offset, i__1; + double d__1, d__2; + + /* Local variables */ + integer i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc, + idxp, ldvt2; + integer isigma; + double orgnrm; + integer coltyp; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, */ +/* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. */ + +/* A related subroutine DLASD7 handles the case in which the singular */ +/* values (and the singular vectors in factored form) are desired. */ + +/* DLASD1 computes the SVD as follows: */ + +/* ( D1(in) 0 0 0 ) */ +/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */ +/* ( 0 0 D2(in) 0 ) */ + +/* = U(out) * ( D(out) 0) * VT(out) */ + +/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */ +/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */ +/* elsewhere; and the entry b is empty if SQRE = 0. */ + +/* The left singular vectors of the original matrix are stored in U, and */ +/* the transpose of the right singular vectors are stored in VT, and the */ +/* singular values are in D. The algorithm consists of three stages: */ + +/* The first stage consists of deflating the size of the problem */ +/* when there are multiple singular values or when there are zeros in */ +/* the Z vector. For each such occurence the dimension of the */ +/* secular equation problem is reduced by one. This stage is */ +/* performed by the routine DLASD2. */ + +/* The second stage consists of calculating the updated */ +/* singular values. This is done by finding the square roots of the */ +/* roots of the secular equation via the routine DLASD4 (as called */ +/* by DLASD3). This routine also calculates the singular vectors of */ +/* the current problem. */ + +/* The final stage consists of computing the updated singular vectors */ +/* directly using the updated singular values. The singular vectors */ +/* for the current problem are multiplied with the singular vectors */ +/* from the overall problem. */ + +/* Arguments */ +/* ========= */ + +/* NL (input) INTEGER */ +/* The row dimension of the upper block. NL >= 1. */ + +/* NR (input) INTEGER */ +/* The row dimension of the lower block. NR >= 1. */ + +/* SQRE (input) INTEGER */ +/* = 0: the lower block is an NR-by-NR square matrix. */ +/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ + +/* The bidiagonal matrix has row dimension N = NL + NR + 1, */ +/* and column dimension M = N + SQRE. */ + +/* D (input/output) DOUBLE PRECISION array, */ +/* dimension (N = NL+NR+1). */ +/* On entry D(1:NL,1:NL) contains the singular values of the */ +/* upper block; and D(NL+2:N) contains the singular values of */ +/* the lower block. On exit D(1:N) contains the singular values */ +/* of the modified matrix. */ + +/* ALPHA (input/output) DOUBLE PRECISION */ +/* Contains the diagonal element associated with the added row. */ + +/* BETA (input/output) DOUBLE PRECISION */ +/* Contains the off-diagonal element associated with the added */ +/* row. */ + +/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */ +/* On entry U(1:NL, 1:NL) contains the left singular vectors of */ +/* the upper block; U(NL+2:N, NL+2:N) contains the left singular */ +/* vectors of the lower block. On exit U contains the left */ +/* singular vectors of the bidiagonal matrix. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= max( 1, N ). */ + +/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */ +/* where M = N + SQRE. */ +/* On entry VT(1:NL+1, 1:NL+1)' contains the right singular */ +/* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains */ +/* the right singular vectors of the lower block. On exit */ +/* VT' contains the right singular vectors of the */ +/* bidiagonal matrix. */ + +/* LDVT (input) INTEGER */ +/* The leading dimension of the array VT. LDVT >= max( 1, M ). */ + +/* IDXQ (output) INTEGER array, dimension(N) */ +/* This contains the permutation which will reintegrate the */ +/* subproblem just solved back into sorted order, i.e. */ +/* D( IDXQ( I = 1, N ) ) will be in ascending order. */ + +/* IWORK (workspace) INTEGER array, dimension( 4 * N ) */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an singular value did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ + +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + --idxq; + --iwork; + --work; + + /* Function Body */ + *info = 0; + + if (*nl < 1) { + *info = -1; + } else if (*nr < 1) { + *info = -2; + } else if (*sqre < 0 || *sqre > 1) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASD1", &i__1); + return 0; + } + + n = *nl + *nr + 1; + m = n + *sqre; + +/* The following values are for bookkeeping purposes only. They are */ +/* integer pointers which indicate the portion of the workspace */ +/* used by a particular array in DLASD2 and DLASD3. */ + + ldu2 = n; + ldvt2 = m; + + iz = 1; + isigma = iz + m; + iu2 = isigma + n; + ivt2 = iu2 + ldu2 * n; + iq = ivt2 + ldvt2 * m; + + idx = 1; + idxc = idx + n; + coltyp = idxc + n; + idxp = coltyp + n; + +/* Scale. */ + +/* Computing MAX */ + d__1 = abs(*alpha), d__2 = abs(*beta); + orgnrm = std::max(d__1,d__2); + d__[*nl + 1] = 0.; + i__1 = n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) > orgnrm) { + orgnrm = (d__1 = d__[i__], abs(d__1)); + } +/* L10: */ + } + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info); + *alpha /= orgnrm; + *beta /= orgnrm; + +/* Deflate singular values. */ + + dlasd2_(nl, nr, sqre, &k, &d__[1], &work[iz], alpha, beta, &u[u_offset], + ldu, &vt[vt_offset], ldvt, &work[isigma], &work[iu2], &ldu2, & + work[ivt2], &ldvt2, &iwork[idxp], &iwork[idx], &iwork[idxc], & + idxq[1], &iwork[coltyp], info); + +/* Solve Secular Equation and update singular vectors. */ + + ldq = k; + dlasd3_(nl, nr, sqre, &k, &d__[1], &work[iq], &ldq, &work[isigma], &u[ + u_offset], ldu, &work[iu2], &ldu2, &vt[vt_offset], ldvt, &work[ + ivt2], &ldvt2, &iwork[idxc], &iwork[coltyp], &work[iz], info); + if (*info != 0) { + return 0; + } + +/* Unscale. */ + + dlascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info); + +/* Prepare the IDXQ sorting permutation. */ + + n1 = k; + n2 = n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]); + + return 0; + +/* End of DLASD1 */ + +} /* dlasd1_ */ + +/* Subroutine */ int dlasd2_(integer *nl, integer *nr, integer *sqre, integer + *k, double *d__, double *z__, double *alpha, double * + beta, double *u, integer *ldu, double *vt, integer *ldvt, + double *dsigma, double *u2, integer *ldu2, double *vt2, + integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer * + idxq, integer *coltyp, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b30 = 0.; + + /* System generated locals */ + integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, + vt2_dim1, vt2_offset, i__1; + double d__1, d__2; + + /* Local variables */ + double c__; + integer i__, j, m, n; + double s; + integer k2; + double z1; + integer ct, jp; + double eps, tau, tol; + integer psm[4], nlp1, nlp2, idxi, idxj; + integer ctot[4], idxjp; + integer jprev; + double hlftol; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASD2 merges the two sets of singular values together into a single */ +/* sorted set. Then it tries to deflate the size of the problem. */ +/* There are two ways in which deflation can occur: when two or more */ +/* singular values are close together or if there is a tiny entry in the */ +/* Z vector. For each such occurrence the order of the related secular */ +/* equation problem is reduced by one. */ + +/* DLASD2 is called from DLASD1. */ + +/* Arguments */ +/* ========= */ + +/* NL (input) INTEGER */ +/* The row dimension of the upper block. NL >= 1. */ + +/* NR (input) INTEGER */ +/* The row dimension of the lower block. NR >= 1. */ + +/* SQRE (input) INTEGER */ +/* = 0: the lower block is an NR-by-NR square matrix. */ +/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ + +/* The bidiagonal matrix has N = NL + NR + 1 rows and */ +/* M = N + SQRE >= N columns. */ + +/* K (output) INTEGER */ +/* Contains the dimension of the non-deflated matrix, */ +/* This is the order of the related secular equation. 1 <= K <=N. */ + +/* D (input/output) DOUBLE PRECISION array, dimension(N) */ +/* On entry D contains the singular values of the two submatrices */ +/* to be combined. On exit D contains the trailing (N-K) updated */ +/* singular values (those which were deflated) sorted into */ +/* increasing order. */ + +/* Z (output) DOUBLE PRECISION array, dimension(N) */ +/* On exit Z contains the updating row vector in the secular */ +/* equation. */ + +/* ALPHA (input) DOUBLE PRECISION */ +/* Contains the diagonal element associated with the added row. */ + +/* BETA (input) DOUBLE PRECISION */ +/* Contains the off-diagonal element associated with the added */ +/* row. */ + +/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */ +/* On entry U contains the left singular vectors of two */ +/* submatrices in the two square blocks with corners at (1,1), */ +/* (NL, NL), and (NL+2, NL+2), (N,N). */ +/* On exit U contains the trailing (N-K) updated left singular */ +/* vectors (those which were deflated) in its last N-K columns. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= N. */ + +/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */ +/* On entry VT' contains the right singular vectors of two */ +/* submatrices in the two square blocks with corners at (1,1), */ +/* (NL+1, NL+1), and (NL+2, NL+2), (M,M). */ +/* On exit VT' contains the trailing (N-K) updated right singular */ +/* vectors (those which were deflated) in its last N-K columns. */ +/* In case SQRE =1, the last row of VT spans the right null */ +/* space. */ + +/* LDVT (input) INTEGER */ +/* The leading dimension of the array VT. LDVT >= M. */ + +/* DSIGMA (output) DOUBLE PRECISION array, dimension (N) */ +/* Contains a copy of the diagonal elements (K-1 singular values */ +/* and one zero) in the secular equation. */ + +/* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N) */ +/* Contains a copy of the first K-1 left singular vectors which */ +/* will be used by DLASD3 in a matrix multiply (DGEMM) to solve */ +/* for the new left singular vectors. U2 is arranged into four */ +/* blocks. The first block contains a column with 1 at NL+1 and */ +/* zero everywhere else; the second block contains non-zero */ +/* entries only at and above NL; the third contains non-zero */ +/* entries only below NL+1; and the fourth is dense. */ + +/* LDU2 (input) INTEGER */ +/* The leading dimension of the array U2. LDU2 >= N. */ + +/* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N) */ +/* VT2' contains a copy of the first K right singular vectors */ +/* which will be used by DLASD3 in a matrix multiply (DGEMM) to */ +/* solve for the new right singular vectors. VT2 is arranged into */ +/* three blocks. The first block contains a row that corresponds */ +/* to the special 0 diagonal element in SIGMA; the second block */ +/* contains non-zeros only at and before NL +1; the third block */ +/* contains non-zeros only at and after NL +2. */ + +/* LDVT2 (input) INTEGER */ +/* The leading dimension of the array VT2. LDVT2 >= M. */ + +/* IDXP (workspace) INTEGER array dimension(N) */ +/* This will contain the permutation used to place deflated */ +/* values of D at the end of the array. On output IDXP(2:K) */ +/* points to the nondeflated D-values and IDXP(K+1:N) */ +/* points to the deflated singular values. */ + +/* IDX (workspace) INTEGER array dimension(N) */ +/* This will contain the permutation used to sort the contents of */ +/* D into ascending order. */ + +/* IDXC (output) INTEGER array dimension(N) */ +/* This will contain the permutation used to arrange the columns */ +/* of the deflated U matrix into three groups: the first group */ +/* contains non-zero entries only at and above NL, the second */ +/* contains non-zero entries only below NL+2, and the third is */ +/* dense. */ + +/* IDXQ (input/output) INTEGER array dimension(N) */ +/* This contains the permutation which separately sorts the two */ +/* sub-problems in D into ascending order. Note that entries in */ +/* the first hlaf of this permutation must first be moved one */ +/* position backward; and entries in the second half */ +/* must first have NL+1 added to their values. */ + +/* COLTYP (workspace/output) INTEGER array dimension(N) */ +/* As workspace, this will contain a label which will indicate */ +/* which of the following types a column in the U2 matrix or a */ +/* row in the VT2 matrix is: */ +/* 1 : non-zero in the upper half only */ +/* 2 : non-zero in the lower half only */ +/* 3 : dense */ +/* 4 : deflated */ + +/* On exit, it is an array of dimension 4, with COLTYP(I) being */ +/* the dimension of the I-th type columns. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --z__; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + --dsigma; + u2_dim1 = *ldu2; + u2_offset = 1 + u2_dim1; + u2 -= u2_offset; + vt2_dim1 = *ldvt2; + vt2_offset = 1 + vt2_dim1; + vt2 -= vt2_offset; + --idxp; + --idx; + --idxc; + --idxq; + --coltyp; + + /* Function Body */ + *info = 0; + + if (*nl < 1) { + *info = -1; + } else if (*nr < 1) { + *info = -2; + } else if (*sqre != 1 && *sqre != 0) { + *info = -3; + } + + n = *nl + *nr + 1; + m = n + *sqre; + + if (*ldu < n) { + *info = -10; + } else if (*ldvt < m) { + *info = -12; + } else if (*ldu2 < n) { + *info = -15; + } else if (*ldvt2 < m) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASD2", &i__1); + return 0; + } + + nlp1 = *nl + 1; + nlp2 = *nl + 2; + +/* Generate the first part of the vector Z; and move the singular */ +/* values in the first part of D one position backward. */ + + z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1]; + z__[1] = z1; + for (i__ = *nl; i__ >= 1; --i__) { + z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1]; + d__[i__ + 1] = d__[i__]; + idxq[i__ + 1] = idxq[i__] + 1; +/* L10: */ + } + +/* Generate the second part of the vector Z. */ + + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1]; +/* L20: */ + } + +/* Initialize some reference arrays. */ + + i__1 = nlp1; + for (i__ = 2; i__ <= i__1; ++i__) { + coltyp[i__] = 1; +/* L30: */ + } + i__1 = n; + for (i__ = nlp2; i__ <= i__1; ++i__) { + coltyp[i__] = 2; +/* L40: */ + } + +/* Sort the singular values into increasing order */ + + i__1 = n; + for (i__ = nlp2; i__ <= i__1; ++i__) { + idxq[i__] += nlp1; +/* L50: */ + } + +/* DSIGMA, IDXC, IDXC, and the first column of U2 */ +/* are used as storage space. */ + + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dsigma[i__] = d__[idxq[i__]]; + u2[i__ + u2_dim1] = z__[idxq[i__]]; + idxc[i__] = coltyp[idxq[i__]]; +/* L60: */ + } + + dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]); + + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + idxi = idx[i__] + 1; + d__[i__] = dsigma[idxi]; + z__[i__] = u2[idxi + u2_dim1]; + coltyp[i__] = idxc[idxi]; +/* L70: */ + } + +/* Calculate the allowable deflation tolerance */ + + eps = dlamch_("Epsilon"); +/* Computing MAX */ + d__1 = abs(*alpha), d__2 = abs(*beta); + tol = std::max(d__1,d__2); +/* Computing MAX */ + d__2 = (d__1 = d__[n], abs(d__1)); + tol = eps * 8. * std::max(d__2,tol); + +/* There are 2 kinds of deflation -- first a value in the z-vector */ +/* is small, second two (or more) singular values are very close */ +/* together (their difference is small). */ + +/* If the value in the z-vector is small, we simply permute the */ +/* array so that the corresponding singular value is moved to the */ +/* end. */ + +/* If two values in the D-vector are close, we perform a two-sided */ +/* rotation designed to make one of the corresponding z-vector */ +/* entries zero, and then permute the array so that the deflated */ +/* singular value is moved to the end. */ + +/* If there are multiple singular values then the problem deflates. */ +/* Here the number of equal singular values are found. As each equal */ +/* singular value is found, an elementary reflector is computed to */ +/* rotate the corresponding singular subspace so that the */ +/* corresponding components of Z are zero in this new basis. */ + + *k = 1; + k2 = n + 1; + i__1 = n; + for (j = 2; j <= i__1; ++j) { + if ((d__1 = z__[j], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + idxp[k2] = j; + coltyp[j] = 4; + if (j == n) { + goto L120; + } + } else { + jprev = j; + goto L90; + } +/* L80: */ + } +L90: + j = jprev; +L100: + ++j; + if (j > n) { + goto L110; + } + if ((d__1 = z__[j], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + idxp[k2] = j; + coltyp[j] = 4; + } else { + +/* Check if singular values are close enough to allow deflation. */ + + if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) { + +/* Deflation is possible. */ + + s = z__[jprev]; + c__ = z__[j]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = dlapy2_(&c__, &s); + c__ /= tau; + s = -s / tau; + z__[j] = tau; + z__[jprev] = 0.; + +/* Apply back the Givens rotation to the left and right */ +/* singular vector matrices. */ + + idxjp = idxq[idx[jprev] + 1]; + idxj = idxq[idx[j] + 1]; + if (idxjp <= nlp1) { + --idxjp; + } + if (idxj <= nlp1) { + --idxj; + } + drot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], & + c__1, &c__, &s); + drot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, & + c__, &s); + if (coltyp[j] != coltyp[jprev]) { + coltyp[j] = 3; + } + coltyp[jprev] = 4; + --k2; + idxp[k2] = jprev; + jprev = j; + } else { + ++(*k); + u2[*k + u2_dim1] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + jprev = j; + } + } + goto L100; +L110: + +/* Record the last singular value. */ + + ++(*k); + u2[*k + u2_dim1] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + +L120: + +/* Count up the total number of the various types of columns, then */ +/* form a permutation which positions the four column types into */ +/* four groups of uniform structure (although one or more of these */ +/* groups may be empty). */ + + for (j = 1; j <= 4; ++j) { + ctot[j - 1] = 0; +/* L130: */ + } + i__1 = n; + for (j = 2; j <= i__1; ++j) { + ct = coltyp[j]; + ++ctot[ct - 1]; +/* L140: */ + } + +/* PSM(*) = Position in SubMatrix (of types 1 through 4) */ + + psm[0] = 2; + psm[1] = ctot[0] + 2; + psm[2] = psm[1] + ctot[1]; + psm[3] = psm[2] + ctot[2]; + +/* Fill out the IDXC array so that the permutation which it induces */ +/* will place all type-1 columns first, all type-2 columns next, */ +/* then all type-3's, and finally all type-4's, starting from the */ +/* second column. This applies similarly to the rows of VT. */ + + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + ct = coltyp[jp]; + idxc[psm[ct - 1]] = j; + ++psm[ct - 1]; +/* L150: */ + } + +/* Sort the singular values and corresponding singular vectors into */ +/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */ +/* which were not deflated go into the first K slots of DSIGMA, U2, */ +/* and VT2 respectively, while those which were deflated go into the */ +/* last N - K slots, except that the first column/row will be treated */ +/* separately. */ + + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + dsigma[j] = d__[jp]; + idxj = idxq[idx[idxp[idxc[j]]] + 1]; + if (idxj <= nlp1) { + --idxj; + } + dcopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1); + dcopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2); +/* L160: */ + } + +/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */ + + dsigma[1] = 0.; + hlftol = tol / 2.; + if (abs(dsigma[2]) <= hlftol) { + dsigma[2] = hlftol; + } + if (m > n) { + z__[1] = dlapy2_(&z1, &z__[m]); + if (z__[1] <= tol) { + c__ = 1.; + s = 0.; + z__[1] = tol; + } else { + c__ = z1 / z__[1]; + s = z__[m] / z__[1]; + } + } else { + if (abs(z1) <= tol) { + z__[1] = tol; + } else { + z__[1] = z1; + } + } + +/* Move the rest of the updating row to Z. */ + + i__1 = *k - 1; + dcopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1); + +/* Determine the first column of U2, the first row of VT2 and the */ +/* last row of VT. */ + + dlaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2); + u2[nlp1 + u2_dim1] = 1.; + if (m > n) { + i__1 = nlp1; + for (i__ = 1; i__ <= i__1; ++i__) { + vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1]; + vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1]; +/* L170: */ + } + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1]; + vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1]; +/* L180: */ + } + } else { + dcopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2); + } + if (m > n) { + dcopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2); + } + +/* The deflated singular values and their corresponding vectors go */ +/* into the back of D, U, and V respectively. */ + + if (n > *k) { + i__1 = n - *k; + dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = n - *k; + dlacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1) + * u_dim1 + 1], ldu); + i__1 = n - *k; + dlacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 + + vt_dim1], ldvt); + } + +/* Copy CTOT into COLTYP for referencing in DLASD3. */ + + for (j = 1; j <= 4; ++j) { + coltyp[j] = ctot[j - 1]; +/* L190: */ + } + + return 0; + +/* End of DLASD2 */ + +} /* dlasd2_ */ + +/* Subroutine */ int dlasd3_(integer *nl, integer *nr, integer *sqre, integer + *k, double *d__, double *q, integer *ldq, double *dsigma, + double *u, integer *ldu, double *u2, integer *ldu2, + double *vt, integer *ldvt, double *vt2, integer *ldvt2, + integer *idxc, integer *ctot, double *z__, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static double c_b13 = 1.; + static double c_b26 = 0.; + + /* System generated locals */ + integer q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, + vt_offset, vt2_dim1, vt2_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, m, n, jc; + double rho; + integer nlp1, nlp2, nrp1; + double temp; + integer ctemp; + integer ktemp; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASD3 finds all the square roots of the roots of the secular */ +/* equation, as defined by the values in D and Z. It makes the */ +/* appropriate calls to DLASD4 and then updates the singular */ +/* vectors by matrix multiplication. */ + +/* This code makes very mild assumptions about floating point */ +/* arithmetic. It will work on machines with a guard digit in */ +/* add/subtract, or on those binary machines without guard digits */ +/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */ +/* It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* DLASD3 is called from DLASD1. */ + +/* Arguments */ +/* ========= */ + +/* NL (input) INTEGER */ +/* The row dimension of the upper block. NL >= 1. */ + +/* NR (input) INTEGER */ +/* The row dimension of the lower block. NR >= 1. */ + +/* SQRE (input) INTEGER */ +/* = 0: the lower block is an NR-by-NR square matrix. */ +/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ + +/* The bidiagonal matrix has N = NL + NR + 1 rows and */ +/* M = N + SQRE >= N columns. */ + +/* K (input) INTEGER */ +/* The size of the secular equation, 1 =< K = < N. */ + +/* D (output) DOUBLE PRECISION array, dimension(K) */ +/* On exit the square roots of the roots of the secular equation, */ +/* in ascending order. */ + +/* Q (workspace) DOUBLE PRECISION array, */ +/* dimension at least (LDQ,K). */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= K. */ + +/* DSIGMA (input) DOUBLE PRECISION array, dimension(K) */ +/* The first K elements of this array contain the old roots */ +/* of the deflated updating problem. These are the poles */ +/* of the secular equation. */ + +/* U (output) DOUBLE PRECISION array, dimension (LDU, N) */ +/* The last N - K columns of this matrix contain the deflated */ +/* left singular vectors. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= N. */ + +/* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N) */ +/* The first K columns of this matrix contain the non-deflated */ +/* left singular vectors for the split problem. */ + +/* LDU2 (input) INTEGER */ +/* The leading dimension of the array U2. LDU2 >= N. */ + +/* VT (output) DOUBLE PRECISION array, dimension (LDVT, M) */ +/* The last M - K columns of VT' contain the deflated */ +/* right singular vectors. */ + +/* LDVT (input) INTEGER */ +/* The leading dimension of the array VT. LDVT >= N. */ + +/* VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N) */ +/* The first K columns of VT2' contain the non-deflated */ +/* right singular vectors for the split problem. */ + +/* LDVT2 (input) INTEGER */ +/* The leading dimension of the array VT2. LDVT2 >= N. */ + +/* IDXC (input) INTEGER array, dimension ( N ) */ +/* The permutation used to arrange the columns of U (and rows of */ +/* VT) into three groups: the first group contains non-zero */ +/* entries only at and above (or before) NL +1; the second */ +/* contains non-zero entries only at and below (or after) NL+2; */ +/* and the third is dense. The first column of U and the row of */ +/* VT are treated separately, however. */ + +/* The rows of the singular vectors found by DLASD4 */ +/* must be likewise permuted before the matrix multiplies can */ +/* take place. */ + +/* CTOT (input) INTEGER array, dimension ( 4 ) */ +/* A count of the total number of the various types of columns */ +/* in U (or rows in VT), as described in IDXC. The fourth column */ +/* type is any column which has been deflated. */ + +/* Z (input) DOUBLE PRECISION array, dimension (K) */ +/* The first K elements of this array contain the components */ +/* of the deflation-adjusted updating row vector. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an singular value did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --dsigma; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + u2_dim1 = *ldu2; + u2_offset = 1 + u2_dim1; + u2 -= u2_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + vt2_dim1 = *ldvt2; + vt2_offset = 1 + vt2_dim1; + vt2 -= vt2_offset; + --idxc; + --ctot; + --z__; + + /* Function Body */ + *info = 0; + + if (*nl < 1) { + *info = -1; + } else if (*nr < 1) { + *info = -2; + } else if (*sqre != 1 && *sqre != 0) { + *info = -3; + } + + n = *nl + *nr + 1; + m = n + *sqre; + nlp1 = *nl + 1; + nlp2 = *nl + 2; + + if (*k < 1 || *k > n) { + *info = -4; + } else if (*ldq < *k) { + *info = -7; + } else if (*ldu < n) { + *info = -10; + } else if (*ldu2 < n) { + *info = -12; + } else if (*ldvt < m) { + *info = -14; + } else if (*ldvt2 < m) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASD3", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*k == 1) { + d__[1] = abs(z__[1]); + dcopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt); + if (z__[1] > 0.) { + dcopy_(&n, &u2[u2_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1); + } else { + i__1 = n; + for (i__ = 1; i__ <= i__1; ++i__) { + u[i__ + u_dim1] = -u2[i__ + u2_dim1]; +/* L10: */ + } + } + return 0; + } + +/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */ +/* be computed with high relative accuracy (barring over/underflow). */ +/* This is a problem on machines without a guard digit in */ +/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ +/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */ +/* which on any of these machines zeros out the bottommost */ +/* bit of DSIGMA(I) if it is 1; this makes the subsequent */ +/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */ +/* occurs. On binary machines with a guard digit (almost all */ +/* machines) it does not change DSIGMA(I) at all. On hexadecimal */ +/* and decimal machines with a guard digit, it slightly */ +/* changes the bottommost bits of DSIGMA(I). It does not account */ +/* for hexadecimal or decimal machines without guard digits */ +/* (we know of none). We use a subroutine call to compute */ +/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */ +/* this code. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; +/* L20: */ + } + +/* Keep a copy of Z. */ + + dcopy_(k, &z__[1], &c__1, &q[q_offset], &c__1); + +/* Normalize Z. */ + + rho = dnrm2_(k, &z__[1], &c__1); + dlascl_("G", &c__0, &c__0, &rho, &c_b13, k, &c__1, &z__[1], k, info); + rho *= rho; + +/* Find the new singular values. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlasd4_(k, &j, &dsigma[1], &z__[1], &u[j * u_dim1 + 1], &rho, &d__[j], + &vt[j * vt_dim1 + 1], info); + +/* If the zero finder fails, the computation is terminated. */ + + if (*info != 0) { + return 0; + } +/* L30: */ + } + +/* Compute updated Z. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + z__[i__] = u[i__ + *k * u_dim1] * vt[i__ + *k * vt_dim1]; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[ + i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]); +/* L40: */ + } + i__2 = *k - 1; + for (j = i__; j <= i__2; ++j) { + z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[ + i__] - dsigma[j + 1]) / (dsigma[i__] + dsigma[j + 1]); +/* L50: */ + } + d__2 = sqrt((d__1 = z__[i__], abs(d__1))); + z__[i__] = d_sign(&d__2, &q[i__ + q_dim1]); +/* L60: */ + } + +/* Compute left singular vectors of the modified diagonal matrix, */ +/* and store related information for the right singular vectors. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + vt[i__ * vt_dim1 + 1] = z__[1] / u[i__ * u_dim1 + 1] / vt[i__ * + vt_dim1 + 1]; + u[i__ * u_dim1 + 1] = -1.; + i__2 = *k; + for (j = 2; j <= i__2; ++j) { + vt[j + i__ * vt_dim1] = z__[j] / u[j + i__ * u_dim1] / vt[j + i__ + * vt_dim1]; + u[j + i__ * u_dim1] = dsigma[j] * vt[j + i__ * vt_dim1]; +/* L70: */ + } + temp = dnrm2_(k, &u[i__ * u_dim1 + 1], &c__1); + q[i__ * q_dim1 + 1] = u[i__ * u_dim1 + 1] / temp; + i__2 = *k; + for (j = 2; j <= i__2; ++j) { + jc = idxc[j]; + q[j + i__ * q_dim1] = u[jc + i__ * u_dim1] / temp; +/* L80: */ + } +/* L90: */ + } + +/* Update the left singular vector matrix. */ + + if (*k == 2) { + dgemm_("N", "N", &n, k, k, &c_b13, &u2[u2_offset], ldu2, &q[q_offset], + ldq, &c_b26, &u[u_offset], ldu); + goto L100; + } + if (ctot[1] > 0) { + dgemm_("N", "N", nl, k, &ctot[1], &c_b13, &u2[(u2_dim1 << 1) + 1], + ldu2, &q[q_dim1 + 2], ldq, &c_b26, &u[u_dim1 + 1], ldu); + if (ctot[3] > 0) { + ktemp = ctot[1] + 2 + ctot[2]; + dgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1] +, ldu2, &q[ktemp + q_dim1], ldq, &c_b13, &u[u_dim1 + 1], + ldu); + } + } else if (ctot[3] > 0) { + ktemp = ctot[1] + 2 + ctot[2]; + dgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1], + ldu2, &q[ktemp + q_dim1], ldq, &c_b26, &u[u_dim1 + 1], ldu); + } else { + dlacpy_("F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu); + } + dcopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu); + ktemp = ctot[1] + 2; + ctemp = ctot[2] + ctot[3]; + dgemm_("N", "N", nr, k, &ctemp, &c_b13, &u2[nlp2 + ktemp * u2_dim1], ldu2, + &q[ktemp + q_dim1], ldq, &c_b26, &u[nlp2 + u_dim1], ldu); + +/* Generate the right singular vectors. */ + +L100: + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = dnrm2_(k, &vt[i__ * vt_dim1 + 1], &c__1); + q[i__ + q_dim1] = vt[i__ * vt_dim1 + 1] / temp; + i__2 = *k; + for (j = 2; j <= i__2; ++j) { + jc = idxc[j]; + q[i__ + j * q_dim1] = vt[jc + i__ * vt_dim1] / temp; +/* L110: */ + } +/* L120: */ + } + +/* Update the right singular vector matrix. */ + + if (*k == 2) { + dgemm_("N", "N", k, &m, k, &c_b13, &q[q_offset], ldq, &vt2[vt2_offset] +, ldvt2, &c_b26, &vt[vt_offset], ldvt); + return 0; + } + ktemp = ctot[1] + 1; + dgemm_("N", "N", k, &nlp1, &ktemp, &c_b13, &q[q_dim1 + 1], ldq, &vt2[ + vt2_dim1 + 1], ldvt2, &c_b26, &vt[vt_dim1 + 1], ldvt); + ktemp = ctot[1] + 2 + ctot[2]; + if (ktemp <= *ldvt2) { + dgemm_("N", "N", k, &nlp1, &ctot[3], &c_b13, &q[ktemp * q_dim1 + 1], + ldq, &vt2[ktemp + vt2_dim1], ldvt2, &c_b13, &vt[vt_dim1 + 1], + ldvt); + } + + ktemp = ctot[1] + 1; + nrp1 = *nr + *sqre; + if (ktemp > 1) { + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + q[i__ + ktemp * q_dim1] = q[i__ + q_dim1]; +/* L130: */ + } + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + vt2[ktemp + i__ * vt2_dim1] = vt2[i__ * vt2_dim1 + 1]; +/* L140: */ + } + } + ctemp = ctot[2] + 1 + ctot[3]; + dgemm_("N", "N", k, &nrp1, &ctemp, &c_b13, &q[ktemp * q_dim1 + 1], ldq, & + vt2[ktemp + nlp2 * vt2_dim1], ldvt2, &c_b26, &vt[nlp2 * vt_dim1 + + 1], ldvt); + + return 0; + +/* End of DLASD3 */ + +} /* dlasd3_ */ + +/* Subroutine */ int dlasd4_(integer *n, integer *i__, double *d__, + double *z__, double *delta, double *rho, double * + sigma, double *work, integer *info) +{ + /* System generated locals */ + integer i__1; + double d__1; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + double a, b, c__; + integer j; + double w, dd[3]; + integer ii; + double dw, zz[3]; + integer ip1; + double eta, phi, eps, tau, psi; + integer iim1, iip1; + double dphi, dpsi; + integer iter; + double temp, prew, sg2lb, sg2ub, temp1, temp2, dtiim, delsq, dtiip; + integer niter; + double dtisq; + bool swtch; + double dtnsq; + double delsq2, dtnsq1; + bool swtch3; + bool orgati; + double erretm, dtipsq, rhoinv; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This subroutine computes the square root of the I-th updated */ +/* eigenvalue of a positive symmetric rank-one modification to */ +/* a positive diagonal matrix whose entries are given as the squares */ +/* of the corresponding entries in the array d, and that */ + +/* 0 <= D(i) < D(j) for i < j */ + +/* and that RHO > 0. This is arranged by the calling routine, and is */ +/* no loss in generality. The rank-one modified system is thus */ + +/* diag( D ) * diag( D ) + RHO * Z * Z_transpose. */ + +/* where we assume the Euclidean norm of Z is 1. */ + +/* The method consists of approximating the rational functions in the */ +/* secular equation by simpler interpolating rational functions. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The length of all arrays. */ + +/* I (input) INTEGER */ +/* The index of the eigenvalue to be computed. 1 <= I <= N. */ + +/* D (input) DOUBLE PRECISION array, dimension ( N ) */ +/* The original eigenvalues. It is assumed that they are in */ +/* order, 0 <= D(I) < D(J) for I < J. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( N ) */ +/* The components of the updating vector. */ + +/* DELTA (output) DOUBLE PRECISION array, dimension ( N ) */ +/* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th */ +/* component. If N = 1, then DELTA(1) = 1. The vector DELTA */ +/* contains the information necessary to construct the */ +/* (singular) eigenvectors. */ + +/* RHO (input) DOUBLE PRECISION */ +/* The scalar in the symmetric updating formula. */ + +/* SIGMA (output) DOUBLE PRECISION */ +/* The computed sigma_I, the I-th updated eigenvalue. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension ( N ) */ +/* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th */ +/* component. If N = 1, then WORK( 1 ) = 1. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* > 0: if INFO = 1, the updating process failed. */ + +/* Internal Parameters */ +/* =================== */ + +/* Logical variable ORGATI (origin-at-i?) is used for distinguishing */ +/* whether D(i) or D(i+1) is treated as the origin. */ + +/* ORGATI = .true. origin at i */ +/* ORGATI = .false. origin at i+1 */ + +/* Logical variable SWTCH3 (switch-for-3-poles?) is for noting */ +/* if we are working with THREE poles! */ + +/* MAXIT is the maximum number of iterations allowed for each */ +/* eigenvalue. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ren-Cang Li, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Since this routine is called in an inner loop, we do no argument */ +/* checking. */ + +/* Quick return for N=1 and 2. */ + + /* Parameter adjustments */ + --work; + --delta; + --z__; + --d__; + + /* Function Body */ + *info = 0; + if (*n == 1) { + +/* Presumably, I=1 upon entry */ + + *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]); + delta[1] = 1.; + work[1] = 1.; + return 0; + } + if (*n == 2) { + dlasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]); + return 0; + } + +/* Compute machine epsilon */ + + eps = dlamch_("Epsilon"); + rhoinv = 1. / *rho; + +/* The case I = N */ + + if (*i__ == *n) { + +/* Initialize some basic variables */ + + ii = *n - 1; + niter = 1; + +/* Calculate initial guess */ + + temp = *rho / 2.; + +/* If ||Z||_2 is not one, then TEMP should be set to */ +/* RHO * ||Z||_2^2 / TWO */ + + temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp)); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*n] + temp1; + delta[j] = d__[j] - d__[*n] - temp1; +/* L10: */ + } + + psi = 0.; + i__1 = *n - 2; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / (delta[j] * work[j]); +/* L20: */ + } + + c__ = rhoinv + psi; + w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[* + n] / (delta[*n] * work[*n]); + + if (w <= 0.) { + temp1 = sqrt(d__[*n] * d__[*n] + *rho); + temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[* + n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] * + z__[*n] / *rho; + +/* The following TAU is to approximate */ +/* SIGMA_n^2 - D( N )*D( N ) */ + + if (c__ <= temp) { + tau = *rho; + } else { + delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); + a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[* + n]; + b = z__[*n] * z__[*n] * delsq; + if (a < 0.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + } + +/* It can be proved that */ +/* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO */ + + } else { + delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); + a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * delsq; + +/* The following TAU is to approximate */ +/* SIGMA_n^2 - D( N )*D( N ) */ + + if (a < 0.) { + tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a); + } else { + tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.); + } + +/* It can be proved that */ +/* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 */ + + } + +/* The following ETA is to approximate SIGMA_n - D( N ) */ + + eta = tau / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau)); + + *sigma = d__[*n] + eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*i__] - eta; + work[j] = d__[j] + d__[*i__] + eta; +/* L30: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (delta[j] * work[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L40: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / (delta[*n] * work[*n]); + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + + dphi); + + w = rhoinv + phi + psi; + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + goto L240; + } + +/* Calculate the new step */ + + ++niter; + dtnsq1 = work[*n - 1] * delta[*n - 1]; + dtnsq = work[*n] * delta[*n]; + c__ = w - dtnsq1 * dpsi - dtnsq * dphi; + a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi); + b = dtnsq * dtnsq1 * w; + if (c__ < 0.) { + c__ = abs(c__); + } + if (c__ == 0.) { + eta = *rho - *sigma * *sigma; + } else if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__ + * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))) + ); + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = eta - dtnsq; + if (temp > *rho) { + eta = *rho + dtnsq; + } + + tau += eta; + eta /= *sigma + sqrt(eta + *sigma * *sigma); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; +/* L50: */ + } + + *sigma += eta; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L60: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / (work[*n] * delta[*n]); + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi + + dphi); + + w = rhoinv + phi + psi; + +/* Main loop to update the values of the array DELTA */ + + iter = niter + 1; + + for (niter = iter; niter <= 20; ++niter) { + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + goto L240; + } + +/* Calculate the new step */ + + dtnsq1 = work[*n - 1] * delta[*n - 1]; + dtnsq = work[*n] * delta[*n]; + c__ = w - dtnsq1 * dpsi - dtnsq * dphi; + a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi); + b = dtnsq1 * dtnsq * w; + if (a >= 0.) { + eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta > 0.) { + eta = -w / (dpsi + dphi); + } + temp = eta - dtnsq; + if (temp <= 0.) { + eta /= 2.; + } + + tau += eta; + eta /= *sigma + sqrt(eta + *sigma * *sigma); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; +/* L70: */ + } + + *sigma += eta; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L80: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / (work[*n] * delta[*n]); + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * ( + dpsi + dphi); + + w = rhoinv + phi + psi; +/* L90: */ + } + +/* Return with INFO = 1, NITER = MAXIT and not converged */ + + *info = 1; + goto L240; + +/* End for the case I = N */ + + } else { + +/* The case for I < N */ + + niter = 1; + ip1 = *i__ + 1; + +/* Calculate initial guess */ + + delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]); + delsq2 = delsq / 2.; + temp = delsq2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + delsq2)); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*i__] + temp; + delta[j] = d__[j] - d__[*i__] - temp; +/* L100: */ + } + + psi = 0.; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / (work[j] * delta[j]); +/* L110: */ + } + + phi = 0.; + i__1 = *i__ + 2; + for (j = *n; j >= i__1; --j) { + phi += z__[j] * z__[j] / (work[j] * delta[j]); +/* L120: */ + } + c__ = rhoinv + psi + phi; + w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[ + ip1] * z__[ip1] / (work[ip1] * delta[ip1]); + + if (w > 0.) { + +/* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 */ + +/* We choose d(i) as origin. */ + + orgati = true; + sg2lb = 0.; + sg2ub = delsq2; + a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * delsq; + if (a > 0.) { + tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } else { + tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } + +/* TAU now is an estimation of SIGMA^2 - D( I )^2. The */ +/* following, however, is the corresponding estimation of */ +/* SIGMA - D( I ). */ + + eta = tau / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau)); + } else { + +/* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 */ + +/* We choose d(i+1) as origin. */ + + orgati = false; + sg2lb = -delsq2; + sg2ub = 0.; + a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * delsq; + if (a < 0.) { + tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs( + d__1)))); + } else { + tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) / + (c__ * 2.); + } + +/* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The */ +/* following, however, is the corresponding estimation of */ +/* SIGMA - D( IP1 ). */ + + eta = tau / (d__[ip1] + sqrt((d__1 = d__[ip1] * d__[ip1] + tau, + abs(d__1)))); + } + + if (orgati) { + ii = *i__; + *sigma = d__[*i__] + eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*i__] + eta; + delta[j] = d__[j] - d__[*i__] - eta; +/* L130: */ + } + } else { + ii = *i__ + 1; + *sigma = d__[ip1] + eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[ip1] + eta; + delta[j] = d__[j] - d__[ip1] - eta; +/* L140: */ + } + } + iim1 = ii - 1; + iip1 = ii + 1; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L150: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L160: */ + } + + w = rhoinv + phi + psi; + +/* W is the value of the secular function with */ +/* its ii-th element removed. */ + + swtch3 = false; + if (orgati) { + if (w < 0.) { + swtch3 = true; + } + } else { + if (w > 0.) { + swtch3 = true; + } + } + if (ii == 1 || ii == *n) { + swtch3 = false; + } + + temp = z__[ii] / (work[ii] * delta[ii]); + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w += temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + + abs(tau) * dw; + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + goto L240; + } + + if (w <= 0.) { + sg2lb = std::max(sg2lb,tau); + } else { + sg2ub = std::min(sg2ub,tau); + } + +/* Calculate the new step */ + + ++niter; + if (! swtch3) { + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (orgati) { +/* Computing 2nd power */ + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { +/* Computing 2nd power */ + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + + dphi); + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / ( + c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs( + d__1)))); + } + } else { + +/* Interpolation using THREE most relevant poles */ + + dtiim = work[iim1] * delta[iim1]; + dtiip = work[iip1] * delta[iip1]; + temp = rhoinv + psi + phi; + if (orgati) { + temp1 = z__[iim1] / dtiim; + temp1 *= temp1; + c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * + (d__[iim1] + d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + if (dpsi < temp1) { + zz[2] = dtiip * dtiip * dphi; + } else { + zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); + } + } else { + temp1 = z__[iip1] / dtiip; + temp1 *= temp1; + c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * + (d__[iim1] + d__[iip1]) * temp1; + if (dphi < temp1) { + zz[0] = dtiim * dtiim * dpsi; + } else { + zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); + } + zz[2] = z__[iip1] * z__[iip1]; + } + zz[1] = z__[ii] * z__[ii]; + dd[0] = dtiim; + dd[1] = delta[ii] * work[ii]; + dd[2] = dtiip; + dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); + if (*info != 0) { + goto L240; + } + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta >= 0.) { + eta = -w / dw; + } + if (orgati) { + temp1 = work[*i__] * delta[*i__]; + temp = eta - temp1; + } else { + temp1 = work[ip1] * delta[ip1]; + temp = eta - temp1; + } + if (temp > sg2ub || temp < sg2lb) { + if (w < 0.) { + eta = (sg2ub - tau) / 2.; + } else { + eta = (sg2lb - tau) / 2.; + } + } + + tau += eta; + eta /= *sigma + sqrt(*sigma * *sigma + eta); + + prew = w; + + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; +/* L170: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L180: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L190: */ + } + + temp = z__[ii] / (work[ii] * delta[ii]); + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + + abs(tau) * dw; + + if (w <= 0.) { + sg2lb = std::max(sg2lb,tau); + } else { + sg2ub = std::min(sg2ub,tau); + } + + swtch = false; + if (orgati) { + if (-w > abs(prew) / 10.) { + swtch = true; + } + } else { + if (w > abs(prew) / 10.) { + swtch = true; + } + } + +/* Main loop to update the values of the array DELTA and WORK */ + + iter = niter + 1; + + for (niter = iter; niter <= 20; ++niter) { + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + goto L240; + } + +/* Calculate the new step */ + + if (! swtch3) { + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (! swtch) { + if (orgati) { +/* Computing 2nd power */ + d__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (d__1 * d__1); + } else { +/* Computing 2nd power */ + d__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (d__1 * d__1); + } + } else { + temp = z__[ii] / (work[ii] * delta[ii]); + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - dtisq * dpsi - dtipsq * dphi; + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.) { + if (a == 0.) { + if (! swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * + (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * ( + dpsi + dphi); + } + } else { + a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi; + } + } + eta = b / a; + } else if (a <= 0.) { + eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) + / (c__ * 2.); + } else { + eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, + abs(d__1)))); + } + } else { + +/* Interpolation using THREE most relevant poles */ + + dtiim = work[iim1] * delta[iim1]; + dtiip = work[iip1] * delta[iip1]; + temp = rhoinv + psi + phi; + if (swtch) { + c__ = temp - dtiim * dpsi - dtiip * dphi; + zz[0] = dtiim * dtiim * dpsi; + zz[2] = dtiip * dtiip * dphi; + } else { + if (orgati) { + temp1 = z__[iim1] / dtiim; + temp1 *= temp1; + temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[ + iip1]) * temp1; + c__ = temp - dtiip * (dpsi + dphi) - temp2; + zz[0] = z__[iim1] * z__[iim1]; + if (dpsi < temp1) { + zz[2] = dtiip * dtiip * dphi; + } else { + zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); + } + } else { + temp1 = z__[iip1] / dtiip; + temp1 *= temp1; + temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[ + iip1]) * temp1; + c__ = temp - dtiim * (dpsi + dphi) - temp2; + if (dphi < temp1) { + zz[0] = dtiim * dtiim * dpsi; + } else { + zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); + } + zz[2] = z__[iip1] * z__[iip1]; + } + } + dd[0] = dtiim; + dd[1] = delta[ii] * work[ii]; + dd[2] = dtiip; + dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); + if (*info != 0) { + goto L240; + } + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta >= 0.) { + eta = -w / dw; + } + if (orgati) { + temp1 = work[*i__] * delta[*i__]; + temp = eta - temp1; + } else { + temp1 = work[ip1] * delta[ip1]; + temp = eta - temp1; + } + if (temp > sg2ub || temp < sg2lb) { + if (w < 0.) { + eta = (sg2ub - tau) / 2.; + } else { + eta = (sg2lb - tau) / 2.; + } + } + + tau += eta; + eta /= *sigma + sqrt(*sigma * *sigma + eta); + + *sigma += eta; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; +/* L200: */ + } + + prew = w; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.; + psi = 0.; + erretm = 0.; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L210: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.; + phi = 0.; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L220: */ + } + + temp = z__[ii] / (work[ii] * delta[ii]); + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + + abs(tau) * dw; + if (w * prew > 0. && abs(w) > abs(prew) / 10.) { + swtch = ! swtch; + } + + if (w <= 0.) { + sg2lb = std::max(sg2lb,tau); + } else { + sg2ub = std::min(sg2ub,tau); + } + +/* L230: */ + } + +/* Return with INFO = 1, NITER = MAXIT and not converged */ + + *info = 1; + + } + +L240: + return 0; + +/* End of DLASD4 */ + +} /* dlasd4_ */ + +/* Subroutine */ int dlasd5_(integer *i__, double *d__, double *z__, + double *delta, double *rho, double *dsigma, double * + work) +{ + /* System generated locals */ + double d__1; + + /* Builtin functions + double sqrt(double); */ + + /* Local variables */ + double b, c__, w, del, tau, delsq; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This subroutine computes the square root of the I-th eigenvalue */ +/* of a positive symmetric rank-one modification of a 2-by-2 diagonal */ +/* matrix */ + +/* diag( D ) * diag( D ) + RHO * Z * transpose(Z) . */ + +/* The diagonal entries in the array D are assumed to satisfy */ + +/* 0 <= D(i) < D(j) for i < j . */ + +/* We also assume RHO > 0 and that the Euclidean norm of the vector */ +/* Z is one. */ + +/* Arguments */ +/* ========= */ + +/* I (input) INTEGER */ +/* The index of the eigenvalue to be computed. I = 1 or I = 2. */ + +/* D (input) DOUBLE PRECISION array, dimension ( 2 ) */ +/* The original eigenvalues. We assume 0 <= D(1) < D(2). */ + +/* Z (input) DOUBLE PRECISION array, dimension ( 2 ) */ +/* The components of the updating vector. */ + +/* DELTA (output) DOUBLE PRECISION array, dimension ( 2 ) */ +/* Contains (D(j) - sigma_I) in its j-th component. */ +/* The vector DELTA contains the information necessary */ +/* to construct the eigenvectors. */ + +/* RHO (input) DOUBLE PRECISION */ +/* The scalar in the symmetric updating formula. */ + +/* DSIGMA (output) DOUBLE PRECISION */ +/* The computed sigma_I, the I-th updated eigenvalue. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 ) */ +/* WORK contains (D(j) + sigma_I) in its j-th component. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ren-Cang Li, Computer Science Division, University of California */ +/* at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --work; + --delta; + --z__; + --d__; + + /* Function Body */ + del = d__[2] - d__[1]; + delsq = del * (d__[2] + d__[1]); + if (*i__ == 1) { + w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] * + z__[1] / (d__[1] * 3. + d__[2])) / del + 1.; + if (w > 0.) { + b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * delsq; + +/* B > ZERO, always */ + +/* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */ + + tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1)))); + +/* The following TAU is DSIGMA - D( 1 ) */ + + tau /= d__[1] + sqrt(d__[1] * d__[1] + tau); + *dsigma = d__[1] + tau; + delta[1] = -tau; + delta[2] = del - tau; + work[1] = d__[1] * 2. + tau; + work[2] = d__[1] + tau + d__[2]; +/* DELTA( 1 ) = -Z( 1 ) / TAU */ +/* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */ + } else { + b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * delsq; + +/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ + + if (b > 0.) { + tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.)); + } else { + tau = (b - sqrt(b * b + c__ * 4.)) / 2.; + } + +/* The following TAU is DSIGMA - D( 2 ) */ + + tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1))); + *dsigma = d__[2] + tau; + delta[1] = -(del + tau); + delta[2] = -tau; + work[1] = d__[1] + tau + d__[2]; + work[2] = d__[2] * 2. + tau; +/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ +/* DELTA( 2 ) = -Z( 2 ) / TAU */ + } +/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ +/* DELTA( 1 ) = DELTA( 1 ) / TEMP */ +/* DELTA( 2 ) = DELTA( 2 ) / TEMP */ + } else { + +/* Now I=2 */ + + b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * delsq; + +/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ + + if (b > 0.) { + tau = (b + sqrt(b * b + c__ * 4.)) / 2.; + } else { + tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.)); + } + +/* The following TAU is DSIGMA - D( 2 ) */ + + tau /= d__[2] + sqrt(d__[2] * d__[2] + tau); + *dsigma = d__[2] + tau; + delta[1] = -(del + tau); + delta[2] = -tau; + work[1] = d__[1] + tau + d__[2]; + work[2] = d__[2] * 2. + tau; +/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ +/* DELTA( 2 ) = -Z( 2 ) / TAU */ +/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ +/* DELTA( 1 ) = DELTA( 1 ) / TEMP */ +/* DELTA( 2 ) = DELTA( 2 ) / TEMP */ + } + return 0; + +/* End of DLASD5 */ + +} /* dlasd5_ */ + +/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr, + integer *sqre, double *d__, double *vf, double *vl, + double *alpha, double *beta, integer *idxq, integer *perm, + integer *givptr, integer *givcol, integer *ldgcol, double *givnum, + integer *ldgnum, double *poles, double *difl, double * + difr, double *z__, integer *k, double *c__, double *s, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__0 = 0; + static double c_b7 = 1.; + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, + poles_dim1, poles_offset, i__1; + double d__1, d__2; + + /* Local variables */ + integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw; + integer isigma; + double orgnrm; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASD6 computes the SVD of an updated upper bidiagonal matrix B */ +/* obtained by merging two smaller ones by appending a row. This */ +/* routine is used only for the problem which requires all singular */ +/* values and optionally singular vector matrices in factored form. */ +/* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. */ +/* A related subroutine, DLASD1, handles the case in which all singular */ +/* values and singular vectors of the bidiagonal matrix are desired. */ + +/* DLASD6 computes the SVD as follows: */ + +/* ( D1(in) 0 0 0 ) */ +/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */ +/* ( 0 0 D2(in) 0 ) */ + +/* = U(out) * ( D(out) 0) * VT(out) */ + +/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */ +/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */ +/* elsewhere; and the entry b is empty if SQRE = 0. */ + +/* The singular values of B can be computed using D1, D2, the first */ +/* components of all the right singular vectors of the lower block, and */ +/* the last components of all the right singular vectors of the upper */ +/* block. These components are stored and updated in VF and VL, */ +/* respectively, in DLASD6. Hence U and VT are not explicitly */ +/* referenced. */ + +/* The singular values are stored in D. The algorithm consists of two */ +/* stages: */ + +/* The first stage consists of deflating the size of the problem */ +/* when there are multiple singular values or if there is a zero */ +/* in the Z vector. For each such occurence the dimension of the */ +/* secular equation problem is reduced by one. This stage is */ +/* performed by the routine DLASD7. */ + +/* The second stage consists of calculating the updated */ +/* singular values. This is done by finding the roots of the */ +/* secular equation via the routine DLASD4 (as called by DLASD8). */ +/* This routine also updates VF and VL and computes the distances */ +/* between the updated singular values and the old singular */ +/* values. */ + +/* DLASD6 is called from DLASDA. */ + +/* Arguments */ +/* ========= */ + +/* ICOMPQ (input) INTEGER */ +/* Specifies whether singular vectors are to be computed in */ +/* factored form: */ +/* = 0: Compute singular values only. */ +/* = 1: Compute singular vectors in factored form as well. */ + +/* NL (input) INTEGER */ +/* The row dimension of the upper block. NL >= 1. */ + +/* NR (input) INTEGER */ +/* The row dimension of the lower block. NR >= 1. */ + +/* SQRE (input) INTEGER */ +/* = 0: the lower block is an NR-by-NR square matrix. */ +/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ + +/* The bidiagonal matrix has row dimension N = NL + NR + 1, */ +/* and column dimension M = N + SQRE. */ + +/* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ). */ +/* On entry D(1:NL,1:NL) contains the singular values of the */ +/* upper block, and D(NL+2:N) contains the singular values */ +/* of the lower block. On exit D(1:N) contains the singular */ +/* values of the modified matrix. */ + +/* VF (input/output) DOUBLE PRECISION array, dimension ( M ) */ +/* On entry, VF(1:NL+1) contains the first components of all */ +/* right singular vectors of the upper block; and VF(NL+2:M) */ +/* contains the first components of all right singular vectors */ +/* of the lower block. On exit, VF contains the first components */ +/* of all right singular vectors of the bidiagonal matrix. */ + +/* VL (input/output) DOUBLE PRECISION array, dimension ( M ) */ +/* On entry, VL(1:NL+1) contains the last components of all */ +/* right singular vectors of the upper block; and VL(NL+2:M) */ +/* contains the last components of all right singular vectors of */ +/* the lower block. On exit, VL contains the last components of */ +/* all right singular vectors of the bidiagonal matrix. */ + +/* ALPHA (input/output) DOUBLE PRECISION */ +/* Contains the diagonal element associated with the added row. */ + +/* BETA (input/output) DOUBLE PRECISION */ +/* Contains the off-diagonal element associated with the added */ +/* row. */ + +/* IDXQ (output) INTEGER array, dimension ( N ) */ +/* This contains the permutation which will reintegrate the */ +/* subproblem just solved back into sorted order, i.e. */ +/* D( IDXQ( I = 1, N ) ) will be in ascending order. */ + +/* PERM (output) INTEGER array, dimension ( N ) */ +/* The permutations (from deflation and sorting) to be applied */ +/* to each block. Not referenced if ICOMPQ = 0. */ + +/* GIVPTR (output) INTEGER */ +/* The number of Givens rotations which took place in this */ +/* subproblem. Not referenced if ICOMPQ = 0. */ + +/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */ +/* Each pair of numbers indicates a pair of columns to take place */ +/* in a Givens rotation. Not referenced if ICOMPQ = 0. */ + +/* LDGCOL (input) INTEGER */ +/* leading dimension of GIVCOL, must be at least N. */ + +/* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ +/* Each number indicates the C or S value to be used in the */ +/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */ + +/* LDGNUM (input) INTEGER */ +/* The leading dimension of GIVNUM and POLES, must be at least N. */ + +/* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ +/* On exit, POLES(1,*) is an array containing the new singular */ +/* values obtained from solving the secular equation, and */ +/* POLES(2,*) is an array containing the poles in the secular */ +/* equation. Not referenced if ICOMPQ = 0. */ + +/* DIFL (output) DOUBLE PRECISION array, dimension ( N ) */ +/* On exit, DIFL(I) is the distance between I-th updated */ +/* (undeflated) singular value and the I-th (undeflated) old */ +/* singular value. */ + +/* DIFR (output) DOUBLE PRECISION array, */ +/* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and */ +/* dimension ( N ) if ICOMPQ = 0. */ +/* On exit, DIFR(I, 1) is the distance between I-th updated */ +/* (undeflated) singular value and the I+1-th (undeflated) old */ +/* singular value. */ + +/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */ +/* normalizing factors for the right singular vector matrix. */ + +/* See DLASD8 for details on DIFL and DIFR. */ + +/* Z (output) DOUBLE PRECISION array, dimension ( M ) */ +/* The first elements of this array contain the components */ +/* of the deflation-adjusted updating row vector. */ + +/* K (output) INTEGER */ +/* Contains the dimension of the non-deflated matrix, */ +/* This is the order of the related secular equation. 1 <= K <=N. */ + +/* C (output) DOUBLE PRECISION */ +/* C contains garbage if SQRE =0 and the C-value of a Givens */ +/* rotation related to the right null space if SQRE = 1. */ + +/* S (output) DOUBLE PRECISION */ +/* S contains garbage if SQRE =0 and the S-value of a Givens */ +/* rotation related to the right null space if SQRE = 1. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M ) */ + +/* IWORK (workspace) INTEGER array, dimension ( 3 * N ) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an singular value did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --vf; + --vl; + --idxq; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + poles_dim1 = *ldgnum; + poles_offset = 1 + poles_dim1; + poles -= poles_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + --difl; + --difr; + --z__; + --work; + --iwork; + + /* Function Body */ + *info = 0; + n = *nl + *nr + 1; + m = n + *sqre; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldgcol < n) { + *info = -14; + } else if (*ldgnum < n) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASD6", &i__1); + return 0; + } + +/* The following values are for bookkeeping purposes only. They are */ +/* integer pointers which indicate the portion of the workspace */ +/* used by a particular array in DLASD7 and DLASD8. */ + + isigma = 1; + iw = isigma + n; + ivfw = iw + m; + ivlw = ivfw + m; + + idx = 1; + idxc = idx + n; + idxp = idxc + n; + +/* Scale. */ + +/* Computing MAX */ + d__1 = abs(*alpha), d__2 = abs(*beta); + orgnrm = std::max(d__1,d__2); + d__[*nl + 1] = 0.; + i__1 = n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) > orgnrm) { + orgnrm = (d__1 = d__[i__], abs(d__1)); + } +/* L10: */ + } + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info); + *alpha /= orgnrm; + *beta /= orgnrm; + +/* Sort and Deflate singular values. */ + + dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], & + work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], & + iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[ + givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s, + info); + +/* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */ + + dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1], + ldgnum, &work[isigma], &work[iw], info); + +/* Save the poles if ICOMPQ = 1. */ + + if (*icompq == 1) { + dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1); + dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1); + } + +/* Unscale. */ + + dlascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info); + +/* Prepare the IDXQ sorting permutation. */ + + n1 = *k; + n2 = n - *k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]); + + return 0; + +/* End of DLASD6 */ + +} /* dlasd6_ */ + +/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr, + integer *sqre, integer *k, double *d__, double *z__, + double *zw, double *vf, double *vfw, double *vl, + double *vlw, double *alpha, double *beta, double * + dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm, + integer *givptr, integer *givcol, integer *ldgcol, double *givnum, + integer *ldgnum, double *c__, double *s, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1; + double d__1, d__2; + + /* Local variables */ + integer i__, j, m, n, k2; + double z1; + integer jp; + double eps, tau, tol; + integer nlp1, nlp2, idxi, idxj; + integer idxjp; + integer jprev; + double hlftol; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASD7 merges the two sets of singular values together into a single */ +/* sorted set. Then it tries to deflate the size of the problem. There */ +/* are two ways in which deflation can occur: when two or more singular */ +/* values are close together or if there is a tiny entry in the Z */ +/* vector. For each such occurrence the order of the related */ +/* secular equation problem is reduced by one. */ + +/* DLASD7 is called from DLASD6. */ + +/* Arguments */ +/* ========= */ + +/* ICOMPQ (input) INTEGER */ +/* Specifies whether singular vectors are to be computed */ +/* in compact form, as follows: */ +/* = 0: Compute singular values only. */ +/* = 1: Compute singular vectors of upper */ +/* bidiagonal matrix in compact form. */ + +/* NL (input) INTEGER */ +/* The row dimension of the upper block. NL >= 1. */ + +/* NR (input) INTEGER */ +/* The row dimension of the lower block. NR >= 1. */ + +/* SQRE (input) INTEGER */ +/* = 0: the lower block is an NR-by-NR square matrix. */ +/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ + +/* The bidiagonal matrix has */ +/* N = NL + NR + 1 rows and */ +/* M = N + SQRE >= N columns. */ + +/* K (output) INTEGER */ +/* Contains the dimension of the non-deflated matrix, this is */ +/* the order of the related secular equation. 1 <= K <=N. */ + +/* D (input/output) DOUBLE PRECISION array, dimension ( N ) */ +/* On entry D contains the singular values of the two submatrices */ +/* to be combined. On exit D contains the trailing (N-K) updated */ +/* singular values (those which were deflated) sorted into */ +/* increasing order. */ + +/* Z (output) DOUBLE PRECISION array, dimension ( M ) */ +/* On exit Z contains the updating row vector in the secular */ +/* equation. */ + +/* ZW (workspace) DOUBLE PRECISION array, dimension ( M ) */ +/* Workspace for Z. */ + +/* VF (input/output) DOUBLE PRECISION array, dimension ( M ) */ +/* On entry, VF(1:NL+1) contains the first components of all */ +/* right singular vectors of the upper block; and VF(NL+2:M) */ +/* contains the first components of all right singular vectors */ +/* of the lower block. On exit, VF contains the first components */ +/* of all right singular vectors of the bidiagonal matrix. */ + +/* VFW (workspace) DOUBLE PRECISION array, dimension ( M ) */ +/* Workspace for VF. */ + +/* VL (input/output) DOUBLE PRECISION array, dimension ( M ) */ +/* On entry, VL(1:NL+1) contains the last components of all */ +/* right singular vectors of the upper block; and VL(NL+2:M) */ +/* contains the last components of all right singular vectors */ +/* of the lower block. On exit, VL contains the last components */ +/* of all right singular vectors of the bidiagonal matrix. */ + +/* VLW (workspace) DOUBLE PRECISION array, dimension ( M ) */ +/* Workspace for VL. */ + +/* ALPHA (input) DOUBLE PRECISION */ +/* Contains the diagonal element associated with the added row. */ + +/* BETA (input) DOUBLE PRECISION */ +/* Contains the off-diagonal element associated with the added */ +/* row. */ + +/* DSIGMA (output) DOUBLE PRECISION array, dimension ( N ) */ +/* Contains a copy of the diagonal elements (K-1 singular values */ +/* and one zero) in the secular equation. */ + +/* IDX (workspace) INTEGER array, dimension ( N ) */ +/* This will contain the permutation used to sort the contents of */ +/* D into ascending order. */ + +/* IDXP (workspace) INTEGER array, dimension ( N ) */ +/* This will contain the permutation used to place deflated */ +/* values of D at the end of the array. On output IDXP(2:K) */ +/* points to the nondeflated D-values and IDXP(K+1:N) */ +/* points to the deflated singular values. */ + +/* IDXQ (input) INTEGER array, dimension ( N ) */ +/* This contains the permutation which separately sorts the two */ +/* sub-problems in D into ascending order. Note that entries in */ +/* the first half of this permutation must first be moved one */ +/* position backward; and entries in the second half */ +/* must first have NL+1 added to their values. */ + +/* PERM (output) INTEGER array, dimension ( N ) */ +/* The permutations (from deflation and sorting) to be applied */ +/* to each singular block. Not referenced if ICOMPQ = 0. */ + +/* GIVPTR (output) INTEGER */ +/* The number of Givens rotations which took place in this */ +/* subproblem. Not referenced if ICOMPQ = 0. */ + +/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */ +/* Each pair of numbers indicates a pair of columns to take place */ +/* in a Givens rotation. Not referenced if ICOMPQ = 0. */ + +/* LDGCOL (input) INTEGER */ +/* The leading dimension of GIVCOL, must be at least N. */ + +/* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ +/* Each number indicates the C or S value to be used in the */ +/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */ + +/* LDGNUM (input) INTEGER */ +/* The leading dimension of GIVNUM, must be at least N. */ + +/* C (output) DOUBLE PRECISION */ +/* C contains garbage if SQRE =0 and the C-value of a Givens */ +/* rotation related to the right null space if SQRE = 1. */ + +/* S (output) DOUBLE PRECISION */ +/* S contains garbage if SQRE =0 and the S-value of a Givens */ +/* rotation related to the right null space if SQRE = 1. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ + +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --z__; + --zw; + --vf; + --vfw; + --vl; + --vlw; + --dsigma; + --idx; + --idxp; + --idxq; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + + /* Function Body */ + *info = 0; + n = *nl + *nr + 1; + m = n + *sqre; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldgcol < n) { + *info = -22; + } else if (*ldgnum < n) { + *info = -24; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASD7", &i__1); + return 0; + } + + nlp1 = *nl + 1; + nlp2 = *nl + 2; + if (*icompq == 1) { + *givptr = 0; + } + +/* Generate the first part of the vector Z and move the singular */ +/* values in the first part of D one position backward. */ + + z1 = *alpha * vl[nlp1]; + vl[nlp1] = 0.; + tau = vf[nlp1]; + for (i__ = *nl; i__ >= 1; --i__) { + z__[i__ + 1] = *alpha * vl[i__]; + vl[i__] = 0.; + vf[i__ + 1] = vf[i__]; + d__[i__ + 1] = d__[i__]; + idxq[i__ + 1] = idxq[i__] + 1; +/* L10: */ + } + vf[1] = tau; + +/* Generate the second part of the vector Z. */ + + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + z__[i__] = *beta * vf[i__]; + vf[i__] = 0.; +/* L20: */ + } + +/* Sort the singular values into increasing order */ + + i__1 = n; + for (i__ = nlp2; i__ <= i__1; ++i__) { + idxq[i__] += nlp1; +/* L30: */ + } + +/* DSIGMA, IDXC, IDXC, and ZW are used as storage space. */ + + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dsigma[i__] = d__[idxq[i__]]; + zw[i__] = z__[idxq[i__]]; + vfw[i__] = vf[idxq[i__]]; + vlw[i__] = vl[idxq[i__]]; +/* L40: */ + } + + dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]); + + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + idxi = idx[i__] + 1; + d__[i__] = dsigma[idxi]; + z__[i__] = zw[idxi]; + vf[i__] = vfw[idxi]; + vl[i__] = vlw[idxi]; +/* L50: */ + } + +/* Calculate the allowable deflation tolerence */ + + eps = dlamch_("Epsilon"); +/* Computing MAX */ + d__1 = abs(*alpha), d__2 = abs(*beta); + tol = std::max(d__1,d__2); +/* Computing MAX */ + d__2 = (d__1 = d__[n], abs(d__1)); + tol = eps * 64. * std::max(d__2,tol); + +/* There are 2 kinds of deflation -- first a value in the z-vector */ +/* is small, second two (or more) singular values are very close */ +/* together (their difference is small). */ + +/* If the value in the z-vector is small, we simply permute the */ +/* array so that the corresponding singular value is moved to the */ +/* end. */ + +/* If two values in the D-vector are close, we perform a two-sided */ +/* rotation designed to make one of the corresponding z-vector */ +/* entries zero, and then permute the array so that the deflated */ +/* singular value is moved to the end. */ + +/* If there are multiple singular values then the problem deflates. */ +/* Here the number of equal singular values are found. As each equal */ +/* singular value is found, an elementary reflector is computed to */ +/* rotate the corresponding singular subspace so that the */ +/* corresponding components of Z are zero in this new basis. */ + + *k = 1; + k2 = n + 1; + i__1 = n; + for (j = 2; j <= i__1; ++j) { + if ((d__1 = z__[j], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + idxp[k2] = j; + if (j == n) { + goto L100; + } + } else { + jprev = j; + goto L70; + } +/* L60: */ + } +L70: + j = jprev; +L80: + ++j; + if (j > n) { + goto L90; + } + if ((d__1 = z__[j], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + idxp[k2] = j; + } else { + +/* Check if singular values are close enough to allow deflation. */ + + if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) { + +/* Deflation is possible. */ + + *s = z__[jprev]; + *c__ = z__[j]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = dlapy2_(c__, s); + z__[j] = tau; + z__[jprev] = 0.; + *c__ /= tau; + *s = -(*s) / tau; + +/* Record the appropriate Givens rotation */ + + if (*icompq == 1) { + ++(*givptr); + idxjp = idxq[idx[jprev] + 1]; + idxj = idxq[idx[j] + 1]; + if (idxjp <= nlp1) { + --idxjp; + } + if (idxj <= nlp1) { + --idxj; + } + givcol[*givptr + (givcol_dim1 << 1)] = idxjp; + givcol[*givptr + givcol_dim1] = idxj; + givnum[*givptr + (givnum_dim1 << 1)] = *c__; + givnum[*givptr + givnum_dim1] = *s; + } + drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s); + drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s); + --k2; + idxp[k2] = jprev; + jprev = j; + } else { + ++(*k); + zw[*k] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + jprev = j; + } + } + goto L80; +L90: + +/* Record the last singular value. */ + + ++(*k); + zw[*k] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + +L100: + +/* Sort the singular values into DSIGMA. The singular values which */ +/* were not deflated go into the first K slots of DSIGMA, except */ +/* that DSIGMA(1) is treated separately. */ + + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + dsigma[j] = d__[jp]; + vfw[j] = vf[jp]; + vlw[j] = vl[jp]; +/* L110: */ + } + if (*icompq == 1) { + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + perm[j] = idxq[idx[jp] + 1]; + if (perm[j] <= nlp1) { + --perm[j]; + } +/* L120: */ + } + } + +/* The deflated singular values go back into the last N - K slots of */ +/* D. */ + + i__1 = n - *k; + dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1); + +/* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and */ +/* VL(M). */ + + dsigma[1] = 0.; + hlftol = tol / 2.; + if (abs(dsigma[2]) <= hlftol) { + dsigma[2] = hlftol; + } + if (m > n) { + z__[1] = dlapy2_(&z1, &z__[m]); + if (z__[1] <= tol) { + *c__ = 1.; + *s = 0.; + z__[1] = tol; + } else { + *c__ = z1 / z__[1]; + *s = -z__[m] / z__[1]; + } + drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s); + drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s); + } else { + if (abs(z1) <= tol) { + z__[1] = tol; + } else { + z__[1] = z1; + } + } + +/* Restore Z, VF, and VL. */ + + i__1 = *k - 1; + dcopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1); + i__1 = n - 1; + dcopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1); + i__1 = n - 1; + dcopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1); + + return 0; + +/* End of DLASD7 */ + +} /* dlasd7_ */ + +/* Subroutine */ int dlasd8_(integer *icompq, integer *k, double *d__, + double *z__, double *vf, double *vl, double *difl, + double *difr, integer *lddifr, double *dsigma, double * + work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__0 = 0; + static double c_b8 = 1.; + + /* System generated locals */ + integer difr_dim1, difr_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double dj, rho; + integer iwk1, iwk2, iwk3; + double temp; + integer iwk2i, iwk3i; + double diflj, difrj, dsigj; + double dsigjp; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASD8 finds the square roots of the roots of the secular equation, */ +/* as defined by the values in DSIGMA and Z. It makes the appropriate */ +/* calls to DLASD4, and stores, for each element in D, the distance */ +/* to its two nearest poles (elements in DSIGMA). It also updates */ +/* the arrays VF and VL, the first and last components of all the */ +/* right singular vectors of the original bidiagonal matrix. */ + +/* DLASD8 is called from DLASD6. */ + +/* Arguments */ +/* ========= */ + +/* ICOMPQ (input) INTEGER */ +/* Specifies whether singular vectors are to be computed in */ +/* factored form in the calling routine: */ +/* = 0: Compute singular values only. */ +/* = 1: Compute singular vectors in factored form as well. */ + +/* K (input) INTEGER */ +/* The number of terms in the rational function to be solved */ +/* by DLASD4. K >= 1. */ + +/* D (output) DOUBLE PRECISION array, dimension ( K ) */ +/* On output, D contains the updated singular values. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( K ) */ +/* The first K elements of this array contain the components */ +/* of the deflation-adjusted updating row vector. */ + +/* VF (input/output) DOUBLE PRECISION array, dimension ( K ) */ +/* On entry, VF contains information passed through DBEDE8. */ +/* On exit, VF contains the first K components of the first */ +/* components of all right singular vectors of the bidiagonal */ +/* matrix. */ + +/* VL (input/output) DOUBLE PRECISION array, dimension ( K ) */ +/* On entry, VL contains information passed through DBEDE8. */ +/* On exit, VL contains the first K components of the last */ +/* components of all right singular vectors of the bidiagonal */ +/* matrix. */ + +/* DIFL (output) DOUBLE PRECISION array, dimension ( K ) */ +/* On exit, DIFL(I) = D(I) - DSIGMA(I). */ + +/* DIFR (output) DOUBLE PRECISION array, */ +/* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */ +/* dimension ( K ) if ICOMPQ = 0. */ +/* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */ +/* defined and will not be referenced. */ + +/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */ +/* normalizing factors for the right singular vector matrix. */ + +/* LDDIFR (input) INTEGER */ +/* The leading dimension of DIFR, must be at least K. */ + +/* DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) */ +/* The first K elements of this array contain the old roots */ +/* of the deflated updating problem. These are the poles */ +/* of the secular equation. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an singular value did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --z__; + --vf; + --vl; + --difl; + difr_dim1 = *lddifr; + difr_offset = 1 + difr_dim1; + difr -= difr_offset; + --dsigma; + --work; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*k < 1) { + *info = -2; + } else if (*lddifr < *k) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASD8", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*k == 1) { + d__[1] = abs(z__[1]); + difl[1] = d__[1]; + if (*icompq == 1) { + difl[2] = 1.; + difr[(difr_dim1 << 1) + 1] = 1.; + } + return 0; + } + +/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */ +/* be computed with high relative accuracy (barring over/underflow). */ +/* This is a problem on machines without a guard digit in */ +/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ +/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */ +/* which on any of these machines zeros out the bottommost */ +/* bit of DSIGMA(I) if it is 1; this makes the subsequent */ +/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */ +/* occurs. On binary machines with a guard digit (almost all */ +/* machines) it does not change DSIGMA(I) at all. On hexadecimal */ +/* and decimal machines with a guard digit, it slightly */ +/* changes the bottommost bits of DSIGMA(I). It does not account */ +/* for hexadecimal or decimal machines without guard digits */ +/* (we know of none). We use a subroutine call to compute */ +/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */ +/* this code. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; +/* L10: */ + } + +/* Book keeping. */ + + iwk1 = 1; + iwk2 = iwk1 + *k; + iwk3 = iwk2 + *k; + iwk2i = iwk2 - 1; + iwk3i = iwk3 - 1; + +/* Normalize Z. */ + + rho = dnrm2_(k, &z__[1], &c__1); + dlascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info); + rho *= rho; + +/* Initialize WORK(IWK3). */ + + dlaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k); + +/* Compute the updated singular values, the arrays DIFL, DIFR, */ +/* and the updated Z. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[ + iwk2], info); + +/* If the root finder fails, the computation is terminated. */ + + if (*info != 0) { + return 0; + } + work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j]; + difl[j] = -work[j]; + difr[j + difr_dim1] = -work[j + 1]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + + i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ + j]); +/* L20: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + + i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ + j]); +/* L30: */ + } +/* L40: */ + } + +/* Compute updated Z. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1))); + z__[i__] = d_sign(&d__2, &z__[i__]); +/* L50: */ + } + +/* Update VF and VL. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + diflj = difl[j]; + dj = d__[j]; + dsigj = -dsigma[j]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -dsigma[j + 1]; + } + work[j] = -z__[j] / diflj / (dsigma[j] + dj); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / ( + dsigma[i__] + dj); +/* L60: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) / + (dsigma[i__] + dj); +/* L70: */ + } + temp = dnrm2_(k, &work[1], &c__1); + work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp; + work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp; + if (*icompq == 1) { + difr[j + (difr_dim1 << 1)] = temp; + } +/* L80: */ + } + + dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1); + dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1); + + return 0; + +/* End of DLASD8 */ + +} /* dlasd8_ */ + +/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n, + integer *sqre, double *d__, double *e, double *u, integer + *ldu, double *vt, integer *k, double *difl, double *difr, + double *z__, double *poles, integer *givptr, integer *givcol, + integer *ldgcol, integer *perm, double *givnum, double *c__, + double *s, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__0 = 0; + static double c_b11 = 0.; + static double c_b12 = 1.; + static integer c__1 = 1; + static integer c__2 = 2; + + /* System generated locals */ + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, + difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, + poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, + z_dim1, z_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf, + vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1; + double beta; + integer idxq, nlvl; + double alpha; + integer inode, ndiml, ndimr, idxqi, itemp; + integer sqrei; + integer nwork1, nwork2; + integer smlszp; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Using a divide and conquer approach, DLASDA computes the singular */ +/* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix */ +/* B with diagonal D and offdiagonal E, where M = N + SQRE. The */ +/* algorithm computes the singular values in the SVD B = U * S * VT. */ +/* The orthogonal matrices U and VT are optionally computed in */ +/* compact form. */ + +/* A related subroutine, DLASD0, computes the singular values and */ +/* the singular vectors in explicit form. */ + +/* Arguments */ +/* ========= */ + +/* ICOMPQ (input) INTEGER */ +/* Specifies whether singular vectors are to be computed */ +/* in compact form, as follows */ +/* = 0: Compute singular values only. */ +/* = 1: Compute singular vectors of upper bidiagonal */ +/* matrix in compact form. */ + +/* SMLSIZ (input) INTEGER */ +/* The maximum size of the subproblems at the bottom of the */ +/* computation tree. */ + +/* N (input) INTEGER */ +/* The row dimension of the upper bidiagonal matrix. This is */ +/* also the dimension of the main diagonal array D. */ + +/* SQRE (input) INTEGER */ +/* Specifies the column dimension of the bidiagonal matrix. */ +/* = 0: The bidiagonal matrix has column dimension M = N; */ +/* = 1: The bidiagonal matrix has column dimension M = N + 1. */ + +/* D (input/output) DOUBLE PRECISION array, dimension ( N ) */ +/* On entry D contains the main diagonal of the bidiagonal */ +/* matrix. On exit D, if INFO = 0, contains its singular values. */ + +/* E (input) DOUBLE PRECISION array, dimension ( M-1 ) */ +/* Contains the subdiagonal entries of the bidiagonal matrix. */ +/* On exit, E has been destroyed. */ + +/* U (output) DOUBLE PRECISION array, */ +/* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced */ +/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left */ +/* singular vector matrices of all subproblems at the bottom */ +/* level. */ + +/* LDU (input) INTEGER, LDU = > N. */ +/* The leading dimension of arrays U, VT, DIFL, DIFR, POLES, */ +/* GIVNUM, and Z. */ + +/* VT (output) DOUBLE PRECISION array, */ +/* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced */ +/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right */ +/* singular vector matrices of all subproblems at the bottom */ +/* level. */ + +/* K (output) INTEGER array, */ +/* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. */ +/* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th */ +/* secular equation on the computation tree. */ + +/* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ), */ +/* where NLVL = floor(log_2 (N/SMLSIZ))). */ + +/* DIFR (output) DOUBLE PRECISION array, */ +/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and */ +/* dimension ( N ) if ICOMPQ = 0. */ +/* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) */ +/* record distances between singular values on the I-th */ +/* level and singular values on the (I -1)-th level, and */ +/* DIFR(1:N, 2 * I ) contains the normalizing factors for */ +/* the right singular vector matrix. See DLASD8 for details. */ + +/* Z (output) DOUBLE PRECISION array, */ +/* dimension ( LDU, NLVL ) if ICOMPQ = 1 and */ +/* dimension ( N ) if ICOMPQ = 0. */ +/* The first K elements of Z(1, I) contain the components of */ +/* the deflation-adjusted updating row vector for subproblems */ +/* on the I-th level. */ + +/* POLES (output) DOUBLE PRECISION array, */ +/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced */ +/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and */ +/* POLES(1, 2*I) contain the new and old singular values */ +/* involved in the secular equations on the I-th level. */ + +/* GIVPTR (output) INTEGER array, */ +/* dimension ( N ) if ICOMPQ = 1, and not referenced if */ +/* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records */ +/* the number of Givens rotations performed on the I-th */ +/* problem on the computation tree. */ + +/* GIVCOL (output) INTEGER array, */ +/* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not */ +/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */ +/* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations */ +/* of Givens rotations performed on the I-th level on the */ +/* computation tree. */ + +/* LDGCOL (input) INTEGER, LDGCOL = > N. */ +/* The leading dimension of arrays GIVCOL and PERM. */ + +/* PERM (output) INTEGER array, */ +/* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced */ +/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records */ +/* permutations done on the I-th level of the computation tree. */ + +/* GIVNUM (output) DOUBLE PRECISION array, */ +/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not */ +/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */ +/* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- */ +/* values of Givens rotations performed on the I-th level on */ +/* the computation tree. */ + +/* C (output) DOUBLE PRECISION array, */ +/* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. */ +/* If ICOMPQ = 1 and the I-th subproblem is not square, on exit, */ +/* C( I ) contains the C-value of a Givens rotation related to */ +/* the right null space of the I-th subproblem. */ + +/* S (output) DOUBLE PRECISION array, dimension ( N ) if */ +/* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 */ +/* and the I-th subproblem is not square, on exit, S( I ) */ +/* contains the S-value of a Givens rotation related to */ +/* the right null space of the I-th subproblem. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension */ +/* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */ + +/* IWORK (workspace) INTEGER array. */ +/* Dimension must be at least (7 * N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = 1, an singular value did not converge */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + givnum_dim1 = *ldu; + givnum_offset = 1 + givnum_dim1; + givnum -= givnum_offset; + poles_dim1 = *ldu; + poles_offset = 1 + poles_dim1; + poles -= poles_offset; + z_dim1 = *ldu; + z_offset = 1 + z_dim1; + z__ -= z_offset; + difr_dim1 = *ldu; + difr_offset = 1 + difr_dim1; + difr -= difr_offset; + difl_dim1 = *ldu; + difl_offset = 1 + difl_dim1; + difl -= difl_offset; + vt_dim1 = *ldu; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + --k; + --givptr; + perm_dim1 = *ldgcol; + perm_offset = 1 + perm_dim1; + perm -= perm_offset; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1; + givcol -= givcol_offset; + --c__; + --s; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*smlsiz < 3) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldu < *n + *sqre) { + *info = -8; + } else if (*ldgcol < *n) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASDA", &i__1); + return 0; + } + + m = *n + *sqre; + +/* If the input matrix is too small, call DLASDQ to find the SVD. */ + + if (*n <= *smlsiz) { + if (*icompq == 0) { + dlasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ + vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, & + work[1], info); + } else { + dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset] +, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], + info); + } + return 0; + } + +/* Book-keeping and set up the computation tree. */ + + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + idxq = ndimr + *n; + iwk = idxq + *n; + + ncc = 0; + nru = 0; + + smlszp = *smlsiz + 1; + vf = 1; + vl = vf + m; + nwork1 = vl + m; + nwork2 = nwork1 + smlszp * smlszp; + + dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); + +/* for the nodes on bottom level of the tree, solve */ +/* their subproblems by DLASDQ. */ + + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + +/* IC : center row of each node */ +/* NL : number of rows of left subproblem */ +/* NR : number of rows of right subproblem */ +/* NLF: starting row of the left subproblem */ +/* NRF: starting row of the right subproblem */ + + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nlp1 = nl + 1; + nr = iwork[ndimr + i1]; + nlf = ic - nl; + nrf = ic + 1; + idxqi = idxq + nlf - 2; + vfi = vf + nlf - 1; + vli = vl + nlf - 1; + sqrei = 1; + if (*icompq == 0) { + dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp); + dlasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], & + work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2], + &nl, &work[nwork2], info); + itemp = nwork1 + nl * smlszp; + dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1); + dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1); + } else { + dlaset_("A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu); + dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], + ldu); + dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], & + vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf + + u_dim1], ldu, &work[nwork1], info); + dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1); + dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1) + ; + } + if (*info != 0) { + return 0; + } + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + iwork[idxqi + j] = j; +/* L10: */ + } + if (i__ == nd && *sqre == 0) { + sqrei = 0; + } else { + sqrei = 1; + } + idxqi += nlp1; + vfi += nlp1; + vli += nlp1; + nrp1 = nr + sqrei; + if (*icompq == 0) { + dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp); + dlasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], & + work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2], + &nr, &work[nwork2], info); + itemp = nwork1 + (nrp1 - 1) * smlszp; + dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1); + dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1); + } else { + dlaset_("A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu); + dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], + ldu); + dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], & + vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf + + u_dim1], ldu, &work[nwork1], info); + dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1); + dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1) + ; + } + if (*info != 0) { + return 0; + } + i__2 = nr; + for (j = 1; j <= i__2; ++j) { + iwork[idxqi + j] = j; +/* L20: */ + } +/* L30: */ + } + +/* Now conquer each subproblem bottom-up. */ + + j = pow_ii(&c__2, &nlvl); + for (lvl = nlvl; lvl >= 1; --lvl) { + lvl2 = (lvl << 1) - 1; + +/* Find the first node LF and last node LL on */ +/* the current level LVL. */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + if (i__ == ll) { + sqrei = *sqre; + } else { + sqrei = 1; + } + vfi = vf + nlf - 1; + vli = vl + nlf - 1; + idxqi = idxq + nlf - 1; + alpha = d__[ic]; + beta = e[ic]; + if (*icompq == 0) { + dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & + work[vli], &alpha, &beta, &iwork[idxqi], &perm[ + perm_offset], &givptr[1], &givcol[givcol_offset], + ldgcol, &givnum[givnum_offset], ldu, &poles[ + poles_offset], &difl[difl_offset], &difr[difr_offset], + &z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1], + &iwork[iwk], info); + } else { + --j; + dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & + work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf + + lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * + givcol_dim1], ldgcol, &givnum[nlf + lvl2 * + givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], & + difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * + difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j], + &s[j], &work[nwork1], &iwork[iwk], info); + } + if (*info != 0) { + return 0; + } +/* L40: */ + } +/* L50: */ + } + + return 0; + +/* End of DLASDA */ + +} /* dlasda_ */ + +/* Subroutine */ int dlasdq_(const char *uplo, integer *sqre, integer *n, integer * + ncvt, integer *nru, integer *ncc, double *d__, double *e, + double *vt, integer *ldvt, double *u, integer *ldu, + double *c__, integer *ldc, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, + i__2; + + /* Local variables */ + integer i__, j; + double r__, cs, sn; + integer np1, isub; + double smin; + integer sqre1; + integer iuplo; + bool rotate; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASDQ computes the singular value decomposition (SVD) of a real */ +/* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal */ +/* E, accumulating the transformations if desired. Letting B denote */ +/* the input bidiagonal matrix, the algorithm computes orthogonal */ +/* matrices Q and P such that B = Q * S * P' (P' denotes the transpose */ +/* of P). The singular values S are overwritten on D. */ + +/* The input matrix U is changed to U * Q if desired. */ +/* The input matrix VT is changed to P' * VT if desired. */ +/* The input matrix C is changed to Q' * C if desired. */ + +/* See "Computing Small Singular Values of Bidiagonal Matrices With */ +/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */ +/* LAPACK Working Note #3, for a detailed description of the algorithm. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* On entry, UPLO specifies whether the input bidiagonal matrix */ +/* is upper or lower bidiagonal, and wether it is square are */ +/* not. */ +/* UPLO = 'U' or 'u' B is upper bidiagonal. */ +/* UPLO = 'L' or 'l' B is lower bidiagonal. */ + +/* SQRE (input) INTEGER */ +/* = 0: then the input matrix is N-by-N. */ +/* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and */ +/* (N+1)-by-N if UPLU = 'L'. */ + +/* The bidiagonal matrix has */ +/* N = NL + NR + 1 rows and */ +/* M = N + SQRE >= N columns. */ + +/* N (input) INTEGER */ +/* On entry, N specifies the number of rows and columns */ +/* in the matrix. N must be at least 0. */ + +/* NCVT (input) INTEGER */ +/* On entry, NCVT specifies the number of columns of */ +/* the matrix VT. NCVT must be at least 0. */ + +/* NRU (input) INTEGER */ +/* On entry, NRU specifies the number of rows of */ +/* the matrix U. NRU must be at least 0. */ + +/* NCC (input) INTEGER */ +/* On entry, NCC specifies the number of columns of */ +/* the matrix C. NCC must be at least 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, D contains the diagonal entries of the */ +/* bidiagonal matrix whose SVD is desired. On normal exit, */ +/* D contains the singular values in ascending order. */ + +/* E (input/output) DOUBLE PRECISION array. */ +/* dimension is (N-1) if SQRE = 0 and N if SQRE = 1. */ +/* On entry, the entries of E contain the offdiagonal entries */ +/* of the bidiagonal matrix whose SVD is desired. On normal */ +/* exit, E will contain 0. If the algorithm does not converge, */ +/* D and E will contain the diagonal and superdiagonal entries */ +/* of a bidiagonal matrix orthogonally equivalent to the one */ +/* given as input. */ + +/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */ +/* On entry, contains a matrix which on exit has been */ +/* premultiplied by P', dimension N-by-NCVT if SQRE = 0 */ +/* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). */ + +/* LDVT (input) INTEGER */ +/* On entry, LDVT specifies the leading dimension of VT as */ +/* declared in the calling (sub) program. LDVT must be at */ +/* least 1. If NCVT is nonzero LDVT must also be at least N. */ + +/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */ +/* On entry, contains a matrix which on exit has been */ +/* postmultiplied by Q, dimension NRU-by-N if SQRE = 0 */ +/* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). */ + +/* LDU (input) INTEGER */ +/* On entry, LDU specifies the leading dimension of U as */ +/* declared in the calling (sub) program. LDU must be at */ +/* least max( 1, NRU ) . */ + +/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */ +/* On entry, contains an N-by-NCC matrix which on exit */ +/* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 */ +/* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). */ + +/* LDC (input) INTEGER */ +/* On entry, LDC specifies the leading dimension of C as */ +/* declared in the calling (sub) program. LDC must be at */ +/* least 1. If NCC is nonzero, LDC must also be at least N. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ +/* Workspace. Only referenced if one of NCVT, NRU, or NCC is */ +/* nonzero, and if N is at least 2. */ + +/* INFO (output) INTEGER */ +/* On exit, a value of 0 indicates a successful exit. */ +/* If INFO < 0, argument number -INFO is illegal. */ +/* If INFO > 0, the algorithm did not converge, and INFO */ +/* specifies how many superdiagonals did not converge. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + iuplo = 0; + if (lsame_(uplo, "U")) { + iuplo = 1; + } + if (lsame_(uplo, "L")) { + iuplo = 2; + } + if (iuplo == 0) { + *info = -1; + } else if (*sqre < 0 || *sqre > 1) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ncvt < 0) { + *info = -4; + } else if (*nru < 0) { + *info = -5; + } else if (*ncc < 0) { + *info = -6; + } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < std::max(1_integer,*n)) { + *info = -10; + } else if (*ldu < std::max(1_integer,*nru)) { + *info = -12; + } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < std::max(1_integer,*n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASDQ", &i__1); + return 0; + } + if (*n == 0) { + return 0; + } + +/* ROTATE is true if any singular vectors desired, false otherwise */ + + rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; + np1 = *n + 1; + sqre1 = *sqre; + +/* If matrix non-square upper bidiagonal, rotate to be lower */ +/* bidiagonal. The rotations are on the right. */ + + if (iuplo == 1 && sqre1 == 1) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (rotate) { + work[i__] = cs; + work[*n + i__] = sn; + } +/* L10: */ + } + dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); + d__[*n] = r__; + e[*n] = 0.; + if (rotate) { + work[*n] = cs; + work[*n + *n] = sn; + } + iuplo = 2; + sqre1 = 0; + +/* Update singular vectors if desired. */ + + if (*ncvt > 0) { + dlasr_("L", "V", "F", &np1, ncvt, &work[1], &work[np1], &vt[ + vt_offset], ldvt); + } + } + +/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ +/* by applying Givens rotations on the left. */ + + if (iuplo == 2) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (rotate) { + work[i__] = cs; + work[*n + i__] = sn; + } +/* L20: */ + } + +/* If matrix (N+1)-by-N lower bidiagonal, one additional */ +/* rotation is needed. */ + + if (sqre1 == 1) { + dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__); + d__[*n] = r__; + if (rotate) { + work[*n] = cs; + work[*n + *n] = sn; + } + } + +/* Update singular vectors if desired. */ + + if (*nru > 0) { + if (sqre1 == 0) { + dlasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[ + u_offset], ldu); + } else { + dlasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[ + u_offset], ldu); + } + } + if (*ncc > 0) { + if (sqre1 == 0) { + dlasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[ + c_offset], ldc); + } else { + dlasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[ + c_offset], ldc); + } + } + } + +/* Call DBDSQR to compute the SVD of the reduced real */ +/* N-by-N upper bidiagonal matrix. */ + + dbdsqr_("U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[ + u_offset], ldu, &c__[c_offset], ldc, &work[1], info); + +/* Sort the singular values into ascending order (insertion sort on */ +/* singular values, but only one transposition per singular vector) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for smallest D(I). */ + + isub = i__; + smin = d__[i__]; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (d__[j] < smin) { + isub = j; + smin = d__[j]; + } +/* L30: */ + } + if (isub != i__) { + +/* Swap singular values and vectors. */ + + d__[isub] = d__[i__]; + d__[i__] = smin; + if (*ncvt > 0) { + dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], + ldvt); + } + if (*nru > 0) { + dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1] +, &c__1); + } + if (*ncc > 0) { + dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc) + ; + } + } +/* L40: */ + } + + return 0; + +/* End of DLASDQ */ + +} /* dlasdq_ */ + +/* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer * + inode, integer *ndiml, integer *ndimr, integer *msub) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, il, ir, maxn; + double temp; + integer nlvl, llst, ncrnt; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASDT creates a tree of subproblems for bidiagonal divide and */ +/* conquer. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* On entry, the number of diagonal elements of the */ +/* bidiagonal matrix. */ + +/* LVL (output) INTEGER */ +/* On exit, the number of levels on the computation tree. */ + +/* ND (output) INTEGER */ +/* On exit, the number of nodes on the tree. */ + +/* INODE (output) INTEGER array, dimension ( N ) */ +/* On exit, centers of subproblems. */ + +/* NDIML (output) INTEGER array, dimension ( N ) */ +/* On exit, row dimensions of left children. */ + +/* NDIMR (output) INTEGER array, dimension ( N ) */ +/* On exit, row dimensions of right children. */ + +/* MSUB (input) INTEGER. */ +/* On entry, the maximum row dimension each subproblem at the */ +/* bottom of the tree can be of. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Ming Gu and Huan Ren, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Find the number of levels on the tree. */ + + /* Parameter adjustments */ + --ndimr; + --ndiml; + --inode; + + /* Function Body */ + maxn = std::max(1_integer,*n); + temp = log((double) maxn / (double) (*msub + 1)) / log(2.); + *lvl = (integer) temp + 1; + + i__ = *n / 2; + inode[1] = i__ + 1; + ndiml[1] = i__; + ndimr[1] = *n - i__ - 1; + il = 0; + ir = 1; + llst = 1; + i__1 = *lvl - 1; + for (nlvl = 1; nlvl <= i__1; ++nlvl) { + +/* Constructing the tree at (NLVL+1)-st level. The number of */ +/* nodes created on this level is LLST * 2. */ + + i__2 = llst - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + il += 2; + ir += 2; + ncrnt = llst + i__; + ndiml[il] = ndiml[ncrnt] / 2; + ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1; + inode[il] = inode[ncrnt] - ndimr[il] - 1; + ndiml[ir] = ndimr[ncrnt] / 2; + ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1; + inode[ir] = inode[ncrnt] + ndiml[ir] + 1; +/* L10: */ + } + llst <<= 1; +/* L20: */ + } + *nd = (llst << 1) - 1; + + return 0; + +/* End of DLASDT */ + +} /* dlasdt_ */ + +/* Subroutine */ int dlaset_(const char *uplo, integer *m, integer *n, double * + alpha, double *beta, double *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASET initializes an m-by-n matrix A to BETA on the diagonal and */ +/* ALPHA on the offdiagonals. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies the part of the matrix A to be set. */ +/* = 'U': Upper triangular part is set; the strictly lower */ +/* triangular part of A is not changed. */ +/* = 'L': Lower triangular part is set; the strictly upper */ +/* triangular part of A is not changed. */ +/* Otherwise: All of the matrix A is set. */ + +/* 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. */ + +/* ALPHA (input) DOUBLE PRECISION */ +/* The constant to which the offdiagonal elements are to be set. */ + +/* BETA (input) DOUBLE PRECISION */ +/* The constant to which the diagonal elements are to be set. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On exit, the leading m-by-n submatrix of A is set as follows: */ + +/* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */ +/* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */ +/* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */ + +/* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + if (lsame_(uplo, "U")) { + +/* Set the strictly upper triangular or trapezoidal part of the */ +/* array to ALPHA. */ + + i__1 = *n; + for (j = 2; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = j - 1; + i__2 = std::min(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +/* L10: */ + } +/* L20: */ + } + + } else if (lsame_(uplo, "L")) { + +/* Set the strictly lower triangular or trapezoidal part of the */ +/* array to ALPHA. */ + + i__1 = std::min(*m,*n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +/* L30: */ + } +/* L40: */ + } + + } else { + +/* Set the leading m-by-n submatrix to ALPHA. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +/* L50: */ + } +/* L60: */ + } + } + +/* Set the first min(M,N) diagonal elements to BETA. */ + + i__1 = std::min(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + i__ * a_dim1] = *beta; +/* L70: */ + } + + return 0; + +/* End of DLASET */ + +} /* dlaset_ */ + +/* Subroutine */ int dlasq1_(integer *n, double *d__, double *e, + double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__2 = 2; + static integer c__0 = 0; + + /* System generated locals */ + integer i__1, i__2; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__; + double eps; + double scale; + integer iinfo; + double sigmn; + double sigmx; + double safmin; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASQ1 computes the singular values of a real N-by-N bidiagonal */ +/* matrix with diagonal D and off-diagonal E. The singular values */ +/* are computed to high relative accuracy, in the absence of */ +/* denormalization, underflow and overflow. The algorithm was first */ +/* presented in */ + +/* "Accurate singular values and differential qd algorithms" by K. V. */ +/* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, */ +/* 1994, */ + +/* and the present implementation is described in "An implementation of */ +/* the dqds Algorithm (Positive Case)", LAPACK Working Note. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of rows and columns in the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, D contains the diagonal elements of the */ +/* bidiagonal matrix whose SVD is desired. On normal exit, */ +/* D contains the singular values in decreasing order. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, elements E(1:N-1) contain the off-diagonal elements */ +/* of the bidiagonal matrix whose SVD is desired. */ +/* On exit, E is overwritten. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: the algorithm failed */ +/* = 1, a split was marked by a positive value in E */ +/* = 2, current block of Z not diagonalized after 30*N */ +/* iterations (in inner while loop) */ +/* = 3, termination criterion of outer while loop not met */ +/* (program created more than N unreduced blocks) */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --work; + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -2; + i__1 = -(*info); + xerbla_("DLASQ1", &i__1); + return 0; + } else if (*n == 0) { + return 0; + } else if (*n == 1) { + d__[1] = abs(d__[1]); + return 0; + } else if (*n == 2) { + dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); + d__[1] = sigmx; + d__[2] = sigmn; + return 0; + } + +/* Estimate the largest singular value. */ + + sigmx = 0.; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = (d__1 = d__[i__], abs(d__1)); +/* Computing MAX */ + d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1)); + sigmx = std::max(d__2,d__3); +/* L10: */ + } + d__[*n] = (d__1 = d__[*n], abs(d__1)); + +/* Early return if SIGMX is zero (matrix is already diagonal). */ + + if (sigmx == 0.) { + dlasrt_("D", n, &d__[1], &iinfo); + return 0; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = sigmx, d__2 = d__[i__]; + sigmx = std::max(d__1,d__2); +/* L20: */ + } + +/* Copy D and E into WORK (in the Z format) and scale (squaring the */ +/* input data makes scaling by a power of the radix pointless). */ + + eps = dlamch_("Precision"); + safmin = dlamch_("Safe minimum"); + scale = sqrt(eps / safmin); + dcopy_(n, &d__[1], &c__1, &work[1], &c__2); + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2); + i__1 = (*n << 1) - 1; + i__2 = (*n << 1) - 1; + dlascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, + &iinfo); + +/* Compute the q's and e's. */ + + i__1 = (*n << 1) - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing 2nd power */ + d__1 = work[i__]; + work[i__] = d__1 * d__1; +/* L30: */ + } + work[*n * 2] = 0.; + + dlasq2_(n, &work[1], info); + + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(work[i__]); +/* L40: */ + } + dlascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & + iinfo); + } + + return 0; + +/* End of DLASQ1 */ + +} /* dlasq1_ */ + +/* Subroutine */ int dlasq2_(integer *n, double *z__, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__2 = 2; + static integer c__10 = 10; + static integer c__3 = 3; + static integer c__4 = 4; + static integer c__11 = 11; + + /* System generated locals */ + integer i__1, i__2, i__3; + double d__1, d__2; + + /* Local variables */ + double d__, e, g; + integer k; + double s, t; + integer i0, i4, n0; + double dn; + integer pp; + double dn1, dn2, dee, eps, tau, tol; + integer ipn4; + double tol2; + bool ieee; + integer nbig; + double dmin__, emin, emax; + integer kmin, ndiv, iter; + double qmin, temp, qmax, zmax; + integer splt; + double dmin1, dmin2; + integer nfail; + double desig, trace, sigma; + integer iinfo, ttype; + double deemin; + integer iwhila, iwhilb; + double oldemn, safmin; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */ +/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */ +/* -- Berkeley -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASQ2 computes all the eigenvalues of the symmetric positive */ +/* definite tridiagonal matrix associated with the qd array Z to high */ +/* relative accuracy are computed to high relative accuracy, in the */ +/* absence of denormalization, underflow and overflow. */ + +/* To see the relation of Z to the tridiagonal matrix, let L be a */ +/* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and */ +/* let U be an upper bidiagonal matrix with 1's above and diagonal */ +/* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the */ +/* symmetric tridiagonal to which it is similar. */ + +/* Note : DLASQ2 defines a logical variable, IEEE, which is true */ +/* on machines which follow ieee-754 floating-point standard in their */ +/* handling of infinities and NaNs, and false otherwise. This variable */ +/* is passed to DLASQ3. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of rows and columns in the matrix. N >= 0. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension ( 4*N ) */ +/* On entry Z holds the qd array. On exit, entries 1 to N hold */ +/* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the */ +/* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If */ +/* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) */ +/* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of */ +/* shifts that failed. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if the i-th argument is a scalar and had an illegal */ +/* value, then INFO = -i, if the i-th argument is an */ +/* array and the j-entry had an illegal value, then */ +/* INFO = -(i*100+j) */ +/* > 0: the algorithm failed */ +/* = 1, a split was marked by a positive value in E */ +/* = 2, current block of Z not diagonalized after 30*N */ +/* iterations (in inner while loop) */ +/* = 3, termination criterion of outer while loop not met */ +/* (program created more than N unreduced blocks) */ + +/* Further Details */ +/* =============== */ +/* Local Variables: I0:N0 defines a current unreduced segment of Z. */ +/* The shifts are accumulated in SIGMA. Iteration count is in ITER. */ +/* Ping-pong is controlled by PP (alternates between 0 and 1). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments. */ +/* (in case DLASQ2 is not called by DLASQ1) */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + *info = 0; + eps = dlamch_("Precision"); + safmin = dlamch_("Safe minimum"); + tol = eps * 100.; +/* Computing 2nd power */ + d__1 = tol; + tol2 = d__1 * d__1; + + if (*n < 0) { + *info = -1; + xerbla_("DLASQ2", &c__1); + return 0; + } else if (*n == 0) { + return 0; + } else if (*n == 1) { + +/* 1-by-1 case. */ + + if (z__[1] < 0.) { + *info = -201; + xerbla_("DLASQ2", &c__2); + } + return 0; + } else if (*n == 2) { + +/* 2-by-2 case. */ + + if (z__[2] < 0. || z__[3] < 0.) { + *info = -2; + xerbla_("DLASQ2", &c__2); + return 0; + } else if (z__[3] > z__[1]) { + d__ = z__[3]; + z__[3] = z__[1]; + z__[1] = d__; + } + z__[5] = z__[1] + z__[2] + z__[3]; + if (z__[2] > z__[3] * tol2) { + t = (z__[1] - z__[3] + z__[2]) * .5; + s = z__[3] * (z__[2] / t); + if (s <= t) { + s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.))); + } else { + s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[1] + (s + z__[2]); + z__[3] *= z__[1] / t; + z__[1] = t; + } + z__[2] = z__[3]; + z__[6] = z__[2] + z__[1]; + return 0; + } + +/* Check for negative data and compute sums of q's and e's. */ + + z__[*n * 2] = 0.; + emin = z__[2]; + qmax = 0.; + zmax = 0.; + d__ = 0.; + e = 0.; + + i__1 = *n - 1 << 1; + for (k = 1; k <= i__1; k += 2) { + if (z__[k] < 0.) { + *info = -(k + 200); + xerbla_("DLASQ2", &c__2); + return 0; + } else if (z__[k + 1] < 0.) { + *info = -(k + 201); + xerbla_("DLASQ2", &c__2); + return 0; + } + d__ += z__[k]; + e += z__[k + 1]; +/* Computing MAX */ + d__1 = qmax, d__2 = z__[k]; + qmax = std::max (d__1,d__2); +/* Computing MIN */ + d__1 = emin, d__2 = z__[k + 1]; + emin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = std::max (qmax,zmax), d__2 = z__[k + 1]; + zmax = std::max (d__1,d__2); +/* L10: */ + } + if (z__[(*n << 1) - 1] < 0.) { + *info = -((*n << 1) + 199); + xerbla_("DLASQ2", &c__2); + return 0; + } + d__ += z__[(*n << 1) - 1]; +/* Computing MAX */ + d__1 = qmax, d__2 = z__[(*n << 1) - 1]; + qmax = std::max (d__1,d__2); + zmax = std::max (qmax,zmax); + +/* Check for diagonality. */ + + if (e == 0.) { + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + z__[k] = z__[(k << 1) - 1]; +/* L20: */ + } + dlasrt_("D", n, &z__[1], &iinfo); + z__[(*n << 1) - 1] = d__; + return 0; + } + + trace = d__ + e; + +/* Check for zero data. */ + + if (trace == 0.) { + z__[(*n << 1) - 1] = 0.; + return 0; + } + +/* Check whether the machine is IEEE conformable. */ + + ieee = ilaenv_(&c__10, "DLASQ2", "N", &c__1, &c__2, &c__3, &c__4) == 1 && ilaenv_(&c__11, "DLASQ2", "N", &c__1, &c__2, + &c__3, &c__4) == 1; + +/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */ + + for (k = *n << 1; k >= 2; k += -2) { + z__[k * 2] = 0.; + z__[(k << 1) - 1] = z__[k]; + z__[(k << 1) - 2] = 0.; + z__[(k << 1) - 3] = z__[k - 1]; +/* L30: */ + } + + i0 = 1; + n0 = *n; + +/* Reverse the qd-array, if warranted. */ + + if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) { + ipn4 = i0 + n0 << 2; + i__1 = i0 + n0 - 1 << 1; + for (i4 = i0 << 2; i4 <= i__1; i4 += 4) { + temp = z__[i4 - 3]; + z__[i4 - 3] = z__[ipn4 - i4 - 3]; + z__[ipn4 - i4 - 3] = temp; + temp = z__[i4 - 1]; + z__[i4 - 1] = z__[ipn4 - i4 - 5]; + z__[ipn4 - i4 - 5] = temp; +/* L40: */ + } + } + +/* Initial split checking via dqd and Li's test. */ + + pp = 0; + + for (k = 1; k <= 2; ++k) { + + d__ = z__[(n0 << 2) + pp - 3]; + i__1 = (i0 << 2) + pp; + for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) { + if (z__[i4 - 1] <= tol2 * d__) { + z__[i4 - 1] = -0.; + d__ = z__[i4 - 3]; + } else { + d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1])); + } +/* L50: */ + } + +/* dqd maps Z to ZZ plus Li's test. */ + + emin = z__[(i0 << 2) + pp + 1]; + d__ = z__[(i0 << 2) + pp - 3]; + i__1 = (n0 - 1 << 2) + pp; + for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) { + z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1]; + if (z__[i4 - 1] <= tol2 * d__) { + z__[i4 - 1] = -0.; + z__[i4 - (pp << 1) - 2] = d__; + z__[i4 - (pp << 1)] = 0.; + d__ = z__[i4 + 1]; + } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] && + safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) { + temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2]; + z__[i4 - (pp << 1)] = z__[i4 - 1] * temp; + d__ *= temp; + } else { + z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - ( + pp << 1) - 2]); + d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]); + } +/* Computing MIN */ + d__1 = emin, d__2 = z__[i4 - (pp << 1)]; + emin = std::min(d__1,d__2); +/* L60: */ + } + z__[(n0 << 2) - pp - 2] = d__; + +/* Now find qmax. */ + + qmax = z__[(i0 << 2) - pp - 2]; + i__1 = (n0 << 2) - pp - 2; + for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) { +/* Computing MAX */ + d__1 = qmax, d__2 = z__[i4]; + qmax = std::max (d__1,d__2); +/* L70: */ + } + +/* Prepare for the next iteration on K. */ + + pp = 1 - pp; +/* L80: */ + } + +/* Initialise variables to pass to DLASQ3. */ + + ttype = 0; + dmin1 = 0.; + dmin2 = 0.; + dn = 0.; + dn1 = 0.; + dn2 = 0.; + g = 0.; + tau = 0.; + + iter = 2; + nfail = 0; + ndiv = n0 - i0 << 1; + + i__1 = *n + 1; + for (iwhila = 1; iwhila <= i__1; ++iwhila) { + if (n0 < 1) { + goto L170; + } + +/* While array unfinished do */ + +/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */ +/* splits from the rest of the array, but is negated. */ + + desig = 0.; + if (n0 == *n) { + sigma = 0.; + } else { + sigma = -z__[(n0 << 2) - 1]; + } + if (sigma < 0.) { + *info = 1; + return 0; + } + +/* Find last unreduced submatrix's top index I0, find QMAX and */ +/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */ + + emax = 0.; + if (n0 > i0) { + emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1)); + } else { + emin = 0.; + } + qmin = z__[(n0 << 2) - 3]; + qmax = qmin; + for (i4 = n0 << 2; i4 >= 8; i4 += -4) { + if (z__[i4 - 5] <= 0.) { + goto L100; + } + if (qmin >= emax * 4.) { +/* Computing MIN */ + d__1 = qmin, d__2 = z__[i4 - 3]; + qmin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = emax, d__2 = z__[i4 - 5]; + emax = std::max (d__1,d__2); + } +/* Computing MAX */ + d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5]; + qmax = std::max (d__1,d__2); +/* Computing MIN */ + d__1 = emin, d__2 = z__[i4 - 5]; + emin = std::min(d__1,d__2); +/* L90: */ + } + i4 = 4; + +L100: + i0 = i4 / 4; + pp = 0; + + if (n0 - i0 > 1) { + dee = z__[(i0 << 2) - 3]; + deemin = dee; + kmin = i0; + i__2 = (n0 << 2) - 3; + for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) { + dee = z__[i4] * (dee / (dee + z__[i4 - 2])); + if (dee <= deemin) { + deemin = dee; + kmin = (i4 + 3) / 4; + } +/* L110: */ + } + if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] * + .5) { + ipn4 = i0 + n0 << 2; + pp = 2; + i__2 = i0 + n0 - 1 << 1; + for (i4 = i0 << 2; i4 <= i__2; i4 += 4) { + temp = z__[i4 - 3]; + z__[i4 - 3] = z__[ipn4 - i4 - 3]; + z__[ipn4 - i4 - 3] = temp; + temp = z__[i4 - 2]; + z__[i4 - 2] = z__[ipn4 - i4 - 2]; + z__[ipn4 - i4 - 2] = temp; + temp = z__[i4 - 1]; + z__[i4 - 1] = z__[ipn4 - i4 - 5]; + z__[ipn4 - i4 - 5] = temp; + temp = z__[i4]; + z__[i4] = z__[ipn4 - i4 - 4]; + z__[ipn4 - i4 - 4] = temp; +/* L120: */ + } + } + } + +/* Put -(initial shift) into DMIN. */ + +/* Computing MAX */ + d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax); + dmin__ = -std::max (d__1,d__2); + +/* Now I0:N0 is unreduced. */ +/* PP = 0 for ping, PP = 1 for pong. */ +/* PP = 2 indicates that flipping was applied to the Z array and */ +/* and that the tests for deflation upon entry in DLASQ3 */ +/* should not be performed. */ + + nbig = (n0 - i0 + 1) * 30; + i__2 = nbig; + for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) { + if (i0 > n0) { + goto L150; + } + +/* While submatrix unfinished take a good dqds step. */ + + dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, & + nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, & + dn1, &dn2, &g, &tau); + + pp = 1 - pp; + +/* When EMIN is very small check for splits. */ + + if (pp == 0 && n0 - i0 >= 3) { + if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * + sigma) { + splt = i0 - 1; + qmax = z__[(i0 << 2) - 3]; + emin = z__[(i0 << 2) - 1]; + oldemn = z__[i0 * 4]; + i__3 = n0 - 3 << 2; + for (i4 = i0 << 2; i4 <= i__3; i4 += 4) { + if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= + tol2 * sigma) { + z__[i4 - 1] = -sigma; + splt = i4 / 4; + qmax = 0.; + emin = z__[i4 + 3]; + oldemn = z__[i4 + 4]; + } else { +/* Computing MAX */ + d__1 = qmax, d__2 = z__[i4 + 1]; + qmax = std::max (d__1,d__2); +/* Computing MIN */ + d__1 = emin, d__2 = z__[i4 - 1]; + emin = std::min(d__1,d__2); +/* Computing MIN */ + d__1 = oldemn, d__2 = z__[i4]; + oldemn = std::min(d__1,d__2); + } +/* L130: */ + } + z__[(n0 << 2) - 1] = emin; + z__[n0 * 4] = oldemn; + i0 = splt + 1; + } + } + +/* L140: */ + } + + *info = 2; + return 0; + +/* end IWHILB */ + +L150: + +/* L160: */ + ; + } + + *info = 3; + return 0; + +/* end IWHILA */ + +L170: + +/* Move q's to the front. */ + + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + z__[k] = z__[(k << 2) - 3]; +/* L180: */ + } + +/* Sort and compute sum of eigenvalues. */ + + dlasrt_("D", n, &z__[1], &iinfo); + + e = 0.; + for (k = *n; k >= 1; --k) { + e += z__[k]; +/* L190: */ + } + +/* Store trace, sum(eigenvalues) and information on performance. */ + + z__[(*n << 1) + 1] = trace; + z__[(*n << 1) + 2] = e; + z__[(*n << 1) + 3] = (double) iter; +/* Computing 2nd power */ + i__1 = *n; + z__[(*n << 1) + 4] = (double) ndiv / (double) (i__1 * i__1); + z__[(*n << 1) + 5] = nfail * 100. / (double) iter; + return 0; + +/* End of DLASQ2 */ + +} /* dlasq2_ */ + +/* Subroutine */ int dlasq3_(integer *i0, integer *n0, double *z__, integer *pp, double *dmin__, double *sigma, + double *desig, double *qmax, integer *nfail, integer *iter, integer *ndiv, bool *ieee, + integer *ttype, double *dmin1, double *dmin2, double *dn, double *dn1, double *dn2, + double *g, double *tau) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + double s, t; + integer j4, nn; + double eps, tol; + integer n0in, ipn4; + double tol2, temp; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */ +/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */ +/* -- Berkeley -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */ +/* In case of failure it changes shifts, and tries again until output */ +/* is positive. */ + +/* Arguments */ +/* ========= */ + +/* I0 (input) INTEGER */ +/* First index. */ + +/* N0 (input) INTEGER */ +/* Last index. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ +/* Z holds the qd array. */ + +/* PP (input/output) INTEGER */ +/* PP=0 for ping, PP=1 for pong. */ +/* PP=2 indicates that flipping was applied to the Z array */ +/* and that the initial tests for deflation should not be */ +/* performed. */ + +/* DMIN (output) DOUBLE PRECISION */ +/* Minimum value of d. */ + +/* SIGMA (output) DOUBLE PRECISION */ +/* Sum of shifts used in current segment. */ + +/* DESIG (input/output) DOUBLE PRECISION */ +/* Lower order part of SIGMA */ + +/* QMAX (input) DOUBLE PRECISION */ +/* Maximum value of q. */ + +/* NFAIL (output) INTEGER */ +/* Number of times shift was too big. */ + +/* ITER (output) INTEGER */ +/* Number of iterations. */ + +/* NDIV (output) INTEGER */ +/* Number of divisions. */ + +/* IEEE (input) LOGICAL */ +/* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). */ + +/* TTYPE (input/output) INTEGER */ +/* Shift type. */ + +/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) DOUBLE PRECISION */ +/* These are passed as arguments in order to save their values */ +/* between calls to DLASQ3. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Function .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + n0in = *n0; + eps = dlamch_("Precision"); + tol = eps * 100.; +/* Computing 2nd power */ + d__1 = tol; + tol2 = d__1 * d__1; + +/* Check for deflation. */ + +L10: + + if (*n0 < *i0) { + return 0; + } + if (*n0 == *i0) { + goto L20; + } + nn = (*n0 << 2) + *pp; + if (*n0 == *i0 + 1) { + goto L40; + } + +/* Check whether E(N0-1) is negligible, 1 eigenvalue. */ + + if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - + 4] > tol2 * z__[nn - 7]) { + goto L30; + } + +L20: + + z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma; + --(*n0); + goto L10; + +/* Check whether E(N0-2) is negligible, 2 eigenvalues. */ + +L30: + + if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ + nn - 11]) { + goto L50; + } + +L40: + + if (z__[nn - 3] > z__[nn - 7]) { + s = z__[nn - 3]; + z__[nn - 3] = z__[nn - 7]; + z__[nn - 7] = s; + } + if (z__[nn - 5] > z__[nn - 3] * tol2) { + t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; + s = z__[nn - 3] * (z__[nn - 5] / t); + if (s <= t) { + s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); + } else { + s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[nn - 7] + (s + z__[nn - 5]); + z__[nn - 3] *= z__[nn - 7] / t; + z__[nn - 7] = t; + } + z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; + z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; + *n0 += -2; + goto L10; + +L50: + if (*pp == 2) { + *pp = 0; + } + +/* Reverse the qd-array, if warranted. */ + + if (*dmin__ <= 0. || *n0 < n0in) { + if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { + ipn4 = *i0 + *n0 << 2; + i__1 = *i0 + *n0 - 1 << 1; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + temp = z__[j4 - 3]; + z__[j4 - 3] = z__[ipn4 - j4 - 3]; + z__[ipn4 - j4 - 3] = temp; + temp = z__[j4 - 2]; + z__[j4 - 2] = z__[ipn4 - j4 - 2]; + z__[ipn4 - j4 - 2] = temp; + temp = z__[j4 - 1]; + z__[j4 - 1] = z__[ipn4 - j4 - 5]; + z__[ipn4 - j4 - 5] = temp; + temp = z__[j4]; + z__[j4] = z__[ipn4 - j4 - 4]; + z__[ipn4 - j4 - 4] = temp; +/* L60: */ + } + if (*n0 - *i0 <= 4) { + z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; + z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; + } +/* Computing MIN */ + d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; + *dmin2 = std::min(d__1,d__2); +/* Computing MIN */ + d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1] + , d__1 = std::min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; + z__[(*n0 << 2) + *pp - 1] = std::min(d__1,d__2); +/* Computing MIN */ + d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = + std::min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4]; + z__[(*n0 << 2) - *pp] = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = std::max(d__1, + d__2), d__2 = z__[(*i0 << 2) + *pp + 1]; + *qmax = std::max(d__1,d__2); + *dmin__ = -0.; + } + } + +/* Choose a shift. */ + + dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g); + +/* Call dqds until DMIN > 0. */ + +L70: + + dlasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2, + ieee); + + *ndiv += *n0 - *i0 + 2; + ++(*iter); + +/* Check status. */ + + if (*dmin__ >= 0. && *dmin1 > 0.) { + +/* Success. */ + + goto L90; + + } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol + * (*sigma + *dn1) && abs(*dn) < tol * *sigma) { + +/* Convergence hidden by negative DN. */ + + z__[(*n0 - 1 << 2) - *pp + 2] = 0.; + *dmin__ = 0.; + goto L90; + } else if (*dmin__ < 0.) { + +/* TAU too big. Select new TAU and try again. */ + + ++(*nfail); + if (*ttype < -22) { + +/* Failed twice. Play it safe. */ + + *tau = 0.; + } else if (*dmin1 > 0.) { + +/* Late failure. Gives excellent shift. */ + + *tau = (*tau + *dmin__) * (1. - eps * 2.); + *ttype += -11; + } else { + +/* Early failure. Divide by 4. */ + + *tau *= .25; + *ttype += -12; + } + goto L70; + } else if (disnan_(dmin__)) { + +/* NaN. */ + + if (*tau == 0.) { + goto L80; + } else { + *tau = 0.; + goto L70; + } + } else { + +/* Possible underflow. Play it safe. */ + + goto L80; + } + +/* Risk of underflow. */ + +L80: + dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2); + *ndiv += *n0 - *i0 + 2; + ++(*iter); + *tau = 0.; + +L90: + if (*tau < *sigma) { + *desig += *tau; + t = *sigma + *desig; + *desig -= t - *sigma; + } else { + t = *sigma + *tau; + *desig = *sigma - (t - *tau) + *desig; + } + *sigma = t; + + return 0; + +/* End of DLASQ3 */ + +} /* dlasq3_ */ + +/* Subroutine */ int dlasq4_(integer *i0, integer *n0, double *z__, + integer *pp, integer *n0in, double *dmin__, double *dmin1, + double *dmin2, double *dn, double *dn1, double *dn2, + double *tau, integer *ttype, double *g) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + double s, a2, b1, b2; + integer i4, nn, np; + double gam, gap1, gap2; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */ +/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */ +/* -- Berkeley -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASQ4 computes an approximation TAU to the smallest eigenvalue */ +/* using values of d from the previous transform. */ + +/* I0 (input) INTEGER */ +/* First index. */ + +/* N0 (input) INTEGER */ +/* Last index. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ +/* Z holds the qd array. */ + +/* PP (input) INTEGER */ +/* PP=0 for ping, PP=1 for pong. */ + +/* NOIN (input) INTEGER */ +/* The value of N0 at start of EIGTEST. */ + +/* DMIN (input) DOUBLE PRECISION */ +/* Minimum value of d. */ + +/* DMIN1 (input) DOUBLE PRECISION */ +/* Minimum value of d, excluding D( N0 ). */ + +/* DMIN2 (input) DOUBLE PRECISION */ +/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ + +/* DN (input) DOUBLE PRECISION */ +/* d(N) */ + +/* DN1 (input) DOUBLE PRECISION */ +/* d(N-1) */ + +/* DN2 (input) DOUBLE PRECISION */ +/* d(N-2) */ + +/* TAU (output) DOUBLE PRECISION */ +/* This is the shift. */ + +/* TTYPE (output) INTEGER */ +/* Shift type. */ + +/* G (input/output) REAL */ +/* G is passed as an argument in order to save its value between */ +/* calls to DLASQ4. */ + +/* Further Details */ +/* =============== */ +/* CNST1 = 9/16 */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* A negative DMIN forces the shift to take that absolute value */ +/* TTYPE records the type of shift. */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + if (*dmin__ <= 0.) { + *tau = -(*dmin__); + *ttype = -1; + return 0; + } + + nn = (*n0 << 2) + *pp; + if (*n0in == *n0) { + +/* No eigenvalues deflated. */ + + if (*dmin__ == *dn || *dmin__ == *dn1) { + + b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); + b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); + a2 = z__[nn - 7] + z__[nn - 5]; + +/* Cases 2 and 3. */ + + if (*dmin__ == *dn && *dmin1 == *dn1) { + gap2 = *dmin2 - a2 - *dmin2 * .25; + if (gap2 > 0. && gap2 > b2) { + gap1 = a2 - *dn - b2 / gap2 * b2; + } else { + gap1 = a2 - *dn - (b1 + b2); + } + if (gap1 > 0. && gap1 > b1) { +/* Computing MAX */ + d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; + s = std::max(d__1,d__2); + *ttype = -2; + } else { + s = 0.; + if (*dn > b1) { + s = *dn - b1; + } + if (a2 > b1 + b2) { +/* Computing MIN */ + d__1 = s, d__2 = a2 - (b1 + b2); + s = std::min(d__1,d__2); + } +/* Computing MAX */ + d__1 = s, d__2 = *dmin__ * .333; + s = std::max(d__1,d__2); + *ttype = -3; + } + } else { + +/* Case 4. */ + + *ttype = -4; + s = *dmin__ * .25; + if (*dmin__ == *dn) { + gam = *dn; + a2 = 0.; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b2 = z__[nn - 5] / z__[nn - 7]; + np = nn - 9; + } else { + np = nn - (*pp << 1); + b2 = z__[np - 2]; + gam = *dn1; + if (z__[np - 4] > z__[np - 2]) { + return 0; + } + a2 = z__[np - 4] / z__[np - 2]; + if (z__[nn - 9] > z__[nn - 11]) { + return 0; + } + b2 = z__[nn - 9] / z__[nn - 11]; + np = nn - 13; + } + +/* Approximate contribution to norm squared from I < NN-1. */ + + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = np; i4 >= i__1; i4 += -4) { + if (b2 == 0.) { + goto L20; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (std::max(b2,b1) * 100. < a2 || .563 < a2) { + goto L20; + } +/* L10: */ + } +L20: + a2 *= 1.05; + +/* Rayleigh quotient residual bound. */ + + if (a2 < .563) { + s = gam * (1. - sqrt(a2)) / (a2 + 1.); + } + } + } else if (*dmin__ == *dn2) { + +/* Case 5. */ + + *ttype = -5; + s = *dmin__ * .25; + +/* Compute contribution to norm squared from I > NN-2. */ + + np = nn - (*pp << 1); + b1 = z__[np - 2]; + b2 = z__[np - 6]; + gam = *dn2; + if (z__[np - 8] > b2 || z__[np - 4] > b1) { + return 0; + } + a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); + +/* Approximate contribution to norm squared from I < NN-2. */ + + if (*n0 - *i0 > 2) { + b2 = z__[nn - 13] / z__[nn - 15]; + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = nn - 17; i4 >= i__1; i4 += -4) { + if (b2 == 0.) { + goto L40; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (std::max(b2,b1) * 100. < a2 || .563 < a2) { + goto L40; + } +/* L30: */ + } +L40: + a2 *= 1.05; + } + + if (a2 < .563) { + s = gam * (1. - sqrt(a2)) / (a2 + 1.); + } + } else { + +/* Case 6, no information to guide us. */ + + if (*ttype == -6) { + *g += (1. - *g) * .333; + } else if (*ttype == -18) { + *g = .083250000000000005; + } else { + *g = .25; + } + s = *g * *dmin__; + *ttype = -6; + } + + } else if (*n0in == *n0 + 1) { + +/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */ + + if (*dmin1 == *dn1 && *dmin2 == *dn2) { + +/* Cases 7 and 8. */ + + *ttype = -7; + s = *dmin1 * .333; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.) { + goto L60; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + a2 = b1; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (std::max(b1,a2) * 100. < b2) { + goto L60; + } +/* L50: */ + } +L60: + b2 = sqrt(b2 * 1.05); +/* Computing 2nd power */ + d__1 = b2; + a2 = *dmin1 / (d__1 * d__1 + 1.); + gap2 = *dmin2 * .5 - a2; + if (gap2 > 0. && gap2 > b2 * a2) { +/* Computing MAX */ + d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); + s = std::max(d__1,d__2); + } else { +/* Computing MAX */ + d__1 = s, d__2 = a2 * (1. - b2 * 1.01); + s = std::max(d__1,d__2); + *ttype = -8; + } + } else { + +/* Case 9. */ + + s = *dmin1 * .25; + if (*dmin1 == *dn1) { + s = *dmin1 * .5; + } + *ttype = -9; + } + + } else if (*n0in == *n0 + 2) { + +/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */ + +/* Cases 10 and 11. */ + + if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { + *ttype = -10; + s = *dmin2 * .333; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.) { + goto L80; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (b1 * 100. < b2) { + goto L80; + } +/* L70: */ + } +L80: + b2 = sqrt(b2 * 1.05); +/* Computing 2nd power */ + d__1 = b2; + a2 = *dmin2 / (d__1 * d__1 + 1.); + gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ + nn - 9]) - a2; + if (gap2 > 0. && gap2 > b2 * a2) { +/* Computing MAX */ + d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); + s = std::max(d__1,d__2); + } else { +/* Computing MAX */ + d__1 = s, d__2 = a2 * (1. - b2 * 1.01); + s = std::max(d__1,d__2); + } + } else { + s = *dmin2 * .25; + *ttype = -11; + } + } else if (*n0in > *n0 + 2) { + +/* Case 12, more than two eigenvalues deflated. No information. */ + + s = 0.; + *ttype = -12; + } + + *tau = s; + return 0; + +/* End of DLASQ4 */ + +} /* dlasq4_ */ + +/* Subroutine */ int dlasq5_(integer *i0, integer *n0, double *z__, + integer *pp, double *tau, double *dmin__, double *dmin1, + double *dmin2, double *dn, double *dnm1, double *dnm2, + bool *ieee) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + double d__; + integer j4, j4p2; + double emin, temp; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASQ5 computes one dqds transform in ping-pong form, one */ +/* version for IEEE machines another for non IEEE machines. */ + +/* Arguments */ +/* ========= */ + +/* I0 (input) INTEGER */ +/* First index. */ + +/* N0 (input) INTEGER */ +/* Last index. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ +/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */ +/* an extra argument. */ + +/* PP (input) INTEGER */ +/* PP=0 for ping, PP=1 for pong. */ + +/* TAU (input) DOUBLE PRECISION */ +/* This is the shift. */ + +/* DMIN (output) DOUBLE PRECISION */ +/* Minimum value of d. */ + +/* DMIN1 (output) DOUBLE PRECISION */ +/* Minimum value of d, excluding D( N0 ). */ + +/* DMIN2 (output) DOUBLE PRECISION */ +/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ + +/* DN (output) DOUBLE PRECISION */ +/* d(N0), the last value of d. */ + +/* DNM1 (output) DOUBLE PRECISION */ +/* d(N0-1). */ + +/* DNM2 (output) DOUBLE PRECISION */ +/* d(N0-2). */ + +/* IEEE (input) LOGICAL */ +/* Flag for IEEE or non IEEE arithmetic. */ + +/* ===================================================================== */ + +/* .. Parameter .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + if (*n0 - *i0 - 1 <= 0) { + return 0; + } + + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4] - *tau; + *dmin__ = d__; + *dmin1 = -z__[j4]; + + if (*ieee) { + +/* Code for IEEE arithmetic. */ + + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + temp = z__[j4 + 1] / z__[j4 - 2]; + d__ = d__ * temp - *tau; + *dmin__ = std::min(*dmin__,d__); + z__[j4] = z__[j4 - 1] * temp; +/* Computing MIN */ + d__1 = z__[j4]; + emin = std::min(d__1,emin); +/* L10: */ + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + temp = z__[j4 + 2] / z__[j4 - 3]; + d__ = d__ * temp - *tau; + *dmin__ = std::min(*dmin__,d__); + z__[j4 - 1] = z__[j4] * temp; +/* Computing MIN */ + d__1 = z__[j4 - 1]; + emin = std::min(d__1,emin); +/* L20: */ + } + } + +/* Unroll last two steps. */ + + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + *dmin__ = std::min(*dmin__,*dnm1); + + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + *dmin__ = std::min(*dmin__,*dn); + + } else { + +/* Code for non IEEE arithmetic. */ + + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (d__ < 0.) { + return 0; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; + } + *dmin__ = std::min(*dmin__,d__); +/* Computing MIN */ + d__1 = emin, d__2 = z__[j4]; + emin = std::min(d__1,d__2); +/* L30: */ + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (d__ < 0.) { + return 0; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; + } + *dmin__ = std::min(*dmin__,d__); +/* Computing MIN */ + d__1 = emin, d__2 = z__[j4 - 1]; + emin = std::min(d__1,d__2); +/* L40: */ + } + } + +/* Unroll last two steps. */ + + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (*dnm2 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + } + *dmin__ = std::min(*dmin__,*dnm1); + + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (*dnm1 < 0.) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + } + *dmin__ = std::min(*dmin__,*dn); + + } + + z__[j4 + 2] = *dn; + z__[(*n0 << 2) - *pp] = emin; + return 0; + +/* End of DLASQ5 */ + +} /* dlasq5_ */ + +/* Subroutine */ int dlasq6_(integer *i0, integer *n0, double *z__, + integer *pp, double *dmin__, double *dmin1, double *dmin2, + double *dn, double *dnm1, double *dnm2) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + double d__; + integer j4, j4p2; + double emin, temp; + + double safmin; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASQ6 computes one dqd (shift equal to zero) transform in */ +/* ping-pong form, with protection against underflow and overflow. */ + +/* Arguments */ +/* ========= */ + +/* I0 (input) INTEGER */ +/* First index. */ + +/* N0 (input) INTEGER */ +/* Last index. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ +/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */ +/* an extra argument. */ + +/* PP (input) INTEGER */ +/* PP=0 for ping, PP=1 for pong. */ + +/* DMIN (output) DOUBLE PRECISION */ +/* Minimum value of d. */ + +/* DMIN1 (output) DOUBLE PRECISION */ +/* Minimum value of d, excluding D( N0 ). */ + +/* DMIN2 (output) DOUBLE PRECISION */ +/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ + +/* DN (output) DOUBLE PRECISION */ +/* d(N0), the last value of d. */ + +/* DNM1 (output) DOUBLE PRECISION */ +/* d(N0-1). */ + +/* DNM2 (output) DOUBLE PRECISION */ +/* d(N0-2). */ + +/* ===================================================================== */ + +/* .. Parameter .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Function .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + if (*n0 - *i0 - 1 <= 0) { + return 0; + } + + safmin = dlamch_("Safe minimum"); + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4]; + *dmin__ = d__; + + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (z__[j4 - 2] == 0.) { + z__[j4] = 0.; + d__ = z__[j4 + 1]; + *dmin__ = d__; + emin = 0.; + } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 + - 2] < z__[j4 + 1]) { + temp = z__[j4 + 1] / z__[j4 - 2]; + z__[j4] = z__[j4 - 1] * temp; + d__ *= temp; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); + } + *dmin__ = std::min(*dmin__,d__); +/* Computing MIN */ + d__1 = emin, d__2 = z__[j4]; + emin = std::min(d__1,d__2); +/* L10: */ + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (z__[j4 - 3] == 0.) { + z__[j4 - 1] = 0.; + d__ = z__[j4 + 2]; + *dmin__ = d__; + emin = 0.; + } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 + - 3] < z__[j4 + 2]) { + temp = z__[j4 + 2] / z__[j4 - 3]; + z__[j4 - 1] = z__[j4] * temp; + d__ *= temp; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); + } + *dmin__ = std::min(*dmin__,d__); +/* Computing MIN */ + d__1 = emin, d__2 = z__[j4 - 1]; + emin = std::min(d__1,d__2); +/* L20: */ + } + } + +/* Unroll last two steps. */ + + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (z__[j4 - 2] == 0.) { + z__[j4] = 0.; + *dnm1 = z__[j4p2 + 2]; + *dmin__ = *dnm1; + emin = 0.; + } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < + z__[j4p2 + 2]) { + temp = z__[j4p2 + 2] / z__[j4 - 2]; + z__[j4] = z__[j4p2] * temp; + *dnm1 = *dnm2 * temp; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); + } + *dmin__ = std::min(*dmin__,*dnm1); + + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (z__[j4 - 2] == 0.) { + z__[j4] = 0.; + *dn = z__[j4p2 + 2]; + *dmin__ = *dn; + emin = 0.; + } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < + z__[j4p2 + 2]) { + temp = z__[j4p2 + 2] / z__[j4 - 2]; + z__[j4] = z__[j4p2] * temp; + *dn = *dnm1 * temp; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); + } + *dmin__ = std::min(*dmin__,*dn); + + z__[j4 + 2] = *dn; + z__[(*n0 << 2) - *pp] = emin; + return 0; + +/* End of DLASQ6 */ + +} /* dlasq6_ */ + +/* Subroutine */ int dlasr_(const char *side, const char *pivot, const char *direct, integer *m, + integer *n, double *c__, double *s, double *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, info; + double temp; + + double ctemp, stemp; + + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASR applies a sequence of plane rotations to a real matrix A, */ +/* from either the left or the right. */ + +/* When SIDE = 'L', the transformation takes the form */ + +/* A := P*A */ + +/* and when SIDE = 'R', the transformation takes the form */ + +/* A := A*P**T */ + +/* where P is an orthogonal matrix consisting of a sequence of z plane */ +/* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */ +/* and P**T is the transpose of P. */ + +/* When DIRECT = 'F' (Forward sequence), then */ + +/* P = P(z-1) * ... * P(2) * P(1) */ + +/* and when DIRECT = 'B' (Backward sequence), then */ + +/* P = P(1) * P(2) * ... * P(z-1) */ + +/* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */ + +/* R(k) = ( c(k) s(k) ) */ +/* = ( -s(k) c(k) ). */ + +/* When PIVOT = 'V' (Variable pivot), the rotation is performed */ +/* for the plane (k,k+1), i.e., P(k) has the form */ + +/* P(k) = ( 1 ) */ +/* ( ... ) */ +/* ( 1 ) */ +/* ( c(k) s(k) ) */ +/* ( -s(k) c(k) ) */ +/* ( 1 ) */ +/* ( ... ) */ +/* ( 1 ) */ + +/* where R(k) appears as a rank-2 modification to the identity matrix in */ +/* rows and columns k and k+1. */ + +/* When PIVOT = 'T' (Top pivot), the rotation is performed for the */ +/* plane (1,k+1), so P(k) has the form */ + +/* P(k) = ( c(k) s(k) ) */ +/* ( 1 ) */ +/* ( ... ) */ +/* ( 1 ) */ +/* ( -s(k) c(k) ) */ +/* ( 1 ) */ +/* ( ... ) */ +/* ( 1 ) */ + +/* where R(k) appears in rows and columns 1 and k+1. */ + +/* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */ +/* performed for the plane (k,z), giving P(k) the form */ + +/* P(k) = ( 1 ) */ +/* ( ... ) */ +/* ( 1 ) */ +/* ( c(k) s(k) ) */ +/* ( 1 ) */ +/* ( ... ) */ +/* ( 1 ) */ +/* ( -s(k) c(k) ) */ + +/* where R(k) appears in rows and columns k and z. The rotations are */ +/* performed without ever forming P(k) explicitly. */ + +/* Arguments */ +/* ========= */ + +/* SIDE (input) CHARACTER*1 */ +/* Specifies whether the plane rotation matrix P is applied to */ +/* A on the left or the right. */ +/* = 'L': Left, compute A := P*A */ +/* = 'R': Right, compute A:= A*P**T */ + +/* PIVOT (input) CHARACTER*1 */ +/* Specifies the plane for which P(k) is a plane rotation */ +/* matrix. */ +/* = 'V': Variable pivot, the plane (k,k+1) */ +/* = 'T': Top pivot, the plane (1,k+1) */ +/* = 'B': Bottom pivot, the plane (k,z) */ + +/* DIRECT (input) CHARACTER*1 */ +/* Specifies whether P is a forward or backward sequence of */ +/* plane rotations. */ +/* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */ +/* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. If m <= 1, an immediate */ +/* return is effected. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix A. If n <= 1, an */ +/* immediate return is effected. */ + +/* C (input) DOUBLE PRECISION array, dimension */ +/* (M-1) if SIDE = 'L' */ +/* (N-1) if SIDE = 'R' */ +/* The cosines c(k) of the plane rotations. */ + +/* S (input) DOUBLE PRECISION array, dimension */ +/* (M-1) if SIDE = 'L' */ +/* (N-1) if SIDE = 'R' */ +/* The sines s(k) of the plane rotations. The 2-by-2 plane */ +/* rotation part of the matrix P(k), R(k), has the form */ +/* R(k) = ( c(k) s(k) ) */ +/* ( -s(k) c(k) ). */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The M-by-N matrix A. On exit, A is overwritten by P*A if */ +/* SIDE = 'R' or by A*P**T if SIDE = 'L'. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + --c__; + --s; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! (lsame_(side, "L") || lsame_(side, "R"))) { + info = 1; + } else if (! (lsame_(pivot, "V") || lsame_(pivot, + "T") || lsame_(pivot, "B"))) { + info = 2; + } else if (! (lsame_(direct, "F") || lsame_(direct, + "B"))) { + info = 3; + } else if (*m < 0) { + info = 4; + } else if (*n < 0) { + info = 5; + } else if (*lda < std::max(1_integer,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("DLASR ", &info); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + if (lsame_(side, "L")) { + +/* Form P * A */ + + if (lsame_(pivot, "V")) { + if (lsame_(direct, "F")) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + 1 + i__ * a_dim1]; + a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * + a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + + i__ * a_dim1]; +/* L10: */ + } + } +/* L20: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + 1 + i__ * a_dim1]; + a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * + a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + + i__ * a_dim1]; +/* L30: */ + } + } +/* L40: */ + } + } + } else if (lsame_(pivot, "T")) { + if (lsame_(direct, "F")) { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ + i__ * a_dim1 + 1]; + a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ + i__ * a_dim1 + 1]; +/* L50: */ + } + } +/* L60: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ + i__ * a_dim1 + 1]; + a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ + i__ * a_dim1 + 1]; +/* L70: */ + } + } +/* L80: */ + } + } + } else if (lsame_(pivot, "B")) { + if (lsame_(direct, "F")) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + + ctemp * temp; + a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * + a_dim1] - stemp * temp; +/* L90: */ + } + } +/* L100: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + + ctemp * temp; + a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * + a_dim1] - stemp * temp; +/* L110: */ + } + } +/* L120: */ + } + } + } + } else if (lsame_(side, "R")) { + +/* Form A * P' */ + + if (lsame_(pivot, "V")) { + if (lsame_(direct, "F")) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + (j + 1) * a_dim1]; + a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * + a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ + i__ + j * a_dim1]; +/* L130: */ + } + } +/* L140: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + (j + 1) * a_dim1]; + a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * + a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ + i__ + j * a_dim1]; +/* L150: */ + } + } +/* L160: */ + } + } + } else if (lsame_(pivot, "T")) { + if (lsame_(direct, "F")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ + i__ + a_dim1]; + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + + a_dim1]; +/* L170: */ + } + } +/* L180: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ + i__ + a_dim1]; + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + + a_dim1]; +/* L190: */ + } + } +/* L200: */ + } + } + } else if (lsame_(pivot, "B")) { + if (lsame_(direct, "F")) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + + ctemp * temp; + a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * + a_dim1] - stemp * temp; +/* L210: */ + } + } +/* L220: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + + ctemp * temp; + a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * + a_dim1] - stemp * temp; +/* L230: */ + } + } +/* L240: */ + } + } + } + } + + return 0; + +/* End of DLASR */ + +} /* dlasr_ */ + +/* Subroutine */ int dlasrt_(const char *id, integer *n, double *d__, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j; + double d1, d2, d3; + integer dir; + double tmp; + integer endd; + + integer stack[64] /* was [2][32] */; + double dmnmx; + integer start; + + integer stkpnt; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Sort the numbers in D in increasing order (if ID = 'I') or */ +/* in decreasing order (if ID = 'D' ). */ + +/* Use Quick Sort, reverting to Insertion sort on arrays of */ +/* size <= 20. Dimension of STACK limits N to about 2**32. */ + +/* Arguments */ +/* ========= */ + +/* ID (input) CHARACTER*1 */ +/* = 'I': sort D in increasing order; */ +/* = 'D': sort D in decreasing order. */ + +/* N (input) INTEGER */ +/* The length of the array D. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the array to be sorted. */ +/* On exit, D has been sorted into increasing order */ +/* (D(1) <= ... <= D(N) ) or into decreasing order */ +/* (D(1) >= ... >= D(N) ), depending on ID. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input paramters. */ + + /* Parameter adjustments */ + --d__; + + /* Function Body */ + *info = 0; + dir = -1; + if (lsame_(id, "D")) { + dir = 0; + } else if (lsame_(id, "I")) { + dir = 1; + } + if (dir == -1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLASRT", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + + stkpnt = 1; + stack[0] = 1; + stack[1] = *n; +L10: + start = stack[(stkpnt << 1) - 2]; + endd = stack[(stkpnt << 1) - 1]; + --stkpnt; + if (endd - start <= 20 && endd - start > 0) { + +/* Do Insertion sort on D( START:ENDD ) */ + + if (dir == 0) { + +/* Sort into decreasing order */ + + i__1 = endd; + for (i__ = start + 1; i__ <= i__1; ++i__) { + i__2 = start + 1; + for (j = i__; j >= i__2; --j) { + if (d__[j] > d__[j - 1]) { + dmnmx = d__[j]; + d__[j] = d__[j - 1]; + d__[j - 1] = dmnmx; + } else { + goto L30; + } +/* L20: */ + } +L30: + ; + } + + } else { + +/* Sort into increasing order */ + + i__1 = endd; + for (i__ = start + 1; i__ <= i__1; ++i__) { + i__2 = start + 1; + for (j = i__; j >= i__2; --j) { + if (d__[j] < d__[j - 1]) { + dmnmx = d__[j]; + d__[j] = d__[j - 1]; + d__[j - 1] = dmnmx; + } else { + goto L50; + } +/* L40: */ + } +L50: + ; + } + + } + + } else if (endd - start > 20) { + +/* Partition D( START:ENDD ) and stack parts, largest one first */ + +/* Choose partition entry as median of 3 */ + + d1 = d__[start]; + d2 = d__[endd]; + i__ = (start + endd) / 2; + d3 = d__[i__]; + if (d1 < d2) { + if (d3 < d1) { + dmnmx = d1; + } else if (d3 < d2) { + dmnmx = d3; + } else { + dmnmx = d2; + } + } else { + if (d3 < d2) { + dmnmx = d2; + } else if (d3 < d1) { + dmnmx = d3; + } else { + dmnmx = d1; + } + } + + if (dir == 0) { + +/* Sort into decreasing order */ + + i__ = start - 1; + j = endd + 1; +L60: +L70: + --j; + if (d__[j] < dmnmx) { + goto L70; + } +L80: + ++i__; + if (d__[i__] > dmnmx) { + goto L80; + } + if (i__ < j) { + tmp = d__[i__]; + d__[i__] = d__[j]; + d__[j] = tmp; + goto L60; + } + if (j - start > endd - j - 1) { + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + } else { + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + } + } else { + +/* Sort into increasing order */ + + i__ = start - 1; + j = endd + 1; +L90: +L100: + --j; + if (d__[j] > dmnmx) { + goto L100; + } +L110: + ++i__; + if (d__[i__] < dmnmx) { + goto L110; + } + if (i__ < j) { + tmp = d__[i__]; + d__[i__] = d__[j]; + d__[j] = tmp; + goto L90; + } + if (j - start > endd - j - 1) { + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + } else { + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + } + } + } + if (stkpnt > 0) { + goto L10; + } + return 0; + +/* End of DLASRT */ + +} /* dlasrt_ */ + +/* Subroutine */ int dlassq_(integer *n, double *x, integer *incx, + double *scale, double *sumsq) +{ + /* System generated locals */ + integer i__1, i__2; + double d__1; + + /* Local variables */ + integer ix; + double absxi; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASSQ returns the values scl and smsq such that */ + +/* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */ + +/* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */ +/* assumed to be non-negative and scl returns the value */ + +/* scl = max( scale, abs( x( i ) ) ). */ + +/* scale and sumsq must be supplied in SCALE and SUMSQ and */ +/* scl and smsq are overwritten on SCALE and SUMSQ respectively. */ + +/* The routine makes only one pass through the vector x. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of elements to be used from the vector X. */ + +/* X (input) DOUBLE PRECISION array, dimension (N) */ +/* The vector for which a scaled sum of squares is computed. */ +/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */ + +/* INCX (input) INTEGER */ +/* The increment between successive values of the vector X. */ +/* INCX > 0. */ + +/* SCALE (input/output) DOUBLE PRECISION */ +/* On entry, the value scale in the equation above. */ +/* On exit, SCALE is overwritten with scl , the scaling factor */ +/* for the sum of squares. */ + +/* SUMSQ (input/output) DOUBLE PRECISION */ +/* On entry, the value sumsq in the equation above. */ +/* On exit, SUMSQ is overwritten with smsq , the basic sum of */ +/* squares from which scl has been factored out. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n > 0) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + if (x[ix] != 0.) { + absxi = (d__1 = x[ix], abs(d__1)); + if (*scale < absxi) { +/* Computing 2nd power */ + d__1 = *scale / absxi; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = absxi; + } else { +/* Computing 2nd power */ + d__1 = absxi / *scale; + *sumsq += d__1 * d__1; + } + } +/* L10: */ + } + } + return 0; + +/* End of DLASSQ */ + +} /* dlassq_ */ + +/* Subroutine */ int dlasv2_(double *f, double *g, double *h__, + double *ssmin, double *ssmax, double *snr, double * + csr, double *snl, double *csl) +{ + /* Table of constant values */ + static double c_b3 = 2.; + static double c_b4 = 1.; + + /* System generated locals */ + double d__1; + + /* Local variables */ + double a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, + crt, slt, srt; + integer pmax; + double temp; + bool swap; + double tsign; + + bool gasmal; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASV2 computes the singular value decomposition of a 2-by-2 */ +/* triangular matrix */ +/* [ F G ] */ +/* [ 0 H ]. */ +/* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */ +/* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */ +/* right singular vectors for abs(SSMAX), giving the decomposition */ + +/* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */ +/* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */ + +/* Arguments */ +/* ========= */ + +/* F (input) DOUBLE PRECISION */ +/* The (1,1) element of the 2-by-2 matrix. */ + +/* G (input) DOUBLE PRECISION */ +/* The (1,2) element of the 2-by-2 matrix. */ + +/* H (input) DOUBLE PRECISION */ +/* The (2,2) element of the 2-by-2 matrix. */ + +/* SSMIN (output) DOUBLE PRECISION */ +/* abs(SSMIN) is the smaller singular value. */ + +/* SSMAX (output) DOUBLE PRECISION */ +/* abs(SSMAX) is the larger singular value. */ + +/* SNL (output) DOUBLE PRECISION */ +/* CSL (output) DOUBLE PRECISION */ +/* The vector (CSL, SNL) is a unit left singular vector for the */ +/* singular value abs(SSMAX). */ + +/* SNR (output) DOUBLE PRECISION */ +/* CSR (output) DOUBLE PRECISION */ +/* The vector (CSR, SNR) is a unit right singular vector for the */ +/* singular value abs(SSMAX). */ + +/* Further Details */ +/* =============== */ + +/* Any input parameter may be aliased with any output parameter. */ + +/* Barring over/underflow and assuming a guard digit in subtraction, all */ +/* output quantities are correct to within a few units in the last */ +/* place (ulps). */ + +/* In IEEE arithmetic, the code works correctly if one matrix element is */ +/* infinite. */ + +/* Overflow will not occur unless the largest singular value itself */ +/* overflows or is within a few ulps of overflow. (On machines with */ +/* partial overflow, like the Cray, overflow may occur if the largest */ +/* singular value is within a factor of 2 of overflow.) */ + +/* Underflow is harmless if underflow is gradual. Otherwise, results */ +/* may correspond to a matrix modified by perturbations of size near */ +/* the underflow threshold. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + ft = *f; + fa = abs(ft); + ht = *h__; + ha = abs(*h__); + +/* PMAX points to the maximum absolute element of matrix */ +/* PMAX = 1 if F largest in absolute values */ +/* PMAX = 2 if G largest in absolute values */ +/* PMAX = 3 if H largest in absolute values */ + + pmax = 1; + swap = ha > fa; + if (swap) { + pmax = 3; + temp = ft; + ft = ht; + ht = temp; + temp = fa; + fa = ha; + ha = temp; + +/* Now FA .ge. HA */ + + } + gt = *g; + ga = abs(gt); + if (ga == 0.) { + +/* Diagonal matrix */ + + *ssmin = ha; + *ssmax = fa; + clt = 1.; + crt = 1.; + slt = 0.; + srt = 0.; + } else { + gasmal = true; + if (ga > fa) { + pmax = 2; + if (fa / ga < dlamch_("EPS")) { + +/* Case of very large GA */ + + gasmal = false; + *ssmax = ga; + if (ha > 1.) { + *ssmin = fa / (ga / ha); + } else { + *ssmin = fa / ga * ha; + } + clt = 1.; + slt = ht / gt; + srt = 1.; + crt = ft / gt; + } + } + if (gasmal) { + +/* Normal case */ + + d__ = fa - ha; + if (d__ == fa) { + +/* Copes with infinite F or H */ + + l = 1.; + } else { + l = d__ / fa; + } + +/* Note that 0 .le. L .le. 1 */ + + m = gt / ft; + +/* Note that abs(M) .le. 1/macheps */ + + t = 2. - l; + +/* Note that T .ge. 1 */ + + mm = m * m; + tt = t * t; + s = sqrt(tt + mm); + +/* Note that 1 .le. S .le. 1 + 1/macheps */ + + if (l == 0.) { + r__ = abs(m); + } else { + r__ = sqrt(l * l + mm); + } + +/* Note that 0 .le. R .le. 1 + 1/macheps */ + + a = (s + r__) * .5; + +/* Note that 1 .le. A .le. 1 + abs(M) */ + + *ssmin = ha / a; + *ssmax = fa * a; + if (mm == 0.) { + +/* Note that M is very tiny */ + + if (l == 0.) { + t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >); + } else { + t = gt / d_sign(&d__, &ft) + m / t; + } + } else { + t = (m / (s + t) + m / (r__ + l)) * (a + 1.); + } + l = sqrt(t * t + 4.); + crt = 2. / l; + srt = t / l; + clt = (crt + srt * m) / a; + slt = ht / ft * srt / a; + } + } + if (swap) { + *csl = srt; + *snl = crt; + *csr = slt; + *snr = clt; + } else { + *csl = clt; + *snl = slt; + *csr = crt; + *snr = srt; + } + +/* Correct signs of SSMAX and SSMIN */ + + if (pmax == 1) { + tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f); + } + if (pmax == 2) { + tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g); + } + if (pmax == 3) { + tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__); + } + *ssmax = d_sign(ssmax, &tsign); + d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__); + *ssmin = d_sign(ssmin, &d__1); + return 0; + +/* End of DLASV2 */ + +} /* dlasv2_ */ + +/* Subroutine */ int dlaswp_(integer *n, double *a, integer *lda, integer + *k1, integer *k2, integer *ipiv, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; + double temp; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASWP performs a series of row interchanges on the matrix A. */ +/* One row interchange is initiated for each of rows K1 through K2 of A. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix A. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the matrix of column dimension N to which the row */ +/* interchanges will be applied. */ +/* On exit, the permuted matrix. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. */ + +/* K1 (input) INTEGER */ +/* The first element of IPIV for which a row interchange will */ +/* be done. */ + +/* K2 (input) INTEGER */ +/* The last element of IPIV for which a row interchange will */ +/* be done. */ + +/* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) */ +/* The vector of pivot indices. Only the elements in positions */ +/* K1 through K2 of IPIV are accessed. */ +/* IPIV(K) = L implies rows K and L are to be interchanged. */ + +/* INCX (input) INTEGER */ +/* The increment between successive values of IPIV. If IPIV */ +/* is negative, the pivots are applied in reverse order. */ + +/* Further Details */ +/* =============== */ + +/* Modified by */ +/* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Interchange row I with row IPIV(I) for each of rows K1 through K2. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + + /* Function Body */ + if (*incx > 0) { + ix0 = *k1; + i1 = *k1; + i2 = *k2; + inc = 1; + } else if (*incx < 0) { + ix0 = (1 - *k2) * *incx + 1; + i1 = *k2; + i2 = *k1; + inc = -1; + } else { + return 0; + } + + n32 = *n / 32 << 5; + if (n32 != 0) { + i__1 = n32; + for (j = 1; j <= i__1; j += 32) { + ix = ix0; + i__2 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) + { + ip = ipiv[ix]; + if (ip != i__) { + i__4 = j + 31; + for (k = j; k <= i__4; ++k) { + temp = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = a[ip + k * a_dim1]; + a[ip + k * a_dim1] = temp; +/* L10: */ + } + } + ix += *incx; +/* L20: */ + } +/* L30: */ + } + } + if (n32 != *n) { + ++n32; + ix = ix0; + i__1 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { + ip = ipiv[ix]; + if (ip != i__) { + i__2 = *n; + for (k = n32; k <= i__2; ++k) { + temp = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = a[ip + k * a_dim1]; + a[ip + k * a_dim1] = temp; +/* L40: */ + } + } + ix += *incx; +/* L50: */ + } + } + + return 0; + +/* End of DLASWP */ + +} /* dlaswp_ */ + +/* Subroutine */ int dlasy2_(bool *ltranl, bool *ltranr, integer *isgn, + integer *n1, integer *n2, double *tl, integer *ldtl, double * + tr, integer *ldtr, double *b, integer *ldb, double *scale, + double *x, integer *ldx, double *xnorm, integer *info) +{ + /* Table of constant values */ + static integer c__4 = 4; + static integer c__1 = 1; + static integer c__16 = 16; + static integer c__0 = 0; + + /* Initialized data */ + + static integer locu12[4] = { 3,4,1,2 }; + static integer locl21[4] = { 2,1,4,3 }; + static integer locu22[4] = { 4,3,2,1 }; + static bool xswpiv[4] = { false,false,true,true }; + static bool bswpiv[4] = { false,true,false,true }; + + /* System generated locals */ + integer b_dim1, b_offset, tl_dim1, tl_offset, tr_dim1, tr_offset, x_dim1, + x_offset; + double d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8; + + /* Local variables */ + integer i__, j, k; + double x2[2], l21, u11, u12; + integer ip, jp; + double u22, t16[16] /* was [4][4] */, gam, bet, eps, sgn, tmp[4], + tau1, btmp[4], smin; + integer ipiv; + double temp; + integer jpiv[4]; + double xmax; + integer ipsv, jpsv; + bool bswap; + bool xswap; + double smlnum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in */ + +/* op(TL)*X + ISGN*X*op(TR) = SCALE*B, */ + +/* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or */ +/* -1. op(T) = T or T', where T' denotes the transpose of T. */ + +/* Arguments */ +/* ========= */ + +/* LTRANL (input) LOGICAL */ +/* On entry, LTRANL specifies the op(TL): */ +/* = .FALSE., op(TL) = TL, */ +/* = .TRUE., op(TL) = TL'. */ + +/* LTRANR (input) LOGICAL */ +/* On entry, LTRANR specifies the op(TR): */ +/* = .FALSE., op(TR) = TR, */ +/* = .TRUE., op(TR) = TR'. */ + +/* ISGN (input) INTEGER */ +/* On entry, ISGN specifies the sign of the equation */ +/* as described before. ISGN may only be 1 or -1. */ + +/* N1 (input) INTEGER */ +/* On entry, N1 specifies the order of matrix TL. */ +/* N1 may only be 0, 1 or 2. */ + +/* N2 (input) INTEGER */ +/* On entry, N2 specifies the order of matrix TR. */ +/* N2 may only be 0, 1 or 2. */ + +/* TL (input) DOUBLE PRECISION array, dimension (LDTL,2) */ +/* On entry, TL contains an N1 by N1 matrix. */ + +/* LDTL (input) INTEGER */ +/* The leading dimension of the matrix TL. LDTL >= max(1,N1). */ + +/* TR (input) DOUBLE PRECISION array, dimension (LDTR,2) */ +/* On entry, TR contains an N2 by N2 matrix. */ + +/* LDTR (input) INTEGER */ +/* The leading dimension of the matrix TR. LDTR >= max(1,N2). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,2) */ +/* On entry, the N1 by N2 matrix B contains the right-hand */ +/* side of the equation. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the matrix B. LDB >= max(1,N1). */ + +/* SCALE (output) DOUBLE PRECISION */ +/* On exit, SCALE contains the scale factor. SCALE is chosen */ +/* less than or equal to 1 to prevent the solution overflowing. */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,2) */ +/* On exit, X contains the N1 by N2 solution. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the matrix X. LDX >= max(1,N1). */ + +/* XNORM (output) DOUBLE PRECISION */ +/* On exit, XNORM is the infinity-norm of the solution. */ + +/* INFO (output) INTEGER */ +/* On exit, INFO is set to */ +/* 0: successful exit. */ +/* 1: TL and TR have too close eigenvalues, so TL or */ +/* TR is perturbed to get a nonsingular equation. */ +/* NOTE: In the interests of speed, this routine does not */ +/* check the inputs for errors. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Data statements .. */ + /* Parameter adjustments */ + tl_dim1 = *ldtl; + tl_offset = 1 + tl_dim1; + tl -= tl_offset; + tr_dim1 = *ldtr; + tr_offset = 1 + tr_dim1; + tr -= tr_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + + /* Function Body */ +/* .. */ +/* .. Executable Statements .. */ + +/* Do not check the input parameters for errors */ + + *info = 0; + +/* Quick return if possible */ + + if (*n1 == 0 || *n2 == 0) { + return 0; + } + +/* Set constants to control overflow */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + sgn = (double) (*isgn); + + k = *n1 + *n1 + *n2 - 2; + switch (k) { + case 1: goto L10; + case 2: goto L20; + case 3: goto L30; + case 4: goto L50; + } + +/* 1 by 1: TL11*X + SGN*X*TR11 = B11 */ + +L10: + tau1 = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + bet = abs(tau1); + if (bet <= smlnum) { + tau1 = smlnum; + bet = smlnum; + *info = 1; + } + + *scale = 1.; + gam = (d__1 = b[b_dim1 + 1], abs(d__1)); + if (smlnum * gam > bet) { + *scale = 1. / gam; + } + + x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / tau1; + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)); + return 0; + +/* 1 by 2: */ +/* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] */ +/* [TR21 TR22] */ + +L20: + +/* Computing MAX */ +/* Computing MAX */ + d__7 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__8 = (d__2 = tr[tr_dim1 + 1] + , abs(d__2)), d__7 = std::max(d__7,d__8), d__8 = (d__3 = tr[(tr_dim1 << + 1) + 1], abs(d__3)), d__7 = std::max(d__7,d__8), d__8 = (d__4 = tr[ + tr_dim1 + 2], abs(d__4)), d__7 = std::max(d__7,d__8), d__8 = (d__5 = + tr[(tr_dim1 << 1) + 2], abs(d__5)); + d__6 = eps * std::max(d__7,d__8); + smin = std::max(d__6,smlnum); + tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + tmp[3] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2]; + if (*ltranr) { + tmp[1] = sgn * tr[tr_dim1 + 2]; + tmp[2] = sgn * tr[(tr_dim1 << 1) + 1]; + } else { + tmp[1] = sgn * tr[(tr_dim1 << 1) + 1]; + tmp[2] = sgn * tr[tr_dim1 + 2]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[(b_dim1 << 1) + 1]; + goto L40; + +/* 2 by 1: */ +/* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] */ +/* [TL21 TL22] [X21] [X21] [B21] */ + +L30: +/* Computing MAX */ +/* Computing MAX */ + d__7 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__8 = (d__2 = tl[tl_dim1 + 1] + , abs(d__2)), d__7 = std::max(d__7,d__8), d__8 = (d__3 = tl[(tl_dim1 << + 1) + 1], abs(d__3)), d__7 = std::max(d__7,d__8), d__8 = (d__4 = tl[ + tl_dim1 + 2], abs(d__4)), d__7 = std::max(d__7,d__8), d__8 = (d__5 = + tl[(tl_dim1 << 1) + 2], abs(d__5)); + d__6 = eps * std::max(d__7,d__8); + smin = std::max(d__6,smlnum); + tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + tmp[3] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1]; + if (*ltranl) { + tmp[1] = tl[(tl_dim1 << 1) + 1]; + tmp[2] = tl[tl_dim1 + 2]; + } else { + tmp[1] = tl[tl_dim1 + 2]; + tmp[2] = tl[(tl_dim1 << 1) + 1]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[b_dim1 + 2]; +L40: + +/* Solve 2 by 2 system using complete pivoting. */ +/* Set pivots less than SMIN to SMIN. */ + + ipiv = idamax_(&c__4, tmp, &c__1); + u11 = tmp[ipiv - 1]; + if (abs(u11) <= smin) { + *info = 1; + u11 = smin; + } + u12 = tmp[locu12[ipiv - 1] - 1]; + l21 = tmp[locl21[ipiv - 1] - 1] / u11; + u22 = tmp[locu22[ipiv - 1] - 1] - u12 * l21; + xswap = xswpiv[ipiv - 1]; + bswap = bswpiv[ipiv - 1]; + if (abs(u22) <= smin) { + *info = 1; + u22 = smin; + } + if (bswap) { + temp = btmp[1]; + btmp[1] = btmp[0] - l21 * temp; + btmp[0] = temp; + } else { + btmp[1] -= l21 * btmp[0]; + } + *scale = 1.; + if (smlnum * 2. * abs(btmp[1]) > abs(u22) || smlnum * 2. * abs(btmp[0]) > + abs(u11)) { +/* Computing MAX */ + d__1 = abs(btmp[0]), d__2 = abs(btmp[1]); + *scale = .5 / std::max(d__1,d__2); + btmp[0] *= *scale; + btmp[1] *= *scale; + } + x2[1] = btmp[1] / u22; + x2[0] = btmp[0] / u11 - u12 / u11 * x2[1]; + if (xswap) { + temp = x2[1]; + x2[1] = x2[0]; + x2[0] = temp; + } + x[x_dim1 + 1] = x2[0]; + if (*n1 == 1) { + x[(x_dim1 << 1) + 1] = x2[1]; + *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << 1) + + 1], abs(d__2)); + } else { + x[x_dim1 + 2] = x2[1]; +/* Computing MAX */ + d__3 = (d__1 = x[x_dim1 + 1], abs(d__1)), d__4 = (d__2 = x[x_dim1 + 2] + , abs(d__2)); + *xnorm = std::max(d__3,d__4); + } + return 0; + +/* 2 by 2: */ +/* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] */ +/* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] */ + +/* Solve equivalent 4 by 4 system using complete pivoting. */ +/* Set pivots less than SMIN to SMIN. */ + +L50: +/* Computing MAX */ + d__5 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__6 = (d__2 = tr[(tr_dim1 << + 1) + 1], abs(d__2)), d__5 = std::max(d__5,d__6), d__6 = (d__3 = tr[ + tr_dim1 + 2], abs(d__3)), d__5 = std::max(d__5,d__6), d__6 = (d__4 = + tr[(tr_dim1 << 1) + 2], abs(d__4)); + smin = std::max(d__5,d__6); +/* Computing MAX */ + d__5 = smin, d__6 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__5 = std::max(d__5, + d__6), d__6 = (d__2 = tl[(tl_dim1 << 1) + 1], abs(d__2)), d__5 = + std::max(d__5,d__6), d__6 = (d__3 = tl[tl_dim1 + 2], abs(d__3)), d__5 = + std::max(d__5,d__6), d__6 = (d__4 = tl[(tl_dim1 << 1) + 2], abs(d__4)) + ; + smin = std::max(d__5,d__6); +/* Computing MAX */ + d__1 = eps * smin; + smin = std::max(d__1,smlnum); + btmp[0] = 0.; + dcopy_(&c__16, btmp, &c__0, t16, &c__1); + t16[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + t16[5] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1]; + t16[10] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2]; + t16[15] = tl[(tl_dim1 << 1) + 2] + sgn * tr[(tr_dim1 << 1) + 2]; + if (*ltranl) { + t16[4] = tl[tl_dim1 + 2]; + t16[1] = tl[(tl_dim1 << 1) + 1]; + t16[14] = tl[tl_dim1 + 2]; + t16[11] = tl[(tl_dim1 << 1) + 1]; + } else { + t16[4] = tl[(tl_dim1 << 1) + 1]; + t16[1] = tl[tl_dim1 + 2]; + t16[14] = tl[(tl_dim1 << 1) + 1]; + t16[11] = tl[tl_dim1 + 2]; + } + if (*ltranr) { + t16[8] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[13] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[2] = sgn * tr[tr_dim1 + 2]; + t16[7] = sgn * tr[tr_dim1 + 2]; + } else { + t16[8] = sgn * tr[tr_dim1 + 2]; + t16[13] = sgn * tr[tr_dim1 + 2]; + t16[2] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[7] = sgn * tr[(tr_dim1 << 1) + 1]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[b_dim1 + 2]; + btmp[2] = b[(b_dim1 << 1) + 1]; + btmp[3] = b[(b_dim1 << 1) + 2]; + +/* Perform elimination */ + + for (i__ = 1; i__ <= 3; ++i__) { + xmax = 0.; + for (ip = i__; ip <= 4; ++ip) { + for (jp = i__; jp <= 4; ++jp) { + if ((d__1 = t16[ip + (jp << 2) - 5], abs(d__1)) >= xmax) { + xmax = (d__1 = t16[ip + (jp << 2) - 5], abs(d__1)); + ipsv = ip; + jpsv = jp; + } +/* L60: */ + } +/* L70: */ + } + if (ipsv != i__) { + dswap_(&c__4, &t16[ipsv - 1], &c__4, &t16[i__ - 1], &c__4); + temp = btmp[i__ - 1]; + btmp[i__ - 1] = btmp[ipsv - 1]; + btmp[ipsv - 1] = temp; + } + if (jpsv != i__) { + dswap_(&c__4, &t16[(jpsv << 2) - 4], &c__1, &t16[(i__ << 2) - 4], + &c__1); + } + jpiv[i__ - 1] = jpsv; + if ((d__1 = t16[i__ + (i__ << 2) - 5], abs(d__1)) < smin) { + *info = 1; + t16[i__ + (i__ << 2) - 5] = smin; + } + for (j = i__ + 1; j <= 4; ++j) { + t16[j + (i__ << 2) - 5] /= t16[i__ + (i__ << 2) - 5]; + btmp[j - 1] -= t16[j + (i__ << 2) - 5] * btmp[i__ - 1]; + for (k = i__ + 1; k <= 4; ++k) { + t16[j + (k << 2) - 5] -= t16[j + (i__ << 2) - 5] * t16[i__ + ( + k << 2) - 5]; +/* L80: */ + } +/* L90: */ + } +/* L100: */ + } + if (abs(t16[15]) < smin) { + t16[15] = smin; + } + *scale = 1.; + if (smlnum * 8. * abs(btmp[0]) > abs(t16[0]) || smlnum * 8. * abs(btmp[1]) + > abs(t16[5]) || smlnum * 8. * abs(btmp[2]) > abs(t16[10]) || + smlnum * 8. * abs(btmp[3]) > abs(t16[15])) { +/* Computing MAX */ + d__1 = abs(btmp[0]), d__2 = abs(btmp[1]), d__1 = std::max(d__1,d__2), d__2 + = abs(btmp[2]), d__1 = std::max(d__1,d__2), d__2 = abs(btmp[3]); + *scale = .125 / std::max(d__1,d__2); + btmp[0] *= *scale; + btmp[1] *= *scale; + btmp[2] *= *scale; + btmp[3] *= *scale; + } + for (i__ = 1; i__ <= 4; ++i__) { + k = 5 - i__; + temp = 1. / t16[k + (k << 2) - 5]; + tmp[k - 1] = btmp[k - 1] * temp; + for (j = k + 1; j <= 4; ++j) { + tmp[k - 1] -= temp * t16[k + (j << 2) - 5] * tmp[j - 1]; +/* L110: */ + } +/* L120: */ + } + for (i__ = 1; i__ <= 3; ++i__) { + if (jpiv[4 - i__ - 1] != 4 - i__) { + temp = tmp[4 - i__ - 1]; + tmp[4 - i__ - 1] = tmp[jpiv[4 - i__ - 1] - 1]; + tmp[jpiv[4 - i__ - 1] - 1] = temp; + } +/* L130: */ + } + x[x_dim1 + 1] = tmp[0]; + x[x_dim1 + 2] = tmp[1]; + x[(x_dim1 << 1) + 1] = tmp[2]; + x[(x_dim1 << 1) + 2] = tmp[3]; +/* Computing MAX */ + d__1 = abs(tmp[0]) + abs(tmp[2]), d__2 = abs(tmp[1]) + abs(tmp[3]); + *xnorm = std::max(d__1,d__2); + return 0; + +/* End of DLASY2 */ + +} /* dlasy2_ */ + +/* Subroutine */ int dlasyf_(const char *uplo, integer *n, integer *nb, integer *kb, + double *a, integer *lda, integer *ipiv, double *w, integer *ldw, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b8 = -1.; + static double c_b9 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2, d__3; + + /* Local variables */ + integer j, k; + double t, r1, d11, d21, d22; + integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax; + double alpha; + integer kstep; + double absakk; + double colmax, rowmax; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLASYF computes a partial factorization of a real symmetric matrix A */ +/* using the Bunch-Kaufman diagonal pivoting method. The partial */ +/* factorization has the form: */ + +/* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* ( 0 U22 ) ( 0 D ) ( U12' U22' ) */ + +/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L' */ +/* ( L21 I ) ( 0 A22 ) ( 0 I ) */ + +/* where the order of D is at most NB. The actual order is returned in */ +/* the argument KB, and is either NB or NB-1, or N if N <= NB. */ + +/* DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code */ +/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */ +/* A22 (if UPLO = 'L'). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored: */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NB (input) INTEGER */ +/* The maximum number of columns of the matrix A that should be */ +/* factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* blocks. */ + +/* KB (output) INTEGER */ +/* The number of columns of A that were actually factored. */ +/* KB is either NB-1 or NB, or N if N <= NB. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n-by-n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n-by-n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ +/* On exit, A contains details of the partial factorization. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D. */ +/* If UPLO = 'U', only the last KB elements of IPIV are set; */ +/* if UPLO = 'L', only the first KB elements are set. */ + +/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ + +/* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB) */ + +/* LDW (input) INTEGER */ +/* The leading dimension of the array W. LDW >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* has been completed, but the block diagonal matrix D is */ +/* exactly singular. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + +/* KW is the column of W which corresponds to column K of A */ + + k = *n; +L10: + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + +/* Copy column K of A to column KW of W and update it */ + + dcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw * + w_dim1 + 1], &c__1); + } + + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = w[k + kw * w_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k > 1) { + i__1 = k - 1; + imax = idamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + colmax = (d__1 = w[imax + kw * w_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (std::max(absakk,colmax) == 0.) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* Copy column IMAX to column KW-1 of W and update it */ + + dcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + dcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = k - imax; + jmax = imax + idamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + rowmax = (d__1 = w[jmax + (kw - 1) * w_dim1], abs(d__1)); + if (imax > 1) { + i__1 = imax - 1; + jmax = idamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = w[jmax + (kw - 1) * w_dim1], + abs(d__1)); + rowmax = std::max(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = w[imax + (kw - 1) * w_dim1], abs(d__1)) >= + alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW */ + + dcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + + kk = k - kstep + 1; + kkw = *nb + kk - *n; + +/* Updated column KP is already stored in column KKW of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = k - 1 - kp; + dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + dcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + +/* Interchange rows KK and KP in last KK columns of A and W */ + + i__1 = *n - kk + 1; + dswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + dswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column KW of W now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Store U(k) in column k of A */ + + dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + r1 = 1. / a[k + k * a_dim1]; + i__1 = k - 1; + dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + +/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ +/* hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + + if (k > 2) { + +/* Store U(k) and U(k-1) in columns k and k-1 of A */ + + d21 = w[k - 1 + kw * w_dim1]; + d11 = w[k + kw * w_dim1] / d21; + d22 = w[k - 1 + (kw - 1) * w_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + d21 = t / d21; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1) + * w_dim1] - w[j + kw * w_dim1]); + a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]); +/* L20: */ + } + } + +/* Copy D(k) to A */ + + a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; + a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; + a[k + k * a_dim1] = w[k + kw * w_dim1]; + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12' = A11 - U12*W' */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = std::min(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + dgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + i__2 = j - 1; + i__3 = *n - k; + dgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[( + k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, + &c_b9, &a[j * a_dim1 + 1], lda); +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in columns k+1:n */ + + j = k + 1; +L60: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + ++j; + } + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + dswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j <= *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + dcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1); + + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = w[k + k * w_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k < *n) { + i__1 = *n - k; + imax = k + idamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + colmax = (d__1 = w[imax + k * w_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (std::max(absakk,colmax) == 0.) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + dcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + dcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) * + w_dim1], &c__1); + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = imax - k; + jmax = k - 1 + idamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + rowmax = (d__1 = w[jmax + (k + 1) * w_dim1], abs(d__1)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + idamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = w[jmax + (k + 1) * w_dim1], + abs(d__1)); + rowmax = std::max(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = w[imax + (k + 1) * w_dim1], abs(d__1)) >= + alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K */ + + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + + kk = k + kstep - 1; + +/* Updated column KP is already stored in column KK of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = kp - k - 1; + dcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + dcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + +/* Interchange rows KK and KP in first KK columns of A and W */ + + dswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + dswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + +/* Store L(k) in column k of A */ + + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + r1 = 1. / a[k + k * a_dim1]; + i__1 = *n - k; + dscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Store L(k) and L(k+1) in columns k and k+1 of A */ + + d21 = w[k + 1 + k * w_dim1]; + d11 = w[k + 1 + (k + 1) * w_dim1] / d21; + d22 = w[k + k * w_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + d21 = t / d21; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] - + w[j + (k + 1) * w_dim1]); + a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]); +/* L80: */ + } + } + +/* Copy D(k) to A */ + + a[k + k * a_dim1] = w[k + k * w_dim1]; + a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; + a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21' = A22 - L21*W' */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = std::min(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + dgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1] +, &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* in columns 1:k-1 */ + + j = k - 1; +L120: + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; + --j; + } + --j; + if (jp != jj && j >= 1) { + dswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of DLASYF */ + +} /* dlasyf_ */ + +int dlat2s_(const char *uplo, integer *n, double *a, integer *lda, float *sa, integer *ldsa, integer *info) +{ + /* System generated locals */ + integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + double rmax; + bool upper; + + + +/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* May 2007 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE */ +/* PRECISION triangular matrix, A. */ + +/* RMAX is the overflow for the SINGLE PRECISION arithmetic */ +/* DLAS2S checks that all the entries of A are between -RMAX and */ +/* RMAX. If not the convertion is aborted and a flag is raised. */ + +/* This is an auxiliary routine so there is no argument checking. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* N (input) INTEGER */ +/* The number of rows and columns of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the N-by-N triangular coefficient matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* SA (output) REAL array, dimension (LDSA,N) */ +/* Only the UPLO part of SA is referenced. On exit, if INFO=0, */ +/* the N-by-N coefficient matrix SA; if INFO>0, the content of */ +/* the UPLO part of SA is unspecified. */ + +/* LDSA (input) INTEGER */ +/* The leading dimension of the array SA. LDSA >= max(1,M). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* = 1: an entry of the matrix A is greater than the SINGLE */ +/* PRECISION overflow threshold, in this case, the content */ +/* of the UPLO part of SA in exit is unspecified. */ + +/* ========= */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + sa_dim1 = *ldsa; + sa_offset = 1 + sa_dim1; + sa -= sa_offset; + + /* Function Body */ + rmax = slamch_("O"); + upper = lsame_(uplo, "U"); + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax) + { + *info = 1; + goto L50; + } + sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax) + { + *info = 1; + goto L50; + } + sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + } +L50: + + return 0; + +/* End of DLAT2S */ + +} /* dlat2s_ */ + +/* Subroutine */ int dlatbs_(const char *uplo, const char *trans, const char *diag, const char * + normin, integer *n, integer *kd, double *ab, integer *ldab, + double *x, double *scale, double *cnorm, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b36 = .5; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j; + double xj, rec, tjj; + integer jinc, jlen; + double xbnd; + integer imax; + double tmax, tjjs, xmax, grow, sumj; + integer maind; + double tscal, uscal; + integer jlast; + bool upper; + double bignum; + bool notran; + integer jfirst; + double smlnum; + bool nounit; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLATBS solves one of the triangular systems */ + +/* A *x = s*b or A'*x = s*b */ + +/* with scaling to prevent overflow, where A is an upper or lower */ +/* triangular band matrix. Here A' denotes the transpose of A, x and b */ +/* are n-element vectors, and s is a scaling factor, usually less than */ +/* or equal to 1, chosen so that the components of x will be less than */ +/* the overflow threshold. If the unscaled problem will not cause */ +/* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A */ +/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ +/* non-trivial solution to A*x = 0 is returned. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the matrix A is upper or lower triangular. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the operation applied to A. */ +/* = 'N': Solve A * x = s*b (No transpose) */ +/* = 'T': Solve A'* x = s*b (Transpose) */ +/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* Specifies whether or not the matrix A is unit triangular. */ +/* = 'N': Non-unit triangular */ +/* = 'U': Unit triangular */ + +/* NORMIN (input) CHARACTER*1 */ +/* Specifies whether CNORM has been set or not. */ +/* = 'Y': CNORM contains the column norms on entry */ +/* = 'N': CNORM is not set on entry. On exit, the norms will */ +/* be computed and stored in CNORM. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of subdiagonals or superdiagonals in the */ +/* triangular matrix A. KD >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The upper or lower triangular band matrix A, stored in the */ +/* first KD+1 rows of the array. The j-th column of A is stored */ +/* in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* X (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the right hand side b of the triangular system. */ +/* On exit, X is overwritten by the solution vector x. */ + +/* SCALE (output) DOUBLE PRECISION */ +/* The scaling factor s for the triangular system */ +/* A * x = s*b or A'* x = s*b. */ +/* If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* the vector x is an exact or approximate solution to A*x = 0. */ + +/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ + +/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* contains the norm of the off-diagonal part of the j-th column */ +/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* must be greater than or equal to the 1-norm. */ + +/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* returns the 1-norm of the offdiagonal part of the j-th column */ +/* of A. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ + +/* Further Details */ +/* ======= ======= */ + +/* A rough bound on x is computed; if that is less than overflow, DTBSV */ +/* is called, otherwise, specific code is used which checks for possible */ +/* overflow or divide-by-zero at every operation. */ + +/* A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* if A is lower triangular is */ + +/* x[1:n] := b[1:n] */ +/* for j = 1, ..., n */ +/* x(j) := x(j) / A(j,j) */ +/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* end */ + +/* Define bounds on the components of x after j iterations of the loop: */ +/* M(j) = bound on x[1:j] */ +/* G(j) = bound on x[j+1:n] */ +/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ + +/* Then for iteration j+1 we have */ +/* M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ + +/* where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* column j+1 of A, not counting the diagonal. Hence */ + +/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* 1<=i<=j */ +/* and */ + +/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* 1<=i< j */ + +/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the */ +/* reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* max(underflow, 1/overflow). */ + +/* The bound on x(j) is also used to determine when a step in the */ +/* columnwise method can be performed without fear of overflow. If */ +/* the computed bound is greater than a large constant, x is scaled to */ +/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ + +/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */ +/* algorithm for A upper triangular is */ + +/* for j = 1, ..., n */ +/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ +/* end */ + +/* We simultaneously compute two bounds */ +/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ +/* M(j) = bound on x(i), 1<=i<=j */ + +/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ +/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* Then the bound on x(j) is */ + +/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ + +/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* 1<=i<=j */ + +/* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater */ +/* than max(underflow, 1/overflow). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --x; + --cnorm; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*kd < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATBS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = dlamch_("Safe minimum") / dlamch_("Precision"); + bignum = 1. / smlnum; + *scale = 1.; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = j - 1; + jlen = std::min(i__2,i__3); + cnorm[j] = dasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], & + c__1); +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + jlen = std::min(i__2,i__3); + if (jlen > 0) { + cnorm[j] = dasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1); + } else { + cnorm[j] = 0.; + } +/* L20: */ + } + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM. */ + + imax = idamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum) { + tscal = 1.; + } else { + tscal = 1. / (smlnum * tmax); + dscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine DTBSV can be used. */ + + j = idamax_(n, &x[1], &c__1); + xmax = (d__1 = x[j], abs(d__1)); + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + maind = *kd + 1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + maind = 1; + } + + if (tscal != 1.) { + grow = 0.; + goto L50; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = max{x(i), i=1,...,n}. */ + + grow = 1. / std::max(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* M(j) = G(j-1) / abs(A(j,j)) */ + + tjj = (d__1 = ab[maind + j * ab_dim1], abs(d__1)); +/* Computing MIN */ + d__1 = xbnd, d__2 = std::min(1.,tjj) * grow; + xbnd = std::min(d__1,d__2); + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.; + } +/* L30: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ + +/* Computing MIN */ + d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); + grow = std::min(d__1,d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1. / (cnorm[j] + 1.); +/* L40: */ + } + } +L50: + + ; + } else { + +/* Compute the growth in A' * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + maind = *kd + 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + maind = 1; + } + + if (tscal != 1.) { + grow = 0.; + goto L80; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = max{x(i), i=1,...,n}. */ + + grow = 1. / std::max(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.; +/* Computing MIN */ + d__1 = grow, d__2 = xbnd / xj; + grow = std::min(d__1,d__2); + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + tjj = (d__1 = ab[maind + j * ab_dim1], abs(d__1)); + if (xj > tjj) { + xbnd *= tjj / xj; + } +/* L60: */ + } + grow = std::min(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ + +/* Computing MIN */ + d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); + grow = std::min(d__1,d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.; + grow /= xj; +/* L70: */ + } + } +L80: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum / xmax; + dscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } + + if (notran) { + +/* Solve A * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + tjjs = ab[maind + j * ab_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L100; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; +/* L90: */ + } + x[j] = 1.; + xj = 1.; + *scale = 0.; + xmax = 0.; + } +L100: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.) { + rec = 1. / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + dscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */ +/* x(j)* A(max(1,j-kd):j-1,j) */ + +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = std::min(i__3,i__4); + d__1 = -x[j] * tscal; + daxpy_(&jlen, &d__1, &ab[*kd + 1 - jlen + j * ab_dim1] +, &c__1, &x[j - jlen], &c__1); + i__3 = j - 1; + i__ = idamax_(&i__3, &x[1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + } else if (j < *n) { + +/* Compute the update */ +/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */ +/* x(j) * A(j+1:min(j+kd,n),j) */ + +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = std::min(i__3,i__4); + if (jlen > 0) { + d__1 = -x[j] * tscal; + daxpy_(&jlen, &d__1, &ab[j * ab_dim1 + 2], &c__1, &x[ + j + 1], &c__1); + } + i__3 = *n - j; + i__ = j + idamax_(&i__3, &x[j + 1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } +/* L110: */ + } + + } else { + +/* Solve A' * x = b */ + + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + xj = (d__1 = x[j], abs(d__1)); + uscal = tscal; + rec = 1. / std::max(xmax,1.); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5; + if (nounit) { + tjjs = ab[maind + j * ab_dim1] * tscal; + } else { + tjjs = tscal; + } + tjj = abs(tjjs); + if (tjj > 1.) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + d__1 = 1., d__2 = rec * tjj; + rec = std::min(d__1,d__2); + uscal /= tjjs; + } + if (rec < 1.) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + sumj = 0.; + if (uscal == 1.) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call DDOT to perform the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = std::min(i__3,i__4); + sumj = ddot_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], + &c__1, &x[j - jlen], &c__1); + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = std::min(i__3,i__4); + if (jlen > 0) { + sumj = ddot_(&jlen, &ab[j * ab_dim1 + 2], &c__1, & + x[j + 1], &c__1); + } + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = std::min(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += ab[*kd + i__ - jlen + j * ab_dim1] * + uscal * x[j - jlen - 1 + i__]; +/* L120: */ + } + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = std::min(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += ab[i__ + 1 + j * ab_dim1] * uscal * x[j + + i__]; +/* L130: */ + } + } + } + + if (uscal == tscal) { + +/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + x[j] -= sumj; + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + tjjs = ab[maind + j * ab_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L150; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A'*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; +/* L140: */ + } + x[j] = 1.; + *scale = 0.; + xmax = 0.; + } +L150: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ +/* product has already been divided by 1/A(j,j). */ + + x[j] = x[j] / tjjs - sumj; + } +/* Computing MAX */ + d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); + xmax = std::max(d__2,d__3); +/* L160: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.) { + d__1 = 1. / tscal; + dscal_(n, &d__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of DLATBS */ + +} /* dlatbs_ */ + +/* Subroutine */ int dlatdf_(integer *ijob, integer *n, double *z__, + integer *ldz, double *rhs, double *rdsum, double *rdscal, + integer *ipiv, integer *jpiv) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b23 = 1.; + static double c_b37 = -1.; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, j, k; + double bm, bp, xm[8], xp[8]; + integer info; + double temp, work[32]; + double pmone; + double sminu; + integer iwork[8]; + double splus; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLATDF uses the LU factorization of the n-by-n matrix Z computed by */ +/* DGETC2 and computes a contribution to the reciprocal Dif-estimate */ +/* by solving Z * x = b for x, and choosing the r.h.s. b such that */ +/* the norm of x is as large as possible. On entry RHS = b holds the */ +/* contribution from earlier solved sub-systems, and on return RHS = x. */ + +/* The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q, */ +/* where P and Q are permutation matrices. L is lower triangular with */ +/* unit diagonal elements and U is upper triangular. */ + +/* Arguments */ +/* ========= */ + +/* IJOB (input) INTEGER */ +/* IJOB = 2: First compute an approximative null-vector e */ +/* of Z using DGECON, e is normalized and solve for */ +/* Zx = +-e - f with the sign giving the greater value */ +/* of 2-norm(x). About 5 times as expensive as Default. */ +/* IJOB .ne. 2: Local look ahead strategy where all entries of */ +/* the r.h.s. b is choosen as either +1 or -1 (Default). */ + +/* N (input) INTEGER */ +/* The number of columns of the matrix Z. */ + +/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* On entry, the LU part of the factorization of the n-by-n */ +/* matrix Z computed by DGETC2: Z = P * L * U * Q */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDA >= max(1, N). */ + +/* RHS (input/output) DOUBLE PRECISION array, dimension N. */ +/* On entry, RHS contains contributions from other subsystems. */ +/* On exit, RHS contains the solution of the subsystem with */ +/* entries acoording to the value of IJOB (see above). */ + +/* RDSUM (input/output) DOUBLE PRECISION */ +/* On entry, the sum of squares of computed contributions to */ +/* the Dif-estimate under computation by DTGSYL, where the */ +/* scaling factor RDSCAL (see below) has been factored out. */ +/* On exit, the corresponding sum of squares updated with the */ +/* contributions from the current sub-system. */ +/* If TRANS = 'T' RDSUM is not touched. */ +/* NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL. */ + +/* RDSCAL (input/output) DOUBLE PRECISION */ +/* On entry, scaling factor used to prevent overflow in RDSUM. */ +/* On exit, RDSCAL is updated w.r.t. the current contributions */ +/* in RDSUM. */ +/* If TRANS = 'T', RDSCAL is not touched. */ +/* NOTE: RDSCAL only makes sense when DTGSY2 is called by */ +/* DTGSYL. */ + +/* IPIV (input) INTEGER array, dimension (N). */ +/* The pivot indices; for 1 <= i <= N, row i of the */ +/* matrix has been interchanged with row IPIV(i). */ + +/* JPIV (input) INTEGER array, dimension (N). */ +/* The pivot indices; for 1 <= j <= N, column j of the */ +/* matrix has been interchanged with column JPIV(j). */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* This routine is a further developed implementation of algorithm */ +/* BSOLVE in [1] using complete pivoting in the LU factorization. */ + +/* [1] Bo Kagstrom and Lars Westin, */ +/* Generalized Schur Methods with Condition Estimators for */ +/* Solving the Generalized Sylvester Equation, IEEE Transactions */ +/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */ + +/* [2] Peter Poromaa, */ +/* On Efficient and Robust Estimators for the Separation */ +/* between two Regular Matrix Pairs with Applications in */ +/* Condition Estimation. Report IMINF-95.05, Departement of */ +/* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --rhs; + --ipiv; + --jpiv; + + /* Function Body */ + if (*ijob != 2) { + +/* Apply permutations IPIV to RHS */ + + i__1 = *n - 1; + dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1); + +/* Solve for L-part choosing RHS either to +1 or -1. */ + + pmone = -1.; + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + bp = rhs[j] + 1.; + bm = rhs[j] - 1.; + splus = 1.; + +/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and */ +/* SMIN computed more efficiently than in BSOLVE [1]. */ + + i__2 = *n - j; + splus += ddot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1 + + j * z_dim1], &c__1); + i__2 = *n - j; + sminu = ddot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], + &c__1); + splus *= rhs[j]; + if (splus > sminu) { + rhs[j] = bp; + } else if (sminu > splus) { + rhs[j] = bm; + } else { + +/* In this case the updating sums are equal and we can */ +/* choose RHS(J) +1 or -1. The first time this happens */ +/* we choose -1, thereafter +1. This is a simple way to */ +/* get good estimates of matrices like Byers well-known */ +/* example (see [1]). (Not done in BSOLVE.) */ + + rhs[j] += pmone; + pmone = 1.; + } + +/* Compute the remaining r.h.s. */ + + temp = -rhs[j]; + i__2 = *n - j; + daxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], + &c__1); + +/* L10: */ + } + +/* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done */ +/* in BSOLVE and will hopefully give us a better estimate because */ +/* any ill-conditioning of the original matrix is transfered to U */ +/* and not to L. U(N, N) is an approximation to sigma_min(LU). */ + + i__1 = *n - 1; + dcopy_(&i__1, &rhs[1], &c__1, xp, &c__1); + xp[*n - 1] = rhs[*n] + 1.; + rhs[*n] += -1.; + splus = 0.; + sminu = 0.; + for (i__ = *n; i__ >= 1; --i__) { + temp = 1. / z__[i__ + i__ * z_dim1]; + xp[i__ - 1] *= temp; + rhs[i__] *= temp; + i__1 = *n; + for (k = i__ + 1; k <= i__1; ++k) { + xp[i__ - 1] -= xp[k - 1] * (z__[i__ + k * z_dim1] * temp); + rhs[i__] -= rhs[k] * (z__[i__ + k * z_dim1] * temp); +/* L20: */ + } + splus += (d__1 = xp[i__ - 1], abs(d__1)); + sminu += (d__1 = rhs[i__], abs(d__1)); +/* L30: */ + } + if (splus > sminu) { + dcopy_(n, xp, &c__1, &rhs[1], &c__1); + } + +/* Apply the permutations JPIV to the computed solution (RHS) */ + + i__1 = *n - 1; + dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1); + +/* Compute the sum of squares */ + + dlassq_(n, &rhs[1], &c__1, rdscal, rdsum); + + } else { + +/* IJOB = 2, Compute approximate nullvector XM of Z */ + + dgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, & + info); + dcopy_(n, &work[*n], &c__1, xm, &c__1); + +/* Compute RHS */ + + i__1 = *n - 1; + dlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1); + temp = 1. / sqrt(ddot_(n, xm, &c__1, xm, &c__1)); + dscal_(n, &temp, xm, &c__1); + dcopy_(n, xm, &c__1, xp, &c__1); + daxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1); + daxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1); + dgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp); + dgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp); + if (dasum_(n, xp, &c__1) > dasum_(n, &rhs[1], &c__1)) { + dcopy_(n, xp, &c__1, &rhs[1], &c__1); + } + +/* Compute the sum of squares */ + + dlassq_(n, &rhs[1], &c__1, rdscal, rdsum); + + } + + return 0; + +/* End of DLATDF */ + +} /* dlatdf_ */ + +/* Subroutine */ int dlatps_(const char *uplo, const char *trans, const char *diag, const char * + normin, integer *n, double *ap, double *x, double *scale, + double *cnorm, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b36 = .5; + + /* System generated locals */ + integer i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, ip; + double xj, rec, tjj; + integer jinc, jlen; + double xbnd; + integer imax; + double tmax, tjjs, xmax, grow, sumj; + double tscal, uscal; + integer jlast; + bool upper; + double bignum; + bool notran; + integer jfirst; + double smlnum; + bool nounit; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLATPS solves one of the triangular systems */ + +/* A *x = s*b or A'*x = s*b */ + +/* with scaling to prevent overflow, where A is an upper or lower */ +/* triangular matrix stored in packed form. Here A' denotes the */ +/* transpose of A, x and b are n-element vectors, and s is a scaling */ +/* factor, usually less than or equal to 1, chosen so that the */ +/* components of x will be less than the overflow threshold. If the */ +/* unscaled problem will not cause overflow, the Level 2 BLAS routine */ +/* DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */ +/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the matrix A is upper or lower triangular. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the operation applied to A. */ +/* = 'N': Solve A * x = s*b (No transpose) */ +/* = 'T': Solve A'* x = s*b (Transpose) */ +/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* Specifies whether or not the matrix A is unit triangular. */ +/* = 'N': Non-unit triangular */ +/* = 'U': Unit triangular */ + +/* NORMIN (input) CHARACTER*1 */ +/* Specifies whether CNORM has been set or not. */ +/* = 'Y': CNORM contains the column norms on entry */ +/* = 'N': CNORM is not set on entry. On exit, the norms will */ +/* be computed and stored in CNORM. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangular matrix A, packed columnwise in */ +/* a linear array. The j-th column of A is stored in the array */ +/* AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* X (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the right hand side b of the triangular system. */ +/* On exit, X is overwritten by the solution vector x. */ + +/* SCALE (output) DOUBLE PRECISION */ +/* The scaling factor s for the triangular system */ +/* A * x = s*b or A'* x = s*b. */ +/* If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* the vector x is an exact or approximate solution to A*x = 0. */ + +/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ + +/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* contains the norm of the off-diagonal part of the j-th column */ +/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* must be greater than or equal to the 1-norm. */ + +/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* returns the 1-norm of the offdiagonal part of the j-th column */ +/* of A. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ + +/* Further Details */ +/* ======= ======= */ + +/* A rough bound on x is computed; if that is less than overflow, DTPSV */ +/* is called, otherwise, specific code is used which checks for possible */ +/* overflow or divide-by-zero at every operation. */ + +/* A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* if A is lower triangular is */ + +/* x[1:n] := b[1:n] */ +/* for j = 1, ..., n */ +/* x(j) := x(j) / A(j,j) */ +/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* end */ + +/* Define bounds on the components of x after j iterations of the loop: */ +/* M(j) = bound on x[1:j] */ +/* G(j) = bound on x[j+1:n] */ +/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ + +/* Then for iteration j+1 we have */ +/* M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ + +/* where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* column j+1 of A, not counting the diagonal. Hence */ + +/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* 1<=i<=j */ +/* and */ + +/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* 1<=i< j */ + +/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the */ +/* reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* max(underflow, 1/overflow). */ + +/* The bound on x(j) is also used to determine when a step in the */ +/* columnwise method can be performed without fear of overflow. If */ +/* the computed bound is greater than a large constant, x is scaled to */ +/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ + +/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */ +/* algorithm for A upper triangular is */ + +/* for j = 1, ..., n */ +/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ +/* end */ + +/* We simultaneously compute two bounds */ +/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ +/* M(j) = bound on x(i), 1<=i<=j */ + +/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ +/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* Then the bound on x(j) is */ + +/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ + +/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* 1<=i<=j */ + +/* and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater */ +/* than max(underflow, 1/overflow). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --cnorm; + --x; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATPS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = dlamch_("Safe minimum") / dlamch_("Precision"); + bignum = 1. / smlnum; + *scale = 1.; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + ip = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + cnorm[j] = dasum_(&i__2, &ap[ip], &c__1); + ip += j; +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + ip = 1; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + cnorm[j] = dasum_(&i__2, &ap[ip + 1], &c__1); + ip = ip + *n - j + 1; +/* L20: */ + } + cnorm[*n] = 0.; + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM. */ + + imax = idamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum) { + tscal = 1.; + } else { + tscal = 1. / (smlnum * tmax); + dscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine DTPSV can be used. */ + + j = idamax_(n, &x[1], &c__1); + xmax = (d__1 = x[j], abs(d__1)); + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + } + + if (tscal != 1.) { + grow = 0.; + goto L50; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = max{x(i), i=1,...,n}. */ + + grow = 1. / std::max(xbnd,smlnum); + xbnd = grow; + ip = jfirst * (jfirst + 1) / 2; + jlen = *n; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* M(j) = G(j-1) / abs(A(j,j)) */ + + tjj = (d__1 = ap[ip], abs(d__1)); +/* Computing MIN */ + d__1 = xbnd, d__2 = std::min(1.,tjj) * grow; + xbnd = std::min(d__1,d__2); + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.; + } + ip += jinc * jlen; + --jlen; +/* L30: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ + +/* Computing MIN */ + d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); + grow = std::min(d__1,d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1. / (cnorm[j] + 1.); +/* L40: */ + } + } +L50: + + ; + } else { + +/* Compute the growth in A' * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + } + + if (tscal != 1.) { + grow = 0.; + goto L80; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = max{x(i), i=1,...,n}. */ + + grow = 1. / std::max(xbnd,smlnum); + xbnd = grow; + ip = jfirst * (jfirst + 1) / 2; + jlen = 1; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.; +/* Computing MIN */ + d__1 = grow, d__2 = xbnd / xj; + grow = std::min(d__1,d__2); + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + tjj = (d__1 = ap[ip], abs(d__1)); + if (xj > tjj) { + xbnd *= tjj / xj; + } + ++jlen; + ip += jinc * jlen; +/* L60: */ + } + grow = std::min(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ + +/* Computing MIN */ + d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); + grow = std::min(d__1,d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.; + grow /= xj; +/* L70: */ + } + } +L80: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + dtpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum / xmax; + dscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } + + if (notran) { + +/* Solve A * x = b */ + + ip = jfirst * (jfirst + 1) / 2; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + tjjs = ap[ip] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L100; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; +/* L90: */ + } + x[j] = 1.; + xj = 1.; + *scale = 0.; + xmax = 0.; + } +L100: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.) { + rec = 1. / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + dscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ + + i__3 = j - 1; + d__1 = -x[j] * tscal; + daxpy_(&i__3, &d__1, &ap[ip - j + 1], &c__1, &x[1], & + c__1); + i__3 = j - 1; + i__ = idamax_(&i__3, &x[1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + ip -= j; + } else { + if (j < *n) { + +/* Compute the update */ +/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ + + i__3 = *n - j; + d__1 = -x[j] * tscal; + daxpy_(&i__3, &d__1, &ap[ip + 1], &c__1, &x[j + 1], & + c__1); + i__3 = *n - j; + i__ = j + idamax_(&i__3, &x[j + 1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + ip = ip + *n - j + 1; + } +/* L110: */ + } + + } else { + +/* Solve A' * x = b */ + + ip = jfirst * (jfirst + 1) / 2; + jlen = 1; + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + xj = (d__1 = x[j], abs(d__1)); + uscal = tscal; + rec = 1. / std::max(xmax,1.); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5; + if (nounit) { + tjjs = ap[ip] * tscal; + } else { + tjjs = tscal; + } + tjj = abs(tjjs); + if (tjj > 1.) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + d__1 = 1., d__2 = rec * tjj; + rec = std::min(d__1,d__2); + uscal /= tjjs; + } + if (rec < 1.) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + sumj = 0.; + if (uscal == 1.) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call DDOT to perform the dot product. */ + + if (upper) { + i__3 = j - 1; + sumj = ddot_(&i__3, &ap[ip - j + 1], &c__1, &x[1], & + c__1); + } else if (j < *n) { + i__3 = *n - j; + sumj = ddot_(&i__3, &ap[ip + 1], &c__1, &x[j + 1], & + c__1); + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += ap[ip - j + i__] * uscal * x[i__]; +/* L120: */ + } + } else if (j < *n) { + i__3 = *n - j; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += ap[ip + i__] * uscal * x[j + i__]; +/* L130: */ + } + } + } + + if (uscal == tscal) { + +/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + x[j] -= sumj; + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + tjjs = ap[ip] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L150; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A'*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; +/* L140: */ + } + x[j] = 1.; + *scale = 0.; + xmax = 0.; + } +L150: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ +/* product has already been divided by 1/A(j,j). */ + + x[j] = x[j] / tjjs - sumj; + } +/* Computing MAX */ + d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); + xmax = std::max(d__2,d__3); + ++jlen; + ip += jinc * jlen; +/* L160: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.) { + d__1 = 1. / tscal; + dscal_(n, &d__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of DLATPS */ + +} /* dlatps_ */ + +/* Subroutine */ int dlatrd_(const char *uplo, integer *n, integer *nb, double * + a, integer *lda, double *e, double *tau, double *w, + integer *ldw) +{ + /* Table of constant values */ + static double c_b5 = -1.; + static double c_b6 = 1.; + static integer c__1 = 1; + static double c_b16 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, iw; + double alpha; + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLATRD reduces NB rows and columns of a real symmetric matrix A to */ +/* symmetric tridiagonal form by an orthogonal similarity */ +/* transformation Q' * A * Q, and returns the matrices V and W which are */ +/* needed to apply the transformation to the unreduced part of A. */ + +/* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a */ +/* matrix, of which the upper triangle is supplied; */ +/* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a */ +/* matrix, of which the lower triangle is supplied. */ + +/* This is an auxiliary routine called by DSYTRD. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored: */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. */ + +/* NB (input) INTEGER */ +/* The number of rows and columns to be reduced. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n-by-n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n-by-n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ +/* On exit: */ +/* if UPLO = 'U', the last NB columns have been reduced to */ +/* tridiagonal form, with the diagonal elements overwriting */ +/* the diagonal elements of A; the elements above the diagonal */ +/* with the array TAU, represent the orthogonal matrix Q as a */ +/* product of elementary reflectors; */ +/* if UPLO = 'L', the first NB columns have been reduced to */ +/* tridiagonal form, with the diagonal elements overwriting */ +/* the diagonal elements of A; 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 >= (1,N). */ + +/* E (output) DOUBLE PRECISION array, dimension (N-1) */ +/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */ +/* elements of the last NB columns of the reduced matrix; */ +/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */ +/* the first NB columns of the reduced matrix. */ + +/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The scalar factors of the elementary reflectors, stored in */ +/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */ +/* See Further Details. */ + +/* W (output) DOUBLE PRECISION array, dimension (LDW,NB) */ +/* The n-by-nb matrix W required to update the unreduced part */ +/* of A. */ + +/* LDW (input) INTEGER */ +/* The leading dimension of the array W. LDW >= max(1,N). */ + +/* Further Details */ +/* =============== */ + +/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ +/* reflectors */ + +/* Q = H(n) H(n-1) . . . H(n-nb+1). */ + +/* 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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */ +/* and tau in TAU(i-1). */ + +/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ +/* reflectors */ + +/* Q = H(1) H(2) . . . H(nb). */ + +/* 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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ +/* and tau in TAU(i). */ + +/* The elements of the vectors v together form the n-by-nb matrix V */ +/* which is needed, with W, to apply the transformation to the unreduced */ +/* part of the matrix, using a symmetric rank-2k update of the form: */ +/* A := A - V*W' - W*V'. */ + +/* The contents of A on exit are illustrated by the following examples */ +/* with n = 5 and nb = 2: */ + +/* if UPLO = 'U': if UPLO = 'L': */ + +/* ( a a a v4 v5 ) ( d ) */ +/* ( a a v4 v5 ) ( 1 d ) */ +/* ( a 1 v5 ) ( v1 1 a ) */ +/* ( d 1 ) ( v1 v2 a a ) */ +/* ( d ) ( v1 v2 a a a ) */ + +/* where d denotes a diagonal element of the reduced matrix, a denotes */ +/* an element of the original matrix that is unchanged, and vi denotes */ +/* an element of the vector defining H(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --e; + --tau; + w_dim1 = *ldw; + w_offset = 1 + w_dim1; + w -= w_offset; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + + if (lsame_(uplo, "U")) { + +/* Reduce last NB columns of upper triangle */ + + i__1 = *n - *nb + 1; + for (i__ = *n; i__ >= i__1; --i__) { + iw = i__ - *n + *nb; + if (i__ < *n) { + +/* Update A(1:i,i) */ + + i__2 = *n - i__; + dgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & + c_b6, &a[i__ * a_dim1 + 1], &c__1); + i__2 = *n - i__; + dgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * + w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b6, &a[i__ * a_dim1 + 1], &c__1); + } + if (i__ > 1) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(1:i-2,i) */ + + i__2 = i__ - 1; + dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + + 1], &c__1, &tau[i__ - 1]); + e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; + a[i__ - 1 + i__ * a_dim1] = 1.; + +/* Compute W(1:i-1,i) */ + + i__2 = i__ - 1; + dsymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * + a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], & + c__1); + if (i__ < *n) { + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * + w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, & + c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, & + c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * + w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); + } + i__2 = i__ - 1; + dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); + i__2 = i__ - 1; + alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1], + &c__1, &a[i__ * a_dim1 + 1], &c__1); + i__2 = i__ - 1; + daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * + w_dim1 + 1], &c__1); + } + +/* L10: */ + } + } else { + +/* Reduce first NB columns of lower triangle */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i:n,i) */ + + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, + &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], & + c__1); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, + &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], & + c__1); + if (i__ < *n) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(i+2:n,i) */ + + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *n)+ + i__ * a_dim1], &c__1, &tau[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.; + +/* Compute W(i+1:n,i) */ + + i__2 = *n - i__; + dsymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1] +, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], + ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ * w_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + + a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ * w_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + + w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ * + w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + } + +/* L20: */ + } + } + + return 0; + +/* End of DLATRD */ + +} /* dlatrd_ */ + +/* Subroutine */ int dlatrs_(const char *uplo, const char *trans, const char *diag, const char * + normin, integer *n, double *a, integer *lda, double *x, + double *scale, double *cnorm, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b36 = .5; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j; + double xj, rec, tjj; + integer jinc; + double xbnd; + integer imax; + double tmax, tjjs, xmax, grow, sumj; + double tscal, uscal; + integer jlast; + bool upper; + double bignum; + bool notran; + integer jfirst; + double smlnum; + bool nounit; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLATRS solves one of the triangular systems */ + +/* A *x = s*b or A'*x = s*b */ + +/* with scaling to prevent overflow. Here A is an upper or lower */ +/* triangular matrix, A' denotes the transpose of A, x and b are */ +/* n-element vectors, and s is a scaling factor, usually less than */ +/* or equal to 1, chosen so that the components of x will be less than */ +/* the overflow threshold. If the unscaled problem will not cause */ +/* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A */ +/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ +/* non-trivial solution to A*x = 0 is returned. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the matrix A is upper or lower triangular. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the operation applied to A. */ +/* = 'N': Solve A * x = s*b (No transpose) */ +/* = 'T': Solve A'* x = s*b (Transpose) */ +/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* Specifies whether or not the matrix A is unit triangular. */ +/* = 'N': Non-unit triangular */ +/* = 'U': Unit triangular */ + +/* NORMIN (input) CHARACTER*1 */ +/* Specifies whether CNORM has been set or not. */ +/* = 'Y': CNORM contains the column norms on entry */ +/* = 'N': CNORM is not set on entry. On exit, the norms will */ +/* be computed and stored in CNORM. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The triangular matrix A. If UPLO = 'U', the leading n by n */ +/* upper triangular part of the array A contains the upper */ +/* triangular matrix, and the strictly lower triangular part of */ +/* A is not referenced. If UPLO = 'L', the leading n by n lower */ +/* triangular part of the array A contains the lower triangular */ +/* matrix, and the strictly upper triangular part of A is not */ +/* referenced. If DIAG = 'U', the diagonal elements of A are */ +/* also not referenced and are assumed to be 1. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max (1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the right hand side b of the triangular system. */ +/* On exit, X is overwritten by the solution vector x. */ + +/* SCALE (output) DOUBLE PRECISION */ +/* The scaling factor s for the triangular system */ +/* A * x = s*b or A'* x = s*b. */ +/* If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* the vector x is an exact or approximate solution to A*x = 0. */ + +/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ + +/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* contains the norm of the off-diagonal part of the j-th column */ +/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* must be greater than or equal to the 1-norm. */ + +/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* returns the 1-norm of the offdiagonal part of the j-th column */ +/* of A. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ + +/* Further Details */ +/* ======= ======= */ + +/* A rough bound on x is computed; if that is less than overflow, DTRSV */ +/* is called, otherwise, specific code is used which checks for possible */ +/* overflow or divide-by-zero at every operation. */ + +/* A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* if A is lower triangular is */ + +/* x[1:n] := b[1:n] */ +/* for j = 1, ..., n */ +/* x(j) := x(j) / A(j,j) */ +/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* end */ + +/* Define bounds on the components of x after j iterations of the loop: */ +/* M(j) = bound on x[1:j] */ +/* G(j) = bound on x[j+1:n] */ +/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ + +/* Then for iteration j+1 we have */ +/* M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ + +/* where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* column j+1 of A, not counting the diagonal. Hence */ + +/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* 1<=i<=j */ +/* and */ + +/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* 1<=i< j */ + +/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the */ +/* reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* max(underflow, 1/overflow). */ + +/* The bound on x(j) is also used to determine when a step in the */ +/* columnwise method can be performed without fear of overflow. If */ +/* the computed bound is greater than a large constant, x is scaled to */ +/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ + +/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */ +/* algorithm for A upper triangular is */ + +/* for j = 1, ..., n */ +/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ +/* end */ + +/* We simultaneously compute two bounds */ +/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ +/* M(j) = bound on x(i), 1<=i<=j */ + +/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ +/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* Then the bound on x(j) is */ + +/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ + +/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* 1<=i<=j */ + +/* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater */ +/* than max(underflow, 1/overflow). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --x; + --cnorm; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = dlamch_("Safe minimum") / dlamch_("Precision"); + bignum = 1. / smlnum; + *scale = 1.; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); +/* L20: */ + } + cnorm[*n] = 0.; + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM. */ + + imax = idamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum) { + tscal = 1.; + } else { + tscal = 1. / (smlnum * tmax); + dscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine DTRSV can be used. */ + + j = idamax_(n, &x[1], &c__1); + xmax = (d__1 = x[j], abs(d__1)); + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + } + + if (tscal != 1.) { + grow = 0.; + goto L50; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = max{x(i), i=1,...,n}. */ + + grow = 1. / std::max(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* M(j) = G(j-1) / abs(A(j,j)) */ + + tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); +/* Computing MIN */ + d__1 = xbnd, d__2 = std::min(1.,tjj) * grow; + xbnd = std::min(d__1,d__2); + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.; + } +/* L30: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ + +/* Computing MIN */ + d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); + grow = std::min(d__1,d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1. / (cnorm[j] + 1.); +/* L40: */ + } + } +L50: + + ; + } else { + +/* Compute the growth in A' * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + } + + if (tscal != 1.) { + grow = 0.; + goto L80; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = max{x(i), i=1,...,n}. */ + + grow = 1. / std::max(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.; +/* Computing MIN */ + d__1 = grow, d__2 = xbnd / xj; + grow = std::min(d__1,d__2); + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); + if (xj > tjj) { + xbnd *= tjj / xj; + } +/* L60: */ + } + grow = std::min(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ + +/* Computing MIN */ + d__1 = 1., d__2 = 1. / std::max(xbnd,smlnum); + grow = std::min(d__1,d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.; + grow /= xj; +/* L70: */ + } + } +L80: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum / xmax; + dscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } + + if (notran) { + +/* Solve A * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L100; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + xj = (d__1 = x[j], abs(d__1)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; +/* L90: */ + } + x[j] = 1.; + xj = 1.; + *scale = 0.; + xmax = 0.; + } +L100: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.) { + rec = 1. / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + dscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ + + i__3 = j - 1; + d__1 = -x[j] * tscal; + daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + i__3 = j - 1; + i__ = idamax_(&i__3, &x[1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + } else { + if (j < *n) { + +/* Compute the update */ +/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ + + i__3 = *n - j; + d__1 = -x[j] * tscal; + daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, & + x[j + 1], &c__1); + i__3 = *n - j; + i__ = j + idamax_(&i__3, &x[j + 1], &c__1); + xmax = (d__1 = x[i__], abs(d__1)); + } + } +/* L110: */ + } + + } else { + +/* Solve A' * x = b */ + + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + xj = (d__1 = x[j], abs(d__1)); + uscal = tscal; + rec = 1. / std::max(xmax,1.); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5; + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + } + tjj = abs(tjjs); + if (tjj > 1.) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + d__1 = 1., d__2 = rec * tjj; + rec = std::min(d__1,d__2); + uscal /= tjjs; + } + if (rec < 1.) { + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + sumj = 0.; + if (uscal == 1.) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call DDOT to perform the dot product. */ + + if (upper) { + i__3 = j - 1; + sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + } else if (j < *n) { + i__3 = *n - j; + sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[ + j + 1], &c__1); + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += a[i__ + j * a_dim1] * uscal * x[i__]; +/* L120: */ + } + } else if (j < *n) { + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + sumj += a[i__ + j * a_dim1] * uscal * x[i__]; +/* L130: */ + } + } + } + + if (uscal == tscal) { + +/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + x[j] -= sumj; + xj = (d__1 = x[j], abs(d__1)); + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.) { + goto L150; + } + } + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1. / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + dscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A'*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.; +/* L140: */ + } + x[j] = 1.; + *scale = 0.; + xmax = 0.; + } +L150: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ +/* product has already been divided by 1/A(j,j). */ + + x[j] = x[j] / tjjs - sumj; + } +/* Computing MAX */ + d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); + xmax = std::max(d__2,d__3); +/* L160: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.) { + d__1 = 1. / tscal; + dscal_(n, &d__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of DLATRS */ + +} /* dlatrs_ */ + +/* Subroutine */ int dlatrz_(integer *m, integer *n, integer *l, double *a, integer *lda, double *tau, double *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__; + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix */ +/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means */ +/* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal */ +/* matrix and, R and A1 are M-by-M upper triangular matrices. */ + +/* 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. */ + +/* L (input) INTEGER */ +/* The number of columns of the matrix A containing the */ +/* meaningful part of the Householder vectors. N-M >= L >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the leading M-by-N upper trapezoidal part of the */ +/* array A must contain the matrix to be factorized. */ +/* On exit, the leading M-by-M upper triangular part of A */ +/* contains the upper triangular matrix R, and elements N-L+1 to */ +/* N of the first M rows of A, with the array TAU, represent the */ +/* orthogonal matrix Z as a product of M elementary reflectors. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* TAU (output) DOUBLE PRECISION array, dimension (M) */ +/* The scalar factors of the elementary reflectors. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* The factorization is obtained by Householder's method. The kth */ +/* transformation matrix, Z( k ), which is used to introduce zeros into */ +/* the ( m - k + 1 )th row of A, is given in the form */ + +/* Z( k ) = ( I 0 ), */ +/* ( 0 T( k ) ) */ + +/* where */ + +/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */ +/* ( 0 ) */ +/* ( z( k ) ) */ + +/* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */ +/* are chosen to annihilate the elements of the kth row of A2. */ + +/* The scalar tau is returned in the kth element of TAU and the vector */ +/* u( k ) in the kth row of A2, such that the elements of z( k ) are */ +/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* the upper triangular part of A1. */ + +/* Z is given by */ + +/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + if (*m == 0) { + return 0; + } else if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.; +/* L10: */ + } + return 0; + } + + for (i__ = *m; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) to annihilate */ +/* [ A(i,i) A(i,n-l+1:n) ] */ + + i__1 = *l + 1; + dlarfp_(&i__1, &a[i__ + i__ * a_dim1], &a[i__ + (*n - *l + 1) * + a_dim1], lda, &tau[i__]); + +/* Apply H(i) to A(1:i-1,i:n) from the right */ + + i__1 = i__ - 1; + i__2 = *n - i__ + 1; + dlarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1], + lda, &tau[i__], &a[i__ * a_dim1 + 1], lda, &work[1]); + +/* L20: */ + } + + return 0; + +/* End of DLATRZ */ + +} /* dlatrz_ */ + +/* Subroutine */ int dlatzm_(const char *side, integer *m, integer *n, double * + v, integer *incv, double *tau, double *c1, double *c2, + integer *ldc, double *work) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b5 = 1.; + + /* System generated locals */ + integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1; + double d__1; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This routine is deprecated and has been replaced by routine DORMRZ. */ + +/* DLATZM applies a Householder matrix generated by DTZRQF to a matrix. */ + +/* Let P = I - tau*u*u', u = ( 1 ), */ +/* ( v ) */ +/* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */ +/* SIDE = 'R'. */ + +/* If SIDE equals 'L', let */ +/* C = [ C1 ] 1 */ +/* [ C2 ] m-1 */ +/* n */ +/* Then C is overwritten by P*C. */ + +/* If SIDE equals 'R', let */ +/* C = [ C1, C2 ] m */ +/* 1 n-1 */ +/* Then C is overwritten by C*P. */ + +/* Arguments */ +/* ========= */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'L': form P * C */ +/* = 'R': form C * P */ + +/* 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' */ +/* (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ +/* The vector v in the representation of P. 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 P. */ + +/* C1 (input/output) DOUBLE PRECISION array, dimension */ +/* (LDC,N) if SIDE = 'L' */ +/* (M,1) if SIDE = 'R' */ +/* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */ +/* if SIDE = 'R'. */ + +/* On exit, the first row of P*C if SIDE = 'L', or the first */ +/* column of C*P if SIDE = 'R'. */ + +/* C2 (input/output) DOUBLE PRECISION array, dimension */ +/* (LDC, N) if SIDE = 'L' */ +/* (LDC, N-1) if SIDE = 'R' */ +/* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */ +/* m x (n - 1) matrix C2 if SIDE = 'R'. */ + +/* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */ +/* if SIDE = 'R'. */ + +/* LDC (input) INTEGER */ +/* The leading dimension of the arrays C1 and C2. LDC >= (1,M). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension */ +/* (N) if SIDE = 'L' */ +/* (M) if SIDE = 'R' */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --v; + c2_dim1 = *ldc; + c2_offset = 1 + c2_dim1; + c2 -= c2_offset; + c1_dim1 = *ldc; + c1_offset = 1 + c1_dim1; + c1 -= c1_offset; + --work; + + /* Function Body */ + if (std::min(*m,*n) == 0 || *tau == 0.) { + return 0; + } + + if (lsame_(side, "L")) { + +/* w := C1 + v' * C2 */ + + dcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1); + i__1 = *m - 1; + dgemv_("Transpose", &i__1, n, &c_b5, &c2[c2_offset], ldc, &v[1], incv, + &c_b5, &work[1], &c__1); + +/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' */ +/* [ C2 ] [ C2 ] [ v ] */ + + d__1 = -(*tau); + daxpy_(n, &d__1, &work[1], &c__1, &c1[c1_offset], ldc); + i__1 = *m - 1; + d__1 = -(*tau); + dger_(&i__1, n, &d__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset], + ldc); + + } else if (lsame_(side, "R")) { + +/* w := C1 + C2 * v */ + + dcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1); + i__1 = *n - 1; + dgemv_("No transpose", m, &i__1, &c_b5, &c2[c2_offset], ldc, &v[1], + incv, &c_b5, &work[1], &c__1); + +/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */ + + d__1 = -(*tau); + daxpy_(m, &d__1, &work[1], &c__1, &c1[c1_offset], &c__1); + i__1 = *n - 1; + d__1 = -(*tau); + dger_(m, &i__1, &d__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset], + ldc); + } + + return 0; + +/* End of DLATZM */ + +} /* dlatzm_ */ + +/* Subroutine */ int dlauu2_(const char *uplo, integer *n, double *a, integer * + lda, integer *info) +{ + /* Table of constant values */ + static double c_b7 = 1.; + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__; + double aii; + bool upper; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAUU2 computes the product U * U' or L' * L, where the triangular */ +/* factor U or L is stored in the upper or lower triangular part of */ +/* the array A. */ + +/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* overwriting the factor U in A. */ +/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* overwriting the factor L in A. */ + +/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the triangular factor stored in the array A */ +/* is upper or lower triangular: */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the triangular factor U or L. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the triangular factor U or L. */ +/* On exit, if UPLO = 'U', the upper triangle of A is */ +/* overwritten with the upper triangle of the product U * U'; */ +/* if UPLO = 'L', the lower triangle of A is overwritten with */ +/* the lower triangle of the product L' * L. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAUU2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Compute the product U * U'. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + aii = a[i__ + i__ * a_dim1]; + if (i__ < *n) { + i__2 = *n - i__ + 1; + a[i__ + i__ * a_dim1] = ddot_(&i__2, &a[i__ + i__ * a_dim1], + lda, &a[i__ + i__ * a_dim1], lda); + i__2 = i__ - 1; + i__3 = *n - i__; + dgemv_("No transpose", &i__2, &i__3, &c_b7, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & + aii, &a[i__ * a_dim1 + 1], &c__1); + } else { + dscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1); + } +/* L10: */ + } + + } else { + +/* Compute the product L' * L. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + aii = a[i__ + i__ * a_dim1]; + if (i__ < *n) { + i__2 = *n - i__ + 1; + a[i__ + i__ * a_dim1] = ddot_(&i__2, &a[i__ + i__ * a_dim1], & + c__1, &a[i__ + i__ * a_dim1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b7, &a[i__ + 1 + a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &aii, &a[i__ + + a_dim1], lda); + } else { + dscal_(&i__, &aii, &a[i__ + a_dim1], lda); + } +/* L20: */ + } + } + + return 0; + +/* End of DLAUU2 */ + +} /* dlauu2_ */ + +/* Subroutine */ int dlauum_(const char *uplo, integer *n, double *a, integer * + lda, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b15 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, ib, nb; + bool upper; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAUUM computes the product U * U' or L' * L, where the triangular */ +/* factor U or L is stored in the upper or lower triangular part of */ +/* the array A. */ + +/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* overwriting the factor U in A. */ +/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* overwriting the factor L in A. */ + +/* This is the blocked form of the algorithm, calling Level 3 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the triangular factor stored in the array A */ +/* is upper or lower triangular: */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the triangular factor U or L. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the triangular factor U or L. */ +/* On exit, if UPLO = 'U', the upper triangle of A is */ +/* overwritten with the upper triangle of the product U * U'; */ +/* if UPLO = 'L', the lower triangle of A is overwritten with */ +/* the lower triangle of the product L' * L. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAUUM", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "DLAUUM", uplo, n, &c_n1, &c_n1, &c_n1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dlauu2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute the product U * U'. */ + + i__1 = *n; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = std::min(i__3,i__4); + i__3 = i__ - 1; + dtrmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, + &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 + + 1], lda) + ; + dlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + dgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & + c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * + a_dim1 + 1], lda); + i__3 = *n - i__ - ib + 1; + dsyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ + i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + + i__ * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the product L' * L. */ + + i__2 = *n; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = std::min(i__3,i__4); + i__3 = i__ - 1; + dtrmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & + c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], + lda); + dlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + dgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & + c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + + ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); + i__3 = *n - i__ - ib + 1; + dsyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + + ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * + a_dim1], lda); + } +/* L20: */ + } + } + } + + return 0; + +/* End of DLAUUM */ + +} /* dlauum_ */ + +/* Subroutine */ int dlazq3_(integer *i0, integer *n0, double *z__, + integer *pp, double *dmin__, double *sigma, double *desig, + double *qmax, integer *nfail, integer *iter, integer *ndiv, + bool *ieee, integer *ttype, double *dmin1, double *dmin2, + double *dn, double *dn1, double *dn2, double *tau) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + double g, s, t; + integer j4, nn; + double eps, tol; + integer n0in, ipn4; + double tol2, temp; + double safmin; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds. */ +/* In case of failure it changes shifts, and tries again until output */ +/* is positive. */ + +/* Arguments */ +/* ========= */ + +/* I0 (input) INTEGER */ +/* First index. */ + +/* N0 (input) INTEGER */ +/* Last index. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ +/* Z holds the qd array. */ + +/* PP (input) INTEGER */ +/* PP=0 for ping, PP=1 for pong. */ + +/* DMIN (output) DOUBLE PRECISION */ +/* Minimum value of d. */ + +/* SIGMA (output) DOUBLE PRECISION */ +/* Sum of shifts used in current segment. */ + +/* DESIG (input/output) DOUBLE PRECISION */ +/* Lower order part of SIGMA */ + +/* QMAX (input) DOUBLE PRECISION */ +/* Maximum value of q. */ + +/* NFAIL (output) INTEGER */ +/* Number of times shift was too big. */ + +/* ITER (output) INTEGER */ +/* Number of iterations. */ + +/* NDIV (output) INTEGER */ +/* Number of divisions. */ + +/* IEEE (input) LOGICAL */ +/* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). */ + +/* TTYPE (input/output) INTEGER */ +/* Shift type. TTYPE is passed as an argument in order to save */ +/* its value between calls to DLAZQ3 */ + +/* DMIN1 (input/output) REAL */ +/* DMIN2 (input/output) REAL */ +/* DN (input/output) REAL */ +/* DN1 (input/output) REAL */ +/* DN2 (input/output) REAL */ +/* TAU (input/output) REAL */ +/* These are passed as arguments in order to save their values */ +/* between calls to DLAZQ3 */ + +/* This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1, */ +/* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of */ +/* declaring them in a SAVE statment. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Function .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + n0in = *n0; + eps = dlamch_("Precision"); + safmin = dlamch_("Safe minimum"); + tol = eps * 100.; +/* Computing 2nd power */ + d__1 = tol; + tol2 = d__1 * d__1; + g = 0.; + +/* Check for deflation. */ + +L10: + + if (*n0 < *i0) { + return 0; + } + if (*n0 == *i0) { + goto L20; + } + nn = (*n0 << 2) + *pp; + if (*n0 == *i0 + 1) { + goto L40; + } + +/* Check whether E(N0-1) is negligible, 1 eigenvalue. */ + + if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - + 4] > tol2 * z__[nn - 7]) { + goto L30; + } + +L20: + + z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma; + --(*n0); + goto L10; + +/* Check whether E(N0-2) is negligible, 2 eigenvalues. */ + +L30: + + if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ + nn - 11]) { + goto L50; + } + +L40: + + if (z__[nn - 3] > z__[nn - 7]) { + s = z__[nn - 3]; + z__[nn - 3] = z__[nn - 7]; + z__[nn - 7] = s; + } + if (z__[nn - 5] > z__[nn - 3] * tol2) { + t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; + s = z__[nn - 3] * (z__[nn - 5] / t); + if (s <= t) { + s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); + } else { + s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[nn - 7] + (s + z__[nn - 5]); + z__[nn - 3] *= z__[nn - 7] / t; + z__[nn - 7] = t; + } + z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; + z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; + *n0 += -2; + goto L10; + +L50: + +/* Reverse the qd-array, if warranted. */ + + if (*dmin__ <= 0. || *n0 < n0in) { + if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { + ipn4 = *i0 + *n0 << 2; + i__1 = *i0 + *n0 - 1 << 1; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + temp = z__[j4 - 3]; + z__[j4 - 3] = z__[ipn4 - j4 - 3]; + z__[ipn4 - j4 - 3] = temp; + temp = z__[j4 - 2]; + z__[j4 - 2] = z__[ipn4 - j4 - 2]; + z__[ipn4 - j4 - 2] = temp; + temp = z__[j4 - 1]; + z__[j4 - 1] = z__[ipn4 - j4 - 5]; + z__[ipn4 - j4 - 5] = temp; + temp = z__[j4]; + z__[j4] = z__[ipn4 - j4 - 4]; + z__[ipn4 - j4 - 4] = temp; +/* L60: */ + } + if (*n0 - *i0 <= 4) { + z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; + z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; + } +/* Computing MIN */ + d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; + *dmin2 = std::min(d__1,d__2); +/* Computing MIN */ + d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1] + , d__1 = std::min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; + z__[(*n0 << 2) + *pp - 1] = std::min(d__1,d__2); +/* Computing MIN */ + d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = + std::min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4]; + z__[(*n0 << 2) - *pp] = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = std::max(d__1, + d__2), d__2 = z__[(*i0 << 2) + *pp + 1]; + *qmax = std::max(d__1,d__2); + *dmin__ = -0.; + } + } + +/* Computing MIN */ + d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*n0 << 2) + *pp - 9], d__1 = + std::min(d__1,d__2), d__2 = *dmin2 + z__[(*n0 << 2) - *pp]; + if (*dmin__ < 0. || safmin * *qmax < std::min(d__1,d__2)) { + +/* Choose a shift. */ + + dlazq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, + dn2, tau, ttype, &g); + +/* Call dqds until DMIN > 0. */ + +L80: + + dlasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2, + ieee); + + *ndiv += *n0 - *i0 + 2; + ++(*iter); + +/* Check status. */ + + if (*dmin__ >= 0. && *dmin1 > 0.) { + +/* Success. */ + + goto L100; + + } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < + tol * (*sigma + *dn1) && abs(*dn) < tol * *sigma) { + +/* Convergence hidden by negative DN. */ + + z__[(*n0 - 1 << 2) - *pp + 2] = 0.; + *dmin__ = 0.; + goto L100; + } else if (*dmin__ < 0.) { + +/* TAU too big. Select new TAU and try again. */ + + ++(*nfail); + if (*ttype < -22) { + +/* Failed twice. Play it safe. */ + + *tau = 0.; + } else if (*dmin1 > 0.) { + +/* Late failure. Gives excellent shift. */ + + *tau = (*tau + *dmin__) * (1. - eps * 2.); + *ttype += -11; + } else { + +/* Early failure. Divide by 4. */ + + *tau *= .25; + *ttype += -12; + } + goto L80; + } else if (*dmin__ != *dmin__) { + +/* NaN. */ + + *tau = 0.; + goto L80; + } else { + +/* Possible underflow. Play it safe. */ + + goto L90; + } + } + +/* Risk of underflow. */ + +L90: + dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2); + *ndiv += *n0 - *i0 + 2; + ++(*iter); + *tau = 0.; + +L100: + if (*tau < *sigma) { + *desig += *tau; + t = *sigma + *desig; + *desig -= t - *sigma; + } else { + t = *sigma + *tau; + *desig = *sigma - (t - *tau) + *desig; + } + *sigma = t; + + return 0; + +/* End of DLAZQ3 */ + +} /* dlazq3_ */ + +/* Subroutine */ int dlazq4_(integer *i0, integer *n0, double *z__, + integer *pp, integer *n0in, double *dmin__, double *dmin1, + double *dmin2, double *dn, double *dn1, double *dn2, + double *tau, integer *ttype, double *g) +{ + /* System generated locals */ + integer i__1; + double d__1, d__2; + + /* Local variables */ + double s, a2, b1, b2; + integer i4, nn, np; + double gam, gap1, gap2; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DLAZQ4 computes an approximation TAU to the smallest eigenvalue */ +/* using values of d from the previous transform. */ + +/* I0 (input) INTEGER */ +/* First index. */ + +/* N0 (input) INTEGER */ +/* Last index. */ + +/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */ +/* Z holds the qd array. */ + +/* PP (input) INTEGER */ +/* PP=0 for ping, PP=1 for pong. */ + +/* N0IN (input) INTEGER */ +/* The value of N0 at start of EIGTEST. */ + +/* DMIN (input) DOUBLE PRECISION */ +/* Minimum value of d. */ + +/* DMIN1 (input) DOUBLE PRECISION */ +/* Minimum value of d, excluding D( N0 ). */ + +/* DMIN2 (input) DOUBLE PRECISION */ +/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ + +/* DN (input) DOUBLE PRECISION */ +/* d(N) */ + +/* DN1 (input) DOUBLE PRECISION */ +/* d(N-1) */ + +/* DN2 (input) DOUBLE PRECISION */ +/* d(N-2) */ + +/* TAU (output) DOUBLE PRECISION */ +/* This is the shift. */ + +/* TTYPE (output) INTEGER */ +/* Shift type. */ + +/* G (input/output) DOUBLE PRECISION */ +/* G is passed as an argument in order to save its value between */ +/* calls to DLAZQ4 */ + +/* Further Details */ +/* =============== */ +/* CNST1 = 9/16 */ + +/* This is a thread safe version of DLASQ4, which passes G through the */ +/* argument list in place of declaring G in a SAVE statment. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* A negative DMIN forces the shift to take that absolute value */ +/* TTYPE records the type of shift. */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + if (*dmin__ <= 0.) { + *tau = -(*dmin__); + *ttype = -1; + return 0; + } + + nn = (*n0 << 2) + *pp; + if (*n0in == *n0) { + +/* No eigenvalues deflated. */ + + if (*dmin__ == *dn || *dmin__ == *dn1) { + + b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); + b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); + a2 = z__[nn - 7] + z__[nn - 5]; + +/* Cases 2 and 3. */ + + if (*dmin__ == *dn && *dmin1 == *dn1) { + gap2 = *dmin2 - a2 - *dmin2 * .25; + if (gap2 > 0. && gap2 > b2) { + gap1 = a2 - *dn - b2 / gap2 * b2; + } else { + gap1 = a2 - *dn - (b1 + b2); + } + if (gap1 > 0. && gap1 > b1) { +/* Computing MAX */ + d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; + s = std::max(d__1,d__2); + *ttype = -2; + } else { + s = 0.; + if (*dn > b1) { + s = *dn - b1; + } + if (a2 > b1 + b2) { +/* Computing MIN */ + d__1 = s, d__2 = a2 - (b1 + b2); + s = std::min(d__1,d__2); + } +/* Computing MAX */ + d__1 = s, d__2 = *dmin__ * .333; + s = std::max(d__1,d__2); + *ttype = -3; + } + } else { + +/* Case 4. */ + + *ttype = -4; + s = *dmin__ * .25; + if (*dmin__ == *dn) { + gam = *dn; + a2 = 0.; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b2 = z__[nn - 5] / z__[nn - 7]; + np = nn - 9; + } else { + np = nn - (*pp << 1); + b2 = z__[np - 2]; + gam = *dn1; + if (z__[np - 4] > z__[np - 2]) { + return 0; + } + a2 = z__[np - 4] / z__[np - 2]; + if (z__[nn - 9] > z__[nn - 11]) { + return 0; + } + b2 = z__[nn - 9] / z__[nn - 11]; + np = nn - 13; + } + +/* Approximate contribution to norm squared from I < NN-1. */ + + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = np; i4 >= i__1; i4 += -4) { + if (b2 == 0.) { + goto L20; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (std::max(b2,b1) * 100. < a2 || .563 < a2) { + goto L20; + } +/* L10: */ + } +L20: + a2 *= 1.05; + +/* Rayleigh quotient residual bound. */ + + if (a2 < .563) { + s = gam * (1. - sqrt(a2)) / (a2 + 1.); + } + } + } else if (*dmin__ == *dn2) { + +/* Case 5. */ + + *ttype = -5; + s = *dmin__ * .25; + +/* Compute contribution to norm squared from I > NN-2. */ + + np = nn - (*pp << 1); + b1 = z__[np - 2]; + b2 = z__[np - 6]; + gam = *dn2; + if (z__[np - 8] > b2 || z__[np - 4] > b1) { + return 0; + } + a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); + +/* Approximate contribution to norm squared from I < NN-2. */ + + if (*n0 - *i0 > 2) { + b2 = z__[nn - 13] / z__[nn - 15]; + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = nn - 17; i4 >= i__1; i4 += -4) { + if (b2 == 0.) { + goto L40; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (std::max(b2,b1) * 100. < a2 || .563 < a2) { + goto L40; + } +/* L30: */ + } +L40: + a2 *= 1.05; + } + + if (a2 < .563) { + s = gam * (1. - sqrt(a2)) / (a2 + 1.); + } + } else { + +/* Case 6, no information to guide us. */ + + if (*ttype == -6) { + *g += (1. - *g) * .333; + } else if (*ttype == -18) { + *g = .083250000000000005; + } else { + *g = .25; + } + s = *g * *dmin__; + *ttype = -6; + } + + } else if (*n0in == *n0 + 1) { + +/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */ + + if (*dmin1 == *dn1 && *dmin2 == *dn2) { + +/* Cases 7 and 8. */ + + *ttype = -7; + s = *dmin1 * .333; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.) { + goto L60; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + a2 = b1; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (std::max(b1,a2) * 100. < b2) { + goto L60; + } +/* L50: */ + } +L60: + b2 = sqrt(b2 * 1.05); +/* Computing 2nd power */ + d__1 = b2; + a2 = *dmin1 / (d__1 * d__1 + 1.); + gap2 = *dmin2 * .5 - a2; + if (gap2 > 0. && gap2 > b2 * a2) { +/* Computing MAX */ + d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); + s = std::max(d__1,d__2); + } else { +/* Computing MAX */ + d__1 = s, d__2 = a2 * (1. - b2 * 1.01); + s = std::max(d__1,d__2); + *ttype = -8; + } + } else { + +/* Case 9. */ + + s = *dmin1 * .25; + if (*dmin1 == *dn1) { + s = *dmin1 * .5; + } + *ttype = -9; + } + + } else if (*n0in == *n0 + 2) { + +/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */ + +/* Cases 10 and 11. */ + + if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { + *ttype = -10; + s = *dmin2 * .333; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.) { + goto L80; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (b1 * 100. < b2) { + goto L80; + } +/* L70: */ + } +L80: + b2 = sqrt(b2 * 1.05); +/* Computing 2nd power */ + d__1 = b2; + a2 = *dmin2 / (d__1 * d__1 + 1.); + gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ + nn - 9]) - a2; + if (gap2 > 0. && gap2 > b2 * a2) { +/* Computing MAX */ + d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); + s = std::max(d__1,d__2); + } else { +/* Computing MAX */ + d__1 = s, d__2 = a2 * (1. - b2 * 1.01); + s = std::max(d__1,d__2); + } + } else { + s = *dmin2 * .25; + *ttype = -11; + } + } else if (*n0in > *n0 + 2) { + +/* Case 12, more than two eigenvalues deflated. No information. */ + + s = 0.; + *ttype = -12; + } + + *tau = s; + return 0; + +/* End of DLAZQ4 */ + +} /* dlazq4_ */ diff --git a/external/clapack/lapack_ds.cpp b/external/clapack/lapack_ds.cpp new file mode 100644 index 00000000..a347381f --- /dev/null +++ b/external/clapack/lapack_ds.cpp @@ -0,0 +1,22791 @@ +#include "clapack.h" +#include "f2cP.h" + +/* Subroutine */ int dsbev_(const char *jobz, const char *uplo, integer *n, integer *kd, + double *ab, integer *ldab, double *w, double *z__, + integer *ldz, double *work, integer *info) +{ + /* Table of constant values */ + static double c_b11 = 1.; + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, z_dim1, z_offset, i__1; + double d__1; + + /* Local variables */ + double eps; + integer inde; + double anrm; + integer imax; + double rmin, rmax; + double sigma; + integer iinfo; + bool lower, wantz; + integer iscale; + double safmin; + double bignum; + integer indwrk; + double smlnum; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBEV computes all the eigenvalues and, optionally, eigenvectors of */ +/* a real symmetric band matrix A. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* On exit, AB is overwritten by values generated during the */ +/* reduction to tridiagonal form. If UPLO = 'U', the first */ +/* superdiagonal and the diagonal of the tridiagonal matrix T */ +/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* the diagonal and first subdiagonal of T are returned in the */ +/* first two rows of AB. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD + 1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ +/* eigenvectors of the matrix A, with the i-th column of Z */ +/* holding the eigenvector associated with W(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2)) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the algorithm failed to converge; i */ +/* off-diagonal elements of an intermediate tridiagonal */ +/* form did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEV ", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (lower) { + w[1] = ab[ab_dim1 + 1]; + } else { + w[1] = ab[*kd + 1 + ab_dim1]; + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + } + +/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ + + inde = 1; + indwrk = inde + *n; + dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ + z_offset], ldz, &work[indwrk], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ + indwrk], info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + + return 0; + +/* End of DSBEV */ + +} /* dsbev_ */ + +/* Subroutine */ int dsbevd_(const char *jobz, const char *uplo, integer *n, integer *kd, + double *ab, integer *ldab, double *w, double *z__, + integer *ldz, double *work, integer *lwork, integer *iwork, + integer *liwork, integer *info) +{ + /* Table of constant values */ + static double c_b11 = 1.; + static double c_b18 = 0.; + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, z_dim1, z_offset, i__1; + double d__1; + + /* Local variables */ + double eps; + integer inde; + double anrm, rmin, rmax; + double sigma; + integer iinfo, lwmin; + bool lower, wantz; + integer indwk2, llwrk2; + integer iscale; + double safmin; + double bignum; + integer indwrk, liwmin; + double smlnum; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of */ +/* a real symmetric band matrix A. If eigenvectors are desired, it uses */ +/* a divide and conquer algorithm. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* On exit, AB is overwritten by values generated during the */ +/* reduction to tridiagonal form. If UPLO = 'U', the first */ +/* superdiagonal and the diagonal of the tridiagonal matrix T */ +/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* the diagonal and first subdiagonal of T are returned in the */ +/* first two rows of AB. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD + 1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ +/* eigenvectors of the matrix A, with the i-th column of Z */ +/* holding the eigenvector associated with W(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace/output) 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 N <= 1, LWORK must be at least 1. */ +/* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. */ +/* If JOBZ = 'V' and N > 2, LWORK must be at least */ +/* ( 1 + 5*N + 2*N**2 ). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal sizes of the WORK and IWORK */ +/* arrays, returns these values as the first entries of the WORK */ +/* and IWORK arrays, and no error message related to LWORK or */ +/* LIWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array LIWORK. */ +/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ +/* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal sizes of the WORK and */ +/* IWORK arrays, returns these values as the first entries of */ +/* the WORK and IWORK arrays, and no error message related to */ +/* LWORK or LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the algorithm failed to converge; i */ +/* off-diagonal elements of an intermediate tridiagonal */ +/* form did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else { + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = *n << 1; + } + } + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*ldab < *kd + 1) { + *info = -6; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + + if (*info == 0) { + work[1] = (double) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEVD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = ab[ab_dim1 + 1]; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + } + +/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ + + inde = 1; + indwrk = inde + *n; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ + z_offset], ldz, &work[indwrk], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info); + dgemm_("N", "N", n, n, n, &c_b11, &z__[z_offset], ldz, &work[indwrk], + n, &c_b18, &work[indwk2], n); + dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + + work[1] = (double) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSBEVD */ + +} /* dsbevd_ */ + +/* Subroutine */ int dsbevx_(const char *jobz, const char *range, const char *uplo, integer *n, + integer *kd, double *ab, integer *ldab, double *q, integer * + ldq, double *vl, double *vu, integer *il, integer *iu, + double *abstol, integer *m, double *w, double *z__, + integer *ldz, double *work, integer *iwork, integer *ifail, + integer *info) +{ + /* Table of constant values */ + static double c_b14 = 1.; + static integer c__1 = 1; + static double c_b34 = 0.; + + /* System generated locals */ + integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1, + i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, jj; + double eps, vll, vuu, tmp1; + integer indd, inde; + double anrm; + integer imax; + double rmin, rmax; + bool test; + integer itmp1, indee; + double sigma; + integer iinfo; + char order[1]; + bool lower, wantz; + bool alleig, indeig; + integer iscale, indibl; + bool valeig; + double safmin; + double abstll, bignum; + integer indisp; + integer indiwo; + integer indwrk; + integer nsplit; + double smlnum; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric band matrix A. Eigenvalues and eigenvectors can */ +/* be selected by specifying either a range of values or a range of */ +/* indices for the desired eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found; */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found; */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ + +/* On exit, AB is overwritten by values generated during the */ +/* reduction to tridiagonal form. If UPLO = 'U', the first */ +/* superdiagonal and the diagonal of the tridiagonal matrix T */ +/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ +/* the diagonal and first subdiagonal of T are returned in the */ +/* first two rows of AB. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD + 1. */ + +/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */ +/* If JOBZ = 'V', the N-by-N orthogonal matrix used in the */ +/* reduction to tridiagonal form. */ +/* If JOBZ = 'N', the array Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. If JOBZ = 'V', then */ +/* LDQ >= max(1,N). */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less than */ +/* or equal to zero, then EPS*|T| will be used in its place, */ +/* where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* by reducing AB to tridiagonal form. */ + +/* Eigenvalues will be computed most accurately when ABSTOL is */ +/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* If this routine returns with INFO>0, indicating that some */ +/* eigenvectors did not converge, try setting ABSTOL to */ +/* 2*DLAMCH('S'). */ + +/* See "Computing Small Singular Values of Bidiagonal Matrices */ +/* with Guaranteed High Relative Accuracy," by Demmel and */ +/* Kahan, LAPACK Working Note #3. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements contain the selected eigenvalues in */ +/* ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ +/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix A */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* If an eigenvector fails to converge, then that column of Z */ +/* contains the latest approximation to the eigenvector, and the */ +/* index of the eigenvector is returned in IFAIL. */ +/* If JOBZ = 'N', then Z is not referenced. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (7*N) */ + +/* IWORK (workspace) INTEGER array, dimension (5*N) */ + +/* IFAIL (output) INTEGER array, dimension (N) */ +/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* indices of the eigenvectors that failed to converge. */ +/* If JOBZ = 'N', then IFAIL is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = i, then i eigenvectors failed to converge. */ +/* Their indices are stored in array IFAIL. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + lower = lsame_(uplo, "L"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } else if (wantz && *ldq < std::max(1_integer,*n)) { + *info = -9; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -11; + } + } else if (indeig) { + if (*il < 1 || *il > std::max(1_integer,*n)) { + *info = -12; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -13; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -18; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBEVX", &i__1); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + *m = 1; + if (lower) { + tmp1 = ab[ab_dim1 + 1]; + } else { + tmp1 = ab[*kd + 1 + ab_dim1]; + } + if (valeig) { + if (! (*vl < tmp1 && *vu >= tmp1)) { + *m = 0; + } + } + if (*m == 1) { + w[1] = tmp1; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); + rmax = std::min(d__1,d__2); + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + abstll = *abstol; + if (valeig) { + vll = *vl; + vuu = *vu; + } else { + vll = 0.; + vuu = 0.; + } + anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + dlascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab, + info); + } else { + dlascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab, + info); + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */ + + indd = 1; + inde = indd + *n; + indwrk = inde + *n; + dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde], + &q[q_offset], ldq, &work[indwrk], &iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal */ +/* to zero, then call DSTERF or SSTEQR. If this fails for some */ +/* eigenvalue, then try DSTEBZ. */ + + test = false; + if (indeig) { + if (*il == 1 && *iu == *n) { + test = true; + } + } + if ((alleig || test) && *abstol <= 0.) { + dcopy_(n, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L30; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwrk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1); + dgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, & + c_b34, &z__[j * z_dim1 + 1], &c__1); +/* L20: */ + } + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L30: + if (iscale == 1) { + if (*info == 0) { + imax = *m; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + +/* If eigenvalues are not in order, then sort them, along with */ +/* eigenvectors. */ + + if (wantz) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp1 = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp1) { + i__ = jj; + tmp1 = w[jj]; + } +/* L40: */ + } + + if (i__ != 0) { + itmp1 = iwork[indibl + i__ - 1]; + w[i__] = w[j]; + iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + w[j] = tmp1; + iwork[indibl + j - 1] = itmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + if (*info != 0) { + itmp1 = ifail[i__]; + ifail[i__] = ifail[j]; + ifail[j] = itmp1; + } + } +/* L50: */ + } + } + + return 0; + +/* End of DSBEVX */ + +} /* dsbevx_ */ + +/* Subroutine */ int dsbgst_(const char *vect, const char *uplo, integer *n, integer *ka, + integer *kb, double *ab, integer *ldab, double *bb, integer * + ldbb, double *x, integer *ldx, double *work, integer *info) +{ + /* Table of constant values */ + static double c_b8 = 0.; + static double c_b9 = 1.; + static integer c__1 = 1; + static double c_b20 = -1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, bb_dim1, bb_offset, x_dim1, x_offset, i__1, + i__2, i__3, i__4; + double d__1; + + /* Local variables */ + integer i__, j, k, l, m; + double t; + integer i0, i1, i2, j1, j2; + double ra; + integer nr, nx, ka1, kb1; + double ra1; + integer j1t, j2t; + double bii; + integer kbt, nrt, inca; + bool upper, wantx; + bool update; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBGST reduces a real symmetric-definite banded generalized */ +/* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, */ +/* such that C has the same bandwidth as A. */ + +/* B must have been previously factorized as S**T*S by DPBSTF, using a */ +/* split Cholesky factorization. A is overwritten by C = X**T*A*X, where */ +/* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the */ +/* bandwidth of A. */ + +/* Arguments */ +/* ========= */ + +/* VECT (input) CHARACTER*1 */ +/* = 'N': do not form the transformation matrix X; */ +/* = 'V': form X. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* KA (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ + +/* KB (input) INTEGER */ +/* The number of superdiagonals of the matrix B if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first ka+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ + +/* On exit, the transformed matrix X**T*A*X, stored in the same */ +/* format as A. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KA+1. */ + +/* BB (input) DOUBLE PRECISION array, dimension (LDBB,N) */ +/* The banded factor S from the split Cholesky factorization of */ +/* B, as returned by DPBSTF, stored in the first KB+1 rows of */ +/* the array. */ + +/* LDBB (input) INTEGER */ +/* The leading dimension of the array BB. LDBB >= KB+1. */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,N) */ +/* If VECT = 'V', the n-by-n matrix X. */ +/* If VECT = 'N', the array X is not referenced. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. */ +/* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + bb_dim1 = *ldbb; + bb_offset = 1 + bb_dim1; + bb -= bb_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --work; + + /* Function Body */ + wantx = lsame_(vect, "V"); + upper = lsame_(uplo, "U"); + ka1 = *ka + 1; + kb1 = *kb + 1; + *info = 0; + if (! wantx && ! lsame_(vect, "N")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ka < 0) { + *info = -4; + } else if (*kb < 0 || *kb > *ka) { + *info = -5; + } else if (*ldab < *ka + 1) { + *info = -7; + } else if (*ldbb < *kb + 1) { + *info = -9; + } else if (*ldx < 1 || wantx && *ldx < std::max(1_integer,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBGST", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + inca = *ldab * ka1; + +/* Initialize X to the unit matrix, if needed */ + + if (wantx) { + dlaset_("Full", n, n, &c_b8, &c_b9, &x[x_offset], ldx); + } + +/* Set M to the splitting point m. It must be the same value as is */ +/* used in DPBSTF. The chosen value allows the arrays WORK and RWORK */ +/* to be of dimension (N). */ + + m = (*n + *kb) / 2; + +/* The routine works in two phases, corresponding to the two halves */ +/* of the split Cholesky factorization of B as S**T*S where */ + +/* S = ( U ) */ +/* ( M L ) */ + +/* with U upper triangular of order m, and L lower triangular of */ +/* order n-m. S has the same bandwidth as B. */ + +/* S is treated as a product of elementary matrices: */ + +/* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) */ + +/* where S(i) is determined by the i-th row of S. */ + +/* In phase 1, the index i takes the values n, n-1, ... , m+1; */ +/* in phase 2, it takes the values 1, 2, ... , m. */ + +/* For each value of i, the current matrix A is updated by forming */ +/* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside */ +/* the band of A. The bulge is then pushed down toward the bottom of */ +/* A in phase 1, and up toward the top of A in phase 2, by applying */ +/* plane rotations. */ + +/* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 */ +/* of them are linearly independent, so annihilating a bulge requires */ +/* only 2*kb-1 plane rotations. The rotations are divided into a 1st */ +/* set of kb-1 rotations, and a 2nd set of kb rotations. */ + +/* Wherever possible, rotations are generated and applied in vector */ +/* operations of length NR between the indices J1 and J2 (sometimes */ +/* replaced by modified values NRT, J1T or J2T). */ + +/* The cosines and sines of the rotations are stored in the array */ +/* WORK. The cosines of the 1st set of rotations are stored in */ +/* elements n+2:n+m-kb-1 and the sines of the 1st set in elements */ +/* 2:m-kb-1; the cosines of the 2nd set are stored in elements */ +/* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. */ + +/* The bulges are not formed explicitly; nonzero elements outside the */ +/* band are created only when they are required for generating new */ +/* rotations; they are stored in the array WORK, in positions where */ +/* they are later overwritten by the sines of the rotations which */ +/* annihilate them. */ + +/* **************************** Phase 1 ***************************** */ + +/* The logical structure of this phase is: */ + +/* UPDATE = .TRUE. */ +/* DO I = N, M + 1, -1 */ +/* use S(i) to update A and create a new bulge */ +/* apply rotations to push all bulges KA positions downward */ +/* END DO */ +/* UPDATE = .FALSE. */ +/* DO I = M + KA + 1, N - 1 */ +/* apply rotations to push all bulges KA positions downward */ +/* END DO */ + +/* To avoid duplicating code, the two loops are merged. */ + + update = true; + i__ = *n + 1; +L10: + if (update) { + --i__; +/* Computing MIN */ + i__1 = *kb, i__2 = i__ - 1; + kbt = std::min(i__1,i__2); + i0 = i__ - 1; +/* Computing MIN */ + i__1 = *n, i__2 = i__ + *ka; + i1 = std::min(i__1,i__2); + i2 = i__ - kbt + ka1; + if (i__ < m + 1) { + update = false; + ++i__; + i0 = m; + if (*ka == 0) { + goto L480; + } + goto L10; + } + } else { + i__ += *ka; + if (i__ > *n - 1) { + goto L480; + } + } + + if (upper) { + +/* Transform A, working with the upper triangle */ + + if (update) { + +/* Form inv(S(i))**T * A * inv(S(i)) */ + + bii = bb[kb1 + i__ * bb_dim1]; + i__1 = i1; + for (j = i__; j <= i__1; ++j) { + ab[i__ - j + ka1 + j * ab_dim1] /= bii; +/* L20: */ + } +/* Computing MAX */ + i__1 = 1, i__2 = i__ - *ka; + i__3 = i__; + for (j = std::max(i__1,i__2); j <= i__3; ++j) { + ab[j - i__ + ka1 + i__ * ab_dim1] /= bii; +/* L30: */ + } + i__3 = i__ - 1; + for (k = i__ - kbt; k <= i__3; ++k) { + i__1 = k; + for (j = i__ - kbt; j <= i__1; ++j) { + ab[j - k + ka1 + k * ab_dim1] = ab[j - k + ka1 + k * + ab_dim1] - bb[j - i__ + kb1 + i__ * bb_dim1] * ab[ + k - i__ + ka1 + i__ * ab_dim1] - bb[k - i__ + kb1 + + i__ * bb_dim1] * ab[j - i__ + ka1 + i__ * + ab_dim1] + ab[ka1 + i__ * ab_dim1] * bb[j - i__ + + kb1 + i__ * bb_dim1] * bb[k - i__ + kb1 + i__ * + bb_dim1]; +/* L40: */ + } +/* Computing MAX */ + i__1 = 1, i__2 = i__ - *ka; + i__4 = i__ - kbt - 1; + for (j = std::max(i__1,i__2); j <= i__4; ++j) { + ab[j - k + ka1 + k * ab_dim1] -= bb[k - i__ + kb1 + i__ * + bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1]; +/* L50: */ + } +/* L60: */ + } + i__3 = i1; + for (j = i__; j <= i__3; ++j) { +/* Computing MAX */ + i__4 = j - *ka, i__1 = i__ - kbt; + i__2 = i__ - 1; + for (k = std::max(i__4,i__1); k <= i__2; ++k) { + ab[k - j + ka1 + j * ab_dim1] -= bb[k - i__ + kb1 + i__ * + bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1]; +/* L70: */ + } +/* L80: */ + } + + if (wantx) { + +/* post-multiply X by inv(S(i)) */ + + i__3 = *n - m; + d__1 = 1. / bii; + dscal_(&i__3, &d__1, &x[m + 1 + i__ * x_dim1], &c__1); + if (kbt > 0) { + i__3 = *n - m; + dger_(&i__3, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], & + c__1, &bb[kb1 - kbt + i__ * bb_dim1], &c__1, &x[m + + 1 + (i__ - kbt) * x_dim1], ldx); + } + } + +/* store a(i,i1) in RA1 for use in next loop over K */ + + ra1 = ab[i__ - i1 + ka1 + i1 * ab_dim1]; + } + +/* Generate and apply vectors of rotations to chase all the */ +/* existing bulges KA positions down toward the bottom of the */ +/* band */ + + i__3 = *kb - 1; + for (k = 1; k <= i__3; ++k) { + if (update) { + +/* Determine the rotations which would annihilate the bulge */ +/* which has in theory just been created */ + + if (i__ - k + *ka < *n && i__ - k > 1) { + +/* generate rotation to annihilate a(i,i-k+ka+1) */ + + dlartg_(&ab[k + 1 + (i__ - k + *ka) * ab_dim1], &ra1, & + work[*n + i__ - k + *ka - m], &work[i__ - k + *ka + - m], &ra); + +/* create nonzero element a(i-k,i-k+ka+1) outside the */ +/* band and store it in WORK(i-k) */ + + t = -bb[kb1 - k + i__ * bb_dim1] * ra1; + work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[ + i__ - k + *ka - m] * ab[(i__ - k + *ka) * ab_dim1 + + 1]; + ab[(i__ - k + *ka) * ab_dim1 + 1] = work[i__ - k + *ka - + m] * t + work[*n + i__ - k + *ka - m] * ab[(i__ - + k + *ka) * ab_dim1 + 1]; + ra1 = ra; + } + } +/* Computing MAX */ + i__2 = 1, i__4 = k - i0 + 2; + j2 = i__ - k - 1 + std::max(i__2,i__4) * ka1; + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + if (update) { +/* Computing MAX */ + i__2 = j2, i__4 = i__ + (*ka << 1) - k + 1; + j2t = std::max(i__2,i__4); + } else { + j2t = j2; + } + nrt = (*n - j2t + *ka) / ka1; + i__2 = j1; + i__4 = ka1; + for (j = j2t; i__4 < 0 ? j >= i__2 : j <= i__2; j += i__4) { + +/* create nonzero element a(j-ka,j+1) outside the band */ +/* and store it in WORK(j-m) */ + + work[j - m] *= ab[(j + 1) * ab_dim1 + 1]; + ab[(j + 1) * ab_dim1 + 1] = work[*n + j - m] * ab[(j + 1) * + ab_dim1 + 1]; +/* L90: */ + } + +/* generate rotations in 1st set to annihilate elements which */ +/* have been created outside the band */ + + if (nrt > 0) { + dlargv_(&nrt, &ab[j2t * ab_dim1 + 1], &inca, &work[j2t - m], & + ka1, &work[*n + j2t - m], &ka1); + } + if (nr > 0) { + +/* apply rotations in 1st set from the right */ + + i__4 = *ka - 1; + for (l = 1; l <= i__4; ++l) { + dlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka + - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2 - + m], &work[j2 - m], &ka1); +/* L100: */ + } + +/* apply rotations in 1st set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) * + ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[ + *n + j2 - m], &work[j2 - m], &ka1); + + } + +/* start applying rotations in 1st set from the left */ + + i__4 = *kb - k + 1; + for (l = *ka - 1; l >= i__4; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & + ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & + work[*n + j2 - m], &work[j2 - m], &ka1); + } +/* L110: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 1st set */ + + i__4 = j1; + i__2 = ka1; + for (j = j2; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) { + i__1 = *n - m; + drot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j + + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j + - m]); +/* L120: */ + } + } +/* L130: */ + } + + if (update) { + if (i2 <= *n && kbt > 0) { + +/* create nonzero element a(i-kbt,i-kbt+ka+1) outside the */ +/* band and store it in WORK(i-kbt) */ + + work[i__ - kbt] = -bb[kb1 - kbt + i__ * bb_dim1] * ra1; + } + } + + for (k = *kb; k >= 1; --k) { + if (update) { +/* Computing MAX */ + i__3 = 2, i__2 = k - i0 + 1; + j2 = i__ - k - 1 + std::max(i__3,i__2) * ka1; + } else { +/* Computing MAX */ + i__3 = 1, i__2 = k - i0 + 1; + j2 = i__ - k - 1 + std::max(i__3,i__2) * ka1; + } + +/* finish applying rotations in 2nd set from the left */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (*n - j2 + *ka + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j2 - l + 1) * ab_dim1], &inca, &ab[ + l + 1 + (j2 - l + 1) * ab_dim1], &inca, &work[*n + + j2 - *ka], &work[j2 - *ka], &ka1); + } +/* L140: */ + } + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + i__3 = j2; + i__2 = -ka1; + for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) { + work[j] = work[j - *ka]; + work[*n + j] = work[*n + j - *ka]; +/* L150: */ + } + i__2 = j1; + i__3 = ka1; + for (j = j2; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) { + +/* create nonzero element a(j-ka,j+1) outside the band */ +/* and store it in WORK(j) */ + + work[j] *= ab[(j + 1) * ab_dim1 + 1]; + ab[(j + 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + 1) * + ab_dim1 + 1]; +/* L160: */ + } + if (update) { + if (i__ - k < *n - *ka && k <= kbt) { + work[i__ - k + *ka] = work[i__ - k]; + } + } +/* L170: */ + } + + for (k = *kb; k >= 1; --k) { +/* Computing MAX */ + i__3 = 1, i__2 = k - i0 + 1; + j2 = i__ - k - 1 + std::max(i__3,i__2) * ka1; + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + if (nr > 0) { + +/* generate rotations in 2nd set to annihilate elements */ +/* which have been created outside the band */ + + dlargv_(&nr, &ab[j2 * ab_dim1 + 1], &inca, &work[j2], &ka1, & + work[*n + j2], &ka1); + +/* apply rotations in 2nd set from the right */ + + i__3 = *ka - 1; + for (l = 1; l <= i__3; ++l) { + dlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka + - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2], + &work[j2], &ka1); +/* L180: */ + } + +/* apply rotations in 2nd set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) * + ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[ + *n + j2], &work[j2], &ka1); + + } + +/* start applying rotations in 2nd set from the left */ + + i__3 = *kb - k + 1; + for (l = *ka - 1; l >= i__3; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & + ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & + work[*n + j2], &work[j2], &ka1); + } +/* L190: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 2nd set */ + + i__3 = j1; + i__2 = ka1; + for (j = j2; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) { + i__4 = *n - m; + drot_(&i__4, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j + + 1) * x_dim1], &c__1, &work[*n + j], &work[j]); +/* L200: */ + } + } +/* L210: */ + } + + i__2 = *kb - 1; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + i__3 = 1, i__4 = k - i0 + 2; + j2 = i__ - k - 1 + std::max(i__3,i__4) * ka1; + +/* finish applying rotations in 1st set from the left */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, & + ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, & + work[*n + j2 - m], &work[j2 - m], &ka1); + } +/* L220: */ + } +/* L230: */ + } + + if (*kb > 1) { + i__2 = i__ - *kb + (*ka << 1) + 1; + for (j = *n - 1; j >= i__2; --j) { + work[*n + j - m] = work[*n + j - *ka - m]; + work[j - m] = work[j - *ka - m]; +/* L240: */ + } + } + + } else { + +/* Transform A, working with the lower triangle */ + + if (update) { + +/* Form inv(S(i))**T * A * inv(S(i)) */ + + bii = bb[i__ * bb_dim1 + 1]; + i__2 = i1; + for (j = i__; j <= i__2; ++j) { + ab[j - i__ + 1 + i__ * ab_dim1] /= bii; +/* L250: */ + } +/* Computing MAX */ + i__2 = 1, i__3 = i__ - *ka; + i__4 = i__; + for (j = std::max(i__2,i__3); j <= i__4; ++j) { + ab[i__ - j + 1 + j * ab_dim1] /= bii; +/* L260: */ + } + i__4 = i__ - 1; + for (k = i__ - kbt; k <= i__4; ++k) { + i__2 = k; + for (j = i__ - kbt; j <= i__2; ++j) { + ab[k - j + 1 + j * ab_dim1] = ab[k - j + 1 + j * ab_dim1] + - bb[i__ - j + 1 + j * bb_dim1] * ab[i__ - k + 1 + + k * ab_dim1] - bb[i__ - k + 1 + k * bb_dim1] * + ab[i__ - j + 1 + j * ab_dim1] + ab[i__ * ab_dim1 + + 1] * bb[i__ - j + 1 + j * bb_dim1] * bb[i__ - k + + 1 + k * bb_dim1]; +/* L270: */ + } +/* Computing MAX */ + i__2 = 1, i__3 = i__ - *ka; + i__1 = i__ - kbt - 1; + for (j = std::max(i__2,i__3); j <= i__1; ++j) { + ab[k - j + 1 + j * ab_dim1] -= bb[i__ - k + 1 + k * + bb_dim1] * ab[i__ - j + 1 + j * ab_dim1]; +/* L280: */ + } +/* L290: */ + } + i__4 = i1; + for (j = i__; j <= i__4; ++j) { +/* Computing MAX */ + i__1 = j - *ka, i__2 = i__ - kbt; + i__3 = i__ - 1; + for (k = std::max(i__1,i__2); k <= i__3; ++k) { + ab[j - k + 1 + k * ab_dim1] -= bb[i__ - k + 1 + k * + bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1]; +/* L300: */ + } +/* L310: */ + } + + if (wantx) { + +/* post-multiply X by inv(S(i)) */ + + i__4 = *n - m; + d__1 = 1. / bii; + dscal_(&i__4, &d__1, &x[m + 1 + i__ * x_dim1], &c__1); + if (kbt > 0) { + i__4 = *n - m; + i__3 = *ldbb - 1; + dger_(&i__4, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], & + c__1, &bb[kbt + 1 + (i__ - kbt) * bb_dim1], &i__3, + &x[m + 1 + (i__ - kbt) * x_dim1], ldx); + } + } + +/* store a(i1,i) in RA1 for use in next loop over K */ + + ra1 = ab[i1 - i__ + 1 + i__ * ab_dim1]; + } + +/* Generate and apply vectors of rotations to chase all the */ +/* existing bulges KA positions down toward the bottom of the */ +/* band */ + + i__4 = *kb - 1; + for (k = 1; k <= i__4; ++k) { + if (update) { + +/* Determine the rotations which would annihilate the bulge */ +/* which has in theory just been created */ + + if (i__ - k + *ka < *n && i__ - k > 1) { + +/* generate rotation to annihilate a(i-k+ka+1,i) */ + + dlartg_(&ab[ka1 - k + i__ * ab_dim1], &ra1, &work[*n + + i__ - k + *ka - m], &work[i__ - k + *ka - m], &ra) + ; + +/* create nonzero element a(i-k+ka+1,i-k) outside the */ +/* band and store it in WORK(i-k) */ + + t = -bb[k + 1 + (i__ - k) * bb_dim1] * ra1; + work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[ + i__ - k + *ka - m] * ab[ka1 + (i__ - k) * ab_dim1] + ; + ab[ka1 + (i__ - k) * ab_dim1] = work[i__ - k + *ka - m] * + t + work[*n + i__ - k + *ka - m] * ab[ka1 + (i__ + - k) * ab_dim1]; + ra1 = ra; + } + } +/* Computing MAX */ + i__3 = 1, i__1 = k - i0 + 2; + j2 = i__ - k - 1 + std::max(i__3,i__1) * ka1; + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + if (update) { +/* Computing MAX */ + i__3 = j2, i__1 = i__ + (*ka << 1) - k + 1; + j2t = std::max(i__3,i__1); + } else { + j2t = j2; + } + nrt = (*n - j2t + *ka) / ka1; + i__3 = j1; + i__1 = ka1; + for (j = j2t; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) { + +/* create nonzero element a(j+1,j-ka) outside the band */ +/* and store it in WORK(j-m) */ + + work[j - m] *= ab[ka1 + (j - *ka + 1) * ab_dim1]; + ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j - m] * ab[ka1 + + (j - *ka + 1) * ab_dim1]; +/* L320: */ + } + +/* generate rotations in 1st set to annihilate elements which */ +/* have been created outside the band */ + + if (nrt > 0) { + dlargv_(&nrt, &ab[ka1 + (j2t - *ka) * ab_dim1], &inca, &work[ + j2t - m], &ka1, &work[*n + j2t - m], &ka1); + } + if (nr > 0) { + +/* apply rotations in 1st set from the left */ + + i__1 = *ka - 1; + for (l = 1; l <= i__1; ++l) { + dlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[ + l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2 + - m], &work[j2 - m], &ka1); +/* L330: */ + } + +/* apply rotations in 1st set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 + + 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2 - m], + &work[j2 - m], &ka1); + + } + +/* start applying rotations in 1st set from the right */ + + i__1 = *kb - k + 1; + for (l = *ka - 1; l >= i__1; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ + ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + + j2 - m], &work[j2 - m], &ka1); + } +/* L340: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 1st set */ + + i__1 = j1; + i__3 = ka1; + for (j = j2; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { + i__2 = *n - m; + drot_(&i__2, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j + + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j + - m]); +/* L350: */ + } + } +/* L360: */ + } + + if (update) { + if (i2 <= *n && kbt > 0) { + +/* create nonzero element a(i-kbt+ka+1,i-kbt) outside the */ +/* band and store it in WORK(i-kbt) */ + + work[i__ - kbt] = -bb[kbt + 1 + (i__ - kbt) * bb_dim1] * ra1; + } + } + + for (k = *kb; k >= 1; --k) { + if (update) { +/* Computing MAX */ + i__4 = 2, i__3 = k - i0 + 1; + j2 = i__ - k - 1 + std::max(i__4,i__3) * ka1; + } else { +/* Computing MAX */ + i__4 = 1, i__3 = k - i0 + 1; + j2 = i__ - k - 1 + std::max(i__4,i__3) * ka1; + } + +/* finish applying rotations in 2nd set from the right */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (*n - j2 + *ka + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j2 - *ka) * ab_dim1], & + inca, &ab[ka1 - l + (j2 - *ka + 1) * ab_dim1], & + inca, &work[*n + j2 - *ka], &work[j2 - *ka], &ka1) + ; + } +/* L370: */ + } + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + i__4 = j2; + i__3 = -ka1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + work[j] = work[j - *ka]; + work[*n + j] = work[*n + j - *ka]; +/* L380: */ + } + i__3 = j1; + i__4 = ka1; + for (j = j2; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j+1,j-ka) outside the band */ +/* and store it in WORK(j) */ + + work[j] *= ab[ka1 + (j - *ka + 1) * ab_dim1]; + ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j] * ab[ka1 + ( + j - *ka + 1) * ab_dim1]; +/* L390: */ + } + if (update) { + if (i__ - k < *n - *ka && k <= kbt) { + work[i__ - k + *ka] = work[i__ - k]; + } + } +/* L400: */ + } + + for (k = *kb; k >= 1; --k) { +/* Computing MAX */ + i__4 = 1, i__3 = k - i0 + 1; + j2 = i__ - k - 1 + std::max(i__4,i__3) * ka1; + nr = (*n - j2 + *ka) / ka1; + j1 = j2 + (nr - 1) * ka1; + if (nr > 0) { + +/* generate rotations in 2nd set to annihilate elements */ +/* which have been created outside the band */ + + dlargv_(&nr, &ab[ka1 + (j2 - *ka) * ab_dim1], &inca, &work[j2] +, &ka1, &work[*n + j2], &ka1); + +/* apply rotations in 2nd set from the left */ + + i__4 = *ka - 1; + for (l = 1; l <= i__4; ++l) { + dlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[ + l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2] +, &work[j2], &ka1); +/* L410: */ + } + +/* apply rotations in 2nd set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 + + 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2], & + work[j2], &ka1); + + } + +/* start applying rotations in 2nd set from the right */ + + i__4 = *kb - k + 1; + for (l = *ka - 1; l >= i__4; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ + ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + + j2], &work[j2], &ka1); + } +/* L420: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 2nd set */ + + i__4 = j1; + i__3 = ka1; + for (j = j2; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + i__1 = *n - m; + drot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j + + 1) * x_dim1], &c__1, &work[*n + j], &work[j]); +/* L430: */ + } + } +/* L440: */ + } + + i__3 = *kb - 1; + for (k = 1; k <= i__3; ++k) { +/* Computing MAX */ + i__4 = 1, i__1 = k - i0 + 2; + j2 = i__ - k - 1 + std::max(i__4,i__1) * ka1; + +/* finish applying rotations in 1st set from the right */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (*n - j2 + l) / ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[ + ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n + + j2 - m], &work[j2 - m], &ka1); + } +/* L450: */ + } +/* L460: */ + } + + if (*kb > 1) { + i__3 = i__ - *kb + (*ka << 1) + 1; + for (j = *n - 1; j >= i__3; --j) { + work[*n + j - m] = work[*n + j - *ka - m]; + work[j - m] = work[j - *ka - m]; +/* L470: */ + } + } + + } + + goto L10; + +L480: + +/* **************************** Phase 2 ***************************** */ + +/* The logical structure of this phase is: */ + +/* UPDATE = .TRUE. */ +/* DO I = 1, M */ +/* use S(i) to update A and create a new bulge */ +/* apply rotations to push all bulges KA positions upward */ +/* END DO */ +/* UPDATE = .FALSE. */ +/* DO I = M - KA - 1, 2, -1 */ +/* apply rotations to push all bulges KA positions upward */ +/* END DO */ + +/* To avoid duplicating code, the two loops are merged. */ + + update = true; + i__ = 0; +L490: + if (update) { + ++i__; +/* Computing MIN */ + i__3 = *kb, i__4 = m - i__; + kbt = std::min(i__3,i__4); + i0 = i__ + 1; +/* Computing MAX */ + i__3 = 1, i__4 = i__ - *ka; + i1 = std::max(i__3,i__4); + i2 = i__ + kbt - ka1; + if (i__ > m) { + update = false; + --i__; + i0 = m + 1; + if (*ka == 0) { + return 0; + } + goto L490; + } + } else { + i__ -= *ka; + if (i__ < 2) { + return 0; + } + } + + if (i__ < m - kbt) { + nx = m; + } else { + nx = *n; + } + + if (upper) { + +/* Transform A, working with the upper triangle */ + + if (update) { + +/* Form inv(S(i))**T * A * inv(S(i)) */ + + bii = bb[kb1 + i__ * bb_dim1]; + i__3 = i__; + for (j = i1; j <= i__3; ++j) { + ab[j - i__ + ka1 + i__ * ab_dim1] /= bii; +/* L500: */ + } +/* Computing MIN */ + i__4 = *n, i__1 = i__ + *ka; + i__3 = std::min(i__4,i__1); + for (j = i__; j <= i__3; ++j) { + ab[i__ - j + ka1 + j * ab_dim1] /= bii; +/* L510: */ + } + i__3 = i__ + kbt; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = i__ + kbt; + for (j = k; j <= i__4; ++j) { + ab[k - j + ka1 + j * ab_dim1] = ab[k - j + ka1 + j * + ab_dim1] - bb[i__ - j + kb1 + j * bb_dim1] * ab[ + i__ - k + ka1 + k * ab_dim1] - bb[i__ - k + kb1 + + k * bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1] + + ab[ka1 + i__ * ab_dim1] * bb[i__ - j + kb1 + j * + bb_dim1] * bb[i__ - k + kb1 + k * bb_dim1]; +/* L520: */ + } +/* Computing MIN */ + i__1 = *n, i__2 = i__ + *ka; + i__4 = std::min(i__1,i__2); + for (j = i__ + kbt + 1; j <= i__4; ++j) { + ab[k - j + ka1 + j * ab_dim1] -= bb[i__ - k + kb1 + k * + bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1]; +/* L530: */ + } +/* L540: */ + } + i__3 = i__; + for (j = i1; j <= i__3; ++j) { +/* Computing MIN */ + i__1 = j + *ka, i__2 = i__ + kbt; + i__4 = std::min(i__1,i__2); + for (k = i__ + 1; k <= i__4; ++k) { + ab[j - k + ka1 + k * ab_dim1] -= bb[i__ - k + kb1 + k * + bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1]; +/* L550: */ + } +/* L560: */ + } + + if (wantx) { + +/* post-multiply X by inv(S(i)) */ + + d__1 = 1. / bii; + dscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1); + if (kbt > 0) { + i__3 = *ldbb - 1; + dger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[ + *kb + (i__ + 1) * bb_dim1], &i__3, &x[(i__ + 1) * + x_dim1 + 1], ldx); + } + } + +/* store a(i1,i) in RA1 for use in next loop over K */ + + ra1 = ab[i1 - i__ + ka1 + i__ * ab_dim1]; + } + +/* Generate and apply vectors of rotations to chase all the */ +/* existing bulges KA positions up toward the top of the band */ + + i__3 = *kb - 1; + for (k = 1; k <= i__3; ++k) { + if (update) { + +/* Determine the rotations which would annihilate the bulge */ +/* which has in theory just been created */ + + if (i__ + k - ka1 > 0 && i__ + k < m) { + +/* generate rotation to annihilate a(i+k-ka-1,i) */ + + dlartg_(&ab[k + 1 + i__ * ab_dim1], &ra1, &work[*n + i__ + + k - *ka], &work[i__ + k - *ka], &ra); + +/* create nonzero element a(i+k-ka-1,i+k) outside the */ +/* band and store it in WORK(m-kb+i+k) */ + + t = -bb[kb1 - k + (i__ + k) * bb_dim1] * ra1; + work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t - + work[i__ + k - *ka] * ab[(i__ + k) * ab_dim1 + 1]; + ab[(i__ + k) * ab_dim1 + 1] = work[i__ + k - *ka] * t + + work[*n + i__ + k - *ka] * ab[(i__ + k) * ab_dim1 + + 1]; + ra1 = ra; + } + } +/* Computing MAX */ + i__4 = 1, i__1 = k + i0 - m + 1; + j2 = i__ + k + 1 - std::max(i__4,i__1) * ka1; + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + if (update) { +/* Computing MIN */ + i__4 = j2, i__1 = i__ - (*ka << 1) + k - 1; + j2t = std::min(i__4,i__1); + } else { + j2t = j2; + } + nrt = (j2t + *ka - 1) / ka1; + i__4 = j2t; + i__1 = ka1; + for (j = j1; i__1 < 0 ? j >= i__4 : j <= i__4; j += i__1) { + +/* create nonzero element a(j-1,j+ka) outside the band */ +/* and store it in WORK(j) */ + + work[j] *= ab[(j + *ka - 1) * ab_dim1 + 1]; + ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + *ka + - 1) * ab_dim1 + 1]; +/* L570: */ + } + +/* generate rotations in 1st set to annihilate elements which */ +/* have been created outside the band */ + + if (nrt > 0) { + dlargv_(&nrt, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[j1], + &ka1, &work[*n + j1], &ka1); + } + if (nr > 0) { + +/* apply rotations in 1st set from the left */ + + i__1 = *ka - 1; + for (l = 1; l <= i__1; ++l) { + dlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, & + ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n + + j1], &work[j1], &ka1); +/* L580: */ + } + +/* apply rotations in 1st set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) * + ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n + + j1], &work[j1], &ka1); + + } + +/* start applying rotations in 1st set from the right */ + + i__1 = *kb - k + 1; + for (l = *ka - 1; l >= i__1; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( + j1t - 1) * ab_dim1], &inca, &work[*n + j1t], & + work[j1t], &ka1); + } +/* L590: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 1st set */ + + i__1 = j2; + i__4 = ka1; + for (j = j1; i__4 < 0 ? j >= i__1 : j <= i__1; j += i__4) { + drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 + + 1], &c__1, &work[*n + j], &work[j]); +/* L600: */ + } + } +/* L610: */ + } + + if (update) { + if (i2 > 0 && kbt > 0) { + +/* create nonzero element a(i+kbt-ka-1,i+kbt) outside the */ +/* band and store it in WORK(m-kb+i+kbt) */ + + work[m - *kb + i__ + kbt] = -bb[kb1 - kbt + (i__ + kbt) * + bb_dim1] * ra1; + } + } + + for (k = *kb; k >= 1; --k) { + if (update) { +/* Computing MAX */ + i__3 = 2, i__4 = k + i0 - m; + j2 = i__ + k + 1 - std::max(i__3,i__4) * ka1; + } else { +/* Computing MAX */ + i__3 = 1, i__4 = k + i0 - m; + j2 = i__ + k + 1 - std::max(i__3,i__4) * ka1; + } + +/* finish applying rotations in 2nd set from the right */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (j2 + *ka + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + (j1t + *ka) * ab_dim1], &inca, &ab[ + l + 1 + (j1t + *ka - 1) * ab_dim1], &inca, &work[* + n + m - *kb + j1t + *ka], &work[m - *kb + j1t + * + ka], &ka1); + } +/* L620: */ + } + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + i__3 = j2; + i__4 = ka1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + work[m - *kb + j] = work[m - *kb + j + *ka]; + work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka]; +/* L630: */ + } + i__4 = j2; + i__3 = ka1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + +/* create nonzero element a(j-1,j+ka) outside the band */ +/* and store it in WORK(m-kb+j) */ + + work[m - *kb + j] *= ab[(j + *ka - 1) * ab_dim1 + 1]; + ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + m - *kb + j] * ab[ + (j + *ka - 1) * ab_dim1 + 1]; +/* L640: */ + } + if (update) { + if (i__ + k > ka1 && k <= kbt) { + work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k]; + } + } +/* L650: */ + } + + for (k = *kb; k >= 1; --k) { +/* Computing MAX */ + i__3 = 1, i__4 = k + i0 - m; + j2 = i__ + k + 1 - std::max(i__3,i__4) * ka1; + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + if (nr > 0) { + +/* generate rotations in 2nd set to annihilate elements */ +/* which have been created outside the band */ + + dlargv_(&nr, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[m - * + kb + j1], &ka1, &work[*n + m - *kb + j1], &ka1); + +/* apply rotations in 2nd set from the left */ + + i__3 = *ka - 1; + for (l = 1; l <= i__3; ++l) { + dlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, & + ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n + + m - *kb + j1], &work[m - *kb + j1], &ka1); +/* L660: */ + } + +/* apply rotations in 2nd set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) * + ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n + + m - *kb + j1], &work[m - *kb + j1], &ka1); + + } + +/* start applying rotations in 2nd set from the right */ + + i__3 = *kb - k + 1; + for (l = *ka - 1; l >= i__3; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( + j1t - 1) * ab_dim1], &inca, &work[*n + m - *kb + + j1t], &work[m - *kb + j1t], &ka1); + } +/* L670: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 2nd set */ + + i__3 = j2; + i__4 = ka1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 + + 1], &c__1, &work[*n + m - *kb + j], &work[m - * + kb + j]); +/* L680: */ + } + } +/* L690: */ + } + + i__4 = *kb - 1; + for (k = 1; k <= i__4; ++k) { +/* Computing MAX */ + i__3 = 1, i__1 = k + i0 - m + 1; + j2 = i__ + k + 1 - std::max(i__3,i__1) * ka1; + +/* finish applying rotations in 1st set from the right */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + ( + j1t - 1) * ab_dim1], &inca, &work[*n + j1t], & + work[j1t], &ka1); + } +/* L700: */ + } +/* L710: */ + } + + if (*kb > 1) { +/* Computing MIN */ + i__3 = i__ + *kb; + i__4 = std::min(i__3,m) - (*ka << 1) - 1; + for (j = 2; j <= i__4; ++j) { + work[*n + j] = work[*n + j + *ka]; + work[j] = work[j + *ka]; +/* L720: */ + } + } + + } else { + +/* Transform A, working with the lower triangle */ + + if (update) { + +/* Form inv(S(i))**T * A * inv(S(i)) */ + + bii = bb[i__ * bb_dim1 + 1]; + i__4 = i__; + for (j = i1; j <= i__4; ++j) { + ab[i__ - j + 1 + j * ab_dim1] /= bii; +/* L730: */ + } +/* Computing MIN */ + i__3 = *n, i__1 = i__ + *ka; + i__4 = std::min(i__3,i__1); + for (j = i__; j <= i__4; ++j) { + ab[j - i__ + 1 + i__ * ab_dim1] /= bii; +/* L740: */ + } + i__4 = i__ + kbt; + for (k = i__ + 1; k <= i__4; ++k) { + i__3 = i__ + kbt; + for (j = k; j <= i__3; ++j) { + ab[j - k + 1 + k * ab_dim1] = ab[j - k + 1 + k * ab_dim1] + - bb[j - i__ + 1 + i__ * bb_dim1] * ab[k - i__ + + 1 + i__ * ab_dim1] - bb[k - i__ + 1 + i__ * + bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1] + ab[ + i__ * ab_dim1 + 1] * bb[j - i__ + 1 + i__ * + bb_dim1] * bb[k - i__ + 1 + i__ * bb_dim1]; +/* L750: */ + } +/* Computing MIN */ + i__1 = *n, i__2 = i__ + *ka; + i__3 = std::min(i__1,i__2); + for (j = i__ + kbt + 1; j <= i__3; ++j) { + ab[j - k + 1 + k * ab_dim1] -= bb[k - i__ + 1 + i__ * + bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1]; +/* L760: */ + } +/* L770: */ + } + i__4 = i__; + for (j = i1; j <= i__4; ++j) { +/* Computing MIN */ + i__1 = j + *ka, i__2 = i__ + kbt; + i__3 = std::min(i__1,i__2); + for (k = i__ + 1; k <= i__3; ++k) { + ab[k - j + 1 + j * ab_dim1] -= bb[k - i__ + 1 + i__ * + bb_dim1] * ab[i__ - j + 1 + j * ab_dim1]; +/* L780: */ + } +/* L790: */ + } + + if (wantx) { + +/* post-multiply X by inv(S(i)) */ + + d__1 = 1. / bii; + dscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1); + if (kbt > 0) { + dger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[ + i__ * bb_dim1 + 2], &c__1, &x[(i__ + 1) * x_dim1 + + 1], ldx); + } + } + +/* store a(i,i1) in RA1 for use in next loop over K */ + + ra1 = ab[i__ - i1 + 1 + i1 * ab_dim1]; + } + +/* Generate and apply vectors of rotations to chase all the */ +/* existing bulges KA positions up toward the top of the band */ + + i__4 = *kb - 1; + for (k = 1; k <= i__4; ++k) { + if (update) { + +/* Determine the rotations which would annihilate the bulge */ +/* which has in theory just been created */ + + if (i__ + k - ka1 > 0 && i__ + k < m) { + +/* generate rotation to annihilate a(i,i+k-ka-1) */ + + dlartg_(&ab[ka1 - k + (i__ + k - *ka) * ab_dim1], &ra1, & + work[*n + i__ + k - *ka], &work[i__ + k - *ka], & + ra); + +/* create nonzero element a(i+k,i+k-ka-1) outside the */ +/* band and store it in WORK(m-kb+i+k) */ + + t = -bb[k + 1 + i__ * bb_dim1] * ra1; + work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t - + work[i__ + k - *ka] * ab[ka1 + (i__ + k - *ka) * + ab_dim1]; + ab[ka1 + (i__ + k - *ka) * ab_dim1] = work[i__ + k - *ka] + * t + work[*n + i__ + k - *ka] * ab[ka1 + (i__ + + k - *ka) * ab_dim1]; + ra1 = ra; + } + } +/* Computing MAX */ + i__3 = 1, i__1 = k + i0 - m + 1; + j2 = i__ + k + 1 - std::max(i__3,i__1) * ka1; + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + if (update) { +/* Computing MIN */ + i__3 = j2, i__1 = i__ - (*ka << 1) + k - 1; + j2t = std::min(i__3,i__1); + } else { + j2t = j2; + } + nrt = (j2t + *ka - 1) / ka1; + i__3 = j2t; + i__1 = ka1; + for (j = j1; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) { + +/* create nonzero element a(j+ka,j-1) outside the band */ +/* and store it in WORK(j) */ + + work[j] *= ab[ka1 + (j - 1) * ab_dim1]; + ab[ka1 + (j - 1) * ab_dim1] = work[*n + j] * ab[ka1 + (j - 1) + * ab_dim1]; +/* L800: */ + } + +/* generate rotations in 1st set to annihilate elements which */ +/* have been created outside the band */ + + if (nrt > 0) { + dlargv_(&nrt, &ab[ka1 + j1 * ab_dim1], &inca, &work[j1], &ka1, + &work[*n + j1], &ka1); + } + if (nr > 0) { + +/* apply rotations in 1st set from the right */ + + i__1 = *ka - 1; + for (l = 1; l <= i__1; ++l) { + dlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2 + + (j1 - 1) * ab_dim1], &inca, &work[*n + j1], & + work[j1], &ka1); +/* L810: */ + } + +/* apply rotations in 1st set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + + 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + j1] +, &work[j1], &ka1); + + } + +/* start applying rotations in 1st set from the left */ + + i__1 = *kb - k + 1; + for (l = *ka - 1; l >= i__1; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] +, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], + &inca, &work[*n + j1t], &work[j1t], &ka1); + } +/* L820: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 1st set */ + + i__1 = j2; + i__3 = ka1; + for (j = j1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { + drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 + + 1], &c__1, &work[*n + j], &work[j]); +/* L830: */ + } + } +/* L840: */ + } + + if (update) { + if (i2 > 0 && kbt > 0) { + +/* create nonzero element a(i+kbt,i+kbt-ka-1) outside the */ +/* band and store it in WORK(m-kb+i+kbt) */ + + work[m - *kb + i__ + kbt] = -bb[kbt + 1 + i__ * bb_dim1] * + ra1; + } + } + + for (k = *kb; k >= 1; --k) { + if (update) { +/* Computing MAX */ + i__4 = 2, i__3 = k + i0 - m; + j2 = i__ + k + 1 - std::max(i__4,i__3) * ka1; + } else { +/* Computing MAX */ + i__4 = 1, i__3 = k + i0 - m; + j2 = i__ + k + 1 - std::max(i__4,i__3) * ka1; + } + +/* finish applying rotations in 2nd set from the left */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (j2 + *ka + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t + l - 1) * ab_dim1], + &inca, &ab[ka1 - l + (j1t + l - 1) * ab_dim1], & + inca, &work[*n + m - *kb + j1t + *ka], &work[m - * + kb + j1t + *ka], &ka1); + } +/* L850: */ + } + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + i__4 = j2; + i__3 = ka1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + work[m - *kb + j] = work[m - *kb + j + *ka]; + work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka]; +/* L860: */ + } + i__3 = j2; + i__4 = ka1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j+ka,j-1) outside the band */ +/* and store it in WORK(m-kb+j) */ + + work[m - *kb + j] *= ab[ka1 + (j - 1) * ab_dim1]; + ab[ka1 + (j - 1) * ab_dim1] = work[*n + m - *kb + j] * ab[ka1 + + (j - 1) * ab_dim1]; +/* L870: */ + } + if (update) { + if (i__ + k > ka1 && k <= kbt) { + work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k]; + } + } +/* L880: */ + } + + for (k = *kb; k >= 1; --k) { +/* Computing MAX */ + i__4 = 1, i__3 = k + i0 - m; + j2 = i__ + k + 1 - std::max(i__4,i__3) * ka1; + nr = (j2 + *ka - 1) / ka1; + j1 = j2 - (nr - 1) * ka1; + if (nr > 0) { + +/* generate rotations in 2nd set to annihilate elements */ +/* which have been created outside the band */ + + dlargv_(&nr, &ab[ka1 + j1 * ab_dim1], &inca, &work[m - *kb + + j1], &ka1, &work[*n + m - *kb + j1], &ka1); + +/* apply rotations in 2nd set from the right */ + + i__4 = *ka - 1; + for (l = 1; l <= i__4; ++l) { + dlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2 + + (j1 - 1) * ab_dim1], &inca, &work[*n + m - *kb + + j1], &work[m - *kb + j1], &ka1); +/* L890: */ + } + +/* apply rotations in 2nd set from both sides to diagonal */ +/* blocks */ + + dlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + + 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + m + - *kb + j1], &work[m - *kb + j1], &ka1); + + } + +/* start applying rotations in 2nd set from the left */ + + i__4 = *kb - k + 1; + for (l = *ka - 1; l >= i__4; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] +, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], + &inca, &work[*n + m - *kb + j1t], &work[m - *kb + + j1t], &ka1); + } +/* L900: */ + } + + if (wantx) { + +/* post-multiply X by product of rotations in 2nd set */ + + i__4 = j2; + i__3 = ka1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) { + drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1 + + 1], &c__1, &work[*n + m - *kb + j], &work[m - * + kb + j]); +/* L910: */ + } + } +/* L920: */ + } + + i__3 = *kb - 1; + for (k = 1; k <= i__3; ++k) { +/* Computing MAX */ + i__4 = 1, i__1 = k + i0 - m + 1; + j2 = i__ + k + 1 - std::max(i__4,i__1) * ka1; + +/* finish applying rotations in 1st set from the left */ + + for (l = *kb - k; l >= 1; --l) { + nrt = (j2 + l - 1) / ka1; + j1t = j2 - (nrt - 1) * ka1; + if (nrt > 0) { + dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1] +, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1], + &inca, &work[*n + j1t], &work[j1t], &ka1); + } +/* L930: */ + } +/* L940: */ + } + + if (*kb > 1) { +/* Computing MIN */ + i__4 = i__ + *kb; + i__3 = std::min(i__4,m) - (*ka << 1) - 1; + for (j = 2; j <= i__3; ++j) { + work[*n + j] = work[*n + j + *ka]; + work[j] = work[j + *ka]; +/* L950: */ + } + } + + } + + goto L490; + +/* End of DSBGST */ + +} /* dsbgst_ */ + +/* Subroutine */ int dsbgv_(const char *jobz, const char *uplo, integer *n, integer *ka, + integer *kb, double *ab, integer *ldab, double *bb, integer * + ldbb, double *w, double *z__, integer *ldz, double *work, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1; + + /* Local variables */ + integer inde; + char vect[1]; + integer iinfo; + bool upper, wantz; + integer indwrk; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBGV computes all the eigenvalues, and optionally, the eigenvectors */ +/* of a real generalized symmetric-definite banded eigenproblem, of */ +/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */ +/* and banded, and B is also positive definite. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangles of A and B are stored; */ +/* = 'L': Lower triangles of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* KA (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ + +/* KB (input) INTEGER */ +/* The number of superdiagonals of the matrix B if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first ka+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ + +/* On exit, the contents of AB are destroyed. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KA+1. */ + +/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix B, stored in the first kb+1 rows of the array. The */ +/* j-th column of B is stored in the j-th column of the array BB */ +/* as follows: */ +/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */ +/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */ + +/* On exit, the factor S from the split Cholesky factorization */ +/* B = S**T*S, as returned by DPBSTF. */ + +/* LDBB (input) INTEGER */ +/* The leading dimension of the array BB. LDBB >= KB+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* eigenvectors, with the i-th column of Z holding the */ +/* eigenvector associated with W(i). The eigenvectors are */ +/* normalized so that Z**T*B*Z = I. */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= N. */ + +/* 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 */ +/* > 0: if INFO = i, and i is: */ +/* <= N: the algorithm failed to converge: */ +/* i off-diagonal elements of an intermediate */ +/* tridiagonal form did not converge to zero; */ +/* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF */ +/* returned INFO = i: B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + bb_dim1 = *ldbb; + bb_offset = 1 + bb_dim1; + bb -= bb_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ka < 0) { + *info = -4; + } else if (*kb < 0 || *kb > *ka) { + *info = -5; + } else if (*ldab < *ka + 1) { + *info = -7; + } else if (*ldbb < *kb + 1) { + *info = -9; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBGV ", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a split Cholesky factorization of B. */ + + dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem. */ + + inde = 1; + indwrk = inde + *n; + dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, + &z__[z_offset], ldz, &work[indwrk], &iinfo) + ; + +/* Reduce to tridiagonal form. */ + + if (wantz) { + *(unsigned char *)vect = 'U'; + } else { + *(unsigned char *)vect = 'N'; + } + dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ + z_offset], ldz, &work[indwrk], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ + indwrk], info); + } + return 0; + +/* End of DSBGV */ + +} /* dsbgv_ */ + +/* Subroutine */ int dsbgvd_(const char *jobz, const char *uplo, integer *n, integer *ka, + integer *kb, double *ab, integer *ldab, double *bb, integer * + ldbb, double *w, double *z__, integer *ldz, double *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* Table of constant values */ + static double c_b12 = 1.; + static double c_b13 = 0.; + + /* System generated locals */ + integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1; + + /* Local variables */ + integer inde; + char vect[1]; + integer iinfo, lwmin; + bool upper, wantz; + integer indwk2, llwrk2; + integer indwrk, liwmin; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors */ +/* of a real generalized symmetric-definite banded eigenproblem, of the */ +/* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and */ +/* banded, and B is also positive definite. If eigenvectors are */ +/* desired, it uses a divide and conquer algorithm. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangles of A and B are stored; */ +/* = 'L': Lower triangles of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* KA (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ + +/* KB (input) INTEGER */ +/* The number of superdiagonals of the matrix B if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first ka+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ + +/* On exit, the contents of AB are destroyed. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KA+1. */ + +/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix B, stored in the first kb+1 rows of the array. The */ +/* j-th column of B is stored in the j-th column of the array BB */ +/* as follows: */ +/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */ +/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */ + +/* On exit, the factor S from the split Cholesky factorization */ +/* B = S**T*S, as returned by DPBSTF. */ + +/* LDBB (input) INTEGER */ +/* The leading dimension of the array BB. LDBB >= KB+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* eigenvectors, with the i-th column of Z holding the */ +/* eigenvector associated with W(i). The eigenvectors are */ +/* normalized so Z**T*B*Z = I. */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* If N <= 1, LWORK >= 1. */ +/* If JOBZ = 'N' and N > 1, LWORK >= 3*N. */ +/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal sizes of the WORK and IWORK */ +/* arrays, returns these values as the first entries of the WORK */ +/* and IWORK arrays, and no error message related to LWORK or */ +/* LIWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */ +/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal sizes of the WORK and */ +/* IWORK arrays, returns these values as the first entries of */ +/* the WORK and IWORK arrays, and no error message related to */ +/* LWORK or LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is: */ +/* <= N: the algorithm failed to converge: */ +/* i off-diagonal elements of an intermediate */ +/* tridiagonal form did not converge to zero; */ +/* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF */ +/* returned INFO = i: B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + bb_dim1 = *ldbb; + bb_offset = 1 + bb_dim1; + bb -= bb_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = *n << 1; + } + + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ka < 0) { + *info = -4; + } else if (*kb < 0 || *kb > *ka) { + *info = -5; + } else if (*ldab < *ka + 1) { + *info = -7; + } else if (*ldbb < *kb + 1) { + *info = -9; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -12; + } + + if (*info == 0) { + work[1] = (double) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -14; + } else if (*liwork < liwmin && ! lquery) { + *info = -16; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBGVD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a split Cholesky factorization of B. */ + + dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem. */ + + inde = 1; + indwrk = inde + *n; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, + &z__[z_offset], ldz, &work[indwrk], &iinfo) + ; + +/* Reduce to tridiagonal form. */ + + if (wantz) { + *(unsigned char *)vect = 'U'; + } else { + *(unsigned char *)vect = 'N'; + } + dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[ + z_offset], ldz, &work[indwrk], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info); + dgemm_("N", "N", n, n, n, &c_b12, &z__[z_offset], ldz, &work[indwrk], + n, &c_b13, &work[indwk2], n); + dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); + } + + work[1] = (double) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSBGVD */ + +} /* dsbgvd_ */ + +/* Subroutine */ int dsbgvx_(const char *jobz, const char *range, const char *uplo, integer *n, + integer *ka, integer *kb, double *ab, integer *ldab, double * + bb, integer *ldbb, double *q, integer *ldq, double *vl, + double *vu, integer *il, integer *iu, double *abstol, integer + *m, double *w, double *z__, integer *ldz, double *work, + integer *iwork, integer *ifail, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b25 = 1.; + static double c_b27 = 0.; + + /* System generated locals */ + integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, jj; + double tmp1; + integer indd, inde; + char vect[1]; + bool test; + integer itmp1, indee; + integer iinfo; + char order[1]; + bool upper, wantz, alleig, indeig; + integer indibl; + bool valeig; + integer indisp; + integer indiwo; + integer indwrk; + integer nsplit; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBGVX computes selected eigenvalues, and optionally, eigenvectors */ +/* of a real generalized symmetric-definite banded eigenproblem, of */ +/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */ +/* and banded, and B is also positive definite. Eigenvalues and */ +/* eigenvectors can be selected by specifying either all eigenvalues, */ +/* a range of values or a range of indices for the desired eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangles of A and B are stored; */ +/* = 'L': Lower triangles of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* KA (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ + +/* KB (input) INTEGER */ +/* The number of superdiagonals of the matrix B if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first ka+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ + +/* On exit, the contents of AB are destroyed. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KA+1. */ + +/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix B, stored in the first kb+1 rows of the array. The */ +/* j-th column of B is stored in the j-th column of the array BB */ +/* as follows: */ +/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */ +/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */ + +/* On exit, the factor S from the split Cholesky factorization */ +/* B = S**T*S, as returned by DPBSTF. */ + +/* LDBB (input) INTEGER */ +/* The leading dimension of the array BB. LDBB >= KB+1. */ + +/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */ +/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */ +/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */ +/* and consequently C to tridiagonal form. */ +/* If JOBZ = 'N', the array Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. If JOBZ = 'N', */ +/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less than */ +/* or equal to zero, then EPS*|T| will be used in its place, */ +/* where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* by reducing A to tridiagonal form. */ + +/* Eigenvalues will be computed most accurately when ABSTOL is */ +/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* If this routine returns with INFO>0, indicating that some */ +/* eigenvectors did not converge, try setting ABSTOL to */ +/* 2*DLAMCH('S'). */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* eigenvectors, with the i-th column of Z holding the */ +/* eigenvector associated with W(i). The eigenvectors are */ +/* normalized so Z**T*B*Z = I. */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N) */ + +/* IWORK (workspace/output) INTEGER array, dimension (5*N) */ + +/* IFAIL (output) INTEGER array, dimension (M) */ +/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* indices of the eigenvalues that failed to converge. */ +/* If JOBZ = 'N', then IFAIL is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0 : successful exit */ +/* < 0 : if INFO = -i, the i-th argument had an illegal value */ +/* <= N: if INFO = i, then i eigenvectors failed to converge. */ +/* Their indices are stored in IFAIL. */ +/* > N : DPBSTF returned an error code; i.e., */ +/* if INFO = N + i, for 1 <= i <= N, then the leading */ +/* minor of order i of B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + bb_dim1 = *ldbb; + bb_offset = 1 + bb_dim1; + bb -= bb_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ka < 0) { + *info = -5; + } else if (*kb < 0 || *kb > *ka) { + *info = -6; + } else if (*ldab < *ka + 1) { + *info = -8; + } else if (*ldbb < *kb + 1) { + *info = -10; + } else if (*ldq < 1 || wantz && *ldq < *n) { + *info = -12; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -14; + } + } else if (indeig) { + if (*il < 1 || *il > std::max(1_integer,*n)) { + *info = -15; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -16; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -21; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBGVX", &i__1); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + +/* Form a split Cholesky factorization of B. */ + + dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem. */ + + dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, + &q[q_offset], ldq, &work[1], &iinfo); + +/* Reduce symmetric band matrix to tridiagonal form. */ + + indd = 1; + inde = indd + *n; + indwrk = inde + *n; + if (wantz) { + *(unsigned char *)vect = 'U'; + } else { + *(unsigned char *)vect = 'N'; + } + dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &work[indd], &work[inde], + &q[q_offset], ldq, &work[indwrk], &iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal */ +/* to zero, then call DSTERF or SSTEQR. If this fails for some */ +/* eigenvalue, then try DSTEBZ. */ + + test = false; + if (indeig) { + if (*il == 1 && *iu == *n) { + test = true; + } + } + if ((alleig || test) && *abstol <= 0.) { + dcopy_(n, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + if (! wantz) { + dsterf_(n, &w[1], &work[indee], info); + } else { + dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L30; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, */ +/* call DSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, vl, vu, il, iu, abstol, &work[indd], &work[inde], + m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], + &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply transformation matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1); + dgemv_("N", n, n, &c_b25, &q[q_offset], ldq, &work[1], &c__1, & + c_b27, &z__[j * z_dim1 + 1], &c__1); +/* L20: */ + } + } + +L30: + +/* If eigenvalues are not in order, then sort them, along with */ +/* eigenvectors. */ + + if (wantz) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp1 = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp1) { + i__ = jj; + tmp1 = w[jj]; + } +/* L40: */ + } + + if (i__ != 0) { + itmp1 = iwork[indibl + i__ - 1]; + w[i__] = w[j]; + iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + w[j] = tmp1; + iwork[indibl + j - 1] = itmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + if (*info != 0) { + itmp1 = ifail[i__]; + ifail[i__] = ifail[j]; + ifail[j] = itmp1; + } + } +/* L50: */ + } + } + + return 0; + +/* End of DSBGVX */ + +} /* dsbgvx_ */ + +/* Subroutine */ int dsbtrd_(const char *vect, const char *uplo, integer *n, integer *kd, + double *ab, integer *ldab, double *d__, double *e, + double *q, integer *ldq, double *work, integer *info) +{ + /* Table of constant values */ + static double c_b9 = 0.; + static double c_b10 = 1.; + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4, + i__5; + + /* Local variables */ + integer i__, j, k, l, i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt, + kdm1, inca, jend, lend, jinc, incx, last; + double temp; + integer j1end, j1inc, iqend; + bool initq, wantq, upper; + integer iqaend; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSBTRD reduces a real symmetric band matrix A to symmetric */ +/* tridiagonal form T by an orthogonal similarity transformation: */ +/* Q**T * A * Q = T. */ + +/* Arguments */ +/* ========= */ + +/* VECT (input) CHARACTER*1 */ +/* = 'N': do not form Q; */ +/* = 'V': form Q; */ +/* = 'U': update a matrix X, by forming X*Q. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals of the matrix A if UPLO = 'U', */ +/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ + +/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* On entry, the upper or lower triangle of the symmetric band */ +/* matrix A, stored in the first KD+1 rows of the array. The */ +/* j-th column of A is stored in the j-th column of the array AB */ +/* as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ +/* On exit, the diagonal elements of AB are overwritten by the */ +/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */ +/* elements on the first superdiagonal (if UPLO = 'U') or the */ +/* first subdiagonal (if UPLO = 'L') are overwritten by the */ +/* off-diagonal elements of T; the rest of AB is overwritten by */ +/* values generated during the reduction. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* D (output) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of the tridiagonal matrix T. */ + +/* E (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The off-diagonal elements of the tridiagonal matrix T: */ +/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* On entry, if VECT = 'U', then Q must contain an N-by-N */ +/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */ + +/* On exit: */ +/* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; */ +/* if VECT = 'U', Q contains the product X*Q; */ +/* if VECT = 'N', the array Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. */ +/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */ + +/* 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 */ +/* =============== */ + +/* Modified by Linda Kaufman, Bell Labs. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --work; + + /* Function Body */ + initq = lsame_(vect, "V"); + wantq = initq || lsame_(vect, "U"); + upper = lsame_(uplo, "U"); + kd1 = *kd + 1; + kdm1 = *kd - 1; + incx = *ldab - 1; + iqend = 1; + + *info = 0; + if (! wantq && ! lsame_(vect, "N")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kd < 0) { + *info = -4; + } else if (*ldab < kd1) { + *info = -6; + } else if (*ldq < std::max(1_integer,*n) && wantq) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSBTRD", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Initialize Q to the unit matrix, if needed */ + + if (initq) { + dlaset_("Full", n, n, &c_b9, &c_b10, &q[q_offset], ldq); + } + +/* Wherever possible, plane rotations are generated and applied in */ +/* vector operations of length NR over the index set J1:J2:KD1. */ + +/* The cosines and sines of the plane rotations are stored in the */ +/* arrays D and WORK. */ + + inca = kd1 * *ldab; +/* Computing MIN */ + i__1 = *n - 1; + kdn = std::min(i__1,*kd); + if (upper) { + + if (*kd > 1) { + +/* Reduce to tridiagonal form, working with upper triangle */ + + nr = 0; + j1 = kdn + 2; + j2 = 1; + + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Reduce i-th row of matrix to tridiagonal form */ + + for (k = kdn + 1; k >= 2; --k) { + j1 += kdn; + j2 += kdn; + + if (nr > 0) { + +/* generate plane rotations to annihilate nonzero */ +/* elements which have been created outside the band */ + + dlargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, & + work[j1], &kd1, &d__[j1], &kd1); + +/* apply rotations from the right */ + + +/* Dependent on the the number of diagonals either */ +/* DLARTV or DROT is used */ + + if (nr >= (*kd << 1) - 1) { + i__2 = *kd - 1; + for (l = 1; l <= i__2; ++l) { + dlartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1], + &inca, &ab[l + j1 * ab_dim1], &inca, & + d__[j1], &work[j1], &kd1); +/* L10: */ + } + + } else { + jend = j1 + (nr - 1) * kd1; + i__2 = jend; + i__3 = kd1; + for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <= + i__2; jinc += i__3) { + drot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], & + c__1, &ab[jinc * ab_dim1 + 1], &c__1, + &d__[jinc], &work[jinc]); +/* L20: */ + } + } + } + + + if (k > 2) { + if (k <= *n - i__ + 1) { + +/* generate plane rotation to annihilate a(i,i+k-1) */ +/* within the band */ + + dlartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1] +, &ab[*kd - k + 2 + (i__ + k - 1) * + ab_dim1], &d__[i__ + k - 1], &work[i__ + + k - 1], &temp); + ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1] = temp; + +/* apply rotation from the right */ + + i__3 = k - 3; + drot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) * + ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ + + k - 1) * ab_dim1], &c__1, &d__[i__ + k - + 1], &work[i__ + k - 1]); + } + ++nr; + j1 = j1 - kdn - 1; + } + +/* apply plane rotations from both sides to diagonal */ +/* blocks */ + + if (nr > 0) { + dlar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 + + j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca, + &d__[j1], &work[j1], &kd1); + } + +/* apply plane rotations from the left */ + + if (nr > 0) { + if ((*kd << 1) - 1 < nr) { + +/* Dependent on the the number of diagonals either */ +/* DLARTV or DROT is used */ + + i__3 = *kd - 1; + for (l = 1; l <= i__3; ++l) { + if (j2 + l > *n) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + dlartv_(&nrt, &ab[*kd - l + (j1 + l) * + ab_dim1], &inca, &ab[*kd - l + 1 + + (j1 + l) * ab_dim1], &inca, & + d__[j1], &work[j1], &kd1); + } +/* L30: */ + } + } else { + j1end = j1 + kd1 * (nr - 2); + if (j1end >= j1) { + i__3 = j1end; + i__2 = kd1; + for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <= + i__3; jin += i__2) { + i__4 = *kd - 1; + drot_(&i__4, &ab[*kd - 1 + (jin + 1) * + ab_dim1], &incx, &ab[*kd + (jin + + 1) * ab_dim1], &incx, &d__[jin], & + work[jin]); +/* L40: */ + } + } +/* Computing MIN */ + i__2 = kdm1, i__3 = *n - j2; + lend = std::min(i__2,i__3); + last = j1end + kd1; + if (lend > 0) { + drot_(&lend, &ab[*kd - 1 + (last + 1) * + ab_dim1], &incx, &ab[*kd + (last + 1) + * ab_dim1], &incx, &d__[last], &work[ + last]); + } + } + } + + if (wantq) { + +/* accumulate product of plane rotations in Q */ + + if (initq) { + +/* take advantage of the fact that Q was */ +/* initially the Identity matrix */ + + iqend = std::max(iqend,j2); +/* Computing MAX */ + i__2 = 0, i__3 = k - 3; + i2 = std::max(i__2,i__3); + iqaend = i__ * *kd + 1; + if (k == 2) { + iqaend += *kd; + } + iqaend = std::min(iqaend,iqend); + i__2 = j2; + i__3 = kd1; + for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j + += i__3) { + ibl = i__ - i2 / kdm1; + ++i2; +/* Computing MAX */ + i__4 = 1, i__5 = j - ibl; + iqb = std::max(i__4,i__5); + nq = iqaend + 1 - iqb; +/* Computing MIN */ + i__4 = iqaend + *kd; + iqaend = std::min(i__4,iqend); + drot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1, + &q[iqb + j * q_dim1], &c__1, &d__[j], + &work[j]); +/* L50: */ + } + } else { + + i__3 = j2; + i__2 = kd1; + for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j + += i__2) { + drot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[ + j * q_dim1 + 1], &c__1, &d__[j], & + work[j]); +/* L60: */ + } + } + + } + + if (j2 + kdn > *n) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 = j2 - kdn - 1; + } + + i__2 = j2; + i__3 = kd1; + for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) + { + +/* create nonzero element a(j-1,j+kd) outside the band */ +/* and store it in WORK */ + + work[j + *kd] = work[j] * ab[(j + *kd) * ab_dim1 + 1]; + ab[(j + *kd) * ab_dim1 + 1] = d__[j] * ab[(j + *kd) * + ab_dim1 + 1]; +/* L70: */ + } +/* L80: */ + } +/* L90: */ + } + } + + if (*kd > 0) { + +/* copy off-diagonal elements to E */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = ab[*kd + (i__ + 1) * ab_dim1]; +/* L100: */ + } + } else { + +/* set E to zero if original matrix was diagonal */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = 0.; +/* L110: */ + } + } + +/* copy diagonal elements to D */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[kd1 + i__ * ab_dim1]; +/* L120: */ + } + + } else { + + if (*kd > 1) { + +/* Reduce to tridiagonal form, working with lower triangle */ + + nr = 0; + j1 = kdn + 2; + j2 = 1; + + i__1 = *n - 2; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Reduce i-th column of matrix to tridiagonal form */ + + for (k = kdn + 1; k >= 2; --k) { + j1 += kdn; + j2 += kdn; + + if (nr > 0) { + +/* generate plane rotations to annihilate nonzero */ +/* elements which have been created outside the band */ + + dlargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, & + work[j1], &kd1, &d__[j1], &kd1); + +/* apply plane rotations from one side */ + + +/* Dependent on the the number of diagonals either */ +/* DLARTV or DROT is used */ + + if (nr > (*kd << 1) - 1) { + i__3 = *kd - 1; + for (l = 1; l <= i__3; ++l) { + dlartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) * + ab_dim1], &inca, &ab[kd1 - l + 1 + ( + j1 - kd1 + l) * ab_dim1], &inca, &d__[ + j1], &work[j1], &kd1); +/* L130: */ + } + } else { + jend = j1 + kd1 * (nr - 1); + i__3 = jend; + i__2 = kd1; + for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <= + i__3; jinc += i__2) { + drot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1] +, &incx, &ab[kd1 + (jinc - *kd) * + ab_dim1], &incx, &d__[jinc], &work[ + jinc]); +/* L140: */ + } + } + + } + + if (k > 2) { + if (k <= *n - i__ + 1) { + +/* generate plane rotation to annihilate a(i+k-1,i) */ +/* within the band */ + + dlartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ * + ab_dim1], &d__[i__ + k - 1], &work[i__ + + k - 1], &temp); + ab[k - 1 + i__ * ab_dim1] = temp; + +/* apply rotation from the left */ + + i__2 = k - 3; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + drot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], & + i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], & + i__4, &d__[i__ + k - 1], &work[i__ + k - + 1]); + } + ++nr; + j1 = j1 - kdn - 1; + } + +/* apply plane rotations from both sides to diagonal */ +/* blocks */ + + if (nr > 0) { + dlar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 * + ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], & + inca, &d__[j1], &work[j1], &kd1); + } + +/* apply plane rotations from the right */ + + +/* Dependent on the the number of diagonals either */ +/* DLARTV or DROT is used */ + + if (nr > 0) { + if (nr > (*kd << 1) - 1) { + i__2 = *kd - 1; + for (l = 1; l <= i__2; ++l) { + if (j2 + l > *n) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + dlartv_(&nrt, &ab[l + 2 + (j1 - 1) * + ab_dim1], &inca, &ab[l + 1 + j1 * + ab_dim1], &inca, &d__[j1], &work[ + j1], &kd1); + } +/* L150: */ + } + } else { + j1end = j1 + kd1 * (nr - 2); + if (j1end >= j1) { + i__2 = j1end; + i__3 = kd1; + for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 : + j1inc <= i__2; j1inc += i__3) { + drot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 + + 3], &c__1, &ab[j1inc * ab_dim1 + + 2], &c__1, &d__[j1inc], &work[ + j1inc]); +/* L160: */ + } + } +/* Computing MIN */ + i__3 = kdm1, i__2 = *n - j2; + lend = std::min(i__3,i__2); + last = j1end + kd1; + if (lend > 0) { + drot_(&lend, &ab[(last - 1) * ab_dim1 + 3], & + c__1, &ab[last * ab_dim1 + 2], &c__1, + &d__[last], &work[last]); + } + } + } + + + + if (wantq) { + +/* accumulate product of plane rotations in Q */ + + if (initq) { + +/* take advantage of the fact that Q was */ +/* initially the Identity matrix */ + + iqend = std::max(iqend,j2); +/* Computing MAX */ + i__3 = 0, i__2 = k - 3; + i2 = std::max(i__3,i__2); + iqaend = i__ * *kd + 1; + if (k == 2) { + iqaend += *kd; + } + iqaend = std::min(iqaend,iqend); + i__3 = j2; + i__2 = kd1; + for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j + += i__2) { + ibl = i__ - i2 / kdm1; + ++i2; +/* Computing MAX */ + i__4 = 1, i__5 = j - ibl; + iqb = std::max(i__4,i__5); + nq = iqaend + 1 - iqb; +/* Computing MIN */ + i__4 = iqaend + *kd; + iqaend = std::min(i__4,iqend); + drot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1, + &q[iqb + j * q_dim1], &c__1, &d__[j], + &work[j]); +/* L170: */ + } + } else { + + i__2 = j2; + i__3 = kd1; + for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j + += i__3) { + drot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[ + j * q_dim1 + 1], &c__1, &d__[j], & + work[j]); +/* L180: */ + } + } + } + + if (j2 + kdn > *n) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 = j2 - kdn - 1; + } + + i__3 = j2; + i__2 = kd1; + for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) + { + +/* create nonzero element a(j+kd,j-1) outside the */ +/* band and store it in WORK */ + + work[j + *kd] = work[j] * ab[kd1 + j * ab_dim1]; + ab[kd1 + j * ab_dim1] = d__[j] * ab[kd1 + j * ab_dim1] + ; +/* L190: */ + } +/* L200: */ + } +/* L210: */ + } + } + + if (*kd > 0) { + +/* copy off-diagonal elements to E */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = ab[i__ * ab_dim1 + 2]; +/* L220: */ + } + } else { + +/* set E to zero if original matrix was diagonal */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = 0.; +/* L230: */ + } + } + +/* copy diagonal elements to D */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[i__ * ab_dim1 + 1]; +/* L240: */ + } + } + + return 0; + +/* End of DSBTRD */ + +} /* dsbtrd_ */ + +int dsfrk_(const char *transr, const char *uplo, const char *trans, integer *n, + integer *k, double *alpha, double *a, integer *lda, + double *beta, double *c__) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer j, n1, n2, nk, info; + bool normaltransr; + integer nrowa; + bool lower, nisodd, notrans; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Level 3 BLAS like routine for C in RFP Format. */ + +/* DSFRK performs one of the symmetric rank--k operations */ + +/* C := alpha*A*A' + beta*C, */ + +/* or */ + +/* C := alpha*A'*A + beta*C, */ + +/* where alpha and beta are real scalars, C is an n--by--n symmetric */ +/* matrix and A is an n--by--k matrix in the first case and a k--by--n */ +/* matrix in the second case. */ + +/* Arguments */ +/* ========== */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': The Normal Form of RFP A is stored; */ +/* = 'T': The Transpose Form of RFP A is stored. */ + +/* UPLO - (input) CHARACTER */ +/* On entry, UPLO specifies whether the upper or lower */ +/* triangular part of the array C is to be referenced as */ +/* follows: */ + +/* UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* is to be referenced. */ + +/* UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* is to be referenced. */ + +/* Unchanged on exit. */ + +/* TRANS - (input) CHARACTER */ +/* On entry, TRANS specifies the operation to be performed as */ +/* follows: */ + +/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */ + +/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */ + +/* Unchanged on exit. */ + +/* N - (input) INTEGER. */ +/* On entry, N specifies the order of the matrix C. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* K - (input) INTEGER. */ +/* On entry with TRANS = 'N' or 'n', K specifies the number */ +/* of columns of the matrix A, and on entry with TRANS = 'T' */ +/* or 't', K specifies the number of rows of the matrix A. K */ +/* must be at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - (input) DOUBLE PRECISION. */ +/* On entry, ALPHA specifies the scalar alpha. */ +/* Unchanged on exit. */ + +/* A - (input) DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where KA */ +/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */ +/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */ +/* the array A must contain the matrix A, otherwise the leading */ +/* K--by--N part of the array A must contain the matrix A. */ +/* Unchanged on exit. */ + +/* LDA - (input) INTEGER. */ +/* On entry, LDA specifies the first dimension of A as declared */ +/* in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* then LDA must be at least max( 1, n ), otherwise LDA must */ +/* be at least max( 1, k ). */ +/* Unchanged on exit. */ + +/* BETA - (input) DOUBLE PRECISION. */ +/* On entry, BETA specifies the scalar beta. */ +/* Unchanged on exit. */ + + +/* C - (input/output) DOUBLE PRECISION array, dimension ( NT ); */ +/* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP */ +/* Format. RFP Format is described by TRANSR, UPLO and N. */ + +/* Arguments */ +/* ========== */ + +/* .. */ +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --c__; + + /* Function Body */ + info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + notrans = lsame_(trans, "N"); + + if (notrans) { + nrowa = *n; + } else { + nrowa = *k; + } + + if (! normaltransr && ! lsame_(transr, "T")) { + info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + info = -2; + } else if (! notrans && ! lsame_(trans, "T")) { + info = -3; + } else if (*n < 0) { + info = -4; + } else if (*k < 0) { + info = -5; + } else if (*lda < std::max(1_integer,nrowa)) { + info = -8; + } + if (info != 0) { + i__1 = -info; + xerbla_("DSFRK ", &i__1); + return 0; + } + +/* Quick return if possible. */ + +/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */ +/* done (it is in DSYRK for example) and left in the general case. */ + + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + + if (*alpha == 0. && *beta == 0.) { + i__1 = *n * (*n + 1) / 2; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; + } + return 0; + } + +/* C is N-by-N. */ +/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ +/* If N is even, NISODD = .FALSE., and NK. */ + + if (*n % 2 == 0) { + nisodd = false; + nk = *n / 2; + } else { + nisodd = true; + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + } + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */ + + dsyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], n); + dsyrk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[*n + 1], n); + dgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1], + lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1], n); + + } else { + +/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */ + + dsyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], n); + dsyrk_("U", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[*n + 1], n) + ; + dgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1 + + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1], n); + + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */ + + dsyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 + 1], n); + dsyrk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda, + beta, &c__[n1 + 1], n); + dgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, + &a[n2 + a_dim1], lda, beta, &c__[1], n); + + } else { + +/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */ + + dsyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 + 1], n); + dsyrk_("U", "T", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda, + beta, &c__[n1 + 1], n); + dgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, + &a[n2 * a_dim1 + 1], lda, beta, &c__[1], n); + + } + + } + + } else { + +/* N is odd, and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */ + + dsyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], &n1); + dsyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[2], &n1); + dgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, + &a[n1 + 1 + a_dim1], lda, beta, &c__[n1 * n1 + 1], + &n1); + + } else { + +/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */ + + dsyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], &n1); + dsyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[2], &n1); + dgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda, + &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[n1 * + n1 + 1], &n1); + + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */ + + dsyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 * n2 + 1], &n2); + dsyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[n1 * n2 + 1], &n2); + dgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1], + lda, &a[a_dim1 + 1], lda, beta, &c__[1], &n2); + + } else { + +/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */ + + dsyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 * n2 + 1], &n2); + dsyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[n1 * n2 + 1], &n2); + dgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1 + + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], & + n2); + + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */ + + i__1 = *n + 1; + dsyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[2], &i__1); + i__1 = *n + 1; + dsyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[1], &i__1); + i__1 = *n + 1; + dgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1], + lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], & + i__1); + + } else { + +/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */ + + i__1 = *n + 1; + dsyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[2], &i__1); + i__1 = *n + 1; + dsyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[1], &i__1); + i__1 = *n + 1; + dgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1 + + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], &i__1); + + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */ + + i__1 = *n + 1; + dsyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 2], &i__1); + i__1 = *n + 1; + dsyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[nk + 1], &i__1); + i__1 = *n + 1; + dgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, + &a[nk + 1 + a_dim1], lda, beta, &c__[1], &i__1); + + } else { + +/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */ + + i__1 = *n + 1; + dsyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 2], &i__1); + i__1 = *n + 1; + dsyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[nk + 1], &i__1); + i__1 = *n + 1; + dgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, + &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[1], &i__1); + + } + + } + + } else { + +/* N is even, and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */ + + dsyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 1], &nk); + dsyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[1], &nk); + dgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, + &a[nk + 1 + a_dim1], lda, beta, &c__[(nk + 1) * + nk + 1], &nk); + + } else { + +/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */ + + dsyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 1], &nk); + dsyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[1], &nk); + dgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda, + &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[(nk + 1) * nk + 1], &nk); + + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */ + + dsyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk * (nk + 1) + 1], &nk); + dsyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[nk * nk + 1], &nk); + dgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1], + lda, &a[a_dim1 + 1], lda, beta, &c__[1], &nk); + + } else { + +/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */ + + dsyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk * (nk + 1) + 1], &nk); + dsyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[nk * nk + 1], &nk); + dgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1 + + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], & + nk); + + } + + } + + } + + } + + return 0; + +/* End of DSFRK */ + +} /* dsfrk_ */ + +#if 0 +/* Subroutine */ int dsgesv_(integer *n, integer *nrhs, double *a, integer *lda, integer *ipiv, double *b, integer *ldb, + double *x, integer *ldx, double *work, float *swork, integer *iter, integer *info) +{ + /* Table of constant values */ + static double c_b10 = -1.; + static double c_b11 = 1.; + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, x_dim1, x_offset, i__1; + double d__1; + + + /* Local variables */ + double cte, eps, anrm, rnrm, xnrm; + integer i__, ptsa, ptsx, iiter; + +/* -- LAPACK PROTOTYPE driver routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* February 2007 */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSGESV computes the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ + +/* DSGESV first attempts to factorize the matrix in SINGLE PRECISION */ +/* and use this factorization within an iterative refinement procedure */ +/* to produce a solution with DOUBLE PRECISION normwise backward error */ +/* quality (see below). If the approach fails the method switches to a */ +/* DOUBLE PRECISION factorization and solve. */ + +/* The iterative refinement is not going to be a winning strategy if */ +/* the ratio SINGLE PRECISION performance over DOUBLE PRECISION */ +/* performance is too small. A reasonable strategy should take the */ +/* number of right-hand sides and the size of the matrix into account. */ +/* This might be done with a call to ILAENV in the future. Up to now, we */ +/* always try iterative refinement. */ + +/* The iterative refinement process is stopped if */ +/* ITER > ITERMAX */ +/* or for all the RHS we have: */ +/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */ +/* where */ +/* o ITER is the number of the current iteration in the iterative */ +/* refinement process */ +/* o RNRM is the infinity-norm of the residual */ +/* o XNRM is the infinity-norm of the solution */ +/* o ANRM is the infinity-operator-norm of the matrix A */ +/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */ +/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */ +/* respectively. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input or input/ouptut) DOUBLE PRECISION array, */ +/* dimension (LDA,N) */ +/* On entry, the N-by-N coefficient matrix A. */ +/* On exit, if iterative refinement has been successfully used */ +/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */ +/* unchanged, if double precision factorization has been used */ +/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */ +/* array A contains the factors L and U from the factorization */ +/* A = P*L*U; the unit diagonal elements of L are not stored. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* The pivot indices that define the permutation matrix P; */ +/* row i of the matrix was interchanged with row IPIV(i). */ +/* Corresponds either to the single precision factorization */ +/* (if INFO.EQ.0 and ITER.GE.0) or the double precision */ +/* factorization (if INFO.EQ.0 and ITER.LT.0). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The N-by-NRHS right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS) */ +/* This array is used to hold the residual vectors. */ + +/* SWORK (workspace) REAL array, dimension (N*(N+NRHS)) */ +/* This array is used to use the single precision matrix and the */ +/* right-hand sides or solutions in single precision. */ + +/* ITER (output) INTEGER */ +/* < 0: iterative refinement has failed, double precision */ +/* factorization has been performed */ +/* -1 : the routine fell back to full precision for */ +/* implementation- or machine-specific reasons */ +/* -2 : narrowing the precision induced an overflow, */ +/* the routine fell back to full precision */ +/* -3 : failure of SGETRF */ +/* -31: stop the iterative refinement after the 30th */ +/* iterations */ +/* > 0: iterative refinement has been sucessfully used. */ +/* Returns the number of iterations */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is */ +/* exactly zero. The factorization has been completed, */ +/* but the factor U is exactly singular, so the solution */ +/* could not be computed. */ + +/* ========= */ + +/* .. Parameters .. */ + + + + +/* .. Local Scalars .. */ + +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + work_dim1 = *n; + work_offset = 1 + work_dim1; + work -= work_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --swork; + + /* Function Body */ + *info = 0; + *iter = 0; + +/* Test the input parameters. */ + + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSGESV", &i__1); + return 0; + } + +/* Quick return if (N.EQ.0). */ + + if (*n == 0) { + return 0; + } + +/* Skip single precision iterative refinement if a priori slower */ +/* than double precision factorization. */ + + if (false) { + *iter = -1; + goto L40; + } + +/* Compute some constants. */ + + anrm = dlange_("I", n, n, &a[a_offset], lda, &work[work_offset]); + eps = dlamch_("Epsilon"); + cte = anrm * eps * sqrt((double) (*n)) * 1.; + +/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */ + + ptsa = 1; + ptsx = ptsa + *n * *n; + +/* Convert B from double precision to single precision and store the */ +/* result in SX. */ + + dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Convert A from double precision to single precision and store the */ +/* result in SA. */ + + dlag2s_(n, n, &a[a_offset], lda, &swork[ptsa], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Compute the LU factorization of SA. */ + + sgetrf_(n, n, &swork[ptsa], n, &ipiv[1], info); + + if (*info != 0) { + *iter = -3; + goto L40; + } + +/* Solve the system SA*SX = SB. */ + + sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ptsx], + n, info); + +/* Convert SX back to double precision */ + + slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info); + +/* Compute R = B - AX (R is WORK). */ + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[a_offset], + lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * + x_dim1], abs(d__1)); + rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + + i__ * work_dim1], abs(d__1)); + if (rnrm > xnrm * cte) { + goto L10; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion. We are good to exit. */ + + *iter = 0; + return 0; + +L10: + + for (iiter = 1; iiter <= 30; ++iiter) { + +/* Convert R (in WORK) from double precision to single precision */ +/* and store the result in SX. */ + + dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Solve the system SA*SX = SR. */ + + sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ + ptsx], n, info); + +/* Convert SX back to double precision and update the current */ +/* iterate. */ + + slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info); + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * + x_dim1 + 1], &c__1); + } + +/* Compute R = B - AX (R is WORK). */ + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[ + a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset], + n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=IITER>0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * + x_dim1], abs(d__1)); + rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + + i__ * work_dim1], abs(d__1)); + if (rnrm > xnrm * cte) { + goto L20; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion, we are good to exit. */ + + *iter = iiter; + + return 0; + +L20: + +/* L30: */ + ; + } + +/* If we are at this place of the code, this is because we have */ +/* performed ITER=ITERMAX iterations and never satisified the */ +/* stopping criterion, set up the ITER flag accordingly and follow up */ +/* on double precision routine. */ + + *iter = -31; + +L40: + +/* Single-precision iterative refinement failed to converge to a */ +/* satisfactory solution, so we resort to double precision. */ + + dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); + + if (*info != 0) { + return 0; + } + + dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &x[x_offset] +, ldx, info); + + return 0; + +/* End of DSGESV. */ + +} /* dsgesv_ */ +#endif + +/* Subroutine */ int dspcon_(const char *uplo, integer *n, double *ap, integer * + ipiv, double *anorm, double *rcond, double *work, integer + *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, ip, kase; + integer isave[3]; + bool upper; + double ainvnm; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPCON estimates the reciprocal of the condition number (in the */ +/* 1-norm) of a real symmetric packed matrix A using the factorization */ +/* A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */ + +/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the details of the factorization are stored */ +/* as an upper or lower triangular matrix. */ +/* = 'U': Upper triangular, form is A = U*D*U**T; */ +/* = 'L': Lower triangular, form is A = L*D*L**T. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The block diagonal matrix D and the multipliers used to */ +/* obtain the factor U or L as computed by DSPTRF, stored as a */ +/* packed triangular matrix. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSPTRF. */ + +/* ANORM (input) DOUBLE PRECISION */ +/* The 1-norm of the original matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* estimate of the 1-norm of inv(A) computed in this routine. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --iwork; + --work; + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*anorm < 0.) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm <= 0.) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + ip = *n * (*n + 1) / 2; + for (i__ = *n; i__ >= 1; --i__) { + if (ipiv[i__] > 0 && ap[ip] == 0.) { + return 0; + } + ip -= i__; +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + ip = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ipiv[i__] > 0 && ap[ip] == 0.) { + return 0; + } + ip = ip + *n - i__ + 1; +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L') or inv(U*D*U'). */ + + dsptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info); + goto L30; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + + return 0; + +/* End of DSPCON */ + +} /* dspcon_ */ + +/* Subroutine */ int dspev_(const char *jobz, const char *uplo, integer *n, double * + ap, double *w, double *z__, integer *ldz, double *work, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1; + double d__1; + + /* Local variables */ + double eps; + integer inde; + double anrm; + integer imax; + double rmin, rmax; + double sigma; + integer iinfo; + bool wantz; + integer iscale; + double safmin; + double bignum; + integer indtau; + integer indwrk; + double smlnum; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPEV computes all the eigenvalues and, optionally, eigenvectors of a */ +/* real symmetric matrix A in packed storage. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, AP is overwritten by values generated during the */ +/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */ +/* and first superdiagonal of the tridiagonal matrix T overwrite */ +/* the corresponding elements of A, and if UPLO = 'L', the */ +/* diagonal and first subdiagonal of T overwrite the */ +/* corresponding elements of A. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ +/* eigenvectors of the matrix A, with the i-th column of Z */ +/* holding the eigenvector associated with W(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* 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. */ +/* > 0: if INFO = i, the algorithm failed to converge; i */ +/* off-diagonal elements of an intermediate tridiagonal */ +/* form did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lsame_(uplo, "U") || lsame_(uplo, + "L"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPEV ", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = ap[1]; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + anrm = dlansp_("M", uplo, n, &ap[1], &work[1]); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + i__1 = *n * (*n + 1) / 2; + dscal_(&i__1, &sigma, &ap[1], &c__1); + } + +/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DOPGTR to generate the orthogonal matrix, then call DSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + indwrk = indtau + *n; + dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[ + indwrk], &iinfo); + dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[ + indtau], info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + + return 0; + +/* End of DSPEV */ + +} /* dspev_ */ + +/* Subroutine */ int dspevd_(const char *jobz, const char *uplo, integer *n, double * + ap, double *w, double *z__, integer *ldz, double *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1; + double d__1; + + /* Local variables */ + double eps; + integer inde; + double anrm, rmin, rmax; + double sigma; + integer iinfo, lwmin; + bool wantz; + integer iscale; + double safmin; + double bignum; + integer indtau; + integer indwrk, liwmin; + integer llwork; + double smlnum; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPEVD computes all the eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric matrix A in packed storage. If eigenvectors are */ +/* desired, it uses a divide and conquer algorithm. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, AP is overwritten by values generated during the */ +/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */ +/* and first superdiagonal of the tridiagonal matrix T overwrite */ +/* the corresponding elements of A, and if UPLO = 'L', the */ +/* diagonal and first subdiagonal of T overwrite the */ +/* corresponding elements of A. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ +/* eigenvectors of the matrix A, with the i-th column of Z */ +/* holding the eigenvector associated with W(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, */ +/* dimension (LWORK) */ +/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* If N <= 1, LWORK must be at least 1. */ +/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. */ +/* If JOBZ = 'V' and N > 1, LWORK must be at least */ +/* 1 + 6*N + N**2. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the required sizes of the WORK and IWORK */ +/* arrays, returns these values as the first entries of the WORK */ +/* and IWORK arrays, and no error message related to LWORK or */ +/* LIWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ +/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the required sizes of the WORK and */ +/* IWORK arrays, returns these values as the first entries of */ +/* the WORK and IWORK arrays, and no error message related to */ +/* LWORK or LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: if INFO = i, the algorithm failed to converge; i */ +/* off-diagonal elements of an intermediate tridiagonal */ +/* form did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lsame_(uplo, "U") || lsame_(uplo, + "L"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -7; + } + + if (*info == 0) { + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else { + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + i__1 * i__1; + } else { + liwmin = 1; + lwmin = *n << 1; + } + } + iwork[1] = liwmin; + work[1] = (double) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -9; + } else if (*liwork < liwmin && ! lquery) { + *info = -11; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPEVD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = ap[1]; + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + anrm = dlansp_("M", uplo, n, &ap[1], &work[1]); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + i__1 = *n * (*n + 1) / 2; + dscal_(&i__1, &sigma, &ap[1], &c__1); + } + +/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ +/* tridiagonal matrix, then call DOPMTR to multiply it by the */ +/* Householder transformations represented in AP. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + dstedc_("I", n, &w[1], &work[inde], &z__[z_offset], ldz, &work[indwrk] +, &llwork, &iwork[1], liwork, info); + dopmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset], + ldz, &work[indwrk], &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + + work[1] = (double) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSPEVD */ + +} /* dspevd_ */ + +/* Subroutine */ int dspevx_(const char *jobz, const char *range, const char *uplo, integer *n, + double *ap, double *vl, double *vu, integer *il, integer * + iu, double *abstol, integer *m, double *w, double *z__, + integer *ldz, double *work, integer *iwork, integer *ifail, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, jj; + double eps, vll, vuu, tmp1; + integer indd, inde; + double anrm; + integer imax; + double rmin, rmax; + bool test; + integer itmp1, indee; + double sigma; + integer iinfo; + char order[1]; + bool wantz; + bool alleig, indeig; + integer iscale, indibl; + bool valeig; + double safmin; + double abstll, bignum; + integer indtau, indisp; + integer indiwo; + integer indwrk; + integer nsplit; + double smlnum; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric matrix A in packed storage. Eigenvalues/vectors */ +/* can be selected by specifying either a range of values or a range of */ +/* indices for the desired eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found; */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found; */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, AP is overwritten by values generated during the */ +/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */ +/* and first superdiagonal of the tridiagonal matrix T overwrite */ +/* the corresponding elements of A, and if UPLO = 'L', the */ +/* diagonal and first subdiagonal of T overwrite the */ +/* corresponding elements of A. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less than */ +/* or equal to zero, then EPS*|T| will be used in its place, */ +/* where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* by reducing AP to tridiagonal form. */ + +/* Eigenvalues will be computed most accurately when ABSTOL is */ +/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* If this routine returns with INFO>0, indicating that some */ +/* eigenvectors did not converge, try setting ABSTOL to */ +/* 2*DLAMCH('S'). */ + +/* See "Computing Small Singular Values of Bidiagonal Matrices */ +/* with Guaranteed High Relative Accuracy," by Demmel and */ +/* Kahan, LAPACK Working Note #3. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the selected eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ +/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix A */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* If an eigenvector fails to converge, then that column of Z */ +/* contains the latest approximation to the eigenvector, and the */ +/* index of the eigenvector is returned in IFAIL. */ +/* If JOBZ = 'N', then Z is not referenced. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) */ + +/* IWORK (workspace) INTEGER array, dimension (5*N) */ + +/* IFAIL (output) INTEGER array, dimension (N) */ +/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* indices of the eigenvectors that failed to converge. */ +/* If JOBZ = 'N', then IFAIL is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, then i eigenvectors failed to converge. */ +/* Their indices are stored in array IFAIL. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lsame_(uplo, "L") || lsame_(uplo, + "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -7; + } + } else if (indeig) { + if (*il < 1 || *il > std::max(1_integer,*n)) { + *info = -8; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -9; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -14; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPEVX", &i__1); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = ap[1]; + } else { + if (*vl < ap[1] && *vu >= ap[1]) { + *m = 1; + w[1] = ap[1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); + rmax = std::min(d__1,d__2); + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + abstll = *abstol; + if (valeig) { + vll = *vl; + vuu = *vu; + } else { + vll = 0.; + vuu = 0.; + } + anrm = dlansp_("M", uplo, n, &ap[1], &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + i__1 = *n * (*n + 1) / 2; + dscal_(&i__1, &sigma, &ap[1], &c__1); + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */ + + indtau = 1; + inde = indtau + *n; + indd = inde + *n; + indwrk = indd + *n; + dsptrd_(uplo, n, &ap[1], &work[indd], &work[inde], &work[indtau], &iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal */ +/* to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails */ +/* for some eigenvalue, then try DSTEBZ. */ + + test = false; + if (indeig) { + if (*il == 1 && *iu == *n) { + test = true; + } + } + if ((alleig || test) && *abstol <= 0.) { + dcopy_(n, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, & + work[indwrk], &iinfo); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L20; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwrk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + dopmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset], + ldz, &work[indwrk], info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L20: + if (iscale == 1) { + if (*info == 0) { + imax = *m; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + +/* If eigenvalues are not in order, then sort them, along with */ +/* eigenvectors. */ + + if (wantz) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp1 = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp1) { + i__ = jj; + tmp1 = w[jj]; + } +/* L30: */ + } + + if (i__ != 0) { + itmp1 = iwork[indibl + i__ - 1]; + w[i__] = w[j]; + iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + w[j] = tmp1; + iwork[indibl + j - 1] = itmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + if (*info != 0) { + itmp1 = ifail[i__]; + ifail[i__] = ifail[j]; + ifail[j] = itmp1; + } + } +/* L40: */ + } + } + + return 0; + +/* End of DSPEVX */ + +} /* dspevx_ */ + +/* Subroutine */ int dspgst_(integer *itype, const char *uplo, integer *n, + double *ap, double *bp, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b9 = -1.; + static double c_b11 = 1.; + + /* System generated locals */ + integer i__1, i__2; + double d__1; + + /* Local variables */ + integer j, k, j1, k1, jj, kk; + double ct, ajj; + integer j1j1; + double akk; + integer k1k1; + double bjj, bkk; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPGST reduces a real symmetric-definite generalized eigenproblem */ +/* to standard form, using packed storage. */ + +/* If ITYPE = 1, the problem is A*x = lambda*B*x, */ +/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */ + +/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ +/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */ + +/* B must have been previously factorized as U**T*U or L*L**T by DPPTRF. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */ +/* = 2 or 3: compute U*A*U**T or L**T*A*L. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored and B is factored as */ +/* U**T*U; */ +/* = 'L': Lower triangle of A is stored and B is factored as */ +/* L*L**T. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, if INFO = 0, the transformed matrix, stored in the */ +/* same format as A. */ + +/* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The triangular factor from the Cholesky factorization of B, */ +/* stored in the same format as A, as returned by DPPTRF. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --bp; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPGST", &i__1); + return 0; + } + + if (*itype == 1) { + if (upper) { + +/* Compute inv(U')*A*inv(U) */ + +/* J1 and JJ are the indices of A(1,j) and A(j,j) */ + + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + j1 = jj + 1; + jj += j; + +/* Compute the j-th column of the upper triangle of A */ + + bjj = bp[jj]; + dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], & + c__1); + i__2 = j - 1; + dspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, & + ap[j1], &c__1); + i__2 = j - 1; + d__1 = 1. / bjj; + dscal_(&i__2, &d__1, &ap[j1], &c__1); + i__2 = j - 1; + ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], & + c__1)) / bjj; +/* L10: */ + } + } else { + +/* Compute inv(L)*A*inv(L') */ + +/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ + + kk = 1; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + k1k1 = kk + *n - k + 1; + +/* Update the lower triangle of A(k:n,k:n) */ + + akk = ap[kk]; + bkk = bp[kk]; +/* Computing 2nd power */ + d__1 = bkk; + akk /= d__1 * d__1; + ap[kk] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &ap[kk + 1], &c__1); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) + ; + i__2 = *n - k; + dspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1] +, &c__1, &ap[k1k1]); + i__2 = *n - k; + daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) + ; + i__2 = *n - k; + dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], + &ap[kk + 1], &c__1); + } + kk = k1k1; +/* L20: */ + } + } + } else { + if (upper) { + +/* Compute U*A*U' */ + +/* K1 and KK are the indices of A(1,k) and A(k,k) */ + + kk = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + k1 = kk + 1; + kk += k; + +/* Update the upper triangle of A(1:k,1:k) */ + + akk = ap[kk]; + bkk = bp[kk]; + i__2 = k - 1; + dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ + k1], &c__1); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); + i__2 = k - 1; + dspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, & + ap[1]); + i__2 = k - 1; + daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); + i__2 = k - 1; + dscal_(&i__2, &bkk, &ap[k1], &c__1); +/* Computing 2nd power */ + d__1 = bkk; + ap[kk] = akk * (d__1 * d__1); +/* L30: */ + } + } else { + +/* Compute L'*A*L */ + +/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ + + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + j1j1 = jj + *n - j + 1; + +/* Compute the j-th column of the lower triangle of A */ + + ajj = ap[jj]; + bjj = bp[jj]; + i__2 = *n - j; + ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj + + 1], &c__1); + i__2 = *n - j; + dscal_(&i__2, &bjj, &ap[jj + 1], &c__1); + i__2 = *n - j; + dspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, & + c_b11, &ap[jj + 1], &c__1); + i__2 = *n - j + 1; + dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj], + &c__1); + jj = j1j1; +/* L40: */ + } + } + } + return 0; + +/* End of DSPGST */ + +} /* dspgst_ */ + +/* Subroutine */ int dspgv_(integer *itype, const char *jobz, const char *uplo, integer * + n, double *ap, double *bp, double *w, double *z__, + integer *ldz, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1; + + /* Local variables */ + integer j, neig; + char trans[1]; + bool upper; + bool wantz; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPGV computes all the eigenvalues and, optionally, the eigenvectors */ +/* of a real generalized symmetric-definite eigenproblem, of the form */ +/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */ +/* Here A and B are assumed to be symmetric, stored in packed format, */ +/* and B is also positive definite. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* Specifies the problem type to be solved: */ +/* = 1: A*x = (lambda)*B*x */ +/* = 2: A*B*x = (lambda)*x */ +/* = 3: B*A*x = (lambda)*x */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangles of A and B are stored; */ +/* = 'L': Lower triangles of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension */ +/* (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, the contents of AP are destroyed. */ + +/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* B, packed columnwise in a linear array. The j-th column of B */ +/* is stored in the array BP as follows: */ +/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ + +/* On exit, the triangular factor U or L from the Cholesky */ +/* factorization B = U**T*U or B = L*L**T, in the same storage */ +/* format as B. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* eigenvectors. The eigenvectors are normalized as follows: */ +/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* 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 */ +/* > 0: DPPTRF or DSPEV returned an error code: */ +/* <= N: if INFO = i, DSPEV failed to converge; */ +/* i off-diagonal elements of an intermediate */ +/* tridiagonal form did not converge to zero. */ +/* > N: if INFO = n + i, for 1 <= i <= n, then the leading */ +/* minor of order i of B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --bp; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPGV ", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dspgst_(itype, uplo, n, &ap[1], &bp[1], info); + dspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info); + + if (wantz) { + +/* Backtransform eigenvectors to the original problem. */ + + neig = *n; + if (*info > 0) { + neig = *info - 1; + } + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L10: */ + } + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U'*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + return 0; + +/* End of DSPGV */ + +} /* dspgv_ */ + +/* Subroutine */ int dspgvd_(integer *itype, const char *jobz, const char *uplo, integer * + n, double *ap, double *bp, double *w, double *z__, + integer *ldz, double *work, integer *lwork, integer *iwork, + integer *liwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1; + double d__1, d__2; + + /* Local variables */ + integer j, neig; + integer lwmin; + char trans[1]; + bool upper; + bool wantz; + integer liwmin; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors */ +/* of a real generalized symmetric-definite eigenproblem, of the form */ +/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ +/* B are assumed to be symmetric, stored in packed format, and B is also */ +/* positive definite. */ +/* If eigenvectors are desired, it uses a divide and conquer algorithm. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* Specifies the problem type to be solved: */ +/* = 1: A*x = (lambda)*B*x */ +/* = 2: A*B*x = (lambda)*x */ +/* = 3: B*A*x = (lambda)*x */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangles of A and B are stored; */ +/* = 'L': Lower triangles of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, the contents of AP are destroyed. */ + +/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* B, packed columnwise in a linear array. The j-th column of B */ +/* is stored in the array BP as follows: */ +/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ + +/* On exit, the triangular factor U or L from the Cholesky */ +/* factorization B = U**T*U or B = L*L**T, in the same storage */ +/* format as B. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* eigenvectors. The eigenvectors are normalized as follows: */ +/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* If N <= 1, LWORK >= 1. */ +/* If JOBZ = 'N' and N > 1, LWORK >= 2*N. */ +/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the required sizes of the WORK and IWORK */ +/* arrays, returns these values as the first entries of the WORK */ +/* and IWORK arrays, and no error message related to LWORK or */ +/* LIWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */ +/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the required sizes of the WORK and */ +/* IWORK arrays, returns these values as the first entries of */ +/* the WORK and IWORK arrays, and no error message related to */ +/* LWORK or LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: DPPTRF or DSPEVD returned an error code: */ +/* <= N: if INFO = i, DSPEVD failed to converge; */ +/* i off-diagonal elements of an intermediate */ +/* tridiagonal form did not converge to zero; */ +/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ +/* minor of order i of B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --bp; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + + if (*info == 0) { + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else { + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = *n << 1; + } + } + work[1] = (double) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPGVD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of BP. */ + + dpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dspgst_(itype, uplo, n, &ap[1], &bp[1], info); + dspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], + lwork, &iwork[1], liwork, info); +/* Computing MAX */ + d__1 = (double) lwmin; + lwmin = (integer) std::max(d__1,work[1]); +/* Computing MAX */ + d__1 = (double) liwmin, d__2 = (double) iwork[1]; + liwmin = (integer) std::max(d__1,d__2); + + if (wantz) { + +/* Backtransform eigenvectors to the original problem. */ + + neig = *n; + if (*info > 0) { + neig = *info - 1; + } + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L10: */ + } + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U'*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + + work[1] = (double) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSPGVD */ + +} /* dspgvd_ */ + +/* Subroutine */ int dspgvx_(integer *itype, const char *jobz, const char *range, const char * + uplo, integer *n, double *ap, double *bp, double *vl, + double *vu, integer *il, integer *iu, double *abstol, integer + *m, double *w, double *z__, integer *ldz, double *work, + integer *iwork, integer *ifail, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1; + + /* Local variables */ + integer j; + char trans[1]; + bool upper; + bool wantz, alleig, indeig, valeig; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPGVX computes selected eigenvalues, and optionally, eigenvectors */ +/* of a real generalized symmetric-definite eigenproblem, of the form */ +/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */ +/* and B are assumed to be symmetric, stored in packed storage, and B */ +/* is also positive definite. Eigenvalues and eigenvectors can be */ +/* selected by specifying either a range of values or a range of indices */ +/* for the desired eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* Specifies the problem type to be solved: */ +/* = 1: A*x = (lambda)*B*x */ +/* = 2: A*B*x = (lambda)*x */ +/* = 3: B*A*x = (lambda)*x */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A and B are stored; */ +/* = 'L': Lower triangle of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix pencil (A,B). N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, the contents of AP are destroyed. */ + +/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* B, packed columnwise in a linear array. The j-th column of B */ +/* is stored in the array BP as follows: */ +/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ + +/* On exit, the triangular factor U or L from the Cholesky */ +/* factorization B = U**T*U or B = L*L**T, in the same storage */ +/* format as B. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less than */ +/* or equal to zero, then EPS*|T| will be used in its place, */ +/* where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* by reducing A to tridiagonal form. */ + +/* Eigenvalues will be computed most accurately when ABSTOL is */ +/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* If this routine returns with INFO>0, indicating that some */ +/* eigenvectors did not converge, try setting ABSTOL to */ +/* 2*DLAMCH('S'). */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* On normal exit, the first M elements contain the selected */ +/* eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ +/* If JOBZ = 'N', then Z is not referenced. */ +/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix A */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* The eigenvectors are normalized as follows: */ +/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ + +/* If an eigenvector fails to converge, then that column of Z */ +/* contains the latest approximation to the eigenvector, and the */ +/* index of the eigenvector is returned in IFAIL. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) */ + +/* IWORK (workspace) INTEGER array, dimension (5*N) */ + +/* IFAIL (output) INTEGER array, dimension (N) */ +/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* indices of the eigenvectors that failed to converge. */ +/* If JOBZ = 'N', then IFAIL is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: DPPTRF or DSPEVX returned an error code: */ +/* <= N: if INFO = i, DSPEVX failed to converge; */ +/* i eigenvectors failed to converge. Their indices */ +/* are stored in array IFAIL. */ +/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ +/* minor of order i of B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --bp; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + upper = lsame_(uplo, "U"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (alleig || valeig || indeig)) { + *info = -3; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -9; + } + } else if (indeig) { + if (*il < 1) { + *info = -10; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -11; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -16; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPGVX", &i__1); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dspgst_(itype, uplo, n, &ap[1], &bp[1], info); + dspevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], & + z__[z_offset], ldz, &work[1], &iwork[1], &ifail[1], info); + + if (wantz) { + +/* Backtransform eigenvectors to the original problem. */ + + if (*info > 0) { + *m = *info - 1; + } + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L10: */ + } + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U'*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + + return 0; + +/* End of DSPGVX */ + +} /* dspgvx_ */ + +/* Subroutine */ int dsprfs_(const char *uplo, integer *n, integer *nrhs, + double *ap, double *afp, integer *ipiv, double *b, + integer *ldb, double *x, integer *ldx, double *ferr, + double *berr, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b12 = -1.; + static double c_b14 = 1.; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s; + integer ik, kk; + double xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + integer count; + bool upper; + double safmin; + double lstres; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPRFS improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric indefinite */ +/* and packed, and provides error bounds and backward error estimates */ +/* for the solution. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangle of the symmetric matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ + +/* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The factored form of the matrix A. AFP contains the block */ +/* diagonal matrix D and the multipliers used to obtain the */ +/* factor U or L from the factorization A = U*D*U**T or */ +/* A = L*D*L**T as computed by DSPTRF, stored as a packed */ +/* triangular matrix. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSPTRF. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DSPTRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --afp; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, & + work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + kk = 1; + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + ik = kk; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; + s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * + x_dim1], abs(d__2)); + ++ik; +/* L40: */ + } + work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk + + s; + kk += k; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + work[k] += (d__1 = ap[kk], abs(d__1)) * xk; + ik = kk + 1; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[ik], abs(d__1)) * xk; + s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j * + x_dim1], abs(d__2)); + ++ik; +/* L60: */ + } + work[k] += s; + kk += *n - k + 1; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info); + daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A'). */ + + dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, + info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L120: */ + } + dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, + info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DSPRFS */ + +} /* dsprfs_ */ + +/* Subroutine */ int dspsv_(const char *uplo, integer *n, integer *nrhs, double + *ap, integer *ipiv, double *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPSV computes the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N symmetric matrix stored in packed format and X */ +/* and B are N-by-NRHS matrices. */ + +/* The diagonal pivoting method is used to factor A as */ +/* A = U * D * U**T, if UPLO = 'U', or */ +/* A = L * D * L**T, if UPLO = 'L', */ +/* where U (or L) is a product of permutation and unit upper (lower) */ +/* triangular matrices, D is symmetric and block diagonal with 1-by-1 */ +/* and 2-by-2 diagonal blocks. The factored form of A is then used to */ +/* solve the system of equations A * X = B. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* See below for further details. */ + +/* On exit, the block diagonal matrix D and the multipliers used */ +/* to obtain the factor U or L from the factorization */ +/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */ +/* a packed triangular matrix in the same storage format as A. */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D, as */ +/* determined by DSPTRF. If IPIV(k) > 0, then rows and columns */ +/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */ +/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */ +/* then rows and columns k-1 and -IPIV(k) were interchanged and */ +/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */ +/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */ +/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */ +/* diagonal block. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* has been completed, but the block diagonal matrix D is */ +/* exactly singular, so the solution could not be */ +/* computed. */ + +/* Further Details */ +/* =============== */ + +/* The packed storage scheme is illustrated by the following example */ +/* when N = 4, UPLO = 'U': */ + +/* Two-dimensional storage of the symmetric matrix A: */ + +/* a11 a12 a13 a14 */ +/* a22 a23 a24 */ +/* a33 a34 (aij = aji) */ +/* a44 */ + +/* Packed storage of the upper triangle of A: */ + +/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ + +/* ===================================================================== */ + +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPSV ", &i__1); + return 0; + } + +/* Compute the factorization A = U*D*U' or A = L*D*L'. */ + + dsptrf_(uplo, n, &ap[1], &ipiv[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dsptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info); + + } + return 0; + +/* End of DSPSV */ + +} /* dspsv_ */ + +/* Subroutine */ int dspsvx_(const char *fact, const char *uplo, integer *n, integer * + nrhs, double *ap, double *afp, integer *ipiv, double *b, + integer *ldb, double *x, integer *ldx, double *rcond, + double *ferr, double *berr, double *work, integer *iwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1; + + /* Local variables */ + double anorm; + bool nofact; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */ +/* A = L*D*L**T to compute the solution to a real system of linear */ +/* equations A * X = B, where A is an N-by-N symmetric matrix stored */ +/* in packed format and X and B are N-by-NRHS matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */ +/* A = U * D * U**T, if UPLO = 'U', or */ +/* A = L * D * L**T, if UPLO = 'L', */ +/* where U (or L) is a product of permutation and unit upper (lower) */ +/* triangular matrices and D is symmetric and block diagonal with */ +/* 1-by-1 and 2-by-2 diagonal blocks. */ + +/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */ +/* returns with INFO = i. Otherwise, the factored form of A is used */ +/* to estimate the condition number of the matrix A. If the */ +/* reciprocal of the condition number is less than machine precision, */ +/* INFO = N+1 is returned as a warning, but the routine still goes on */ +/* to solve for X and compute error bounds as described below. */ + +/* 3. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 4. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of A has been */ +/* supplied on entry. */ +/* = 'F': On entry, AFP and IPIV contain the factored form of */ +/* A. AP, AFP and IPIV will not be modified. */ +/* = 'N': The matrix A will be copied to AFP and factored. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangle of the symmetric matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* See below for further details. */ + +/* AFP (input or output) DOUBLE PRECISION array, dimension */ +/* (N*(N+1)/2) */ +/* If FACT = 'F', then AFP is an input argument and on entry */ +/* contains the block diagonal matrix D and the multipliers used */ +/* to obtain the factor U or L from the factorization */ +/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */ +/* a packed triangular matrix in the same storage format as A. */ + +/* If FACT = 'N', then AFP is an output argument and on exit */ +/* contains the block diagonal matrix D and the multipliers used */ +/* to obtain the factor U or L from the factorization */ +/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */ +/* a packed triangular matrix in the same storage format as A. */ + +/* IPIV (input or output) INTEGER array, dimension (N) */ +/* If FACT = 'F', then IPIV is an input argument and on entry */ +/* contains details of the interchanges and the block structure */ +/* of D, as determined by DSPTRF. */ +/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ + +/* If FACT = 'N', then IPIV is an output argument and on exit */ +/* contains details of the interchanges and the block structure */ +/* of D, as determined by DSPTRF. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The N-by-NRHS right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The estimate of the reciprocal condition number of the matrix */ +/* A. If RCOND is less than the machine precision (in */ +/* particular, if RCOND = 0), the matrix is singular to working */ +/* precision. This condition is indicated by a return code of */ +/* INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= N: D(i,i) is exactly zero. The factorization */ +/* has been completed but the factor D is exactly */ +/* singular, so the solution and error bounds could */ +/* not be computed. RCOND = 0 is returned. */ +/* = N+1: D is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* Further Details */ +/* =============== */ + +/* The packed storage scheme is illustrated by the following example */ +/* when N = 4, UPLO = 'U': */ + +/* Two-dimensional storage of the symmetric matrix A: */ + +/* a11 a12 a13 a14 */ +/* a22 a23 a24 */ +/* a33 a34 (aij = aji) */ +/* a44 */ + +/* Packed storage of the upper triangle of A: */ + +/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --afp; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPSVX", &i__1); + return 0; + } + + if (nofact) { + +/* Compute the factorization A = U*D*U' or A = L*D*L'. */ + + i__1 = *n * (*n + 1) / 2; + dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); + dsptrf_(uplo, n, &afp[1], &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlansp_("I", uplo, n, &ap[1], &work[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], &iwork[1], + info); + +/* Compute the solution vectors X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dsptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + dsprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[ + x_offset], ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of DSPSVX */ + +} /* dspsvx_ */ + +/* Subroutine */ int dsptrd_(const char *uplo, integer *n, double *ap, + double *d__, double *e, double *tau, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b8 = 0.; + static double c_b14 = -1.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, i1, ii, i1i1; + double taui; + double alpha; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPTRD reduces a real symmetric matrix A stored in packed form to */ +/* symmetric tridiagonal form T by an orthogonal similarity */ +/* transformation: Q**T * A * Q = T. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ +/* of A are overwritten by the corresponding elements of the */ +/* tridiagonal matrix T, and the elements above the first */ +/* superdiagonal, with the array TAU, represent the orthogonal */ +/* matrix Q as a product of elementary reflectors; if UPLO */ +/* = 'L', the diagonal and first subdiagonal of A are over- */ +/* written by the corresponding elements of the tridiagonal */ +/* matrix T, and the elements below the first subdiagonal, with */ +/* the array TAU, represent the orthogonal matrix Q as a product */ +/* of elementary reflectors. See Further Details. */ + +/* D (output) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of the tridiagonal matrix T: */ +/* D(i) = A(i,i). */ + +/* E (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The off-diagonal elements of the tridiagonal matrix T: */ +/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ + +/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The scalar factors of the elementary reflectors (see Further */ +/* Details). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Further Details */ +/* =============== */ + +/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ +/* reflectors */ + +/* Q = H(n-1) . . . H(2) H(1). */ + +/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */ +/* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */ + +/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ +/* reflectors */ + +/* Q = H(1) H(2) . . . H(n-1). */ + +/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */ +/* overwriting A(i+2:n,i), and tau is stored in TAU(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + --tau; + --e; + --d__; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPTRD", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + if (upper) { + +/* Reduce the upper triangle of A. */ +/* I1 is the index in AP of A(1,I+1). */ + + i1 = *n * (*n - 1) / 2 + 1; + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) = I - tau * v * v' */ +/* to annihilate A(1:i-1,i+1) */ + + dlarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui); + e[i__] = ap[i1 + i__ - 1]; + + if (taui != 0.) { + +/* Apply H(i) from both sides to A(1:i,1:i) */ + + ap[i1 + i__ - 1] = 1.; + +/* Compute y := tau * A * v storing y in TAU(1:i) */ + + dspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b8, &tau[ + 1], &c__1); + +/* Compute w := y - 1/2 * tau * (y'*v) * v */ + + alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &ap[i1], & + c__1); + daxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w' - w * v' */ + + dspr2_(uplo, &i__, &c_b14, &ap[i1], &c__1, &tau[1], &c__1, & + ap[1]); + + ap[i1 + i__ - 1] = e[i__]; + } + d__[i__ + 1] = ap[i1 + i__]; + tau[i__] = taui; + i1 -= i__; +/* L10: */ + } + d__[1] = ap[1]; + } else { + +/* Reduce the lower triangle of A. II is the index in AP of */ +/* A(i,i) and I1I1 is the index of A(i+1,i+1). */ + + ii = 1; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i1i1 = ii + *n - i__ + 1; + +/* Generate elementary reflector H(i) = I - tau * v * v' */ +/* to annihilate A(i+2:n,i) */ + + i__2 = *n - i__; + dlarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui); + e[i__] = ap[ii + 1]; + + if (taui != 0.) { + +/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ + + ap[ii + 1] = 1.; + +/* Compute y := tau * A * v storing y in TAU(i:n-1) */ + + i__2 = *n - i__; + dspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & + c_b8, &tau[i__], &c__1); + +/* Compute w := y - 1/2 * tau * (y'*v) * v */ + + i__2 = *n - i__; + alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &ap[ii + + 1], &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w' - w * v' */ + + i__2 = *n - i__; + dspr2_(uplo, &i__2, &c_b14, &ap[ii + 1], &c__1, &tau[i__], & + c__1, &ap[i1i1]); + + ap[ii + 1] = e[i__]; + } + d__[i__] = ap[ii]; + tau[i__] = taui; + ii = i1i1; +/* L20: */ + } + d__[*n] = ap[ii]; + } + + return 0; + +/* End of DSPTRD */ + +} /* dsptrd_ */ + +/* Subroutine */ int dsptrf_(const char *uplo, integer *n, double *ap, integer * + ipiv, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1, i__2; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double t, r1, d11, d12, d21, d22; + integer kc, kk, kp; + double wk; + integer kx, knc, kpc, npp; + double wkm1, wkp1; + integer imax, jmax; + double alpha; + integer kstep; + bool upper; + double absakk; + double colmax, rowmax; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPTRF computes the factorization of a real symmetric matrix A stored */ +/* in packed format using the Bunch-Kaufman diagonal pivoting method: */ + +/* A = U*D*U**T or A = L*D*L**T */ + +/* where U (or L) is a product of permutation and unit upper (lower) */ +/* triangular matrices, and D is symmetric and block diagonal with */ +/* 1-by-1 and 2-by-2 diagonal blocks. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangle of the symmetric matrix */ +/* A, packed columnwise in a linear array. The j-th column of A */ +/* is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* On exit, the block diagonal matrix D and the multipliers used */ +/* to obtain the factor U or L, stored as a packed triangular */ +/* matrix overwriting A (see below for further details). */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D. */ +/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* has been completed, but the block diagonal matrix D is */ +/* exactly singular, and division by zero will occur if it */ +/* is used to solve a system of equations. */ + +/* Further Details */ +/* =============== */ + +/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */ +/* Company */ + +/* If UPLO = 'U', then A = U*D*U', where */ +/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ + +/* ( I v 0 ) k-s */ +/* U(k) = ( 0 I 0 ) s */ +/* ( 0 0 I ) n-k */ +/* k-s s n-k */ + +/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */ + +/* If UPLO = 'L', then A = L*D*L', where */ +/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ + +/* ( I 0 0 ) k-1 */ +/* L(k) = ( 0 I 0 ) s */ +/* ( 0 v I ) n-k-s+1 */ +/* k-1 s n-k-s+1 */ + +/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPTRF", &i__1); + return 0; + } + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + + if (upper) { + +/* Factorize A as U*D*U' using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2 */ + + k = *n; + kc = (*n - 1) * *n / 2 + 1; +L10: + knc = kc; + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L110; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = ap[kc + k - 1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k > 1) { + i__1 = k - 1; + imax = idamax_(&i__1, &ap[kc], &c__1); + colmax = (d__1 = ap[kc + imax - 1], abs(d__1)); + } else { + colmax = 0.; + } + + if (std::max(absakk,colmax) == 0.) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + rowmax = 0.; + jmax = imax; + kx = imax * (imax + 1) / 2 + imax; + i__1 = k; + for (j = imax + 1; j <= i__1; ++j) { + if ((d__1 = ap[kx], abs(d__1)) > rowmax) { + rowmax = (d__1 = ap[kx], abs(d__1)); + jmax = j; + } + kx += j; +/* L20: */ + } + kpc = (imax - 1) * imax / 2 + 1; + if (imax > 1) { + i__1 = imax - 1; + jmax = idamax_(&i__1, &ap[kpc], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], abs( + d__1)); + rowmax = std::max(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = ap[kpc + imax - 1], abs(d__1)) >= alpha * + rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + + kk = k - kstep + 1; + if (kstep == 2) { + knc = knc - k + 1; + } + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + i__1 = kp - 1; + dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1); + kx = kpc + kp - 1; + i__1 = kk - 1; + for (j = kp + 1; j <= i__1; ++j) { + kx = kx + j - 1; + t = ap[knc + j - 1]; + ap[knc + j - 1] = ap[kx]; + ap[kx] = t; +/* L30: */ + } + t = ap[knc + kk - 1]; + ap[knc + kk - 1] = ap[kpc + kp - 1]; + ap[kpc + kp - 1] = t; + if (kstep == 2) { + t = ap[kc + k - 2]; + ap[kc + k - 2] = ap[kc + kp - 1]; + ap[kc + kp - 1] = t; + } + } + +/* Update the leading submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ + +/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */ + + r1 = 1. / ap[kc + k - 1]; + i__1 = k - 1; + d__1 = -r1; + dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]); + +/* Store U(k) in column k */ + + i__1 = k - 1; + dscal_(&i__1, &r1, &ap[kc], &c__1); + } else { + +/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ + +/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */ +/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */ + + if (k > 2) { + + d12 = ap[k - 1 + (k - 1) * k / 2]; + d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12; + d11 = ap[k + (k - 1) * k / 2] / d12; + t = 1. / (d11 * d22 - 1.); + d12 = t / d12; + + for (j = k - 2; j >= 1; --j) { + wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] - + ap[j + (k - 1) * k / 2]); + wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k + - 2) * (k - 1) / 2]); + for (i__ = j; i__ >= 1; --i__) { + ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j / + 2] - ap[i__ + (k - 1) * k / 2] * wk - ap[ + i__ + (k - 2) * (k - 1) / 2] * wkm1; +/* L40: */ + } + ap[j + (k - 1) * k / 2] = wk; + ap[j + (k - 2) * (k - 1) / 2] = wkm1; +/* L50: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + kc = knc - k; + goto L10; + + } else { + +/* Factorize A as L*D*L' using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2 */ + + k = 1; + kc = 1; + npp = *n * (*n + 1) / 2; +L60: + knc = kc; + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L110; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = ap[kc], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k < *n) { + i__1 = *n - k; + imax = k + idamax_(&i__1, &ap[kc + 1], &c__1); + colmax = (d__1 = ap[kc + imax - k], abs(d__1)); + } else { + colmax = 0.; + } + + if (std::max(absakk,colmax) == 0.) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + rowmax = 0.; + kx = kc + imax - k; + i__1 = imax - 1; + for (j = k; j <= i__1; ++j) { + if ((d__1 = ap[kx], abs(d__1)) > rowmax) { + rowmax = (d__1 = ap[kx], abs(d__1)); + jmax = j; + } + kx = kx + *n - j; +/* L70: */ + } + kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1; + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], abs( + d__1)); + rowmax = std::max(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = ap[kpc], abs(d__1)) >= alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + + kk = k + kstep - 1; + if (kstep == 2) { + knc = knc + *n - k + 1; + } + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the trailing */ +/* submatrix A(k:n,k:n) */ + + if (kp < *n) { + i__1 = *n - kp; + dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1], + &c__1); + } + kx = knc + kp - kk; + i__1 = kp - 1; + for (j = kk + 1; j <= i__1; ++j) { + kx = kx + *n - j + 1; + t = ap[knc + j - kk]; + ap[knc + j - kk] = ap[kx]; + ap[kx] = t; +/* L80: */ + } + t = ap[knc]; + ap[knc] = ap[kpc]; + ap[kpc] = t; + if (kstep == 2) { + t = ap[kc + 1]; + ap[kc + 1] = ap[kc + kp - k]; + ap[kc + kp - k] = t; + } + } + +/* Update the trailing submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + + if (k < *n) { + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ + +/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */ + + r1 = 1. / ap[kc]; + i__1 = *n - k; + d__1 = -r1; + dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n + - k + 1]); + +/* Store L(k) in column K */ + + i__1 = *n - k; + dscal_(&i__1, &r1, &ap[kc + 1], &c__1); + } + } else { + +/* 2-by-2 pivot block D(k): columns K and K+1 now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ + +/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */ +/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */ + + d21 = ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]; + d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21; + d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21; + t = 1. / (d11 * d22 - 1.); + d21 = t / d21; + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) / + 2] - ap[j + k * ((*n << 1) - k - 1) / 2]); + wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) / + 2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]); + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[i__ + (j - 1) * ((*n << 1) - j) / 2] = ap[i__ + + (j - 1) * ((*n << 1) - j) / 2] - ap[i__ + + (k - 1) * ((*n << 1) - k) / 2] * wk - + ap[i__ + k * ((*n << 1) - k - 1) / 2] * + wkp1; +/* L90: */ + } + + ap[j + (k - 1) * ((*n << 1) - k) / 2] = wk; + ap[j + k * ((*n << 1) - k - 1) / 2] = wkp1; + +/* L100: */ + } + } + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + kc = knc + *n - k + 2; + goto L60; + + } + +L110: + return 0; + +/* End of DSPTRF */ + +} /* dsptrf_ */ + +/* Subroutine */ int dsptri_(const char *uplo, integer *n, double *ap, integer * + ipiv, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b11 = -1.; + static double c_b13 = 0.; + + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + double d__; + integer j, k; + double t, ak; + integer kc, kp, kx, kpc, npp; + double akp1; + double temp, akkp1; + integer kstep; + bool upper; + integer kcnext; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPTRI computes the inverse of a real symmetric indefinite matrix */ +/* A in packed storage using the factorization A = U*D*U**T or */ +/* A = L*D*L**T computed by DSPTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the details of the factorization are stored */ +/* as an upper or lower triangular matrix. */ +/* = 'U': Upper triangular, form is A = U*D*U**T; */ +/* = 'L': Lower triangular, form is A = L*D*L**T. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the block diagonal matrix D and the multipliers */ +/* used to obtain the factor U or L as computed by DSPTRF, */ +/* stored as a packed triangular matrix. */ + +/* On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* matrix, stored as a packed triangular matrix. The j-th column */ +/* of inv(A) is stored in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', */ +/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSPTRF. */ + +/* 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 */ +/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* inverse could not be computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --work; + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPTRI", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + kp = *n * (*n + 1) / 2; + for (*info = *n; *info >= 1; --(*info)) { + if (ipiv[*info] > 0 && ap[kp] == 0.) { + return 0; + } + kp -= *info; +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + kp = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ipiv[*info] > 0 && ap[kp] == 0.) { + return 0; + } + kp = kp + *n - *info + 1; +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U'. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L30: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + kcnext = kc + k; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + ap[kc + k - 1] = 1. / ap[kc + k - 1]; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); + i__1 = k - 1; + dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & + ap[kc], &c__1); + i__1 = k - 1; + ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], & + c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = ap[kcnext + k - 1], abs(d__1)); + ak = ap[kc + k - 1] / t; + akp1 = ap[kcnext + k] / t; + akkp1 = ap[kcnext + k - 1] / t; + d__ = t * (ak * akp1 - 1.); + ap[kc + k - 1] = akp1 / d__; + ap[kcnext + k] = ak / d__; + ap[kcnext + k - 1] = -akkp1 / d__; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); + i__1 = k - 1; + dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & + ap[kc], &c__1); + i__1 = k - 1; + ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], & + c__1); + i__1 = k - 1; + ap[kcnext + k - 1] -= ddot_(&i__1, &ap[kc], &c__1, &ap[kcnext] +, &c__1); + i__1 = k - 1; + dcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1); + i__1 = k - 1; + dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, & + ap[kcnext], &c__1); + i__1 = k - 1; + ap[kcnext + k] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext], & + c__1); + } + kstep = 2; + kcnext = kcnext + k + 1; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the leading */ +/* submatrix A(1:k+1,1:k+1) */ + + kpc = (kp - 1) * kp / 2 + 1; + i__1 = kp - 1; + dswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1); + kx = kpc + kp - 1; + i__1 = k - 1; + for (j = kp + 1; j <= i__1; ++j) { + kx = kx + j - 1; + temp = ap[kc + j - 1]; + ap[kc + j - 1] = ap[kx]; + ap[kx] = temp; +/* L40: */ + } + temp = ap[kc + k - 1]; + ap[kc + k - 1] = ap[kpc + kp - 1]; + ap[kpc + kp - 1] = temp; + if (kstep == 2) { + temp = ap[kc + k + k - 1]; + ap[kc + k + k - 1] = ap[kc + k + kp - 1]; + ap[kc + k + kp - 1] = temp; + } + } + + k += kstep; + kc = kcnext; + goto L30; +L50: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L'. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + npp = *n * (*n + 1) / 2; + k = *n; + kc = npp; +L60: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L80; + } + + kcnext = kc - (*n - k + 2); + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + ap[kc] = 1. / ap[kc]; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dspmv_(uplo, &i__1, &c_b11, &ap[kc + *n - k + 1], &work[1], & + c__1, &c_b13, &ap[kc + 1], &c__1); + i__1 = *n - k; + ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = ap[kcnext + 1], abs(d__1)); + ak = ap[kcnext] / t; + akp1 = ap[kc] / t; + akkp1 = ap[kcnext + 1] / t; + d__ = t * (ak * akp1 - 1.); + ap[kcnext] = akp1 / d__; + ap[kc] = ak / d__; + ap[kcnext + 1] = -akkp1 / d__; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1], + &c__1, &c_b13, &ap[kc + 1], &c__1); + i__1 = *n - k; + ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1); + i__1 = *n - k; + ap[kcnext + 1] -= ddot_(&i__1, &ap[kc + 1], &c__1, &ap[kcnext + + 2], &c__1); + i__1 = *n - k; + dcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1); + i__1 = *n - k; + dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1], + &c__1, &c_b13, &ap[kcnext + 2], &c__1); + i__1 = *n - k; + ap[kcnext] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext + 2], & + c__1); + } + kstep = 2; + kcnext -= *n - k + 3; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the trailing */ +/* submatrix A(k-1:n,k-1:n) */ + + kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1; + if (kp < *n) { + i__1 = *n - kp; + dswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], & + c__1); + } + kx = kc + kp - k; + i__1 = kp - 1; + for (j = k + 1; j <= i__1; ++j) { + kx = kx + *n - j + 1; + temp = ap[kc + j - k]; + ap[kc + j - k] = ap[kx]; + ap[kx] = temp; +/* L70: */ + } + temp = ap[kc]; + ap[kc] = ap[kpc]; + ap[kpc] = temp; + if (kstep == 2) { + temp = ap[kc - *n + k - 1]; + ap[kc - *n + k - 1] = ap[kc - *n + kp - 1]; + ap[kc - *n + kp - 1] = temp; + } + } + + k -= kstep; + kc = kcnext; + goto L60; +L80: + ; + } + + return 0; + +/* End of DSPTRI */ + +} /* dsptri_ */ + +/* Subroutine */ int dsptrs_(const char *uplo, integer *n, integer *nrhs, + double *ap, integer *ipiv, double *b, integer *ldb, integer * + info) +{ + /* Table of constant values */ + static double c_b7 = -1.; + static integer c__1 = 1; + static double c_b19 = 1.; + + /* System generated locals */ + integer b_dim1, b_offset, i__1; + double d__1; + + /* Local variables */ + integer j, k; + double ak, bk; + integer kc, kp; + double akm1, bkm1; + double akm1k; + double denom; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSPTRS solves a system of linear equations A*X = B with a real */ +/* symmetric matrix A stored in packed format using the factorization */ +/* A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the details of the factorization are stored */ +/* as an upper or lower triangular matrix. */ +/* = 'U': Upper triangular, form is A = U*D*U**T; */ +/* = 'L': Lower triangular, form is A = L*D*L**T. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The block diagonal matrix D and the multipliers used to */ +/* obtain the factor U or L as computed by DSPTRF, stored as a */ +/* packed triangular matrix. */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSPTRF. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --ap; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSPTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U*D*U'. */ + +/* First solve U*D*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; + kc = *n * (*n + 1) / 2 + 1; +L10: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L30; + } + + kc -= k; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[ + b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / ap[kc + k - 1]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K-1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k - 1) { + dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in columns K-1 and K of A. */ + + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[ + b_dim1 + 1], ldb); + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &ap[kc - (k - 1)], &c__1, &b[k - 1 + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + akm1k = ap[kc + k - 2]; + akm1 = ap[kc - 1] / akm1k; + ak = ap[kc + k - 1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k - 1 + j * b_dim1] / akm1k; + bk = b[k + j * b_dim1] / akm1k; + b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L20: */ + } + kc = kc - k + 1; + k += -2; + } + + goto L10; +L30: + +/* Next solve U'*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L40: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(U'(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc] +, &c__1, &c_b19, &b[k + b_dim1], ldb); + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc += k; + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc] +, &c__1, &c_b19, &b[k + b_dim1], ldb); + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc + + k], &c__1, &c_b19, &b[k + 1 + b_dim1], ldb); + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc = kc + (k << 1) + 1; + k += 2; + } + + goto L40; +L50: + + ; + } else { + +/* Solve A*X = B, where A = L*D*L'. */ + +/* First solve L*D*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L60: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L80; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dger_(&i__1, nrhs, &c_b7, &ap[kc + 1], &c__1, &b[k + b_dim1], + ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / ap[kc]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + kc = kc + *n - k + 1; + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K+1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k + 1) { + dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k < *n - 1) { + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &ap[kc + 2], &c__1, &b[k + b_dim1], + ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &ap[kc + *n - k + 2], &c__1, &b[k + + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + akm1k = ap[kc + 1]; + akm1 = ap[kc] / akm1k; + ak = ap[kc + *n - k + 1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k + j * b_dim1] / akm1k; + bk = b[k + 1 + j * b_dim1] / akm1k; + b[k + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L70: */ + } + kc = kc + (*n - k << 1) + 1; + k += 2; + } + + goto L60; +L80: + +/* Next solve L'*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; + kc = *n * (*n + 1) / 2 + 1; +L90: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L100; + } + + kc -= *n - k + 1; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(L'(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &ap[kc - (*n - k)], &c__1, &c_b19, &b[k - 1 + + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc -= *n - k + 2; + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of DSPTRS */ + +} /* dsptrs_ */ + +/* Subroutine */ int dstebz_(const char *range, const char *order, integer *n, double + *vl, double *vu, integer *il, integer *iu, double *abstol, + double *d__, double *e, integer *m, integer *nsplit, + double *w, integer *iblock, integer *isplit, double *work, + integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + static integer c__0 = 0; + + /* System generated locals */ + integer i__1, i__2, i__3; + double d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + integer j, ib, jb, ie, je, nb; + double gl; + integer im, in; + double gu; + integer iw; + double wl, wu; + integer nwl; + double ulp, wlu, wul; + integer nwu; + double tmp1, tmp2; + integer iend, ioff, iout, itmp1, jdisc; + integer iinfo; + double atoli; + integer iwoff; + double bnorm; + integer itmax; + double wkill, rtoli, tnorm; + integer ibegin; + integer irange, idiscl; + double safemn; + integer idumma[1]; + integer idiscu, iorder; + bool ncnvrg; + double pivmin; + bool toofew; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ +/* 8-18-00: Increase FUDGE factor for T3E (eca) */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEBZ computes the eigenvalues of a symmetric tridiagonal */ +/* matrix T. The user may ask for all eigenvalues, all eigenvalues */ +/* in the half-open interval (VL, VU], or the IL-th through IU-th */ +/* eigenvalues. */ + +/* To avoid overflow, the matrix must be scaled so that its */ +/* largest element is no greater than overflow**(1/2) * */ +/* underflow**(1/4) in absolute value, and for greatest */ +/* accuracy, it should not be much smaller than that. */ + +/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ +/* Matrix", Report CS41, Computer Science Dept., Stanford */ +/* University, July 21, 1966. */ + +/* Arguments */ +/* ========= */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': ("All") all eigenvalues will be found. */ +/* = 'V': ("Value") all eigenvalues in the half-open interval */ +/* (VL, VU] will be found. */ +/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ +/* entire matrix) will be found. */ + +/* ORDER (input) CHARACTER*1 */ +/* = 'B': ("By Block") the eigenvalues will be grouped by */ +/* split-off block (see IBLOCK, ISPLIT) and */ +/* ordered from smallest to largest within */ +/* the block. */ +/* = 'E': ("Entire matrix") */ +/* the eigenvalues for the entire matrix */ +/* will be ordered from smallest to */ +/* largest. */ + +/* N (input) INTEGER */ +/* The order of the tridiagonal matrix T. N >= 0. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. Eigenvalues less than or equal */ +/* to VL, or greater than VU, will not be returned. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute tolerance for the eigenvalues. An eigenvalue */ +/* (or cluster) is considered to be located if it has been */ +/* determined to lie in an interval whose width is ABSTOL or */ +/* less. If ABSTOL is less than or equal to zero, then ULP*|T| */ +/* will be used, where |T| means the 1-norm of T. */ + +/* Eigenvalues will be computed most accurately when ABSTOL is */ +/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the tridiagonal matrix T. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */ + +/* M (output) INTEGER */ +/* The actual number of eigenvalues found. 0 <= M <= N. */ +/* (See also the description of INFO=2,3.) */ + +/* NSPLIT (output) INTEGER */ +/* The number of diagonal blocks in the matrix T. */ +/* 1 <= NSPLIT <= N. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, the first M elements of W will contain the */ +/* eigenvalues. (DSTEBZ may use the remaining N-M elements as */ +/* workspace.) */ + +/* IBLOCK (output) INTEGER array, dimension (N) */ +/* At each row/column j where E(j) is zero or small, the */ +/* matrix T is considered to split into a block diagonal */ +/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */ +/* block (from 1 to the number of blocks) the eigenvalue W(i) */ +/* belongs. (DSTEBZ may use the remaining N-M elements as */ +/* workspace.) */ + +/* ISPLIT (output) INTEGER array, dimension (N) */ +/* The splitting points, at which T breaks up into submatrices. */ +/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */ +/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ +/* etc., and the NSPLIT-th consists of rows/columns */ +/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ +/* (Only the first NSPLIT elements will actually be used, but */ +/* since the user cannot know a priori what value NSPLIT will */ +/* have, N words must be reserved for ISPLIT.) */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* IWORK (workspace) INTEGER array, dimension (3*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: some or all of the eigenvalues failed to converge or */ +/* were not computed: */ +/* =1 or 3: Bisection failed to converge for some */ +/* eigenvalues; these eigenvalues are flagged by a */ +/* negative block number. The effect is that the */ +/* eigenvalues may not be as accurate as the */ +/* absolute and relative tolerances. This is */ +/* generally caused by unexpectedly inaccurate */ +/* arithmetic. */ +/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */ +/* IL:IU were found. */ +/* Effect: M < IU+1-IL */ +/* Cause: non-monotonic arithmetic, causing the */ +/* Sturm sequence to be non-monotonic. */ +/* Cure: recalculate, using RANGE='A', and pick */ +/* out eigenvalues IL:IU. In some cases, */ +/* increasing the PARAMETER "FUDGE" may */ +/* make things work. */ +/* = 4: RANGE='I', and the Gershgorin interval */ +/* initially used was too small. No eigenvalues */ +/* were computed. */ +/* Probable cause: your machine has sloppy */ +/* floating-point arithmetic. */ +/* Cure: Increase the PARAMETER "FUDGE", */ +/* recompile, and try again. */ + +/* Internal Parameters */ +/* =================== */ + +/* RELFAC DOUBLE PRECISION, default = 2.0e0 */ +/* The relative tolerance. An interval (a,b] lies within */ +/* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), */ +/* where "ulp" is the machine precision (distance from 1 to */ +/* the next larger floating point number.) */ + +/* FUDGE DOUBLE PRECISION, default = 2 */ +/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */ +/* a value of 1 should work, but on machines with sloppy */ +/* arithmetic, this needs to be larger. The default for */ +/* publicly released versions should be large enough to handle */ +/* the worst machine around. Note that this has no effect */ +/* on accuracy of the solution. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + --iwork; + --work; + --isplit; + --iblock; + --w; + --e; + --d__; + + /* Function Body */ + *info = 0; + +/* Decode RANGE */ + + if (lsame_(range, "A")) { + irange = 1; + } else if (lsame_(range, "V")) { + irange = 2; + } else if (lsame_(range, "I")) { + irange = 3; + } else { + irange = 0; + } + +/* Decode ORDER */ + + if (lsame_(order, "B")) { + iorder = 2; + } else if (lsame_(order, "E")) { + iorder = 1; + } else { + iorder = 0; + } + +/* Check for Errors */ + + if (irange <= 0) { + *info = -1; + } else if (iorder <= 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (irange == 2) { + if (*vl >= *vu) { + *info = -5; + } + } else if (irange == 3 && (*il < 1 || *il > std::max(1_integer,*n))) { + *info = -6; + } else if (irange == 3 && (*iu < std::min(*n,*il) || *iu > *n)) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEBZ", &i__1); + return 0; + } + +/* Initialize error flags */ + + *info = 0; + ncnvrg = false; + toofew = false; + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + +/* Simplifications: */ + + if (irange == 3 && *il == 1 && *iu == *n) { + irange = 1; + } + +/* Get machine constants */ +/* NB is the minimum vector length for vector bisection, or 0 */ +/* if only scalar is to be done. */ + + safemn = dlamch_("S"); + ulp = dlamch_("P"); + rtoli = ulp * 2.; + nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1); + if (nb <= 1) { + nb = 0; + } + +/* Special Case when N=1 */ + + if (*n == 1) { + *nsplit = 1; + isplit[1] = 1; + if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) { + *m = 0; + } else { + w[1] = d__[1]; + iblock[1] = 1; + *m = 1; + } + return 0; + } + +/* Compute Splitting Points */ + + *nsplit = 1; + work[*n] = 0.; + pivmin = 1.; + +/* DIR$ NOVECTOR */ + i__1 = *n; + for (j = 2; j <= i__1; ++j) { +/* Computing 2nd power */ + d__1 = e[j - 1]; + tmp1 = d__1 * d__1; +/* Computing 2nd power */ + d__2 = ulp; + if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn + > tmp1) { + isplit[*nsplit] = j - 1; + ++(*nsplit); + work[j - 1] = 0.; + } else { + work[j - 1] = tmp1; + pivmin = std::max(pivmin,tmp1); + } +/* L10: */ + } + isplit[*nsplit] = *n; + pivmin *= safemn; + +/* Compute Interval and ATOLI */ + + if (irange == 3) { + +/* RANGE='I': Compute the interval containing eigenvalues */ +/* IL through IU. */ + +/* Compute Gershgorin interval for entire (split) matrix */ +/* and use it as the initial interval */ + + gu = d__[1]; + gl = d__[1]; + tmp1 = 0.; + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + tmp2 = sqrt(work[j]); +/* Computing MAX */ + d__1 = gu, d__2 = d__[j] + tmp1 + tmp2; + gu = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = gl, d__2 = d__[j] - tmp1 - tmp2; + gl = std::min(d__1,d__2); + tmp1 = tmp2; +/* L20: */ + } + +/* Computing MAX */ + d__1 = gu, d__2 = d__[*n] + tmp1; + gu = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = gl, d__2 = d__[*n] - tmp1; + gl = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = abs(gl), d__2 = abs(gu); + tnorm = std::max(d__1,d__2); + gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002; + gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1; + +/* Compute Iteration parameters */ + + itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2; + if (*abstol <= 0.) { + atoli = ulp * tnorm; + } else { + atoli = *abstol; + } + + work[*n + 1] = gl; + work[*n + 2] = gl; + work[*n + 3] = gu; + work[*n + 4] = gu; + work[*n + 5] = gl; + work[*n + 6] = gu; + iwork[1] = -1; + iwork[2] = -1; + iwork[3] = *n + 1; + iwork[4] = *n + 1; + iwork[5] = *il - 1; + iwork[6] = *iu; + + dlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin, + &d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n + + 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo); + + if (iwork[6] == *iu) { + wl = work[*n + 1]; + wlu = work[*n + 3]; + nwl = iwork[1]; + wu = work[*n + 4]; + wul = work[*n + 2]; + nwu = iwork[4]; + } else { + wl = work[*n + 2]; + wlu = work[*n + 4]; + nwl = iwork[2]; + wu = work[*n + 3]; + wul = work[*n + 1]; + nwu = iwork[3]; + } + + if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) { + *info = 4; + return 0; + } + } else { + +/* RANGE='A' or 'V' -- Set ATOLI */ + +/* Computing MAX */ + d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + ( + d__2 = e[*n - 1], abs(d__2)); + tnorm = std::max(d__3,d__4); + + i__1 = *n - 1; + for (j = 2; j <= i__1; ++j) { +/* Computing MAX */ + d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1] + , abs(d__2)) + (d__3 = e[j], abs(d__3)); + tnorm = std::max(d__4,d__5); +/* L30: */ + } + + if (*abstol <= 0.) { + atoli = ulp * tnorm; + } else { + atoli = *abstol; + } + + if (irange == 2) { + wl = *vl; + wu = *vu; + } else { + wl = 0.; + wu = 0.; + } + } + +/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. */ +/* NWL accumulates the number of eigenvalues .le. WL, */ +/* NWU accumulates the number of eigenvalues .le. WU */ + + *m = 0; + iend = 0; + *info = 0; + nwl = 0; + nwu = 0; + + i__1 = *nsplit; + for (jb = 1; jb <= i__1; ++jb) { + ioff = iend; + ibegin = ioff + 1; + iend = isplit[jb]; + in = iend - ioff; + + if (in == 1) { + +/* Special Case -- IN=1 */ + + if (irange == 1 || wl >= d__[ibegin] - pivmin) { + ++nwl; + } + if (irange == 1 || wu >= d__[ibegin] - pivmin) { + ++nwu; + } + if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin] + - pivmin) { + ++(*m); + w[*m] = d__[ibegin]; + iblock[*m] = jb; + } + } else { + +/* General Case -- IN > 1 */ + +/* Compute Gershgorin Interval */ +/* and use it as the initial interval */ + + gu = d__[ibegin]; + gl = d__[ibegin]; + tmp1 = 0.; + + i__2 = iend - 1; + for (j = ibegin; j <= i__2; ++j) { + tmp2 = (d__1 = e[j], abs(d__1)); +/* Computing MAX */ + d__1 = gu, d__2 = d__[j] + tmp1 + tmp2; + gu = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = gl, d__2 = d__[j] - tmp1 - tmp2; + gl = std::min(d__1,d__2); + tmp1 = tmp2; +/* L40: */ + } + +/* Computing MAX */ + d__1 = gu, d__2 = d__[iend] + tmp1; + gu = std::max(d__1,d__2); +/* Computing MIN */ + d__1 = gl, d__2 = d__[iend] - tmp1; + gl = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = abs(gl), d__2 = abs(gu); + bnorm = std::max(d__1,d__2); + gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1; + gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1; + +/* Compute ATOLI for the current submatrix */ + + if (*abstol <= 0.) { +/* Computing MAX */ + d__1 = abs(gl), d__2 = abs(gu); + atoli = ulp * std::max(d__1,d__2); + } else { + atoli = *abstol; + } + + if (irange > 1) { + if (gu < wl) { + nwl += in; + nwu += in; + goto L70; + } + gl = std::max(gl,wl); + gu = std::min(gu,wu); + if (gl >= gu) { + goto L70; + } + } + +/* Set Up Initial Interval */ + + work[*n + 1] = gl; + work[*n + in + 1] = gu; + dlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, & + pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, & + work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], & + w[*m + 1], &iblock[*m + 1], &iinfo); + + nwl += iwork[1]; + nwu += iwork[in + 1]; + iwoff = *m - iwork[1]; + +/* Compute Eigenvalues */ + + itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(2.) + ) + 2; + dlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, & + pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, & + work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], + &w[*m + 1], &iblock[*m + 1], &iinfo); + +/* Copy Eigenvalues Into W and IBLOCK */ +/* Use -JB for block number for unconverged eigenvalues. */ + + i__2 = iout; + for (j = 1; j <= i__2; ++j) { + tmp1 = (work[j + *n] + work[j + in + *n]) * .5; + +/* Flag non-convergence. */ + + if (j > iout - iinfo) { + ncnvrg = true; + ib = -jb; + } else { + ib = jb; + } + i__3 = iwork[j + in] + iwoff; + for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) { + w[je] = tmp1; + iblock[je] = ib; +/* L50: */ + } +/* L60: */ + } + + *m += im; + } +L70: + ; + } + +/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */ +/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */ + + if (irange == 3) { + im = 0; + idiscl = *il - 1 - nwl; + idiscu = nwu - *iu; + + if (idiscl > 0 || idiscu > 0) { + i__1 = *m; + for (je = 1; je <= i__1; ++je) { + if (w[je] <= wlu && idiscl > 0) { + --idiscl; + } else if (w[je] >= wul && idiscu > 0) { + --idiscu; + } else { + ++im; + w[im] = w[je]; + iblock[im] = iblock[je]; + } +/* L80: */ + } + *m = im; + } + if (idiscl > 0 || idiscu > 0) { + +/* Code to deal with effects of bad arithmetic: */ +/* Some low eigenvalues to be discarded are not in (WL,WLU], */ +/* or high eigenvalues to be discarded are not in (WUL,WU] */ +/* so just kill off the smallest IDISCL/largest IDISCU */ +/* eigenvalues, by simply finding the smallest/largest */ +/* eigenvalue(s). */ + +/* (If N(w) is monotone non-decreasing, this should never */ +/* happen.) */ + + if (idiscl > 0) { + wkill = wu; + i__1 = idiscl; + for (jdisc = 1; jdisc <= i__1; ++jdisc) { + iw = 0; + i__2 = *m; + for (je = 1; je <= i__2; ++je) { + if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) { + iw = je; + wkill = w[je]; + } +/* L90: */ + } + iblock[iw] = 0; +/* L100: */ + } + } + if (idiscu > 0) { + + wkill = wl; + i__1 = idiscu; + for (jdisc = 1; jdisc <= i__1; ++jdisc) { + iw = 0; + i__2 = *m; + for (je = 1; je <= i__2; ++je) { + if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) { + iw = je; + wkill = w[je]; + } +/* L110: */ + } + iblock[iw] = 0; +/* L120: */ + } + } + im = 0; + i__1 = *m; + for (je = 1; je <= i__1; ++je) { + if (iblock[je] != 0) { + ++im; + w[im] = w[je]; + iblock[im] = iblock[je]; + } +/* L130: */ + } + *m = im; + } + if (idiscl < 0 || idiscu < 0) { + toofew = true; + } + } + +/* If ORDER='B', do nothing -- the eigenvalues are already sorted */ +/* by block. */ +/* If ORDER='E', sort the eigenvalues from smallest to largest */ + + if (iorder == 1 && *nsplit > 1) { + i__1 = *m - 1; + for (je = 1; je <= i__1; ++je) { + ie = 0; + tmp1 = w[je]; + i__2 = *m; + for (j = je + 1; j <= i__2; ++j) { + if (w[j] < tmp1) { + ie = j; + tmp1 = w[j]; + } +/* L140: */ + } + + if (ie != 0) { + itmp1 = iblock[ie]; + w[ie] = w[je]; + iblock[ie] = iblock[je]; + w[je] = tmp1; + iblock[je] = itmp1; + } +/* L150: */ + } + } + + *info = 0; + if (ncnvrg) { + ++(*info); + } + if (toofew) { + *info += 2; + } + return 0; + +/* End of DSTEBZ */ + +} /* dstebz_ */ + +/* Subroutine */ int dstedc_(const char *compz, integer *n, double *d__, + double *e, double *z__, integer *ldz, double *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* Table of constant values */ + static integer c__9 = 9; + static integer c__0 = 0; + static integer c__2 = 2; + static double c_b17 = 0.; + static double c_b18 = 1.; + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, k, m; + double p; + integer ii, lgn; + double eps, tiny; + integer lwmin; + integer start; + integer finish; + integer liwmin, icompz; + double orgnrm; + bool lquery; + integer smlsiz, storez, strtrw; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a */ +/* symmetric tridiagonal matrix using the divide and conquer method. */ +/* The eigenvectors of a full or band real symmetric matrix can also be */ +/* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this */ +/* matrix to tridiagonal form. */ + +/* This code makes very mild assumptions about floating point */ +/* arithmetic. It will work on machines with a guard digit in */ +/* add/subtract, or on those binary machines without guard digits */ +/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ +/* It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. See DLAED3 for details. */ + +/* Arguments */ +/* ========= */ + +/* COMPZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only. */ +/* = 'I': Compute eigenvectors of tridiagonal matrix also. */ +/* = 'V': Compute eigenvectors of original dense symmetric */ +/* matrix also. On entry, Z contains the orthogonal */ +/* matrix used to reduce the original matrix to */ +/* tridiagonal form. */ + +/* N (input) INTEGER */ +/* The dimension of the symmetric tridiagonal matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the diagonal elements of the tridiagonal matrix. */ +/* On exit, if INFO = 0, the eigenvalues in ascending order. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the subdiagonal elements of the tridiagonal matrix. */ +/* On exit, E has been destroyed. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* On entry, if COMPZ = 'V', then Z contains the orthogonal */ +/* matrix used in the reduction to tridiagonal form. */ +/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ +/* orthonormal eigenvectors of the original symmetric matrix, */ +/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ +/* of the symmetric tridiagonal matrix. */ +/* If COMPZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1. */ +/* If eigenvectors are desired, then LDZ >= max(1,N). */ + +/* WORK (workspace/output) 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 COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */ +/* If COMPZ = 'V' and N > 1 then LWORK must be at least */ +/* ( 1 + 3*N + 2*N*lg N + 3*N**2 ), */ +/* where lg( N ) = smallest integer k such */ +/* that 2**k >= N. */ +/* If COMPZ = 'I' and N > 1 then LWORK must be at least */ +/* ( 1 + 4*N + N**2 ). */ +/* Note that for COMPZ = 'I' or 'V', then if N is less than or */ +/* equal to the minimum divide size, usually 25, then LWORK need */ +/* only be max(1,2*(N-1)). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */ +/* If COMPZ = 'V' and N > 1 then LIWORK must be at least */ +/* ( 6 + 6*N + 5*N*lg N ). */ +/* If COMPZ = 'I' and N > 1 then LIWORK must be at least */ +/* ( 3 + 5*N ). */ +/* Note that for COMPZ = 'I' or 'V', then if N is less than or */ +/* equal to the minimum divide size, usually 25, then LIWORK */ +/* need only be 1. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal size of the IWORK array, */ +/* returns this value as the first entry of the IWORK array, and */ +/* no error message related to LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: The algorithm failed to compute an eigenvalue while */ +/* working on the submatrix lying in rows and columns */ +/* INFO/(N+1) through mod(INFO,N+1). */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ +/* Modified by Francoise Tisseur, University of Tennessee. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < std::max(1_integer,*n)) { + *info = -6; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + + smlsiz = ilaenv_(&c__9, "DSTEDC", " ", &c__0, &c__0, &c__0, &c__0); + if (*n <= 1 || icompz == 0) { + liwmin = 1; + lwmin = 1; + } else if (*n <= smlsiz) { + liwmin = 1; + lwmin = *n - 1 << 1; + } else { + lgn = (integer) (log((double) (*n)) / log(2.)); + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (icompz == 1) { +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3; + liwmin = *n * 6 + 6 + *n * 5 * lgn; + } else if (icompz == 2) { +/* Computing 2nd power */ + i__1 = *n; + lwmin = (*n << 2) + 1 + i__1 * i__1; + liwmin = *n * 5 + 3; + } + } + work[1] = (double) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEDC", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*n == 1) { + if (icompz != 0) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* If the following conditional clause is removed, then the routine */ +/* will use the Divide and Conquer routine to compute only the */ +/* eigenvalues, which requires (3N + 3N**2) real workspace and */ +/* (2 + 5N + 2N lg(N)) integer workspace. */ +/* Since on many architectures DSTERF is much faster than any other */ +/* algorithm for finding eigenvalues only, it is used here */ +/* as the default. If the conditional clause is removed, then */ +/* information on the size of workspace needs to be changed. */ + +/* If COMPZ = 'N', use DSTERF to compute the eigenvalues. */ + + if (icompz == 0) { + dsterf_(n, &d__[1], &e[1], info); + goto L50; + } + +/* If N is smaller than the minimum divide size (SMLSIZ+1), then */ +/* solve the problem with another solver. */ + + if (*n <= smlsiz) { + + dsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info); + + } else { + +/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */ +/* use. */ + + if (icompz == 1) { + storez = *n * *n + 1; + } else { + storez = 1; + } + + if (icompz == 2) { + dlaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz); + } + +/* Scale. */ + + orgnrm = dlanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.) { + goto L50; + } + + eps = dlamch_("Epsilon"); + + start = 1; + +/* while ( START <= N ) */ + +L10: + if (start <= *n) { + +/* Let FINISH be the position of the next subdiagonal entry */ +/* such that E( FINISH ) <= TINY or FINISH = N if no such */ +/* subdiagonal exists. The matrix identified by the elements */ +/* between START and FINISH constitutes an independent */ +/* sub-problem. */ + + finish = start; +L20: + if (finish < *n) { + tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt(( + d__2 = d__[finish + 1], abs(d__2))); + if ((d__1 = e[finish], abs(d__1)) > tiny) { + ++finish; + goto L20; + } + } + +/* (Sub) Problem determined. Compute its size and solve it. */ + + m = finish - start + 1; + if (m == 1) { + start = finish + 1; + goto L10; + } + if (m > smlsiz) { + +/* Scale. */ + + orgnrm = dlanst_("M", &m, &d__[start], &e[start]); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[ + start], &m, info); + i__1 = m - 1; + i__2 = m - 1; + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[ + start], &i__2, info); + + if (icompz == 1) { + strtrw = 1; + } else { + strtrw = start; + } + dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw + + start * z_dim1], ldz, &work[1], n, &work[storez], & + iwork[1], info); + if (*info != 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % + (m + 1) + start - 1; + goto L50; + } + +/* Scale back. */ + + dlascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[ + start], &m, info); + + } else { + if (icompz == 1) { + +/* Since QR won't update a Z matrix which is larger than */ +/* the length of D, we must solve the sub-problem in a */ +/* workspace and then multiply back into Z. */ + + dsteqr_("I", &m, &d__[start], &e[start], &work[1], &m, & + work[m * m + 1], info); + dlacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[ + storez], n); + dgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, & + work[1], &m, &c_b17, &z__[start * z_dim1 + 1], + ldz); + } else if (icompz == 2) { + dsteqr_("I", &m, &d__[start], &e[start], &z__[start + + start * z_dim1], ldz, &work[1], info); + } else { + dsterf_(&m, &d__[start], &e[start], info); + } + if (*info != 0) { + *info = start * (*n + 1) + finish; + goto L50; + } + } + + start = finish + 1; + goto L10; + } + +/* endwhile */ + +/* If the problem split any number of times, then the eigenvalues */ +/* will not be properly ordered. Here we permute the eigenvalues */ +/* (and the associated eigenvectors) into ascending order. */ + + if (m != *n) { + if (icompz == 0) { + +/* Use Quick Sort */ + + dlasrt_("I", n, &d__[1], info); + + } else { + +/* Use Selection Sort to minimize swaps of eigenvectors */ + + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } +/* L30: */ + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * + z_dim1 + 1], &c__1); + } +/* L40: */ + } + } + } + } + +L50: + work[1] = (double) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSTEDC */ + +} /* dstedc_ */ + +/* Subroutine */ int dstegr_(const char *jobz, const char *range, integer *n, double * + d__, double *e, double *vl, double *vu, integer *il, + integer *iu, double *abstol, integer *m, double *w, + double *z__, integer *ldz, integer *isuppz, double *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset; + + /* Local variables */ + bool tryrac; + + +/* -- LAPACK computational routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEGR computes selected eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ +/* a well defined set of pairwise different real eigenvalues, the corresponding */ +/* real eigenvectors are pairwise orthogonal. */ + +/* The spectrum may be computed either completely or partially by specifying */ +/* either an interval (VL,VU] or a range of indices IL:IU for the desired */ +/* eigenvalues. */ + +/* DSTEGR is a compatability wrapper around the improved DSTEMR routine. */ +/* See DSTEMR for further details. */ + +/* One important change is that the ABSTOL parameter no longer provides any */ +/* benefit and hence is no longer used. */ + +/* Note : DSTEGR and DSTEMR work only on machines which follow */ +/* IEEE-754 floating-point standard in their handling of infinities and */ +/* NaNs. Normal execution may create these exceptiona values and hence */ +/* may abort due to a floating point exception in environments which */ +/* do not conform to the IEEE-754 standard. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the N diagonal elements of the tridiagonal matrix */ +/* T. On exit, D is overwritten. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the (N-1) subdiagonal elements of the tridiagonal */ +/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */ +/* input, but is used internally as workspace. */ +/* On exit, E is overwritten. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* Unused. Was the absolute error tolerance for the */ +/* eigenvalues/eigenvectors in previous versions. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements contain the selected eigenvalues in */ +/* ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ +/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix T */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ +/* Supplying N columns is always safe. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', then LDZ >= max(1,N). */ + +/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */ +/* The support of the eigenvectors in Z, i.e., the indices */ +/* indicating the nonzero elements in Z. The i-th computed eigenvector */ +/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */ +/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal */ +/* (and minimal) LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,18*N) */ +/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */ +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */ +/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */ +/* if only the eigenvalues are to be computed. */ +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal size of the IWORK array, */ +/* returns this value as the first entry of the IWORK array, and */ +/* no error message related to LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* On exit, INFO */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = 1X, internal error in DLARRE, */ +/* if INFO = 2X, internal error in DLARRV. */ +/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ +/* the nonzero error code returned by DLARRE or */ +/* DLARRV, respectively. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Inderjit Dhillon, IBM Almaden, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, LBNL/NERSC, USA */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + /* Parameter adjustments */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + *info = 0; + tryrac = false; + dstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[ + z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1] +, liwork, info); + +/* End of DSTEGR */ + + return 0; +} /* dstegr_ */ + +/* Subroutine */ int dstein_(integer *n, double *d__, double *e, + integer *m, double *w, integer *iblock, integer *isplit, + double *z__, integer *ldz, double *work, integer *iwork, + integer *ifail, integer *info) +{ + /* Table of constant values */ + static integer c__2 = 2; + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3; + double d__1, d__2, d__3, d__4, d__5; + + /* Local variables */ + integer i__, j, b1, j1, bn; + double xj, scl, eps, sep, nrm, tol; + integer its; + double xjm, ztr, eps1; + integer jblk, nblk; + integer jmax; + integer iseed[4], gpind, iinfo; + double ortol; + integer indrv1, indrv2, indrv3, indrv4, indrv5; + integer nrmchk; + integer blksiz; + double onenrm, dtpcrt, pertol; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEIN computes the eigenvectors of a real symmetric tridiagonal */ +/* matrix T corresponding to specified eigenvalues, using inverse */ +/* iteration. */ + +/* The maximum number of iterations allowed for each eigenvector is */ +/* specified by an internal parameter MAXITS (currently set to 5). */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input) DOUBLE PRECISION array, dimension (N) */ +/* The n diagonal elements of the tridiagonal matrix T. */ + +/* E (input) DOUBLE PRECISION array, dimension (N-1) */ +/* The (n-1) subdiagonal elements of the tridiagonal matrix */ +/* T, in elements 1 to N-1. */ + +/* M (input) INTEGER */ +/* The number of eigenvectors to be found. 0 <= M <= N. */ + +/* W (input) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements of W contain the eigenvalues for */ +/* which eigenvectors are to be computed. The eigenvalues */ +/* should be grouped by split-off block and ordered from */ +/* smallest to largest within the block. ( The output array */ +/* W from DSTEBZ with ORDER = 'B' is expected here. ) */ + +/* IBLOCK (input) INTEGER array, dimension (N) */ +/* The submatrix indices associated with the corresponding */ +/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */ +/* the first submatrix from the top, =2 if W(i) belongs to */ +/* the second submatrix, etc. ( The output array IBLOCK */ +/* from DSTEBZ is expected here. ) */ + +/* ISPLIT (input) INTEGER array, dimension (N) */ +/* The splitting points, at which T breaks up into submatrices. */ +/* The first submatrix consists of rows/columns 1 to */ +/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */ +/* through ISPLIT( 2 ), etc. */ +/* ( The output array ISPLIT from DSTEBZ is expected here. ) */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, M) */ +/* The computed eigenvectors. The eigenvector associated */ +/* with the eigenvalue W(i) is stored in the i-th column of */ +/* Z. Any vector which fails to converge is set to its current */ +/* iterate after MAXITS iterations. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* IFAIL (output) INTEGER array, dimension (M) */ +/* On normal exit, all elements of IFAIL are zero. */ +/* If one or more eigenvectors fail to converge after */ +/* MAXITS iterations, then their indices are stored in */ +/* array IFAIL. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, then i eigenvectors failed to converge */ +/* in MAXITS iterations. Their indices are stored in */ +/* array IFAIL. */ + +/* Internal Parameters */ +/* =================== */ + +/* MAXITS INTEGER, default = 5 */ +/* The maximum number of iterations performed. */ + +/* EXTRA INTEGER, default = 2 */ +/* The number of iterations performed after norm growth */ +/* criterion is satisfied, should be at least 1. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + --iblock; + --isplit; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + *info = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + + if (*n < 0) { + *info = -1; + } else if (*m < 0 || *m > *n) { + *info = -4; + } else if (*ldz < std::max(1_integer,*n)) { + *info = -9; + } else { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + if (iblock[j] < iblock[j - 1]) { + *info = -6; + goto L30; + } + if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { + *info = -5; + goto L30; + } +/* L20: */ + } +L30: + ; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEIN", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } else if (*n == 1) { + z__[z_dim1 + 1] = 1.; + return 0; + } + +/* Get machine constants. */ + + eps = dlamch_("Precision"); + +/* Initialize seed for random number generator DLARNV. */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__ - 1] = 1; +/* L40: */ + } + +/* Initialize pointers. */ + + indrv1 = 0; + indrv2 = indrv1 + *n; + indrv3 = indrv2 + *n; + indrv4 = indrv3 + *n; + indrv5 = indrv4 + *n; + +/* Compute eigenvectors of matrix blocks. */ + + j1 = 1; + i__1 = iblock[*m]; + for (nblk = 1; nblk <= i__1; ++nblk) { + +/* Find starting and ending indices of block nblk. */ + + if (nblk == 1) { + b1 = 1; + } else { + b1 = isplit[nblk - 1] + 1; + } + bn = isplit[nblk]; + blksiz = bn - b1 + 1; + if (blksiz == 1) { + goto L60; + } + gpind = b1; + +/* Compute reorthogonalization criterion and stopping criterion. */ + + onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 = e[b1], abs(d__2)); +/* Computing MAX */ + d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1], + abs(d__2)); + onenrm = std::max(d__3,d__4); + i__2 = bn - 1; + for (i__ = b1 + 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[ + i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3)); + onenrm = std::max(d__4,d__5); +/* L50: */ + } + ortol = onenrm * .001; + + dtpcrt = sqrt(.1 / blksiz); + +/* Loop through eigenvalues of block nblk. */ + +L60: + jblk = 0; + i__2 = *m; + for (j = j1; j <= i__2; ++j) { + if (iblock[j] != nblk) { + j1 = j; + goto L160; + } + ++jblk; + xj = w[j]; + +/* Skip all the work if the block size is one. */ + + if (blksiz == 1) { + work[indrv1 + 1] = 1.; + goto L120; + } + +/* If eigenvalues j and j-1 are too close, add a relatively */ +/* small perturbation. */ + + if (jblk > 1) { + eps1 = (d__1 = eps * xj, abs(d__1)); + pertol = eps1 * 10.; + sep = xj - xjm; + if (sep < pertol) { + xj = xjm + pertol; + } + } + + its = 0; + nrmchk = 0; + +/* Get random starting vector. */ + + dlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]); + +/* Copy the matrix T so it won't be destroyed in factorization. */ + + dcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1); + i__3 = blksiz - 1; + dcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1); + i__3 = blksiz - 1; + dcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1); + +/* Compute LU factors with partial pivoting ( PT = LU ) */ + + tol = 0.; + dlagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[ + indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo); + +/* Update iteration count. */ + +L70: + ++its; + if (its > 5) { + goto L100; + } + +/* Normalize and scale the righthand side vector Pb. */ + +/* Computing MAX */ + d__2 = eps, d__3 = (d__1 = work[indrv4 + blksiz], abs(d__1)); + scl = blksiz * onenrm * std::max(d__2,d__3) / dasum_(&blksiz, &work[ + indrv1 + 1], &c__1); + dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); + +/* Solve the system LU = Pb. */ + + dlagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], & + work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[ + indrv1 + 1], &tol, &iinfo); + +/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */ +/* close enough. */ + + if (jblk == 1) { + goto L90; + } + if ((d__1 = xj - xjm, abs(d__1)) > ortol) { + gpind = j; + } + if (gpind != j) { + i__3 = j - 1; + for (i__ = gpind; i__ <= i__3; ++i__) { + ztr = -ddot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 + + i__ * z_dim1], &c__1); + daxpy_(&blksiz, &ztr, &z__[b1 + i__ * z_dim1], &c__1, & + work[indrv1 + 1], &c__1); +/* L80: */ + } + } + +/* Check the infinity norm of the iterate. */ + +L90: + jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); + nrm = (d__1 = work[indrv1 + jmax], abs(d__1)); + +/* Continue for additional iterations after norm reaches */ +/* stopping criterion. */ + + if (nrm < dtpcrt) { + goto L70; + } + ++nrmchk; + if (nrmchk < 3) { + goto L70; + } + + goto L110; + +/* If stopping criterion was not satisfied, update info and */ +/* store eigenvector number in array ifail. */ + +L100: + ++(*info); + ifail[*info] = j; + +/* Accept iterate as jth eigenvector. */ + +L110: + scl = 1. / dnrm2_(&blksiz, &work[indrv1 + 1], &c__1); + jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1); + if (work[indrv1 + jmax] < 0.) { + scl = -scl; + } + dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); +L120: + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[i__ + j * z_dim1] = 0.; +/* L130: */ + } + i__3 = blksiz; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__]; +/* L140: */ + } + +/* Save the shift to check eigenvalue spacing at next */ +/* iteration. */ + + xjm = xj; + +/* L150: */ + } +L160: + ; + } + + return 0; + +/* End of DSTEIN */ + +} /* dstein_ */ + +/* Subroutine */ int dstemr_(const char *jobz, const char *range, integer *n, double * + d__, double *e, double *vl, double *vu, integer *il, + integer *iu, integer *m, double *w, double *z__, integer *ldz, + integer *nzc, integer *isuppz, bool *tryrac, double *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b18 = .001; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j; + double r1, r2; + integer jj; + double cs; + integer in; + double sn, wl, wu; + integer iil, iiu; + double eps, tmp; + integer indd, iend, jblk, wend; + double rmin, rmax; + integer itmp; + double tnrm; + integer inde2, itmp2; + double rtol1, rtol2; + double scale; + integer indgp; + integer iinfo, iindw, ilast; + integer lwmin; + bool wantz; + bool alleig; + integer ibegin; + bool indeig; + integer iindbl; + bool valeig; + integer wbegin; + double safmin; + double bignum; + integer inderr, iindwk, indgrs, offset; + double thresh; + integer iinspl, ifirst, indwrk, liwmin, nzcmin; + double pivmin; + integer nsplit; + double smlnum; + bool lquery, zquery; + + +/* -- LAPACK computational routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEMR computes selected eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */ +/* a well defined set of pairwise different real eigenvalues, the corresponding */ +/* real eigenvectors are pairwise orthogonal. */ + +/* The spectrum may be computed either completely or partially by specifying */ +/* either an interval (VL,VU] or a range of indices IL:IU for the desired */ +/* eigenvalues. */ + +/* Depending on the number of desired eigenvalues, these are computed either */ +/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */ +/* computed by the use of various suitable L D L^T factorizations near clusters */ +/* of close eigenvalues (referred to as RRRs, Relatively Robust */ +/* Representations). An informal sketch of the algorithm follows. */ + +/* For each unreduced block (submatrix) of T, */ +/* (a) Compute T - sigma I = L D L^T, so that L and D */ +/* define all the wanted eigenvalues to high relative accuracy. */ +/* This means that small relative changes in the entries of D and L */ +/* cause only small relative changes in the eigenvalues and */ +/* eigenvectors. The standard (unfactored) representation of the */ +/* tridiagonal matrix T does not have this property in general. */ +/* (b) Compute the eigenvalues to suitable accuracy. */ +/* If the eigenvectors are desired, the algorithm attains full */ +/* accuracy of the computed eigenvalues only right before */ +/* the corresponding vectors have to be computed, see steps c) and d). */ +/* (c) For each cluster of close eigenvalues, select a new */ +/* shift close to the cluster, find a new factorization, and refine */ +/* the shifted eigenvalues to suitable accuracy. */ +/* (d) For each eigenvalue with a large enough relative separation compute */ +/* the corresponding eigenvector by forming a rank revealing twisted */ +/* factorization. Go back to (c) for any clusters that remain. */ + +/* For more details, see: */ +/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ +/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ +/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ +/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ +/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ +/* 2004. Also LAPACK Working Note 154. */ +/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ +/* tridiagonal eigenvalue/eigenvector problem", */ +/* Computer Science Division Technical Report No. UCB/CSD-97-971, */ +/* UC Berkeley, May 1997. */ + +/* Notes: */ +/* 1.DSTEMR works only on machines which follow IEEE-754 */ +/* floating-point standard in their handling of infinities and NaNs. */ +/* This permits the use of efficient inner loops avoiding a check for */ +/* zero divisors. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the N diagonal elements of the tridiagonal matrix */ +/* T. On exit, D is overwritten. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the (N-1) subdiagonal elements of the tridiagonal */ +/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */ +/* input, but is used internally as workspace. */ +/* On exit, E is overwritten. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements contain the selected eigenvalues in */ +/* ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ +/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix T */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and can be computed with a workspace */ +/* query by setting NZC = -1, see below. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', then LDZ >= max(1,N). */ + +/* NZC (input) INTEGER */ +/* The number of eigenvectors to be held in the array Z. */ +/* If RANGE = 'A', then NZC >= max(1,N). */ +/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */ +/* If RANGE = 'I', then NZC >= IU-IL+1. */ +/* If NZC = -1, then a workspace query is assumed; the */ +/* routine calculates the number of columns of the array Z that */ +/* are needed to hold the eigenvectors. */ +/* This value is returned as the first entry of the Z array, and */ +/* no error message related to NZC is issued by XERBLA. */ + +/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */ +/* The support of the eigenvectors in Z, i.e., the indices */ +/* indicating the nonzero elements in Z. The i-th computed eigenvector */ +/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */ +/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */ + +/* TRYRAC (input/output) LOGICAL */ +/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */ +/* the tridiagonal matrix defines its eigenvalues to high relative */ +/* accuracy. If so, the code uses relative-accuracy preserving */ +/* algorithms that might be (a bit) slower depending on the matrix. */ +/* If the matrix does not define its eigenvalues to high relative */ +/* accuracy, the code can uses possibly faster algorithms. */ +/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */ +/* relatively accurate eigenvalues and can use the fastest possible */ +/* techniques. */ +/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */ +/* does not define its eigenvalues to high relative accuracy. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal */ +/* (and minimal) LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,18*N) */ +/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */ +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */ +/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */ +/* if only the eigenvalues are to be computed. */ +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal size of the IWORK array, */ +/* returns this value as the first entry of the IWORK array, and */ +/* no error message related to LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* On exit, INFO */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = 1X, internal error in DLARRE, */ +/* if INFO = 2X, internal error in DLARRV. */ +/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */ +/* the nonzero error code returned by DLARRE or */ +/* DLARRV, respectively. */ + + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Beresford Parlett, University of California, Berkeley, USA */ +/* Jim Demmel, University of California, Berkeley, USA */ +/* Inderjit Dhillon, University of Texas, Austin, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + lquery = *lwork == -1 || *liwork == -1; + zquery = *nzc == -1; + *tryrac = *info != 0; +/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */ +/* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */ +/* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */ + if (wantz) { + lwmin = *n * 18; + liwmin = *n * 10; + } else { +/* need less workspace if only the eigenvalues are wanted */ + lwmin = *n * 12; + liwmin = *n << 3; + } + wl = 0.; + wu = 0.; + iil = 0; + iiu = 0; + if (valeig) { +/* We do not reference VL, VU in the cases RANGE = 'I','A' */ +/* The interval (WL, WU] contains all the wanted eigenvalues. */ +/* It is either given by the user or computed in DLARRE. */ + wl = *vl; + wu = *vu; + } else if (indeig) { +/* We do not reference IL, IU in the cases RANGE = 'V','A' */ + iil = *il; + iiu = *iu; + } + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (valeig && *n > 0 && wu <= wl) { + *info = -7; + } else if (indeig && (iil < 1 || iil > *n)) { + *info = -8; + } else if (indeig && (iiu < iil || iiu > *n)) { + *info = -9; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -13; + } else if (*lwork < lwmin && ! lquery) { + *info = -17; + } else if (*liwork < liwmin && ! lquery) { + *info = -19; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); + rmax = std::min(d__1,d__2); + + if (*info == 0) { + work[1] = (double) lwmin; + iwork[1] = liwmin; + + if (wantz && alleig) { + nzcmin = *n; + } else if (wantz && valeig) { + dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, & + itmp2, info); + } else if (wantz && indeig) { + nzcmin = iiu - iil + 1; + } else { +/* WANTZ .EQ. FALSE. */ + nzcmin = 0; + } + if (zquery && *info == 0) { + z__[z_dim1 + 1] = (double) nzcmin; + } else if (*nzc < nzcmin && ! zquery) { + *info = -14; + } + } + if (*info != 0) { + + i__1 = -(*info); + xerbla_("DSTEMR", &i__1); + + return 0; + } else if (lquery || zquery) { + return 0; + } + +/* Handle N = 0, 1, and 2 cases immediately */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = d__[1]; + } else { + if (wl < d__[1] && wu >= d__[1]) { + *m = 1; + w[1] = d__[1]; + } + } + if (wantz && ! zquery) { + z__[z_dim1 + 1] = 1.; + isuppz[1] = 1; + isuppz[2] = 1; + } + return 0; + } + + if (*n == 2) { + if (! wantz) { + dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2); + } else if (wantz && ! zquery) { + dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn); + } + if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) { + ++(*m); + w[*m] = r2; + if (wantz && ! zquery) { + z__[*m * z_dim1 + 1] = -sn; + z__[*m * z_dim1 + 2] = cs; +/* Note: At most one of SN and CS can be zero. */ + if (sn != 0.) { + if (cs != 0.) { + isuppz[(*m << 1) - 1] = 1; + isuppz[(*m << 1) - 1] = 2; + } else { + isuppz[(*m << 1) - 1] = 1; + isuppz[(*m << 1) - 1] = 1; + } + } else { + isuppz[(*m << 1) - 1] = 2; + isuppz[*m * 2] = 2; + } + } + } + if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) { + ++(*m); + w[*m] = r1; + if (wantz && ! zquery) { + z__[*m * z_dim1 + 1] = cs; + z__[*m * z_dim1 + 2] = sn; +/* Note: At most one of SN and CS can be zero. */ + if (sn != 0.) { + if (cs != 0.) { + isuppz[(*m << 1) - 1] = 1; + isuppz[(*m << 1) - 1] = 2; + } else { + isuppz[(*m << 1) - 1] = 1; + isuppz[(*m << 1) - 1] = 1; + } + } else { + isuppz[(*m << 1) - 1] = 2; + isuppz[*m * 2] = 2; + } + } + } + return 0; + } +/* Continue with general N */ + indgrs = 1; + inderr = (*n << 1) + 1; + indgp = *n * 3 + 1; + indd = (*n << 2) + 1; + inde2 = *n * 5 + 1; + indwrk = *n * 6 + 1; + + iinspl = 1; + iindbl = *n + 1; + iindw = (*n << 1) + 1; + iindwk = *n * 3 + 1; + +/* Scale matrix to allowable range, if necessary. */ +/* The allowable range is related to the PIVMIN parameter; see the */ +/* comments in DLARRD. The preference for scaling small values */ +/* up is heuristic; we expect users' matrices not to be close to the */ +/* RMAX threshold. */ + + scale = 1.; + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + scale = rmin / tnrm; + } else if (tnrm > rmax) { + scale = rmax / tnrm; + } + if (scale != 1.) { + dscal_(n, &scale, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &scale, &e[1], &c__1); + tnrm *= scale; + if (valeig) { +/* If eigenvalues in interval have to be found, */ +/* scale (WL, WU] accordingly */ + wl *= scale; + wu *= scale; + } + } + +/* Compute the desired eigenvalues of the tridiagonal after splitting */ +/* into smaller subblocks if the corresponding off-diagonal elements */ +/* are small */ +/* THRESH is the splitting parameter for DLARRE */ +/* A negative THRESH forces the old splitting criterion based on the */ +/* size of the off-diagonal. A positive THRESH switches to splitting */ +/* which preserves relative accuracy. */ + + if (*tryrac) { +/* Test whether the matrix warrants the more expensive relative approach. */ + dlarrr_(n, &d__[1], &e[1], &iinfo); + } else { +/* The user does not care about relative accurately eigenvalues */ + iinfo = -1; + } +/* Set the splitting criterion */ + if (iinfo == 0) { + thresh = eps; + } else { + thresh = -eps; +/* relative accuracy is desired but T does not guarantee it */ + *tryrac = false; + } + + if (*tryrac) { +/* Copy original diagonal, needed to guarantee relative accuracy */ + dcopy_(n, &d__[1], &c__1, &work[indd], &c__1); + } +/* Store the squares of the offdiagonal values of T */ + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing 2nd power */ + d__1 = e[j]; + work[inde2 + j - 1] = d__1 * d__1; +/* L5: */ + } +/* Set the tolerance parameters for bisection */ + if (! wantz) { +/* DLARRE computes the eigenvalues to full precision. */ + rtol1 = eps * 4.; + rtol2 = eps * 4.; + } else { +/* DLARRE computes the eigenvalues to less than full precision. */ +/* DLARRV will refine the eigenvalue approximations, and we can */ +/* need less accurate initial bisection in DLARRE. */ +/* Note: these settings do only affect the subset case and DLARRE */ + rtol1 = sqrt(eps); +/* Computing MAX */ + d__1 = sqrt(eps) * .005, d__2 = eps * 4.; + rtol2 = std::max(d__1,d__2); + } + dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], & + rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[ + inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[ + indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo); + if (iinfo != 0) { + *info = abs(iinfo) + 10; + return 0; + } +/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */ +/* part of the spectrum. All desired eigenvalues are contained in */ +/* (WL,WU] */ + if (wantz) { + +/* Compute the desired eigenvectors corresponding to the computed */ +/* eigenvalues */ + + dlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, & + c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[ + indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[ + z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], & + iinfo); + if (iinfo != 0) { + *info = abs(iinfo) + 20; + return 0; + } + } else { +/* DLARRE computes eigenvalues of the (shifted) root representation */ +/* DLARRV returns the eigenvalues of the unshifted matrix. */ +/* However, if the eigenvectors are not desired by the user, we need */ +/* to apply the corresponding shifts from DLARRE to obtain the */ +/* eigenvalues of the original matrix. */ + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + itmp = iwork[iindbl + j - 1]; + w[j] += e[iwork[iinspl + itmp - 1]]; +/* L20: */ + } + } + + if (*tryrac) { +/* Refine computed eigenvalues so that they are relatively accurate */ +/* with respect to the original matrix T. */ + ibegin = 1; + wbegin = 1; + i__1 = iwork[iindbl + *m - 1]; + for (jblk = 1; jblk <= i__1; ++jblk) { + iend = iwork[iinspl + jblk - 1]; + in = iend - ibegin + 1; + wend = wbegin - 1; +/* check if any eigenvalues have to be refined in this block */ +L36: + if (wend < *m) { + if (iwork[iindbl + wend] == jblk) { + ++wend; + goto L36; + } + } + if (wend < wbegin) { + ibegin = iend + 1; + goto L39; + } + offset = iwork[iindw + wbegin - 1] - 1; + ifirst = iwork[iindw + wbegin - 1]; + ilast = iwork[iindw + wend - 1]; + rtol2 = eps * 4.; + dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1], + &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[ + inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], & + pivmin, &tnrm, &iinfo); + ibegin = iend + 1; + wbegin = wend + 1; +L39: + ; + } + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (scale != 1.) { + d__1 = 1. / scale; + dscal_(m, &d__1, &w[1], &c__1); + } + +/* If eigenvalues are not in increasing order, then sort them, */ +/* possibly along with eigenvectors. */ + + if (nsplit > 1) { + if (! wantz) { + dlasrt_("I", m, &w[1], &iinfo); + if (iinfo != 0) { + *info = 3; + return 0; + } + } else { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp) { + i__ = jj; + tmp = w[jj]; + } +/* L50: */ + } + if (i__ != 0) { + w[i__] = w[j]; + w[j] = tmp; + if (wantz) { + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * + z_dim1 + 1], &c__1); + itmp = isuppz[(i__ << 1) - 1]; + isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1]; + isuppz[(j << 1) - 1] = itmp; + itmp = isuppz[i__ * 2]; + isuppz[i__ * 2] = isuppz[j * 2]; + isuppz[j * 2] = itmp; + } + } +/* L60: */ + } + } + } + + + work[1] = (double) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSTEMR */ + +} /* dstemr_ */ + +/* Subroutine */ int dsteqr_(const char *compz, integer *n, double *d__, + double *e, double *z__, integer *ldz, double *work, + integer *info) +{ + /* Table of constant values */ + static double c_b9 = 0.; + static double c_b10 = 1.; + static integer c__0 = 0; + static integer c__1 = 1; + static integer c__2 = 2; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + double b, c__, f, g; + integer i__, j, k, l, m; + double p, r__, s; + integer l1, ii, mm, lm1, mm1, nm1; + double rt1, rt2, eps; + integer lsv; + double tst, eps2; + integer lend, jtot; + double anorm; + integer lendm1, lendp1; + integer iscale; + double safmin; + double safmax; + integer lendsv; + double ssfmin; + integer nmaxit, icompz; + double ssfmax; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */ +/* symmetric tridiagonal matrix using the implicit QL or QR method. */ +/* The eigenvectors of a full or band symmetric matrix can also be found */ +/* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */ +/* tridiagonal form. */ + +/* Arguments */ +/* ========= */ + +/* COMPZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only. */ +/* = 'V': Compute eigenvalues and eigenvectors of the original */ +/* symmetric matrix. On entry, Z must contain the */ +/* orthogonal matrix used to reduce the original matrix */ +/* to tridiagonal form. */ +/* = 'I': Compute eigenvalues and eigenvectors of the */ +/* tridiagonal matrix. Z is initialized to the identity */ +/* matrix. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the diagonal elements of the tridiagonal matrix. */ +/* On exit, if INFO = 0, the eigenvalues in ascending order. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix. */ +/* On exit, E has been destroyed. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* On entry, if COMPZ = 'V', then Z contains the orthogonal */ +/* matrix used in the reduction to tridiagonal form. */ +/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */ +/* orthonormal eigenvectors of the original symmetric matrix, */ +/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */ +/* of the symmetric tridiagonal matrix. */ +/* If COMPZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* eigenvectors are desired, then LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */ +/* If COMPZ = 'N', then WORK is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: the algorithm has failed to find all the eigenvalues in */ +/* a total of 30*N iterations; if INFO = i, then i */ +/* elements of E have not converged to zero; on exit, D */ +/* and E contain the elements of a symmetric tridiagonal */ +/* matrix which is orthogonally similar to the original */ +/* matrix. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + + if (lsame_(compz, "N")) { + icompz = 0; + } else if (lsame_(compz, "V")) { + icompz = 1; + } else if (lsame_(compz, "I")) { + icompz = 2; + } else { + icompz = -1; + } + if (icompz < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || icompz > 0 && *ldz < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEQR", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (icompz == 2) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Determine the unit roundoff and over/underflow thresholds. */ + + eps = dlamch_("E"); +/* Computing 2nd power */ + d__1 = eps; + eps2 = d__1 * d__1; + safmin = dlamch_("S"); + safmax = 1. / safmin; + ssfmax = sqrt(safmax) / 3.; + ssfmin = sqrt(safmin) / eps2; + +/* Compute the eigenvalues and eigenvectors of the tridiagonal */ +/* matrix. */ + + if (icompz == 2) { + dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz); + } + + nmaxit = *n * 30; + jtot = 0; + +/* Determine where the matrix splits and choose QL or QR iteration */ +/* for each block, according to whether top or bottom diagonal */ +/* element is smaller. */ + + l1 = 1; + nm1 = *n - 1; + +L10: + if (l1 > *n) { + goto L160; + } + if (l1 > 1) { + e[l1 - 1] = 0.; + } + if (l1 <= nm1) { + i__1 = nm1; + for (m = l1; m <= i__1; ++m) { + tst = (d__1 = e[m], abs(d__1)); + if (tst == 0.) { + goto L30; + } + if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m + + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } +/* L20: */ + } + } + m = *n; + +L30: + l = l1; + lsv = l; + lend = m; + lendsv = lend; + l1 = m + 1; + if (lend == l) { + goto L10; + } + +/* Scale submatrix in rows and columns L to LEND */ + + i__1 = lend - l + 1; + anorm = dlanst_("I", &i__1, &d__[l], &e[l]); + iscale = 0; + if (anorm == 0.) { + goto L10; + } + if (anorm > ssfmax) { + iscale = 1; + i__1 = lend - l + 1; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, + info); + } else if (anorm < ssfmin) { + iscale = 2; + i__1 = lend - l + 1; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, + info); + } + +/* Choose between QL and QR iteration */ + + if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { + lend = lsv; + l = lendsv; + } + + if (lend > l) { + +/* QL Iteration */ + +/* Look for small subdiagonal element. */ + +L40: + if (l != lend) { + lendm1 = lend - 1; + i__1 = lendm1; + for (m = l; m <= i__1; ++m) { +/* Computing 2nd power */ + d__2 = (d__1 = e[m], abs(d__1)); + tst = d__2 * d__2; + if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + + 1], abs(d__2)) + safmin) { + goto L60; + } +/* L50: */ + } + } + + m = lend; + +L60: + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L80; + } + +/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ +/* to compute its eigensystem. */ + + if (m == l + 1) { + if (icompz > 0) { + dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s); + work[l] = c__; + work[*n - 1 + l] = s; + dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], & + z__[l * z_dim1 + 1], ldz); + } else { + dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2); + } + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L40; + } + goto L140; + } + + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + +/* Form shift. */ + + g = (d__[l + 1] - p) / (e[l] * 2.); + r__ = dlapy2_(&g, &c_b10); + g = d__[m] - p + e[l] / (g + d_sign(&r__, &g)); + + s = 1.; + c__ = 1.; + p = 0.; + +/* Inner loop */ + + mm1 = m - 1; + i__1 = l; + for (i__ = mm1; i__ >= i__1; --i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m - 1) { + e[i__ + 1] = r__; + } + g = d__[i__ + 1] - p; + r__ = (d__[i__] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__ + 1] = g + p; + g = c__ * r__ - b; + +/* If eigenvectors are desired, then save rotations. */ + + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = -s; + } + +/* L70: */ + } + +/* If eigenvectors are desired, then apply saved rotations. */ + + if (icompz > 0) { + mm = m - l + 1; + dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l + * z_dim1 + 1], ldz); + } + + d__[l] -= p; + e[l] = g; + goto L40; + +/* Eigenvalue found. */ + +L80: + d__[l] = p; + + ++l; + if (l <= lend) { + goto L40; + } + goto L140; + + } else { + +/* QR Iteration */ + +/* Look for small superdiagonal element. */ + +L90: + if (l != lend) { + lendp1 = lend + 1; + i__1 = lendp1; + for (m = l; m >= i__1; --m) { +/* Computing 2nd power */ + d__2 = (d__1 = e[m - 1], abs(d__1)); + tst = d__2 * d__2; + if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m + - 1], abs(d__2)) + safmin) { + goto L110; + } +/* L100: */ + } + } + + m = lend; + +L110: + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L130; + } + +/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */ +/* to compute its eigensystem. */ + + if (m == l - 1) { + if (icompz > 0) { + dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s) + ; + work[m] = c__; + work[*n - 1 + m] = s; + dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], & + z__[(l - 1) * z_dim1 + 1], ldz); + } else { + dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2); + } + d__[l - 1] = rt1; + d__[l] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L90; + } + goto L140; + } + + if (jtot == nmaxit) { + goto L140; + } + ++jtot; + +/* Form shift. */ + + g = (d__[l - 1] - p) / (e[l - 1] * 2.); + r__ = dlapy2_(&g, &c_b10); + g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g)); + + s = 1.; + c__ = 1.; + p = 0.; + +/* Inner loop */ + + lm1 = l - 1; + i__1 = lm1; + for (i__ = m; i__ <= i__1; ++i__) { + f = s * e[i__]; + b = c__ * e[i__]; + dlartg_(&g, &f, &c__, &s, &r__); + if (i__ != m) { + e[i__ - 1] = r__; + } + g = d__[i__] - p; + r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b; + p = s * r__; + d__[i__] = g + p; + g = c__ * r__ - b; + +/* If eigenvectors are desired, then save rotations. */ + + if (icompz > 0) { + work[i__] = c__; + work[*n - 1 + i__] = s; + } + +/* L120: */ + } + +/* If eigenvectors are desired, then apply saved rotations. */ + + if (icompz > 0) { + mm = l - m + 1; + dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m + * z_dim1 + 1], ldz); + } + + d__[l] -= p; + e[lm1] = g; + goto L90; + +/* Eigenvalue found. */ + +L130: + d__[l] = p; + + --l; + if (l >= lend) { + goto L90; + } + goto L140; + + } + +/* Undo scaling if necessary */ + +L140: + if (iscale == 1) { + i__1 = lendsv - lsv + 1; + dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + i__1 = lendsv - lsv; + dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, + info); + } else if (iscale == 2) { + i__1 = lendsv - lsv + 1; + dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + i__1 = lendsv - lsv; + dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, + info); + } + +/* Check for no convergence to an eigenvalue after a total */ +/* of N*MAXIT iterations. */ + + if (jtot < nmaxit) { + goto L10; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } +/* L150: */ + } + goto L190; + +/* Order eigenvalues and eigenvectors. */ + +L160: + if (icompz == 0) { + +/* Use Quick Sort */ + + dlasrt_("I", n, &d__[1], info); + + } else { + +/* Use Selection Sort to minimize swaps of eigenvectors */ + + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + k = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] < p) { + k = j; + p = d__[j]; + } +/* L170: */ + } + if (k != i__) { + d__[k] = d__[i__]; + d__[i__] = p; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1], + &c__1); + } +/* L180: */ + } + } + +L190: + return 0; + +/* End of DSTEQR */ + +} /* dsteqr_ */ + +/* Subroutine */ int dsterf_(integer *n, double *d__, double *e, + integer *info) +{ + /* Table of constant values */ + static integer c__0 = 0; + static integer c__1 = 1; + static double c_b32 = 1.; + + /* System generated locals */ + integer i__1; + double d__1, d__2, d__3; + + /* Local variables */ + double c__; + integer i__, l, m; + double p, r__, s; + integer l1; + double bb, rt1, rt2, eps, rte; + integer lsv; + double eps2, oldc; + integer lend, jtot; + double gamma, alpha, sigma, anorm; + integer iscale; + double oldgam, safmin; + double safmax; + integer lendsv; + double ssfmin; + integer nmaxit; + double ssfmax; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix */ +/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the tridiagonal matrix. */ +/* On exit, if INFO = 0, the eigenvalues in ascending order. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix. */ +/* On exit, E has been destroyed. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: the algorithm failed to find all of the eigenvalues in */ +/* a total of 30*N iterations; if INFO = i, then i */ +/* elements of E have not converged to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("DSTERF", &i__1); + return 0; + } + if (*n <= 1) { + return 0; + } + +/* Determine the unit roundoff for this environment. */ + + eps = dlamch_("E"); +/* Computing 2nd power */ + d__1 = eps; + eps2 = d__1 * d__1; + safmin = dlamch_("S"); + safmax = 1. / safmin; + ssfmax = sqrt(safmax) / 3.; + ssfmin = sqrt(safmin) / eps2; + +/* Compute the eigenvalues of the tridiagonal matrix. */ + + nmaxit = *n * 30; + sigma = 0.; + jtot = 0; + +/* Determine where the matrix splits and choose QL or QR iteration */ +/* for each block, according to whether top or bottom diagonal */ +/* element is smaller. */ + + l1 = 1; + +L10: + if (l1 > *n) { + goto L170; + } + if (l1 > 1) { + e[l1 - 1] = 0.; + } + i__1 = *n - 1; + for (m = l1; m <= i__1; ++m) { + if ((d__3 = e[m], abs(d__3)) <= sqrt((d__1 = d__[m], abs(d__1))) * + sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) { + e[m] = 0.; + goto L30; + } +/* L20: */ + } + m = *n; + +L30: + l = l1; + lsv = l; + lend = m; + lendsv = lend; + l1 = m + 1; + if (lend == l) { + goto L10; + } + +/* Scale submatrix in rows and columns L to LEND */ + + i__1 = lend - l + 1; + anorm = dlanst_("I", &i__1, &d__[l], &e[l]); + iscale = 0; + if (anorm > ssfmax) { + iscale = 1; + i__1 = lend - l + 1; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, + info); + } else if (anorm < ssfmin) { + iscale = 2; + i__1 = lend - l + 1; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, + info); + i__1 = lend - l; + dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, + info); + } + + i__1 = lend - 1; + for (i__ = l; i__ <= i__1; ++i__) { +/* Computing 2nd power */ + d__1 = e[i__]; + e[i__] = d__1 * d__1; +/* L40: */ + } + +/* Choose between QL and QR iteration */ + + if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) { + lend = lsv; + l = lendsv; + } + + if (lend >= l) { + +/* QL Iteration */ + +/* Look for small subdiagonal element. */ + +L50: + if (l != lend) { + i__1 = lend - 1; + for (m = l; m <= i__1; ++m) { + if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m + + 1], abs(d__1))) { + goto L70; + } +/* L60: */ + } + } + m = lend; + +L70: + if (m < lend) { + e[m] = 0.; + } + p = d__[l]; + if (m == l) { + goto L90; + } + +/* If remaining matrix is 2 by 2, use DLAE2 to compute its */ +/* eigenvalues. */ + + if (m == l + 1) { + rte = sqrt(e[l]); + dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); + d__[l] = rt1; + d__[l + 1] = rt2; + e[l] = 0.; + l += 2; + if (l <= lend) { + goto L50; + } + goto L150; + } + + if (jtot == nmaxit) { + goto L150; + } + ++jtot; + +/* Form shift. */ + + rte = sqrt(e[l]); + sigma = (d__[l + 1] - p) / (rte * 2.); + r__ = dlapy2_(&sigma, &c_b32); + sigma = p - rte / (sigma + d_sign(&r__, &sigma)); + + c__ = 1.; + s = 0.; + gamma = d__[m] - sigma; + p = gamma * gamma; + +/* Inner loop */ + + i__1 = l; + for (i__ = m - 1; i__ >= i__1; --i__) { + bb = e[i__]; + r__ = p + bb; + if (i__ != m - 1) { + e[i__ + 1] = s * r__; + } + oldc = c__; + c__ = p / r__; + s = bb / r__; + oldgam = gamma; + alpha = d__[i__]; + gamma = c__ * (alpha - sigma) - s * oldgam; + d__[i__ + 1] = oldgam + (alpha - gamma); + if (c__ != 0.) { + p = gamma * gamma / c__; + } else { + p = oldc * bb; + } +/* L80: */ + } + + e[l] = s * p; + d__[l] = sigma + gamma; + goto L50; + +/* Eigenvalue found. */ + +L90: + d__[l] = p; + + ++l; + if (l <= lend) { + goto L50; + } + goto L150; + + } else { + +/* QR Iteration */ + +/* Look for small superdiagonal element. */ + +L100: + i__1 = lend + 1; + for (m = l; m >= i__1; --m) { + if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m + - 1], abs(d__1))) { + goto L120; + } +/* L110: */ + } + m = lend; + +L120: + if (m > lend) { + e[m - 1] = 0.; + } + p = d__[l]; + if (m == l) { + goto L140; + } + +/* If remaining matrix is 2 by 2, use DLAE2 to compute its */ +/* eigenvalues. */ + + if (m == l - 1) { + rte = sqrt(e[l - 1]); + dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); + d__[l] = rt1; + d__[l - 1] = rt2; + e[l - 1] = 0.; + l += -2; + if (l >= lend) { + goto L100; + } + goto L150; + } + + if (jtot == nmaxit) { + goto L150; + } + ++jtot; + +/* Form shift. */ + + rte = sqrt(e[l - 1]); + sigma = (d__[l - 1] - p) / (rte * 2.); + r__ = dlapy2_(&sigma, &c_b32); + sigma = p - rte / (sigma + d_sign(&r__, &sigma)); + + c__ = 1.; + s = 0.; + gamma = d__[m] - sigma; + p = gamma * gamma; + +/* Inner loop */ + + i__1 = l - 1; + for (i__ = m; i__ <= i__1; ++i__) { + bb = e[i__]; + r__ = p + bb; + if (i__ != m) { + e[i__ - 1] = s * r__; + } + oldc = c__; + c__ = p / r__; + s = bb / r__; + oldgam = gamma; + alpha = d__[i__ + 1]; + gamma = c__ * (alpha - sigma) - s * oldgam; + d__[i__] = oldgam + (alpha - gamma); + if (c__ != 0.) { + p = gamma * gamma / c__; + } else { + p = oldc * bb; + } +/* L130: */ + } + + e[l - 1] = s * p; + d__[l] = sigma + gamma; + goto L100; + +/* Eigenvalue found. */ + +L140: + d__[l] = p; + + --l; + if (l >= lend) { + goto L100; + } + goto L150; + + } + +/* Undo scaling if necessary */ + +L150: + if (iscale == 1) { + i__1 = lendsv - lsv + 1; + dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + } + if (iscale == 2) { + i__1 = lendsv - lsv + 1; + dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], + n, info); + } + +/* Check for no convergence to an eigenvalue after a total */ +/* of N*MAXIT iterations. */ + + if (jtot < nmaxit) { + goto L10; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } +/* L160: */ + } + goto L180; + +/* Sort eigenvalues in increasing order. */ + +L170: + dlasrt_("I", n, &d__[1], info); + +L180: + return 0; + +/* End of DSTERF */ + +} /* dsterf_ */ + +/* Subroutine */ int dstev_(const char *jobz, integer *n, double *d__, + double *e, double *z__, integer *ldz, double *work, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1; + double d__1; + + /* Local variables */ + double eps; + integer imax; + double rmin, rmax, tnrm; + double sigma; + bool wantz; + integer iscale; + double safmin; + double bignum; + double smlnum; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEV computes all eigenvalues and, optionally, eigenvectors of a */ +/* real symmetric tridiagonal matrix A. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the tridiagonal matrix */ +/* A. */ +/* On exit, if INFO = 0, the eigenvalues in ascending order. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix A, stored in elements 1 to N-1 of E. */ +/* On exit, the contents of E are destroyed. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ +/* eigenvectors of the matrix A, with the i-th column of Z */ +/* holding the eigenvector associated with D(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */ +/* If JOBZ = 'N', WORK is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the algorithm failed to converge; i */ +/* off-diagonal elements of E did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -6; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEV ", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + iscale = 1; + sigma = rmin / tnrm; + } else if (tnrm > rmax) { + iscale = 1; + sigma = rmax / tnrm; + } + if (iscale == 1) { + dscal_(n, &sigma, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &sigma, &e[1], &c__1); + } + +/* For eigenvalues only, call DSTERF. For eigenvalues and */ +/* eigenvectors, call DSTEQR. */ + + if (! wantz) { + dsterf_(n, &d__[1], &e[1], info); + } else { + dsteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &d__[1], &c__1); + } + + return 0; + +/* End of DSTEV */ + +} /* dstev_ */ + +/* Subroutine */ int dstevd_(const char *jobz, integer *n, double *d__, + double *e, double *z__, integer *ldz, double *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1; + double d__1; + + /* Local variables */ + double eps, rmin, rmax, tnrm; + double sigma; + integer lwmin; + bool wantz; + integer iscale; + double safmin; + double bignum; + integer liwmin; + double smlnum; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a */ +/* real symmetric tridiagonal matrix. If eigenvectors are desired, it */ +/* uses a divide and conquer algorithm. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the tridiagonal matrix */ +/* A. */ +/* On exit, if INFO = 0, the eigenvalues in ascending order. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix A, stored in elements 1 to N-1 of E. */ +/* On exit, the contents of E are destroyed. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */ +/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ +/* eigenvectors of the matrix A, with the i-th column of Z */ +/* holding the eigenvector associated with D(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace/output) 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 JOBZ = 'N' or N <= 1 then LWORK must be at least 1. */ +/* If JOBZ = 'V' and N > 1 then LWORK must be at least */ +/* ( 1 + 4*N + N**2 ). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal sizes of the WORK and IWORK */ +/* arrays, returns these values as the first entries of the WORK */ +/* and IWORK arrays, and no error message related to LWORK or */ +/* LIWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. */ +/* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal sizes of the WORK and */ +/* IWORK arrays, returns these values as the first entries of */ +/* the WORK and IWORK arrays, and no error message related to */ +/* LWORK or LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the algorithm failed to converge; i */ +/* off-diagonal elements of E did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + liwmin = 1; + lwmin = 1; + if (*n > 1 && wantz) { +/* Computing 2nd power */ + i__1 = *n; + lwmin = (*n << 2) + 1 + i__1 * i__1; + liwmin = *n * 5 + 3; + } + + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -6; + } + + if (*info == 0) { + work[1] = (double) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEVD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + iscale = 1; + sigma = rmin / tnrm; + } else if (tnrm > rmax) { + iscale = 1; + sigma = rmax / tnrm; + } + if (iscale == 1) { + dscal_(n, &sigma, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &sigma, &e[1], &c__1); + } + +/* For eigenvalues only, call DSTERF. For eigenvalues and */ +/* eigenvectors, call DSTEDC. */ + + if (! wantz) { + dsterf_(n, &d__[1], &e[1], info); + } else { + dstedc_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], lwork, + &iwork[1], liwork, info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &d__[1], &c__1); + } + + work[1] = (double) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DSTEVD */ + +} /* dstevd_ */ + +/* Subroutine */ int dstevr_(const char *jobz, const char *range, integer *n, double * + d__, double *e, double *vl, double *vu, integer *il, + integer *iu, double *abstol, integer *m, double *w, + double *z__, integer *ldz, integer *isuppz, double *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* Table of constant values */ + static integer c__10 = 10; + static integer c__1 = 1; + static integer c__2 = 2; + static integer c__3 = 3; + static integer c__4 = 4; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, jj; + double eps, vll, vuu, tmp1; + integer imax; + double rmin, rmax; + bool test; + double tnrm; + integer itmp1; + double sigma; + char order[1]; + integer lwmin; + bool wantz; + bool alleig, indeig; + integer iscale, ieeeok, indibl, indifl; + bool valeig; + double safmin; + double bignum; + integer indisp; + integer indiwo; + integer liwmin; + bool tryrac; + integer nsplit; + double smlnum; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEVR computes selected eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric tridiagonal matrix T. Eigenvalues and */ +/* eigenvectors can be selected by specifying either a range of values */ +/* or a range of indices for the desired eigenvalues. */ + +/* Whenever possible, DSTEVR calls DSTEMR to compute the */ +/* eigenspectrum using Relatively Robust Representations. DSTEMR */ +/* computes eigenvalues by the dqds algorithm, while orthogonal */ +/* eigenvectors are computed from various "good" L D L^T representations */ +/* (also known as Relatively Robust Representations). Gram-Schmidt */ +/* orthogonalization is avoided as far as possible. More specifically, */ +/* the various steps of the algorithm are as follows. For the i-th */ +/* unreduced block of T, */ +/* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T */ +/* is a relatively robust representation, */ +/* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high */ +/* relative accuracy by the dqds algorithm, */ +/* (c) If there is a cluster of close eigenvalues, "choose" sigma_i */ +/* close to the cluster, and go to step (a), */ +/* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, */ +/* compute the corresponding eigenvector by forming a */ +/* rank-revealing twisted factorization. */ +/* The desired accuracy of the output can be specified by the input */ +/* parameter ABSTOL. */ + +/* For more details, see "A new O(n^2) algorithm for the symmetric */ +/* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, */ +/* Computer Science Division Technical Report No. UCB//CSD-97-971, */ +/* UC Berkeley, May 1997. */ + + +/* Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested */ +/* on machines which conform to the ieee-754 floating point standard. */ +/* DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and */ +/* when partial spectrum requests are made. */ + +/* Normal execution of DSTEMR may create NaNs and infinities and */ +/* hence may abort due to a floating point exception in environments */ +/* which do not handle NaNs and infinities in the ieee standard default */ +/* manner. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ +/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ +/* ********* DSTEIN are called */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the tridiagonal matrix */ +/* A. */ +/* On exit, D may be multiplied by a constant factor chosen */ +/* to avoid over/underflow in computing the eigenvalues. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1)) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix A in elements 1 to N-1 of E. */ +/* On exit, E may be multiplied by a constant factor chosen */ +/* to avoid over/underflow in computing the eigenvalues. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less than */ +/* or equal to zero, then EPS*|T| will be used in its place, */ +/* where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* by reducing A to tridiagonal form. */ + +/* See "Computing Small Singular Values of Bidiagonal Matrices */ +/* with Guaranteed High Relative Accuracy," by Demmel and */ +/* Kahan, LAPACK Working Note #3. */ + +/* If high relative accuracy is important, set ABSTOL to */ +/* DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ +/* eigenvalues are computed to high relative accuracy when */ +/* possible in future releases. The current code does not */ +/* make any guarantees about high relative accuracy, but */ +/* future releases will. See J. Barlow and J. Demmel, */ +/* "Computing Accurate Eigensystems of Scaled Diagonally */ +/* Dominant Matrices", LAPACK Working Note #7, for a discussion */ +/* of which matrices define their eigenvalues to high relative */ +/* accuracy. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements contain the selected eigenvalues in */ +/* ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ +/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix A */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */ +/* The support of the eigenvectors in Z, i.e., the indices */ +/* indicating the nonzero elements in Z. The i-th eigenvector */ +/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* ISUPPZ( 2*i ). */ +/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal (and */ +/* minimal) LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,20*N). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal sizes of the WORK and IWORK */ +/* arrays, returns these values as the first entries of the WORK */ +/* and IWORK arrays, and no error message related to LWORK or */ +/* LIWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal (and */ +/* minimal) LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal sizes of the WORK and */ +/* IWORK arrays, returns these values as the first entries of */ +/* the WORK and IWORK arrays, and no error message related to */ +/* LWORK or LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: Internal error */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Inderjit Dhillon, IBM Almaden, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Ken Stanley, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + ieeeok = ilaenv_(&c__10, "DSTEVR", "N", &c__1, &c__2, &c__3, &c__4); + + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + lquery = *lwork == -1 || *liwork == -1; +/* Computing MAX */ + i__1 = 1, i__2 = *n * 20; + lwmin = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * 10; + liwmin = std::max(i__1,i__2); + + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -7; + } + } else if (indeig) { + if (*il < 1 || *il > std::max(1_integer,*n)) { + *info = -8; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -9; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -14; + } + } + + if (*info == 0) { + work[1] = (double) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -17; + } else if (*liwork < liwmin && ! lquery) { + *info = -19; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEVR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = d__[1]; + } else { + if (*vl < d__[1] && *vu >= d__[1]) { + *m = 1; + w[1] = d__[1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); + rmax = std::min(d__1,d__2); + + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + vll = *vl; + vuu = *vu; + + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + iscale = 1; + sigma = rmin / tnrm; + } else if (tnrm > rmax) { + iscale = 1; + sigma = rmax / tnrm; + } + if (iscale == 1) { + dscal_(n, &sigma, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &sigma, &e[1], &c__1); + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } +/* Initialize indices into workspaces. Note: These indices are used only */ +/* if DSTERF or DSTEMR fail. */ +/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */ +/* stores the block indices of each of the M<=N eigenvalues. */ + indibl = 1; +/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */ +/* stores the starting and finishing indices of each block. */ + indisp = indibl + *n; +/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ +/* that corresponding to eigenvectors that fail to converge in */ +/* DSTEIN. This information is discarded; if any fail, the driver */ +/* returns INFO > 0. */ + indifl = indisp + *n; +/* INDIWO is the offset of the remaining integer workspace. */ + indiwo = indisp + *n; + +/* If all eigenvalues are desired, then */ +/* call DSTERF or DSTEMR. If this fails for some eigenvalue, then */ +/* try DSTEBZ. */ + + + test = false; + if (indeig) { + if (*il == 1 && *iu == *n) { + test = true; + } + } + if ((alleig || test) && ieeeok == 1) { + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1); + if (! wantz) { + dcopy_(n, &d__[1], &c__1, &w[1], &c__1); + dsterf_(n, &w[1], &work[1], info); + } else { + dcopy_(n, &d__[1], &c__1, &work[*n + 1], &c__1); + if (*abstol <= *n * 2. * eps) { + tryrac = true; + } else { + tryrac = false; + } + i__1 = *lwork - (*n << 1); + dstemr_(jobz, "A", n, &work[*n + 1], &work[1], vl, vu, il, iu, m, + &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &work[ + (*n << 1) + 1], &i__1, &iwork[1], liwork, info); + + } + if (*info == 0) { + *m = *n; + goto L10; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, & + nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[1], &iwork[ + indiwo], info); + + if (wantz) { + dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], & + z__[z_offset], ldz, &work[1], &iwork[indiwo], &iwork[indifl], + info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L10: + if (iscale == 1) { + if (*info == 0) { + imax = *m; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + +/* If eigenvalues are not in order, then sort them, along with */ +/* eigenvectors. */ + + if (wantz) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp1 = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp1) { + i__ = jj; + tmp1 = w[jj]; + } +/* L20: */ + } + + if (i__ != 0) { + itmp1 = iwork[i__]; + w[i__] = w[j]; + iwork[i__] = iwork[j]; + w[j] = tmp1; + iwork[j] = itmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + } +/* L30: */ + } + } + +/* Causes problems with tests 19 & 20: */ +/* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 */ + + + work[1] = (double) lwmin; + iwork[1] = liwmin; + return 0; + +/* End of DSTEVR */ + +} /* dstevr_ */ + +/* Subroutine */ int dstevx_(const char *jobz, const char *range, integer *n, double * + d__, double *e, double *vl, double *vu, integer *il, + integer *iu, double *abstol, integer *m, double *w, + double *z__, integer *ldz, double *work, integer *iwork, + integer *ifail, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, jj; + double eps, vll, vuu, tmp1; + integer imax; + double rmin, rmax; + bool test; + double tnrm; + integer itmp1; + double sigma; + char order[1]; + bool wantz; + bool alleig, indeig; + integer iscale, indibl; + bool valeig; + double safmin; + double bignum; + integer indisp; + integer indiwo; + integer indwrk; + integer nsplit; + double smlnum; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSTEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric tridiagonal matrix A. Eigenvalues and */ +/* eigenvectors can be selected by specifying either a range of values */ +/* or a range of indices for the desired eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* N (input) INTEGER */ +/* The order of the matrix. N >= 0. */ + +/* D (input/output) DOUBLE PRECISION array, dimension (N) */ +/* On entry, the n diagonal elements of the tridiagonal matrix */ +/* A. */ +/* On exit, D may be multiplied by a constant factor chosen */ +/* to avoid over/underflow in computing the eigenvalues. */ + +/* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1)) */ +/* On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* matrix A in elements 1 to N-1 of E. */ +/* On exit, E may be multiplied by a constant factor chosen */ +/* to avoid over/underflow in computing the eigenvalues. */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less */ +/* than or equal to zero, then EPS*|T| will be used in */ +/* its place, where |T| is the 1-norm of the tridiagonal */ +/* matrix. */ + +/* Eigenvalues will be computed most accurately when ABSTOL is */ +/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* If this routine returns with INFO>0, indicating that some */ +/* eigenvectors did not converge, try setting ABSTOL to */ +/* 2*DLAMCH('S'). */ + +/* See "Computing Small Singular Values of Bidiagonal Matrices */ +/* with Guaranteed High Relative Accuracy," by Demmel and */ +/* Kahan, LAPACK Working Note #3. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements contain the selected eigenvalues in */ +/* ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */ +/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix A */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* If an eigenvector fails to converge (INFO > 0), then that */ +/* column of Z contains the latest approximation to the */ +/* eigenvector, and the index of the eigenvector is returned */ +/* in IFAIL. If JOBZ = 'N', then Z is not referenced. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) */ + +/* IWORK (workspace) INTEGER array, dimension (5*N) */ + +/* IFAIL (output) INTEGER array, dimension (N) */ +/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* indices of the eigenvectors that failed to converge. */ +/* If JOBZ = 'N', then IFAIL is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, then i eigenvectors failed to converge. */ +/* Their indices are stored in array IFAIL. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -7; + } + } else if (indeig) { + if (*il < 1 || *il > std::max(1_integer,*n)) { + *info = -8; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -9; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -14; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEVX", &i__1); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = d__[1]; + } else { + if (*vl < d__[1] && *vu >= d__[1]) { + *m = 1; + w[1] = d__[1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); + rmax = std::min(d__1,d__2); + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + if (valeig) { + vll = *vl; + vuu = *vu; + } else { + vll = 0.; + vuu = 0.; + } + tnrm = dlanst_("M", n, &d__[1], &e[1]); + if (tnrm > 0. && tnrm < rmin) { + iscale = 1; + sigma = rmin / tnrm; + } else if (tnrm > rmax) { + iscale = 1; + sigma = rmax / tnrm; + } + if (iscale == 1) { + dscal_(n, &sigma, &d__[1], &c__1); + i__1 = *n - 1; + dscal_(&i__1, &sigma, &e[1], &c__1); + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* If all eigenvalues are desired and ABSTOL is less than zero, then */ +/* call DSTERF or SSTEQR. If this fails for some eigenvalue, then */ +/* try DSTEBZ. */ + + test = false; + if (indeig) { + if (*il == 1 && *iu == *n) { + test = true; + } + } + if ((alleig || test) && *abstol <= 0.) { + dcopy_(n, &d__[1], &c__1, &w[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1); + indwrk = *n + 1; + if (! wantz) { + dsterf_(n, &w[1], &work[1], info); + } else { + dsteqr_("I", n, &w[1], &work[1], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L20; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indwrk = 1; + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, & + nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], & + iwork[indiwo], info); + + if (wantz) { + dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], & + z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1], + info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L20: + if (iscale == 1) { + if (*info == 0) { + imax = *m; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + +/* If eigenvalues are not in order, then sort them, along with */ +/* eigenvectors. */ + + if (wantz) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp1 = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp1) { + i__ = jj; + tmp1 = w[jj]; + } +/* L30: */ + } + + if (i__ != 0) { + itmp1 = iwork[indibl + i__ - 1]; + w[i__] = w[j]; + iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + w[j] = tmp1; + iwork[indibl + j - 1] = itmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + if (*info != 0) { + itmp1 = ifail[i__]; + ifail[i__] = ifail[j]; + ifail[j] = itmp1; + } + } +/* L40: */ + } + } + + return 0; + +/* End of DSTEVX */ + +} /* dstevx_ */ + +/* Subroutine */ int dsycon_(const char *uplo, integer *n, double *a, integer * + lda, integer *ipiv, double *anorm, double *rcond, double * + work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer i__, kase; + integer isave[3]; + bool upper; + double ainvnm; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYCON estimates the reciprocal of the condition number (in the */ +/* 1-norm) of a real symmetric matrix A using the factorization */ +/* A = U*D*U**T or A = L*D*L**T computed by DSYTRF. */ + +/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the details of the factorization are stored */ +/* as an upper or lower triangular matrix. */ +/* = 'U': Upper triangular, form is A = U*D*U**T; */ +/* = 'L': Lower triangular, form is A = L*D*L**T. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The block diagonal matrix D and the multipliers used to */ +/* obtain the factor U or L as computed by DSYTRF. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSYTRF. */ + +/* ANORM (input) DOUBLE PRECISION */ +/* The 1-norm of the original matrix A. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* estimate of the 1-norm of inv(A) computed in this routine. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else if (*anorm < 0.) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm <= 0.) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (i__ = *n; i__ >= 1; --i__) { + if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) { + return 0; + } +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L') or inv(U*D*U'). */ + + dsytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n, + info); + goto L30; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + + return 0; + +/* End of DSYCON */ + +} /* dsycon_ */ + +int dsyequb_(const char *uplo, integer *n, double *a, integer *lda, double *s, double *scond, + double *amax, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1, d__2, d__3; + + /* Local variables */ + double d__; + integer i__, j; + double t, u, c0, c1, c2, si; + bool up; + double avg, std, tol, base; + integer iter; + double smin, smax, scale, sumsq, bignum, smlnum; + + +/* -- LAPACK routine (version 3.2) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYEQUB computes row and column scalings intended to equilibrate a */ +/* symmetric matrix A and reduce its condition number */ +/* (with respect to the two-norm). S contains the scale factors, */ +/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */ +/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */ +/* choice of S puts the condition number of B within a factor N of the */ +/* smallest possible condition number over all possible diagonal */ +/* scalings. */ + +/* Arguments */ +/* ========= */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The N-by-N symmetric matrix whose scaling */ +/* factors are to be computed. Only the diagonal elements of A */ +/* are referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* S (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, S contains the scale factors for A. */ + +/* SCOND (output) DOUBLE PRECISION */ +/* If INFO = 0, S contains the ratio of the smallest S(i) to */ +/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */ +/* large nor too small, it is not worth scaling by S. */ + +/* AMAX (output) DOUBLE PRECISION */ +/* Absolute value of largest matrix element. If AMAX is very */ +/* close to overflow or very close to underflow, the matrix */ +/* should be scaled. */ +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */ + +/* Further Details */ +/* ======= ======= */ + +/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */ +/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */ +/* DOI 10.1023/B:NUMA.0000016606.32820.69 */ +/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --s; + --work; + + /* Function Body */ + *info = 0; + if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEQUB", &i__1); + return 0; + } + up = lsame_(uplo, "U"); + *amax = 0.; + +/* Quick return if possible. */ + + if (*n == 0) { + *scond = 1.; + return 0; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 0.; + } + *amax = 0.; + if (up) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + s[i__] = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + s[j] = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + *amax = std::max(d__2,d__3); + } +/* Computing MAX */ + d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); + s[j] = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); + *amax = std::max(d__2,d__3); + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); + s[j] = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1)); + *amax = std::max(d__2,d__3); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + s[i__] = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + s[j] = std::max(d__2,d__3); +/* Computing MAX */ + d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + *amax = std::max(d__2,d__3); + } + } + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + s[j] = 1. / s[j]; + } + tol = 1. / sqrt(*n * 2.); + for (iter = 1; iter <= 100; ++iter) { + scale = 0.; + sumsq = 0.; +/* BETA = |A|S */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + if (up) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ + j]; + work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ + i__]; + } + work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j]; + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j]; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ + j]; + work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[ + i__]; + } + } + } +/* avg = s^T beta / n */ + avg = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + avg += s[i__] * work[i__]; + } + avg /= *n; + std = 0.; + i__1 = *n * 3; + for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) { + work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg; + } + dlassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq); + std = scale * sqrt(sumsq / *n); + if (std < tol * avg) { + goto L999; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + t = (d__1 = a[i__ + i__ * a_dim1], abs(d__1)); + si = s[i__]; + c2 = (*n - 1) * t; + c1 = (*n - 2) * (work[i__] - t * si); + c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg; + d__ = c1 * c1 - c0 * 4 * c2; + if (d__ <= 0.) { + *info = -1; + return 0; + } + si = c0 * -2 / (c1 + sqrt(d__)); + d__ = si - s[i__]; + u = 0.; + if (up) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + u += s[j] * t; + work[j] += d__ * t; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + u += s[j] * t; + work[j] += d__ * t; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t = (d__1 = a[i__ + j * a_dim1], abs(d__1)); + u += s[j] * t; + work[j] += d__ * t; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + t = (d__1 = a[j + i__ * a_dim1], abs(d__1)); + u += s[j] * t; + work[j] += d__ * t; + } + } + avg += (u + work[i__]) * d__ / *n; + s[i__] = si; + } + } +L999: + smlnum = dlamch_("SAFEMIN"); + bignum = 1. / smlnum; + smin = bignum; + smax = 0.; + t = 1. / sqrt(avg); + base = dlamch_("B"); + u = 1. / log(base); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = (integer) (u * log(s[i__] * t)); + s[i__] = pow_di(&base, &i__2); +/* Computing MIN */ + d__1 = smin, d__2 = s[i__]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = smax, d__2 = s[i__]; + smax = std::max(d__1,d__2); + } + *scond = std::max(smin,smlnum) / std::min(smax,bignum); + + return 0; +} /* dsyequb_ */ + +/* Subroutine */ int dsyev_(const char *jobz, const char *uplo, integer *n, double *a, + integer *lda, double *w, double *work, integer *lwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__0 = 0; + static double c_b17 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer nb; + double eps; + integer inde; + double anrm; + integer imax; + double rmin, rmax; + double sigma; + integer iinfo; + bool lower, wantz; + integer iscale; + double safmin; + double bignum; + integer indtau; + integer indwrk; + integer llwork; + double smlnum; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYEV computes all eigenvalues and, optionally, eigenvectors of a */ +/* real symmetric matrix A. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of A contains the */ +/* upper triangular part of the matrix A. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of A contains */ +/* the lower triangular part of the matrix A. */ +/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* orthonormal eigenvectors of the matrix A. */ +/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */ +/* or the upper triangle (if UPLO='U') of A, including the */ +/* diagonal, is destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of the array WORK. LWORK >= max(1,3*N-1). */ +/* For optimal efficiency, LWORK >= (NB+2)*N, */ +/* where NB is the blocksize for DSYTRD returned by ILAENV. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the algorithm failed to converge; i */ +/* off-diagonal elements of an intermediate tridiagonal */ +/* form did not converge to zero. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --w; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } + + if (*info == 0) { + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); +/* Computing MAX */ + i__1 = 1, i__2 = (nb + 2) * *n; + lwkopt = std::max(i__1,i__2); + work[1] = (double) lwkopt; + +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3 - 1; + if (*lwork < std::max(i__1,i__2) && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = a[a_dim1 + 1]; + work[1] = 2.; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, + info); + } + +/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], & + work[indwrk], &llwork, &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DORGTR to generate the orthogonal matrix, then call DSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], & + llwork, &iinfo); + dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau], + info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (double) lwkopt; + + return 0; + +/* End of DSYEV */ + +} /* dsyev_ */ + +/* Subroutine */ int dsyevd_(const char *jobz, const char *uplo, integer *n, double * + a, integer *lda, double *w, double *work, integer *lwork, + integer *iwork, integer *liwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__0 = 0; + static double c_b17 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + double d__1; + + /* Local variables */ + double eps; + integer inde; + double anrm, rmin, rmax; + integer lopt; + double sigma; + integer iinfo, lwmin, liopt; + bool lower, wantz; + integer indwk2, llwrk2; + integer iscale; + double safmin; + double bignum; + integer indtau; + integer indwrk, liwmin; + integer llwork; + double smlnum; + bool lquery; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a */ +/* real symmetric matrix A. If eigenvectors are desired, it uses a */ +/* divide and conquer algorithm. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Because of large use of BLAS of level 3, DSYEVD needs N**2 more */ +/* workspace than DSYEVX. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of A contains the */ +/* upper triangular part of the matrix A. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of A contains */ +/* the lower triangular part of the matrix A. */ +/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* orthonormal eigenvectors of the matrix A. */ +/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */ +/* or the upper triangle (if UPLO='U') of A, including the */ +/* diagonal, is destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* WORK (workspace/output) 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 N <= 1, LWORK must be at least 1. */ +/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. */ +/* If JOBZ = 'V' and N > 1, LWORK must be at least */ +/* 1 + 6*N + 2*N**2. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal sizes of the WORK and IWORK */ +/* arrays, returns these values as the first entries of the WORK */ +/* and IWORK arrays, and no error message related to LWORK or */ +/* LIWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If N <= 1, LIWORK must be at least 1. */ +/* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */ +/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal sizes of the WORK and */ +/* IWORK arrays, returns these values as the first entries of */ +/* the WORK and IWORK arrays, and no error message related to */ +/* LWORK or LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed */ +/* to converge; i off-diagonal elements of an intermediate */ +/* tridiagonal form did not converge to zero; */ +/* if INFO = i and JOBZ = 'V', then the algorithm failed */ +/* to compute an eigenvalue while working on the submatrix */ +/* lying in rows and columns INFO/(N+1) through */ +/* mod(INFO,N+1). */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Jeff Rutter, Computer Science Division, University of California */ +/* at Berkeley, USA */ +/* Modified by Francoise Tisseur, University of Tennessee. */ + +/* Modified description of INFO. Sven, 16 Feb 05. */ +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ + +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --w; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } + + if (*info == 0) { + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + lopt = lwmin; + liopt = liwmin; + } else { + if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = (*n << 1) + 1; + } +/* Computing MAX */ + i__1 = lwmin, i__2 = (*n << 1) + ilaenv_(&c__1, "DSYTRD", uplo, n, + &c_n1, &c_n1, &c_n1); + lopt = std::max(i__1,i__2); + liopt = liwmin; + } + work[1] = (double) lopt; + iwork[1] = liopt; + + if (*lwork < lwmin && ! lquery) { + *info = -8; + } else if (*liwork < liwmin && ! lquery) { + *info = -10; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = a[a_dim1 + 1]; + if (wantz) { + a[a_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, + info); + } + +/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ + + inde = 1; + indtau = inde + *n; + indwrk = indtau + *n; + llwork = *lwork - indwrk + 1; + indwk2 = indwrk + *n * *n; + llwrk2 = *lwork - indwk2 + 1; + + dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], & + work[indwrk], &llwork, &iinfo); + lopt = (integer) ((*n << 1) + work[indwrk]); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ +/* tridiagonal matrix, then call DORMTR to multiply it by the */ +/* Householder transformations stored in A. */ + + if (! wantz) { + dsterf_(n, &w[1], &work[inde], info); + } else { + dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], & + llwrk2, &iwork[1], liwork, info); + dormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[ + indwrk], n, &work[indwk2], &llwrk2, &iinfo); + dlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda); +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; + i__1 = lopt, i__2 = *n * 6 + 1 + (i__3 * i__3 << 1); + lopt = std::max(i__1,i__2); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + d__1 = 1. / sigma; + dscal_(n, &d__1, &w[1], &c__1); + } + + work[1] = (double) lopt; + iwork[1] = liopt; + + return 0; + +/* End of DSYEVD */ + +} /* dsyevd_ */ + +/* Subroutine */ int dsyevr_(const char *jobz, const char *range, const char *uplo, integer *n, + double *a, integer *lda, double *vl, double *vu, integer * + il, integer *iu, double *abstol, integer *m, double *w, + double *z__, integer *ldz, integer *isuppz, double *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* Table of constant values */ + static integer c__10 = 10; + static integer c__1 = 1; + static integer c__2 = 2; + static integer c__3 = 3; + static integer c__4 = 4; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, nb, jj; + double eps, vll, vuu, tmp1; + integer indd, inde; + double anrm; + integer imax; + double rmin, rmax; + integer inddd, indee; + double sigma; + integer iinfo; + char order[1]; + integer indwk; + integer lwmin; + bool lower, wantz; + bool alleig, indeig; + integer iscale, ieeeok, indibl, indifl; + bool valeig; + double safmin; + double abstll, bignum; + integer indtau, indisp; + integer indiwo, indwkn; + integer liwmin; + bool tryrac; + integer llwrkn, llwork, nsplit; + double smlnum; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYEVR computes selected eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ +/* selected by specifying either a range of values or a range of */ +/* indices for the desired eigenvalues. */ + +/* DSYEVR first reduces the matrix A to tridiagonal form T with a call */ +/* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute */ +/* the eigenspectrum using Relatively Robust Representations. DSTEMR */ +/* computes eigenvalues by the dqds algorithm, while orthogonal */ +/* eigenvectors are computed from various "good" L D L^T representations */ +/* (also known as Relatively Robust Representations). Gram-Schmidt */ +/* orthogonalization is avoided as far as possible. More specifically, */ +/* the various steps of the algorithm are as follows. */ + +/* For each unreduced block (submatrix) of T, */ +/* (a) Compute T - sigma I = L D L^T, so that L and D */ +/* define all the wanted eigenvalues to high relative accuracy. */ +/* This means that small relative changes in the entries of D and L */ +/* cause only small relative changes in the eigenvalues and */ +/* eigenvectors. The standard (unfactored) representation of the */ +/* tridiagonal matrix T does not have this property in general. */ +/* (b) Compute the eigenvalues to suitable accuracy. */ +/* If the eigenvectors are desired, the algorithm attains full */ +/* accuracy of the computed eigenvalues only right before */ +/* the corresponding vectors have to be computed, see steps c) and d). */ +/* (c) For each cluster of close eigenvalues, select a new */ +/* shift close to the cluster, find a new factorization, and refine */ +/* the shifted eigenvalues to suitable accuracy. */ +/* (d) For each eigenvalue with a large enough relative separation compute */ +/* the corresponding eigenvector by forming a rank revealing twisted */ +/* factorization. Go back to (c) for any clusters that remain. */ + +/* The desired accuracy of the output can be specified by the input */ +/* parameter ABSTOL. */ + +/* For more details, see DSTEMR's documentation and: */ +/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ +/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ +/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ +/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ +/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ +/* 2004. Also LAPACK Working Note 154. */ +/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ +/* tridiagonal eigenvalue/eigenvector problem", */ +/* Computer Science Division Technical Report No. UCB/CSD-97-971, */ +/* UC Berkeley, May 1997. */ + + +/* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested */ +/* on machines which conform to the ieee-754 floating point standard. */ +/* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and */ +/* when partial spectrum requests are made. */ + +/* Normal execution of DSTEMR may create NaNs and infinities and */ +/* hence may abort due to a floating point exception in environments */ +/* which do not handle NaNs and infinities in the ieee standard default */ +/* manner. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ +/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ +/* ********* DSTEIN are called */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of A contains the */ +/* upper triangular part of the matrix A. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of A contains */ +/* the lower triangular part of the matrix A. */ +/* On exit, the lower triangle (if UPLO='L') or the upper */ +/* triangle (if UPLO='U') of A, including the diagonal, is */ +/* destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less than */ +/* or equal to zero, then EPS*|T| will be used in its place, */ +/* where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* by reducing A to tridiagonal form. */ + +/* See "Computing Small Singular Values of Bidiagonal Matrices */ +/* with Guaranteed High Relative Accuracy," by Demmel and */ +/* Kahan, LAPACK Working Note #3. */ + +/* If high relative accuracy is important, set ABSTOL to */ +/* DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ +/* eigenvalues are computed to high relative accuracy when */ +/* possible in future releases. The current code does not */ +/* make any guarantees about high relative accuracy, but */ +/* future releases will. See J. Barlow and J. Demmel, */ +/* "Computing Accurate Eigensystems of Scaled Diagonally */ +/* Dominant Matrices", LAPACK Working Note #7, for a discussion */ +/* of which matrices define their eigenvalues to high relative */ +/* accuracy. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* The first M elements contain the selected eigenvalues in */ +/* ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ +/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix A */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* If JOBZ = 'N', then Z is not referenced. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ +/* Supplying N columns is always safe. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */ +/* The support of the eigenvectors in Z, i.e., the indices */ +/* indicating the nonzero elements in Z. The i-th eigenvector */ +/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */ +/* ISUPPZ( 2*i ). */ +/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1,26*N). */ +/* For optimal efficiency, LWORK >= (NB+6)*N, */ +/* where NB is the max of the blocksize for DSYTRD and DORMTR */ +/* returned by ILAENV. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal size of the IWORK array, */ +/* returns this value as the first entry of the IWORK array, and */ +/* no error message related to LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: Internal error */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Inderjit Dhillon, IBM Almaden, USA */ +/* Osni Marques, LBNL/NERSC, USA */ +/* Ken Stanley, Computer Science Division, University of */ +/* California at Berkeley, USA */ +/* Jason Riedy, Computer Science Division, University of */ +/* California at Berkeley, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + ieeeok = ilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4); + + lower = lsame_(uplo, "L"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + lquery = *lwork == -1 || *liwork == -1; + +/* Computing MAX */ + i__1 = 1, i__2 = *n * 26; + lwmin = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * 10; + liwmin = std::max(i__1,i__2); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -8; + } + } else if (indeig) { + if (*il < 1 || *il > std::max(1_integer,*n)) { + *info = -9; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -10; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -15; + } else if (*lwork < lwmin && ! lquery) { + *info = -18; + } else if (*liwork < liwmin && ! lquery) { + *info = -20; + } + } + + if (*info == 0) { + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, & + c_n1); + nb = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = (nb + 1) * *n; + lwkopt = std::max(i__1,lwmin); + work[1] = (double) lwkopt; + iwork[1] = liwmin; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVR", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + work[1] = 1.; + return 0; + } + + if (*n == 1) { + work[1] = 7.; + if (alleig || indeig) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } else { + if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); + rmax = std::min(d__1,d__2); + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + abstll = *abstol; + vll = *vl; + vuu = *vu; + anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j + 1; + dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); +/* L10: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); +/* L20: */ + } + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } +/* Initialize indices into workspaces. Note: The IWORK indices are */ +/* used only if DSTERF or DSTEMR fail. */ +/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */ +/* elementary reflectors used in DSYTRD. */ + indtau = 1; +/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */ + indd = indtau + *n; +/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */ +/* tridiagonal matrix from DSYTRD. */ + inde = indd + *n; +/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */ +/* -written by DSTEMR (the DSTERF path copies the diagonal to W). */ + inddd = inde + *n; +/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */ +/* -written while computing the eigenvalues in DSTERF and DSTEMR. */ + indee = inddd + *n; +/* INDWK is the starting offset of the left-over workspace, and */ +/* LLWORK is the remaining workspace size. */ + indwk = indee + *n; + llwork = *lwork - indwk + 1; +/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */ +/* stores the block indices of each of the M<=N eigenvalues. */ + indibl = 1; +/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */ +/* stores the starting and finishing indices of each block. */ + indisp = indibl + *n; +/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */ +/* that corresponding to eigenvectors that fail to converge in */ +/* DSTEIN. This information is discarded; if any fail, the driver */ +/* returns INFO > 0. */ + indifl = indisp + *n; +/* INDIWO is the offset of the remaining integer workspace. */ + indiwo = indisp + *n; + +/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ + + dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ + indtau], &work[indwk], &llwork, &iinfo); + +/* If all eigenvalues are desired */ +/* then call DSTERF or DSTEMR and DORMTR. */ + + if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) { + if (! wantz) { + dcopy_(n, &work[indd], &c__1, &w[1], &c__1); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dcopy_(n, &work[indd], &c__1, &work[inddd], &c__1); + + if (*abstol <= *n * 0. * eps) { + tryrac = true; + } else { + tryrac = false; + } + dstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu, + m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, & + work[indwk], lwork, &iwork[1], liwork, info); + + + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + if (wantz && *info == 0) { + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau] +, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + } + + + if (*info == 0) { +/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are */ +/* undefined. */ + *m = *n; + goto L30; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */ +/* Also call DSTEBZ and DSTEIN if DSTEMR fails. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], & + iwork[indifl], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ + z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +/* Jump here if DSTEMR/DSTEIN succeeded. */ +L30: + if (iscale == 1) { + if (*info == 0) { + imax = *m; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + +/* If eigenvalues are not in order, then sort them, along with */ +/* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. */ +/* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do */ +/* not return this detailed information to the user. */ + + if (wantz) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp1 = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp1) { + i__ = jj; + tmp1 = w[jj]; + } +/* L40: */ + } + + if (i__ != 0) { + w[i__] = w[j]; + w[j] = tmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + } +/* L50: */ + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (double) lwkopt; + iwork[1] = liwmin; + + return 0; + +/* End of DSYEVR */ + +} /* dsyevr_ */ + +/* Subroutine */ int dsyevx_(const char *jobz, const char *range, const char *uplo, integer *n, + double *a, integer *lda, double *vl, double *vu, integer * + il, integer *iu, double *abstol, integer *m, double *w, + double *z__, integer *ldz, double *work, integer *lwork, + integer *iwork, integer *ifail, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, nb, jj; + double eps, vll, vuu, tmp1; + integer indd, inde; + double anrm; + integer imax; + double rmin, rmax; + bool test; + integer itmp1, indee; + double sigma; + integer iinfo; + char order[1]; + bool lower, wantz; + bool alleig, indeig; + integer iscale, indibl; + bool valeig; + double safmin; + double abstll, bignum; + integer indtau, indisp; + integer indiwo, indwkn; + integer indwrk, lwkmin; + integer llwrkn, llwork, nsplit; + double smlnum; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ +/* selected by specifying either a range of values or a range of indices */ +/* for the desired eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of A contains the */ +/* upper triangular part of the matrix A. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of A contains */ +/* the lower triangular part of the matrix A. */ +/* On exit, the lower triangle (if UPLO='L') or the upper */ +/* triangle (if UPLO='U') of A, including the diagonal, is */ +/* destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less than */ +/* or equal to zero, then EPS*|T| will be used in its place, */ +/* where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* by reducing A to tridiagonal form. */ + +/* Eigenvalues will be computed most accurately when ABSTOL is */ +/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* If this routine returns with INFO>0, indicating that some */ +/* eigenvectors did not converge, try setting ABSTOL to */ +/* 2*DLAMCH('S'). */ + +/* See "Computing Small Singular Values of Bidiagonal Matrices */ +/* with Guaranteed High Relative Accuracy," by Demmel and */ +/* Kahan, LAPACK Working Note #3. */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* On normal exit, the first M elements contain the selected */ +/* eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ +/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix A */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* If an eigenvector fails to converge, then that column of Z */ +/* contains the latest approximation to the eigenvector, and the */ +/* index of the eigenvector is returned in IFAIL. */ +/* If JOBZ = 'N', then Z is not referenced. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of the array WORK. LWORK >= 1, when N <= 1; */ +/* otherwise 8*N. */ +/* For optimal efficiency, LWORK >= (NB+3)*N, */ +/* where NB is the max of the blocksize for DSYTRD and DORMTR */ +/* returned by ILAENV. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (5*N) */ + +/* IFAIL (output) INTEGER array, dimension (N) */ +/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* indices of the eigenvectors that failed to converge. */ +/* If JOBZ = 'N', then IFAIL is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, then i eigenvectors failed to converge. */ +/* Their indices are stored in array IFAIL. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + lower = lsame_(uplo, "L"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + lquery = *lwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lower || lsame_(uplo, "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -8; + } + } else if (indeig) { + if (*il < 1 || *il > std::max(1_integer,*n)) { + *info = -9; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -10; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -15; + } + } + + if (*info == 0) { + if (*n <= 1) { + lwkmin = 1; + work[1] = (double) lwkmin; + } else { + lwkmin = *n << 3; + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, + &c_n1); + nb = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = lwkmin, i__2 = (nb + 3) * *n; + lwkopt = std::max(i__1,i__2); + work[1] = (double) lwkopt; + } + + if (*lwork < lwkmin && ! lquery) { + *info = -17; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYEVX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } else { + if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) { + *m = 1; + w[1] = a[a_dim1 + 1]; + } + } + if (wantz) { + z__[z_dim1 + 1] = 1.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); + rmax = std::min(d__1,d__2); + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + abstll = *abstol; + if (valeig) { + vll = *vl; + vuu = *vu; + } + anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + if (lower) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j + 1; + dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1); +/* L10: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1); +/* L20: */ + } + } + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */ + + indtau = 1; + inde = indtau + *n; + indd = inde + *n; + indwrk = indd + *n; + llwork = *lwork - indwrk + 1; + dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ + indtau], &work[indwrk], &llwork, &iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal to */ +/* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for */ +/* some eigenvalue, then try DSTEBZ. */ + + test = false; + if (indeig) { + if (*il == 1 && *iu == *n) { + test = true; + } + } + if ((alleig || test) && *abstol <= 0.) { + dcopy_(n, &work[indd], &c__1, &w[1], &c__1); + indee = indwrk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsterf_(n, &w[1], &work[indee], info); + } else { + dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz); + dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] +, &llwork, &iinfo); + i__1 = *n - 1; + dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); + dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ + indwrk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L30: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L40; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwo = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ + inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ + indwrk], &iwork[indiwo], info); + + if (wantz) { + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & + ifail[1], info); + +/* Apply orthogonal matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by DSTEIN. */ + + indwkn = inde; + llwrkn = *lwork - indwkn + 1; + dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ + z_offset], ldz, &work[indwkn], &llwrkn, &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L40: + if (iscale == 1) { + if (*info == 0) { + imax = *m; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + +/* If eigenvalues are not in order, then sort them, along with */ +/* eigenvectors. */ + + if (wantz) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp1 = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp1) { + i__ = jj; + tmp1 = w[jj]; + } +/* L50: */ + } + + if (i__ != 0) { + itmp1 = iwork[indibl + i__ - 1]; + w[i__] = w[j]; + iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + w[j] = tmp1; + iwork[indibl + j - 1] = itmp1; + dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + if (*info != 0) { + itmp1 = ifail[i__]; + ifail[i__] = ifail[j]; + ifail[j] = itmp1; + } + } +/* L60: */ + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (double) lwkopt; + + return 0; + +/* End of DSYEVX */ + +} /* dsyevx_ */ + +/* Subroutine */ int dsygs2_(integer *itype, const char *uplo, integer *n, + double *a, integer *lda, double *b, integer *ldb, integer * + info) +{ + /* Table of constant values */ + static double c_b6 = -1.; + static integer c__1 = 1; + static double c_b27 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer k; + double ct, akk, bkk; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYGS2 reduces a real symmetric-definite generalized eigenproblem */ +/* to standard form. */ + +/* If ITYPE = 1, the problem is A*x = lambda*B*x, */ +/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */ + +/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ +/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */ + +/* B must have been previously factorized as U'*U or L*L' by DPOTRF. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */ +/* = 2 or 3: compute U*A*U' or L'*A*L. */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored, and how B has been factorized. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n by n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n by n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if INFO = 0, the transformed matrix, stored in the */ +/* same format as A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */ +/* The triangular factor from the Cholesky factorization of B, */ +/* as returned by DPOTRF. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGS2", &i__1); + return 0; + } + + if (*itype == 1) { + if (upper) { + +/* Compute inv(U')*A*inv(U) */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Update the upper triangle of A(k:n,k:n) */ + + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; +/* Computing 2nd power */ + d__1 = bkk; + akk /= d__1 * d__1; + a[k + k * a_dim1] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( + k + 1) * a_dim1], lda); + i__2 = *n - k; + dsyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda, + &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1) + * a_dim1], lda); + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + ( + k + 1) * a_dim1], lda); + i__2 = *n - k; + dtrsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + ( + k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], + lda); + } +/* L10: */ + } + } else { + +/* Compute inv(L)*A*inv(L') */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Update the lower triangle of A(k:n,k:n) */ + + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; +/* Computing 2nd power */ + d__1 = bkk; + akk /= d__1 * d__1; + a[k + k * a_dim1] = akk; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1); + ct = akk * -.5; + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + + 1 + k * a_dim1], &c__1); + i__2 = *n - k; + dsyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1, + &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1) + * a_dim1], lda); + i__2 = *n - k; + daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + + 1 + k * a_dim1], &c__1); + i__2 = *n - k; + dtrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1 + + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1], + &c__1); + } +/* L20: */ + } + } + } else { + if (upper) { + +/* Compute U*A*U' */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Update the upper triangle of A(1:k,1:k) */ + + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + i__2 = k - 1; + dtrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset], + ldb, &a[k * a_dim1 + 1], &c__1); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + + 1], &c__1); + i__2 = k - 1; + dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k * + b_dim1 + 1], &c__1, &a[a_offset], lda); + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + + 1], &c__1); + i__2 = k - 1; + dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1); +/* Computing 2nd power */ + d__1 = bkk; + a[k + k * a_dim1] = akk * (d__1 * d__1); +/* L30: */ + } + } else { + +/* Compute L'*A*L */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Update the lower triangle of A(1:k,1:k) */ + + akk = a[k + k * a_dim1]; + bkk = b[k + k * b_dim1]; + i__2 = k - 1; + dtrmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset], + ldb, &a[k + a_dim1], lda); + ct = akk * .5; + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); + i__2 = k - 1; + dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k + + b_dim1], ldb, &a[a_offset], lda); + i__2 = k - 1; + daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda); + i__2 = k - 1; + dscal_(&i__2, &bkk, &a[k + a_dim1], lda); +/* Computing 2nd power */ + d__1 = bkk; + a[k + k * a_dim1] = akk * (d__1 * d__1); +/* L40: */ + } + } + } + return 0; + +/* End of DSYGS2 */ + +} /* dsygs2_ */ + +/* Subroutine */ int dsygst_(integer *itype, const char *uplo, integer *n, + double *a, integer *lda, double *b, integer *ldb, integer * + info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b14 = 1.; + static double c_b16 = -.5; + static double c_b19 = -1.; + static double c_b52 = .5; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + + /* Local variables */ + integer k, kb, nb; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYGST reduces a real symmetric-definite generalized eigenproblem */ +/* to standard form. */ + +/* If ITYPE = 1, the problem is A*x = lambda*B*x, */ +/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */ + +/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ +/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */ + +/* B must have been previously factorized as U**T*U or L*L**T by DPOTRF. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */ +/* = 2 or 3: compute U*A*U**T or L**T*A*L. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored and B is factored as */ +/* U**T*U; */ +/* = 'L': Lower triangle of A is stored and B is factored as */ +/* L*L**T. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if INFO = 0, the transformed matrix, stored in the */ +/* same format as A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */ +/* The triangular factor from the Cholesky factorization of B, */ +/* as returned by DPOTRF. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGST", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "DSYGST", uplo, n, &c_n1, &c_n1, &c_n1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dsygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + } else { + +/* Use blocked code */ + + if (*itype == 1) { + if (upper) { + +/* Compute inv(U')*A*inv(U) */ + + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { +/* Computing MIN */ + i__3 = *n - k + 1; + kb = std::min(i__3,nb); + +/* Update the upper triangle of A(k:n,k:n) */ + + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info); + if (k + kb <= *n) { + i__3 = *n - k - kb + 1; + dtrsm_("Left", uplo, "Transpose", "Non-unit", &kb, & + i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k + + (k + kb) * a_dim1], lda); + i__3 = *n - k - kb + 1; + dsymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * + a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, + &c_b14, &a[k + (k + kb) * a_dim1], lda); + i__3 = *n - k - kb + 1; + dsyr2k_(uplo, "Transpose", &i__3, &kb, &c_b19, &a[k + + (k + kb) * a_dim1], lda, &b[k + (k + kb) * + b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * + a_dim1], lda); + i__3 = *n - k - kb + 1; + dsymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * + a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, + &c_b14, &a[k + (k + kb) * a_dim1], lda); + i__3 = *n - k - kb + 1; + dtrsm_("Right", uplo, "No transpose", "Non-unit", &kb, + &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1] +, ldb, &a[k + (k + kb) * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute inv(L)*A*inv(L') */ + + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { +/* Computing MIN */ + i__3 = *n - k + 1; + kb = std::min(i__3,nb); + +/* Update the lower triangle of A(k:n,k:n) */ + + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info); + if (k + kb <= *n) { + i__3 = *n - k - kb + 1; + dtrsm_("Right", uplo, "Transpose", "Non-unit", &i__3, + &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k + + kb + k * a_dim1], lda); + i__3 = *n - k - kb + 1; + dsymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * + a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & + c_b14, &a[k + kb + k * a_dim1], lda); + i__3 = *n - k - kb + 1; + dsyr2k_(uplo, "No transpose", &i__3, &kb, &c_b19, &a[ + k + kb + k * a_dim1], lda, &b[k + kb + k * + b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * + a_dim1], lda); + i__3 = *n - k - kb + 1; + dsymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * + a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & + c_b14, &a[k + kb + k * a_dim1], lda); + i__3 = *n - k - kb + 1; + dtrsm_("Left", uplo, "No transpose", "Non-unit", & + i__3, &kb, &c_b14, &b[k + kb + (k + kb) * + b_dim1], ldb, &a[k + kb + k * a_dim1], lda); + } +/* L20: */ + } + } + } else { + if (upper) { + +/* Compute U*A*U' */ + + i__1 = *n; + i__2 = nb; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { +/* Computing MIN */ + i__3 = *n - k + 1; + kb = std::min(i__3,nb); + +/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */ + + i__3 = k - 1; + dtrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, & + kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1], + lda) + ; + i__3 = k - 1; + dsymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * + a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ + k * a_dim1 + 1], lda); + i__3 = k - 1; + dsyr2k_(uplo, "No transpose", &i__3, &kb, &c_b14, &a[k * + a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, + &a[a_offset], lda); + i__3 = k - 1; + dsymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * + a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[ + k * a_dim1 + 1], lda); + i__3 = k - 1; + dtrmm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb, + &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 + + 1], lda); + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info); +/* L30: */ + } + } else { + +/* Compute L'*A*L */ + + i__2 = *n; + i__1 = nb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { +/* Computing MIN */ + i__3 = *n - k + 1; + kb = std::min(i__3,nb); + +/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */ + + i__3 = k - 1; + dtrmm_("Right", uplo, "No transpose", "Non-unit", &kb, & + i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1], + lda); + i__3 = k - 1; + dsymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + + a_dim1], lda); + i__3 = k - 1; + dsyr2k_(uplo, "Transpose", &i__3, &kb, &c_b14, &a[k + + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[ + a_offset], lda); + i__3 = k - 1; + dsymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * + a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + + a_dim1], lda); + i__3 = k - 1; + dtrmm_("Left", uplo, "Transpose", "Non-unit", &kb, &i__3, + &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1], + lda); + dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + + k * b_dim1], ldb, info); +/* L40: */ + } + } + } + } + return 0; + +/* End of DSYGST */ + +} /* dsygst_ */ + +/* Subroutine */ int dsygv_(integer *itype, const char *jobz, const char *uplo, integer * + n, double *a, integer *lda, double *b, integer *ldb, + double *w, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b16 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer nb, neig; + char trans[1]; + bool upper; + bool wantz; + integer lwkmin; + integer lwkopt; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYGV computes all the eigenvalues, and optionally, the eigenvectors */ +/* of a real generalized symmetric-definite eigenproblem, of the form */ +/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */ +/* Here A and B are assumed to be symmetric and B is also */ +/* positive definite. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* Specifies the problem type to be solved: */ +/* = 1: A*x = (lambda)*B*x */ +/* = 2: A*B*x = (lambda)*x */ +/* = 3: B*A*x = (lambda)*x */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangles of A and B are stored; */ +/* = 'L': Lower triangles of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of A contains the */ +/* upper triangular part of the matrix A. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of A contains */ +/* the lower triangular part of the matrix A. */ + +/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* matrix Z of eigenvectors. The eigenvectors are normalized */ +/* as follows: */ +/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ +/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */ +/* or the lower triangle (if UPLO='L') of A, including the */ +/* diagonal, is destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the symmetric positive definite matrix B. */ +/* If UPLO = 'U', the leading N-by-N upper triangular part of B */ +/* contains the upper triangular part of the matrix B. */ +/* If UPLO = 'L', the leading N-by-N lower triangular part of B */ +/* contains the lower triangular part of the matrix B. */ + +/* On exit, if INFO <= N, the part of B containing the matrix is */ +/* overwritten by the triangular factor U or L from the Cholesky */ +/* factorization B = U**T*U or B = L*L**T. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of the array WORK. LWORK >= max(1,3*N-1). */ +/* For optimal efficiency, LWORK >= (NB+2)*N, */ +/* where NB is the blocksize for DSYTRD returned by ILAENV. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: DPOTRF or DSYEV returned an error code: */ +/* <= N: if INFO = i, DSYEV failed to converge; */ +/* i off-diagonal elements of an intermediate */ +/* tridiagonal form did not converge to zero; */ +/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ +/* minor of order i of B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --w; + --work; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3 - 1; + lwkmin = std::max(i__1,i__2); + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); +/* Computing MAX */ + i__1 = lwkmin, i__2 = (nb + 2) * *n; + lwkopt = std::max(i__1,i__2); + work[1] = (double) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -11; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpotrf_(uplo, n, &b[b_offset], ldb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + dsyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, info); + + if (wantz) { + +/* Backtransform eigenvectors to the original problem. */ + + neig = *n; + if (*info > 0) { + neig = *info - 1; + } + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + dtrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[ + b_offset], ldb, &a[a_offset], lda); + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U'*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + dtrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[ + b_offset], ldb, &a[a_offset], lda); + } + } + + work[1] = (double) lwkopt; + return 0; + +/* End of DSYGV */ + +} /* dsygv_ */ + +/* Subroutine */ int dsygvd_(integer *itype, const char *jobz, const char *uplo, integer * + n, double *a, integer *lda, double *b, integer *ldb, + double *w, double *work, integer *lwork, integer *iwork, + integer *liwork, integer *info) +{ + /* Table of constant values */ + static double c_b11 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + double d__1, d__2; + + /* Local variables */ + integer lopt; + integer lwmin; + char trans[1]; + integer liopt; + bool upper, wantz; + integer liwmin; + bool lquery; + + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYGVD computes all the eigenvalues, and optionally, the eigenvectors */ +/* of a real generalized symmetric-definite eigenproblem, of the form */ +/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ +/* B are assumed to be symmetric and B is also positive definite. */ +/* If eigenvectors are desired, it uses a divide and conquer algorithm. */ + +/* The divide and conquer algorithm makes very mild assumptions about */ +/* floating point arithmetic. It will work on machines with a guard */ +/* digit in add/subtract, or on those binary machines without guard */ +/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* without guard digits, but we know of none. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* Specifies the problem type to be solved: */ +/* = 1: A*x = (lambda)*B*x */ +/* = 2: A*B*x = (lambda)*x */ +/* = 3: B*A*x = (lambda)*x */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangles of A and B are stored; */ +/* = 'L': Lower triangles of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of A contains the */ +/* upper triangular part of the matrix A. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of A contains */ +/* the lower triangular part of the matrix A. */ + +/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */ +/* matrix Z of eigenvectors. The eigenvectors are normalized */ +/* as follows: */ +/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ +/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */ +/* or the lower triangle (if UPLO='L') of A, including the */ +/* diagonal, is destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, the symmetric matrix B. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of B contains the */ +/* upper triangular part of the matrix B. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of B contains */ +/* the lower triangular part of the matrix B. */ + +/* On exit, if INFO <= N, the part of B containing the matrix is */ +/* overwritten by the triangular factor U or L from the Cholesky */ +/* factorization B = U**T*U or B = L*L**T. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* If INFO = 0, the eigenvalues in ascending order. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* If N <= 1, LWORK >= 1. */ +/* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. */ +/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal sizes of the WORK and IWORK */ +/* arrays, returns these values as the first entries of the WORK */ +/* and IWORK arrays, and no error message related to LWORK or */ +/* LIWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If N <= 1, LIWORK >= 1. */ +/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */ +/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal sizes of the WORK and */ +/* IWORK arrays, returns these values as the first entries of */ +/* the WORK and IWORK arrays, and no error message related to */ +/* LWORK or LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: DPOTRF or DSYEVD returned an error code: */ +/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */ +/* failed to converge; i off-diagonal elements of an */ +/* intermediate tridiagonal form did not converge to */ +/* zero; */ +/* if INFO = i and JOBZ = 'V', then the algorithm */ +/* failed to compute an eigenvalue while working on */ +/* the submatrix lying in rows and columns INFO/(N+1) */ +/* through mod(INFO,N+1); */ +/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ +/* minor of order i of B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* Modified so that no backsubstitution is performed if DSYEVD fails to */ +/* converge (NEIG in old code could be greater than N causing out of */ +/* bounds reference to A - reported by Ralf Meyer). Also corrected the */ +/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */ +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --w; + --work; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1 || *liwork == -1; + + *info = 0; + if (*n <= 1) { + liwmin = 1; + lwmin = 1; + } else if (wantz) { + liwmin = *n * 5 + 3; +/* Computing 2nd power */ + i__1 = *n; + lwmin = *n * 6 + 1 + (i__1 * i__1 << 1); + } else { + liwmin = 1; + lwmin = (*n << 1) + 1; + } + lopt = lwmin; + liopt = liwmin; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } + + if (*info == 0) { + work[1] = (double) lopt; + iwork[1] = liopt; + + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGVD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpotrf_(uplo, n, &b[b_offset], ldb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + dsyevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &iwork[ + 1], liwork, info); +/* Computing MAX */ + d__1 = (double) lopt; + lopt = (integer) std::max(d__1,work[1]); +/* Computing MAX */ + d__1 = (double) liopt, d__2 = (double) iwork[1]; + liopt = (integer) std::max(d__1,d__2); + + if (wantz && *info == 0) { + +/* Backtransform eigenvectors to the original problem. */ + + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + dtrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset] +, ldb, &a[a_offset], lda); + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U'*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + dtrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset] +, ldb, &a[a_offset], lda); + } + } + + work[1] = (double) lopt; + iwork[1] = liopt; + + return 0; + +/* End of DSYGVD */ + +} /* dsygvd_ */ + +/* Subroutine */ int dsygvx_(integer *itype, const char *jobz, const char *range, const char * + uplo, integer *n, double *a, integer *lda, double *b, integer + *ldb, double *vl, double *vu, integer *il, integer *iu, + double *abstol, integer *m, double *w, double *z__, + integer *ldz, double *work, integer *lwork, integer *iwork, + integer *ifail, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static double c_b19 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2; + + /* Local variables */ + integer nb; + char trans[1]; + bool upper, wantz, alleig, indeig, valeig; + integer lwkmin; + integer lwkopt; + bool lquery; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYGVX computes selected eigenvalues, and optionally, eigenvectors */ +/* of a real generalized symmetric-definite eigenproblem, of the form */ +/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */ +/* and B are assumed to be symmetric and B is also positive definite. */ +/* Eigenvalues and eigenvectors can be selected by specifying either a */ +/* range of values or a range of indices for the desired eigenvalues. */ + +/* Arguments */ +/* ========= */ + +/* ITYPE (input) INTEGER */ +/* Specifies the problem type to be solved: */ +/* = 1: A*x = (lambda)*B*x */ +/* = 2: A*B*x = (lambda)*x */ +/* = 3: B*A*x = (lambda)*x */ + +/* JOBZ (input) CHARACTER*1 */ +/* = 'N': Compute eigenvalues only; */ +/* = 'V': Compute eigenvalues and eigenvectors. */ + +/* RANGE (input) CHARACTER*1 */ +/* = 'A': all eigenvalues will be found. */ +/* = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* will be found. */ +/* = 'I': the IL-th through IU-th eigenvalues will be found. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A and B are stored; */ +/* = 'L': Lower triangle of A and B are stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix pencil (A,B). N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of A contains the */ +/* upper triangular part of the matrix A. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of A contains */ +/* the lower triangular part of the matrix A. */ + +/* On exit, the lower triangle (if UPLO='L') or the upper */ +/* triangle (if UPLO='U') of A, including the diagonal, is */ +/* destroyed. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDA, N) */ +/* On entry, the symmetric matrix B. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of B contains the */ +/* upper triangular part of the matrix B. If UPLO = 'L', */ +/* the leading N-by-N lower triangular part of B contains */ +/* the lower triangular part of the matrix B. */ + +/* On exit, if INFO <= N, the part of B containing the matrix is */ +/* overwritten by the triangular factor U or L from the Cholesky */ +/* factorization B = U**T*U or B = L*L**T. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* VL (input) DOUBLE PRECISION */ +/* VU (input) DOUBLE PRECISION */ +/* If RANGE='V', the lower and upper bounds of the interval to */ +/* be searched for eigenvalues. VL < VU. */ +/* Not referenced if RANGE = 'A' or 'I'. */ + +/* IL (input) INTEGER */ +/* IU (input) INTEGER */ +/* If RANGE='I', the indices (in ascending order) of the */ +/* smallest and largest eigenvalues to be returned. */ +/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* Not referenced if RANGE = 'A' or 'V'. */ + +/* ABSTOL (input) DOUBLE PRECISION */ +/* The absolute error tolerance for the eigenvalues. */ +/* An approximate eigenvalue is accepted as converged */ +/* when it is determined to lie in an interval [a,b] */ +/* of width less than or equal to */ + +/* ABSTOL + EPS * max( |a|,|b| ) , */ + +/* where EPS is the machine precision. If ABSTOL is less than */ +/* or equal to zero, then EPS*|T| will be used in its place, */ +/* where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* by reducing A to tridiagonal form. */ + +/* Eigenvalues will be computed most accurately when ABSTOL is */ +/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* If this routine returns with INFO>0, indicating that some */ +/* eigenvectors did not converge, try setting ABSTOL to */ +/* 2*DLAMCH('S'). */ + +/* M (output) INTEGER */ +/* The total number of eigenvalues found. 0 <= M <= N. */ +/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ + +/* W (output) DOUBLE PRECISION array, dimension (N) */ +/* On normal exit, the first M elements contain the selected */ +/* eigenvalues in ascending order. */ + +/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */ +/* If JOBZ = 'N', then Z is not referenced. */ +/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* contain the orthonormal eigenvectors of the matrix A */ +/* corresponding to the selected eigenvalues, with the i-th */ +/* column of Z holding the eigenvector associated with W(i). */ +/* The eigenvectors are normalized as follows: */ +/* if ITYPE = 1 or 2, Z**T*B*Z = I; */ +/* if ITYPE = 3, Z**T*inv(B)*Z = I. */ + +/* If an eigenvector fails to converge, then that column of Z */ +/* contains the latest approximation to the eigenvector, and the */ +/* index of the eigenvector is returned in IFAIL. */ +/* Note: the user must ensure that at least max(1,M) columns are */ +/* supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* is not known in advance and an upper bound must be used. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1, and if */ +/* JOBZ = 'V', LDZ >= max(1,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of the array WORK. LWORK >= max(1,8*N). */ +/* For optimal efficiency, LWORK >= (NB+3)*N, */ +/* where NB is the blocksize for DSYTRD returned by ILAENV. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (5*N) */ + +/* IFAIL (output) INTEGER array, dimension (N) */ +/* If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* indices of the eigenvectors that failed to converge. */ +/* If JOBZ = 'N', then IFAIL is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: DPOTRF or DSYEVX returned an error code: */ +/* <= N: if INFO = i, DSYEVX failed to converge; */ +/* i eigenvectors failed to converge. Their indices */ +/* are stored in array IFAIL. */ +/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */ +/* minor of order i of B is not positive definite. */ +/* The factorization of B could not be completed and */ +/* no eigenvalues or eigenvectors were computed. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + --iwork; + --ifail; + + /* Function Body */ + upper = lsame_(uplo, "U"); + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + lquery = *lwork == -1; + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (alleig || valeig || indeig)) { + *info = -3; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -11; + } + } else if (indeig) { + if (*il < 1 || *il > std::max(1_integer,*n)) { + *info = -12; + } else if (*iu < std::min(*n,*il) || *iu > *n) { + *info = -13; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -18; + } + } + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 3; + lwkmin = std::max(i__1,i__2); + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); +/* Computing MAX */ + i__1 = lwkmin, i__2 = (nb + 3) * *n; + lwkopt = std::max(i__1,i__2); + work[1] = (double) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -20; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYGVX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + dpotrf_(uplo, n, &b[b_offset], ldb, info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); + dsyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol, + m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], &ifail[ + 1], info); + + if (wantz) { + +/* Backtransform eigenvectors to the original problem. */ + + if (*info > 0) { + *m = *info - 1; + } + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'T'; + } + + dtrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset] +, ldb, &z__[z_offset], ldz); + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U'*y */ + + if (upper) { + *(unsigned char *)trans = 'T'; + } else { + *(unsigned char *)trans = 'N'; + } + + dtrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset] +, ldb, &z__[z_offset], ldz); + } + } + +/* Set WORK(1) to optimal workspace size. */ + + work[1] = (double) lwkopt; + + return 0; + +/* End of DSYGVX */ + +} /* dsygvx_ */ + +/* Subroutine */ int dsyrfs_(const char *uplo, integer *n, integer *nrhs, + double *a, integer *lda, double *af, integer *ldaf, integer * + ipiv, double *b, integer *ldb, double *x, integer *ldx, + double *ferr, double *berr, double *work, integer *iwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b12 = -1.; + static double c_b14 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s, xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + integer count; + bool upper; + double safmin; + double lstres; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYRFS improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric indefinite, and */ +/* provides error bounds and backward error estimates for the solution. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of A contains the upper triangular part */ +/* of the matrix A, and the strictly lower triangular part of A */ +/* is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* triangular part of A contains the lower triangular part of */ +/* the matrix A, and the strictly upper triangular part of A is */ +/* not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* The factored form of the matrix A. AF contains the block */ +/* diagonal matrix D and the multipliers used to obtain the */ +/* factor U or L from the factorization A = U*D*U**T or */ +/* A = L*D*L**T as computed by DSYTRF. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSYTRF. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DSYTRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Internal Parameters */ +/* =================== */ + +/* ITMAX is the maximum number of steps of iterative refinement. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -10; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, + &c_b14, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ + i__ + j * x_dim1], abs(d__2)); +/* L40: */ + } + work[k] = work[k] + (d__1 = a[k + k * a_dim1], abs(d__1)) * + xk + s; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + work[k] += (d__1 = a[k + k * a_dim1], abs(d__1)) * xk; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ + i__ + j * x_dim1], abs(d__2)); +/* L60: */ + } + work[k] += s; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n + + 1], n, info); + daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A'). */ + + dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + *n + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L120: */ + } + dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + *n + 1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of DSYRFS */ + +} /* dsyrfs_ */ + +#if 0 +int dsyrfsx_(const char *uplo, const char *equed, integer *n, integer *nrhs, double *a, + integer *lda, double *af, integer *ldaf, integer *ipiv, double *s, double *b, integer *ldb, + double *x, integer *ldx, double *rcond, double *berr, integer *n_err_bnds__, + double *err_bnds_norm__, double *err_bnds_comp__, integer *nparams, double *params, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c_n1 = -1; + static integer c__0 = 0; + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + double d__1, d__2; + + /* Local variables */ + double illrcond_thresh__, unstable_thresh__, err_lbnd__; + integer ref_type__, j; + double rcond_tmp__; + integer prec_type__; + double cwise_wrong__; + char norm[1]; + bool ignore_cwise__; + double anorm; + bool rcequ; + integer ithresh, n_norms__; + double rthresh; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYRFSX improves the computed solution to a system of linear */ +/* equations when the coefficient matrix is symmetric indefinite, and */ +/* provides error bounds and backward error estimates for the */ +/* solution. In addition to normwise error bound, the code provides */ +/* maximum componentwise error bound if possible. See comments for */ +/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */ + +/* The original system of linear equations may have been equilibrated */ +/* before calling this routine, as described by arguments EQUED and S */ +/* below. In this case, the solution and error bounds returned are */ +/* for the original unequilibrated system. */ + +/* Arguments */ +/* ========= */ + +/* Some optional parameters are bundled in the PARAMS array. These */ +/* settings determine how refinement is performed, but often the */ +/* defaults are acceptable. If the defaults are acceptable, users */ +/* can pass NPARAMS = 0 which prevents the source code from accessing */ +/* the PARAMS argument. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* EQUED (input) CHARACTER*1 */ +/* Specifies the form of equilibration that was done to A */ +/* before calling this routine. This is needed to compute */ +/* the solution and error bounds correctly. */ +/* = 'N': No equilibration */ +/* = 'Y': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(S) * A * diag(S). */ +/* The right hand side B has been changed accordingly. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of A contains the upper triangular */ +/* part of the matrix A, and the strictly lower triangular */ +/* part of A is not referenced. If UPLO = 'L', the leading */ +/* N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* The factored form of the matrix A. AF contains the block */ +/* diagonal matrix D and the multipliers used to obtain the */ +/* factor U or L from the factorization A = U*D*U**T or A = */ +/* L*D*L**T as computed by DSYTRF. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSYTRF. */ + +/* S (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A. If EQUED = 'Y', A is multiplied on */ +/* the left and right by diag(S). S is an input argument if FACT = */ +/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ +/* = 'Y', each element of S must be positive. If S is output, each */ +/* element of S is a power of the radix. If S is input, each element */ +/* of S should be a power of the radix to ensure a reliable solution */ +/* and error estimates. Scaling by powers of the radix does not cause */ +/* rounding errors unless the result underflows or overflows. */ +/* Rounding errors during scaling lead to refining with a matrix that */ +/* is not equivalent to the input matrix, producing error estimates */ +/* that may not be reliable. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* On entry, the solution matrix X, as computed by DGETRS. */ +/* On exit, the improved solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* Reciprocal scaled condition number. This is an estimate of the */ +/* reciprocal Skeel condition number of the matrix A after */ +/* equilibration (if done). If this is less than the machine */ +/* precision (in particular, if it is zero), the matrix is singular */ +/* to working precision. Note that the error may still be small even */ +/* if this number is very small and the matrix appears ill- */ +/* conditioned. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* Componentwise relative backward error. This is the */ +/* componentwise relative backward error of each solution vector X(j) */ +/* (i.e., the smallest relative change in any element of A or B that */ +/* makes X(j) an exact solution). */ + +/* N_ERR_BNDS (input) INTEGER */ +/* Number of error bounds to return for each right hand side */ +/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* ERR_BNDS_COMP below. */ + +/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* For each right-hand side, this array contains information about */ +/* various error bounds and condition numbers corresponding to the */ +/* normwise relative error, which is defined as follows: */ + +/* Normwise relative error in the ith solution vector: */ +/* max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* ------------------------------ */ +/* max_j abs(X(j,i)) */ + +/* The array is indexed by the type of error information as described */ +/* below. There currently are up to three pieces of information */ +/* returned. */ + +/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* right-hand side. */ + +/* The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* three fields: */ +/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* reciprocal condition number is less than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). */ + +/* err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* almost certainly within a factor of 10 of the true error */ +/* so long as the next entry is greater than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* be trusted if the previous boolean is true. */ + +/* err = 3 Reciprocal condition number: Estimated normwise */ +/* reciprocal condition number. Compared with the threshold */ +/* sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* estimate is "guaranteed". These reciprocal condition */ +/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* appropriately scaled matrix Z. */ +/* Let Z = S*A, where S scales each row by a power of the */ +/* radix so all absolute row sums of Z are approximately 1. */ + +/* See Lapack Working Note 165 for further details and extra */ +/* cautions. */ + +/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* For each right-hand side, this array contains information about */ +/* various error bounds and condition numbers corresponding to the */ +/* componentwise relative error, which is defined as follows: */ + +/* Componentwise relative error in the ith solution vector: */ +/* abs(XTRUE(j,i) - X(j,i)) */ +/* max_j ---------------------- */ +/* abs(X(j,i)) */ + +/* The array is indexed by the right-hand side i (on which the */ +/* componentwise relative error depends), and the type of error */ +/* information as described below. There currently are up to three */ +/* pieces of information returned for each right-hand side. If */ +/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ +/* the first (:,N_ERR_BNDS) entries are returned. */ + +/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* right-hand side. */ + +/* The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* three fields: */ +/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* reciprocal condition number is less than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). */ + +/* err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* almost certainly within a factor of 10 of the true error */ +/* so long as the next entry is greater than the threshold */ +/* sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* be trusted if the previous boolean is true. */ + +/* err = 3 Reciprocal condition number: Estimated componentwise */ +/* reciprocal condition number. Compared with the threshold */ +/* sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* estimate is "guaranteed". These reciprocal condition */ +/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* appropriately scaled matrix Z. */ +/* Let Z = S*(A*diag(x)), where x is the solution for the */ +/* current right-hand side and S scales each row of */ +/* A*diag(x) by a power of the radix so all absolute row */ +/* sums of Z are approximately 1. */ + +/* See Lapack Working Note 165 for further details and extra */ +/* cautions. */ + +/* NPARAMS (input) INTEGER */ +/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */ +/* PARAMS array is never referenced and default values are used. */ + +/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */ +/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */ +/* that entry will be filled with default value used for that */ +/* parameter. Only positions up to NPARAMS are accessed; defaults */ +/* are used for higher-numbered parameters. */ + +/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* refinement or not. */ +/* Default: 1.0D+0 */ +/* = 0.0 : No refinement is performed, and no error bounds are */ +/* computed. */ +/* = 1.0 : Use the double-precision refinement algorithm, */ +/* possibly with doubled-single computations if the */ +/* compilation environment does not support DOUBLE */ +/* PRECISION. */ +/* (other values are reserved for future use) */ + +/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* computations allowed for refinement. */ +/* Default: 10 */ +/* Aggressive: Set to 100 to permit convergence using approximate */ +/* factorizations or factorizations other than LU. If */ +/* the factorization uses a technique other than */ +/* Gaussian elimination, the guarantees in */ +/* err_bnds_norm and err_bnds_comp may no longer be */ +/* trustworthy. */ + +/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* will attempt to find a solution with small componentwise */ +/* relative error in the double-precision algorithm. Positive */ +/* is true, 0.0 is false. */ +/* Default: 1.0 (attempt componentwise convergence) */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: Successful exit. The solution to every right-hand side is */ +/* guaranteed. */ +/* < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly singular, so */ +/* the solution and error bounds could not be computed. RCOND = 0 */ +/* is returned. */ +/* = N+J: The solution corresponding to the Jth right-hand side is */ +/* not guaranteed. The solutions corresponding to other right- */ +/* hand sides K with K > J may not be guaranteed as well, but */ +/* only the first such right-hand side is reported. If a small */ +/* componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* the Jth right-hand side is the first with a normwise error */ +/* bound that is not guaranteed (the smallest J such */ +/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* the Jth right-hand side is the first with either a normwise or */ +/* componentwise error bound that is not guaranteed (the smallest */ +/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* about all of the right-hand sides check ERR_BNDS_NORM or */ +/* ERR_BNDS_COMP. */ + +/* ================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Check the input parameters. */ + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --ipiv; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + ref_type__ = 1; + if (*nparams >= 1) { + if (params[1] < 0.) { + params[1] = 1.; + } else { + ref_type__ = (integer) params[1]; + } + } + +/* Set default parameters. */ + + illrcond_thresh__ = (double) (*n) * dlamch_("Epsilon"); + ithresh = 10; + rthresh = .5; + unstable_thresh__ = .25; + ignore_cwise__ = false; + + if (*nparams >= 2) { + if (params[2] < 0.) { + params[2] = (double) ithresh; + } else { + ithresh = (integer) params[2]; + } + } + if (*nparams >= 3) { + if (params[3] < 0.) { + if (ignore_cwise__) { + params[3] = 0.; + } else { + params[3] = 1.; + } + } else { + ignore_cwise__ = params[3] == 0.; + } + } + if (ref_type__ == 0 || *n_err_bnds__ == 0) { + n_norms__ = 0; + } else if (ignore_cwise__) { + n_norms__ = 1; + } else { + n_norms__ = 2; + } + + rcequ = lsame_(equed, "Y"); + +/* Test input parameters. */ + + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! rcequ && ! lsame_(equed, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -11; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYRFSX", &i__1); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *nrhs == 0) { + *rcond = 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 0.; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } else if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.; + } else if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.; + } + } + return 0; + } + +/* Default to failure. */ + + *rcond = 0.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 1.; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } else if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + } else if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.; + } + } + +/* Compute the norm of A and the reciprocal of the condition */ +/* number of A. */ + + *(unsigned char *)norm = 'I'; + anorm = dlansy_(norm, uplo, n, &a[a_offset], lda, &work[1]); + dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], + &iwork[1], info); + +/* Perform refinement on each right-hand side */ + + if (ref_type__ != 0) { + prec_type__ = ilaprec_("E"); + dla_syrfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda, + &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset], + ldb, &x[x_offset], ldx, &berr[1], &n_norms__, & + err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n << + 1) + 1], &work[1], rcond, &ithresh, &rthresh, & + unstable_thresh__, &ignore_cwise__, info, 1_integer); + } +/* Computing MAX */ + d__1 = 10., d__2 = sqrt((double) (*n)); + err_lbnd__ = std::max(d__1,d__2) * dlamch_("Epsilon"); + if (*n_err_bnds__ >= 1 && n_norms__ >= 1) { + +/* Compute scaled normwise condition number cond(A*C). */ + + if (rcequ) { + rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &c_n1, &s[1], info, &work[1], + &iwork[1], 1_integer); + } else { + rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &c__0, &s[1], info, &work[1], + &iwork[1], 1_integer); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 + << 1)] > 1.) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.; + err_bnds_norm__[j + err_bnds_norm_dim1] = 0.; + if (*info <= *n) { + *info = *n + j; + } + } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < + err_lbnd__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__; + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__; + } + } + } + if (*n_err_bnds__ >= 1 && n_norms__ >= 2) { + +/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */ +/* each right-hand side using the current solution as an estimate of */ +/* the true solution. If the componentwise error estimate is too */ +/* large, then the solution is a lousy estimate of truth and the */ +/* estimated RCOND may be too optimistic. To avoid misleading users, */ +/* the inverse condition number is set to 0.0 when the estimated */ +/* cwise error is at least CWISE_WRONG. */ + + cwise_wrong__ = sqrt(dlamch_("Epsilon")); + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + cwise_wrong__) { + rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &c__1, &x[j * x_dim1 + 1], + info, &work[1], &iwork[1], 1_integer); + } else { + rcond_tmp__ = 0.; + } + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 + << 1)] > 1.) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.; + err_bnds_comp__[j + err_bnds_comp_dim1] = 0.; + if (params[3] == 1. && *info < *n + j) { + *info = *n + j; + } + } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + err_lbnd__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__; + } + } + } + + return 0; + +/* End of DSYRFSX */ + +} /* dsyrfsx_ */ +#endif + +/* Subroutine */ int dsysv_(const char *uplo, integer *n, integer *nrhs, double + *a, integer *lda, integer *ipiv, double *b, integer *ldb, + double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer nb; + integer lwkopt; + bool lquery; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYSV computes the solution to a real system of linear equations */ +/* A * X = B, */ +/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* matrices. */ + +/* The diagonal pivoting method is used to factor A as */ +/* A = U * D * U**T, if UPLO = 'U', or */ +/* A = L * D * L**T, if UPLO = 'L', */ +/* where U (or L) is a product of permutation and unit upper (lower) */ +/* triangular matrices, and D is symmetric and block diagonal with */ +/* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */ +/* used to solve the system of equations A * X = B. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if INFO = 0, the block diagonal matrix D and the */ +/* multipliers used to obtain the factor U or L from the */ +/* factorization A = U*D*U**T or A = L*D*L**T as computed by */ +/* DSYTRF. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D, as */ +/* determined by DSYTRF. If IPIV(k) > 0, then rows and columns */ +/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */ +/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */ +/* then rows and columns k-1 and -IPIV(k) were interchanged and */ +/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */ +/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */ +/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */ +/* diagonal block. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of WORK. LWORK >= 1, and for best performance */ +/* LWORK >= max(1,N*NB), where NB is the optimal blocksize for */ +/* DSYTRF. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* has been completed, but the block diagonal matrix D is */ +/* exactly singular, so the solution could not be computed. */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } else if (*lwork < 1 && ! lquery) { + *info = -10; + } + + if (*info == 0) { + if (*n == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1); + lwkopt = *n * nb; + } + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSV ", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Compute the factorization A = U*D*U' or A = L*D*L'. */ + + dsytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + dsytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb, + info); + + } + + work[1] = (double) lwkopt; + + return 0; + +/* End of DSYSV */ + +} /* dsysv_ */ + +/* Subroutine */ int dsysvx_(const char *fact, const char *uplo, integer *n, integer * + nrhs, double *a, integer *lda, double *af, integer *ldaf, + integer *ipiv, double *b, integer *ldb, double *x, integer * + ldx, double *rcond, double *ferr, double *berr, + double *work, integer *lwork, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, i__1, i__2; + + /* Local variables */ + integer nb; + double anorm; + bool nofact; + integer lwkopt; + bool lquery; + +/* -- LAPACK driver routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYSVX uses the diagonal pivoting factorization to compute the */ +/* solution to a real system of linear equations A * X = B, */ +/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */ +/* matrices. */ + +/* Error bounds on the solution and a condition estimate are also */ +/* provided. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */ +/* The form of the factorization is */ +/* A = U * D * U**T, if UPLO = 'U', or */ +/* A = L * D * L**T, if UPLO = 'L', */ +/* where U (or L) is a product of permutation and unit upper (lower) */ +/* triangular matrices, and D is symmetric and block diagonal with */ +/* 1-by-1 and 2-by-2 diagonal blocks. */ + +/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */ +/* returns with INFO = i. Otherwise, the factored form of A is used */ +/* to estimate the condition number of the matrix A. If the */ +/* reciprocal of the condition number is less than machine precision, */ +/* INFO = N+1 is returned as a warning, but the routine still goes on */ +/* to solve for X and compute error bounds as described below. */ + +/* 3. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 4. Iterative refinement is applied to improve the computed solution */ +/* matrix and calculate error bounds and backward error estimates */ +/* for it. */ + +/* Arguments */ +/* ========= */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of A has been */ +/* supplied on entry. */ +/* = 'F': On entry, AF and IPIV contain the factored form of */ +/* A. AF and IPIV will not be modified. */ +/* = 'N': The matrix A will be copied to AF and factored. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of A contains the upper triangular part */ +/* of the matrix A, and the strictly lower triangular part of A */ +/* is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* triangular part of A contains the lower triangular part of */ +/* the matrix A, and the strictly upper triangular part of A is */ +/* not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* If FACT = 'F', then AF is an input argument and on entry */ +/* contains the block diagonal matrix D and the multipliers used */ +/* to obtain the factor U or L from the factorization */ +/* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF. */ + +/* If FACT = 'N', then AF is an output argument and on exit */ +/* returns the block diagonal matrix D and the multipliers used */ +/* to obtain the factor U or L from the factorization */ +/* A = U*D*U**T or A = L*D*L**T. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* IPIV (input or output) INTEGER array, dimension (N) */ +/* If FACT = 'F', then IPIV is an input argument and on entry */ +/* contains details of the interchanges and the block structure */ +/* of D, as determined by DSYTRF. */ +/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ + +/* If FACT = 'N', then IPIV is an output argument and on exit */ +/* contains details of the interchanges and the block structure */ +/* of D, as determined by DSYTRF. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The N-by-NRHS right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The estimate of the reciprocal condition number of the matrix */ +/* A. If RCOND is less than the machine precision (in */ +/* particular, if RCOND = 0), the matrix is singular to working */ +/* precision. This condition is indicated by a return code of */ +/* INFO > 0. */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of WORK. LWORK >= max(1,3*N), and for best */ +/* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where */ +/* NB is the optimal blocksize for DSYTRF. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, and i is */ +/* <= N: D(i,i) is exactly zero. The factorization */ +/* has been completed but the factor D is exactly */ +/* singular, so the solution and error bounds could */ +/* not be computed. RCOND = 0 is returned. */ +/* = N+1: D is nonsingular, but RCOND is less than machine */ +/* precision, meaning that the matrix is singular */ +/* to working precision. Nevertheless, the */ +/* solution and error bounds are computed because */ +/* there are a number of situations where the */ +/* computed solution can be more accurate than the */ +/* value of RCOND would suggest. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + lquery = *lwork == -1; + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -11; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -13; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3; + if (*lwork < std::max(i__1,i__2) && ! lquery) { + *info = -18; + } + } + + if (*info == 0) { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3; + lwkopt = std::max(i__1,i__2); + if (nofact) { + nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1); +/* Computing MAX */ + i__1 = lwkopt, i__2 = *n * nb; + lwkopt = std::max(i__1,i__2); + } + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSVX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + + if (nofact) { + +/* Compute the factorization A = U*D*U' or A = L*D*L'. */ + + dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + dsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork, + info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[1]); + +/* Compute the reciprocal of the condition number of A. */ + + dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], + &iwork[1], info); + +/* Compute the solution vectors X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, + info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + dsyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], + &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] +, &iwork[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + work[1] = (double) lwkopt; + + return 0; + +/* End of DSYSVX */ + +} /* dsysvx_ */ + +#if 0 +int dsysvxx_(const char *fact, const char *uplo, integer *n, integer * + nrhs, double *a, integer *lda, double *af, integer *ldaf, + integer *ipiv, char *equed, double *s, double *b, integer * + ldb, double *x, integer *ldx, double *rcond, double * + rpvgrw, double *berr, integer *n_err_bnds__, double * + err_bnds_norm__, double *err_bnds_comp__, integer *nparams, + double *params, double *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, + x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + double d__1, d__2; + + /* Local variables */ + integer j; + double amax, smin, smax; + double scond; + bool equil, rcequ, nofact; + double bignum; + integer infequ; + double smlnum; + + +/* -- LAPACK routine (version 3.2.1) -- */ +/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */ +/* -- Jason Riedy of Univ. of California Berkeley. -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley and NAG Ltd. -- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYSVXX uses the diagonal pivoting factorization to compute the */ +/* solution to a double precision system of linear equations A * X = B, where A */ +/* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. */ + +/* If requested, both normwise and maximum componentwise error bounds */ +/* are returned. DSYSVXX will return a solution with a tiny */ +/* guaranteed error (O(eps) where eps is the working machine */ +/* precision) unless the matrix is very ill-conditioned, in which */ +/* case a warning is returned. Relevant condition numbers also are */ +/* calculated and returned. */ + +/* DSYSVXX accepts user-provided factorizations and equilibration */ +/* factors; see the definitions of the FACT and EQUED options. */ +/* Solving with refinement and using a factorization from a previous */ +/* DSYSVXX call will also produce a solution with either O(eps) */ +/* errors or warnings, but we cannot make that claim for general */ +/* user-provided factorizations and equilibration factors if they */ +/* differ from what DSYSVXX would itself produce. */ + +/* Description */ +/* =========== */ + +/* The following steps are performed: */ + +/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */ +/* the system: */ + +/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */ + +/* Whether or not the system will be equilibrated depends on the */ +/* scaling of the matrix A, but if equilibration is used, A is */ +/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */ + +/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */ +/* the matrix A (after equilibration if FACT = 'E') as */ + +/* A = U * D * U**T, if UPLO = 'U', or */ +/* A = L * D * L**T, if UPLO = 'L', */ + +/* where U (or L) is a product of permutation and unit upper (lower) */ +/* triangular matrices, and D is symmetric and block diagonal with */ +/* 1-by-1 and 2-by-2 diagonal blocks. */ + +/* 3. If some D(i,i)=0, so that D is exactly singular, then the */ +/* routine returns with INFO = i. Otherwise, the factored form of A */ +/* is used to estimate the condition number of the matrix A (see */ +/* argument RCOND). If the reciprocal of the condition number is */ +/* less than machine precision, the routine still goes on to solve */ +/* for X and compute error bounds as described below. */ + +/* 4. The system of equations is solved for X using the factored form */ +/* of A. */ + +/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ +/* the routine will use iterative refinement to try to get a small */ +/* error and error bounds. Refinement calculates the residual to at */ +/* least twice the working precision. */ + +/* 6. If equilibration was used, the matrix X is premultiplied by */ +/* diag(R) so that it solves the original system before */ +/* equilibration. */ + +/* Arguments */ +/* ========= */ + +/* Some optional parameters are bundled in the PARAMS array. These */ +/* settings determine how refinement is performed, but often the */ +/* defaults are acceptable. If the defaults are acceptable, users */ +/* can pass NPARAMS = 0 which prevents the source code from accessing */ +/* the PARAMS argument. */ + +/* FACT (input) CHARACTER*1 */ +/* Specifies whether or not the factored form of the matrix A is */ +/* supplied on entry, and if not, whether the matrix A should be */ +/* equilibrated before it is factored. */ +/* = 'F': On entry, AF and IPIV contain the factored form of A. */ +/* If EQUED is not 'N', the matrix A has been */ +/* equilibrated with scaling factors given by S. */ +/* A, AF, and IPIV are not modified. */ +/* = 'N': The matrix A will be copied to AF and factored. */ +/* = 'E': The matrix A will be equilibrated if necessary, then */ +/* copied to AF and factored. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The number of linear equations, i.e., the order of the */ +/* matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of A contains the upper triangular */ +/* part of the matrix A, and the strictly lower triangular */ +/* part of A is not referenced. If UPLO = 'L', the leading */ +/* N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */ +/* diag(S)*A*diag(S). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */ +/* If FACT = 'F', then AF is an input argument and on entry */ +/* contains the block diagonal matrix D and the multipliers */ +/* used to obtain the factor U or L from the factorization A = */ +/* U*D*U**T or A = L*D*L**T as computed by DSYTRF. */ + +/* If FACT = 'N', then AF is an output argument and on exit */ +/* returns the block diagonal matrix D and the multipliers */ +/* used to obtain the factor U or L from the factorization A = */ +/* U*D*U**T or A = L*D*L**T. */ + +/* LDAF (input) INTEGER */ +/* The leading dimension of the array AF. LDAF >= max(1,N). */ + +/* IPIV (input or output) INTEGER array, dimension (N) */ +/* If FACT = 'F', then IPIV is an input argument and on entry */ +/* contains details of the interchanges and the block */ +/* structure of D, as determined by DSYTRF. If IPIV(k) > 0, */ +/* then rows and columns k and IPIV(k) were interchanged and */ +/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */ +/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */ +/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */ +/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */ +/* then rows and columns k+1 and -IPIV(k) were interchanged */ +/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ + +/* If FACT = 'N', then IPIV is an output argument and on exit */ +/* contains details of the interchanges and the block */ +/* structure of D, as determined by DSYTRF. */ + +/* EQUED (input or output) CHARACTER*1 */ +/* Specifies the form of equilibration that was done. */ +/* = 'N': No equilibration (always true if FACT = 'N'). */ +/* = 'Y': Both row and column equilibration, i.e., A has been */ +/* replaced by diag(S) * A * diag(S). */ +/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* output argument. */ + +/* S (input or output) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A. If EQUED = 'Y', A is multiplied on */ +/* the left and right by diag(S). S is an input argument if FACT = */ +/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */ +/* = 'Y', each element of S must be positive. If S is output, each */ +/* element of S is a power of the radix. If S is input, each element */ +/* of S should be a power of the radix to ensure a reliable solution */ +/* and error estimates. Scaling by powers of the radix does not cause */ +/* rounding errors unless the result underflows or overflows. */ +/* Rounding errors during scaling lead to refining with a matrix that */ +/* is not equivalent to the input matrix, producing error estimates */ +/* that may not be reliable. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the N-by-NRHS right hand side matrix B. */ +/* On exit, */ +/* if EQUED = 'N', B is not modified; */ +/* if EQUED = 'Y', B is overwritten by diag(S)*B; */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* If INFO = 0, the N-by-NRHS solution matrix X to the original */ +/* system of equations. Note that A and B are modified on exit if */ +/* EQUED .ne. 'N', and the solution to the equilibrated system is */ +/* inv(diag(S))*X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* Reciprocal scaled condition number. This is an estimate of the */ +/* reciprocal Skeel condition number of the matrix A after */ +/* equilibration (if done). If this is less than the machine */ +/* precision (in particular, if it is zero), the matrix is singular */ +/* to working precision. Note that the error may still be small even */ +/* if this number is very small and the matrix appears ill- */ +/* conditioned. */ + +/* RPVGRW (output) DOUBLE PRECISION */ +/* Reciprocal pivot growth. On exit, this contains the reciprocal */ +/* pivot growth factor norm(A)/norm(U). The "max absolute element" */ +/* norm is used. If this is much less than 1, then the stability of */ +/* the LU factorization of the (equilibrated) matrix A could be poor. */ +/* This also means that the solution X, estimated condition numbers, */ +/* and error bounds could be unreliable. If factorization fails with */ +/* 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* has been completed, but the factor U is exactly singular, so */ +/* the solution and error bounds could not be computed. RCOND = 0 */ +/* is returned. */ +/* = N+J: The solution corresponding to the Jth right-hand side is */ +/* not guaranteed. The solutions corresponding to other right- */ +/* hand sides K with K > J may not be guaranteed as well, but */ +/* only the first such right-hand side is reported. If a small */ +/* componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* the Jth right-hand side is the first with a normwise error */ +/* bound that is not guaranteed (the smallest J such */ +/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* the Jth right-hand side is the first with either a normwise or */ +/* componentwise error bound that is not guaranteed (the smallest */ +/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* about all of the right-hand sides check ERR_BNDS_NORM or */ +/* ERR_BNDS_COMP. */ + +/* ================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1; + err_bnds_norm__ -= err_bnds_norm_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1; + af -= af_offset; + --ipiv; + --s; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rcequ = false; + } else { + rcequ = lsame_(equed, "Y"); + } + +/* Default is failure. If an input parameter is wrong or */ +/* factorization fails, make everything look horrible. Only the */ +/* pivot growth is set here, the rest is initialized in DSYRFSX. */ + + *rpvgrw = 0.; + +/* Test the input parameters. PARAMS is not tested until DSYRFSX. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldaf < std::max(1_integer,*n)) { + *info = -8; + } else if (lsame_(fact, "F") && ! (rcequ || lsame_( + equed, "N"))) { + *info = -9; + } else { + if (rcequ) { + smin = bignum; + smax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = smin, d__2 = s[j]; + smin = std::min(d__1,d__2); +/* Computing MAX */ + d__1 = smax, d__2 = s[j]; + smax = std::max(d__1,d__2); +/* L10: */ + } + if (smin <= 0.) { + *info = -10; + } else if (*n > 0) { + scond = std::max(smin,smlnum) / min(smax,bignum); + } else { + scond = 1.; + } + } + if (*info == 0) { + if (*ldb < std::max(1_integer,*n)) { + *info = -12; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -14; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYSVXX", &i__1); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + dsyequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], & + infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed); + rcequ = lsame_(equed, "Y"); + } + } + +/* Scale the right-hand side. */ + + if (rcequ) { + dlascl2_(n, nrhs, &s[1], &b[b_offset], ldb); + } + + if (nofact || equil) { + +/* Compute the LU factorization of A. */ + + dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf); + i__1 = std::max(1_integer,*n) * 5; + dsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1, + info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Pivot in column INFO is exactly 0 */ +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + if (*n > 0) { + *rpvgrw = dla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, & + af[af_offset], ldaf, &ipiv[1], &work[1], 1_integer); + } + return 0; + } + } + +/* Compute the reciprocal pivot growth factor RPVGRW. */ + + if (*n > 0) { + *rpvgrw = dla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &af[ + af_offset], ldaf, &ipiv[1], &work[1], 1_integer); + } + +/* Compute the solution matrix X. */ + + dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + dsyrfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, & + ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, & + berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], & + err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[ + 1], &iwork[1], info); + +/* Scale solutions. */ + + if (rcequ) { + dlascl2_(n, nrhs, &s[1], &x[x_offset], ldx); + } + + return 0; + +/* End of DSYSVXX */ + +} /* dsysvxx_ */ +#endif + +/* Subroutine */ int dsytd2_(const char *uplo, integer *n, double *a, integer * + lda, double *d__, double *e, double *tau, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b8 = 0.; + static double c_b14 = -1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__; + double taui; + double alpha; + bool upper; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */ +/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored: */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n-by-n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n-by-n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ +/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ +/* of A are overwritten by the corresponding elements of the */ +/* tridiagonal matrix T, and the elements above the first */ +/* superdiagonal, with the array TAU, represent the orthogonal */ +/* matrix Q as a product of elementary reflectors; if UPLO */ +/* = 'L', the diagonal and first subdiagonal of A are over- */ +/* written by the corresponding elements of the tridiagonal */ +/* matrix T, and the elements below the first subdiagonal, 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,N). */ + +/* D (output) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of the tridiagonal matrix T: */ +/* D(i) = A(i,i). */ + +/* E (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The off-diagonal elements of the tridiagonal matrix T: */ +/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ + +/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The scalar factors of the elementary reflectors (see Further */ +/* Details). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ + +/* Further Details */ +/* =============== */ + +/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ +/* reflectors */ + +/* Q = H(n-1) . . . H(2) H(1). */ + +/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ +/* A(1:i-1,i+1), and tau in TAU(i). */ + +/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ +/* reflectors */ + +/* Q = H(1) H(2) . . . H(n-1). */ + +/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ +/* and tau in TAU(i). */ + +/* The contents of A on exit are illustrated by the following examples */ +/* with n = 5: */ + +/* if UPLO = 'U': if UPLO = 'L': */ + +/* ( d e v2 v3 v4 ) ( d ) */ +/* ( d e v3 v4 ) ( e d ) */ +/* ( d e v4 ) ( v1 e d ) */ +/* ( d e ) ( v1 v2 e d ) */ +/* ( d ) ( v1 v2 v3 e d ) */ + +/* where d and e denote diagonal and off-diagonal elements of T, and vi */ +/* denotes an element of the vector defining H(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tau; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTD2", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + if (upper) { + +/* Reduce the upper triangle of A */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) = I - tau * v * v' */ +/* to annihilate A(1:i-1,i+1) */ + + dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 + + 1], &c__1, &taui); + e[i__] = a[i__ + (i__ + 1) * a_dim1]; + + if (taui != 0.) { + +/* Apply H(i) from both sides to A(1:i,1:i) */ + + a[i__ + (i__ + 1) * a_dim1] = 1.; + +/* Compute x := tau * A * v storing x in TAU(1:i) */ + + dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * + a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1); + +/* Compute w := x - 1/2 * tau * (x'*v) * v */ + + alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1) + * a_dim1 + 1], &c__1); + daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ + 1], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w' - w * v' */ + + dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, + &tau[1], &c__1, &a[a_offset], lda); + + a[i__ + (i__ + 1) * a_dim1] = e[i__]; + } + d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1]; + tau[i__] = taui; +/* L10: */ + } + d__[1] = a[a_dim1 + 1]; + } else { + +/* Reduce the lower triangle of A */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) = I - tau * v * v' */ +/* to annihilate A(i+2:n,i) */ + + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[std::min(i__3, *n)+ i__ * + a_dim1], &c__1, &taui); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + + if (taui != 0.) { + +/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ + + a[i__ + 1 + i__ * a_dim1] = 1.; + +/* Compute x := tau * A * v storing y in TAU(i:n-1) */ + + i__2 = *n - i__; + dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[ + i__], &c__1); + +/* Compute w := x - 1/2 * tau * (x'*v) * v */ + + i__2 = *n - i__; + alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ + + 1 + i__ * a_dim1], &c__1); + i__2 = *n - i__; + daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w' - w * v' */ + + i__2 = *n - i__; + dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1, + &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], + lda); + + a[i__ + 1 + i__ * a_dim1] = e[i__]; + } + d__[i__] = a[i__ + i__ * a_dim1]; + tau[i__] = taui; +/* L20: */ + } + d__[*n] = a[*n + *n * a_dim1]; + } + + return 0; + +/* End of DSYTD2 */ + +} /* dsytd2_ */ + +/* Subroutine */ int dsytf2_(const char *uplo, integer *n, double *a, integer * + lda, integer *ipiv, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double t, r1, d11, d12, d21, d22; + integer kk, kp; + double wk, wkm1, wkp1; + integer imax, jmax; + double alpha; + integer kstep; + bool upper; + double absakk; + double colmax, rowmax; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYTF2 computes the factorization of a real symmetric matrix A using */ +/* the Bunch-Kaufman diagonal pivoting method: */ + +/* A = U*D*U' or A = L*D*L' */ + +/* where U (or L) is a product of permutation and unit upper (lower) */ +/* triangular matrices, U' is the transpose of U, and D is symmetric and */ +/* block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ + +/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* symmetric matrix A is stored: */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* n-by-n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n-by-n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, the block diagonal matrix D and the multipliers used */ +/* to obtain the factor U or L (see below for further details). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D. */ +/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* has been completed, but the block diagonal matrix D is */ +/* exactly singular, and division by zero will occur if it */ +/* is used to solve a system of equations. */ + +/* Further Details */ +/* =============== */ + +/* 09-29-06 - patch from */ +/* Bobby Cheng, MathWorks */ + +/* Replace l.204 and l.372 */ +/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */ +/* by */ +/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */ + +/* 01-01-96 - Based on modifications by */ +/* J. Lewis, Boeing Computer Services Company */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ +/* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */ +/* Company */ + +/* If UPLO = 'U', then A = U*D*U', where */ +/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ + +/* ( I v 0 ) k-s */ +/* U(k) = ( 0 I 0 ) s */ +/* ( 0 0 I ) n-k */ +/* k-s s n-k */ + +/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */ + +/* If UPLO = 'L', then A = L*D*L', where */ +/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ + +/* ( I 0 0 ) k-1 */ +/* L(k) = ( 0 I 0 ) s */ +/* ( 0 v I ) n-k-s+1 */ +/* k-1 s n-k-s+1 */ + +/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTF2", &i__1); + return 0; + } + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + + if (upper) { + +/* Factorize A as U*D*U' using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2 */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L70; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k > 1) { + i__1 = k - 1; + imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1); + colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (std::max(absakk,colmax) == 0. || disnan_(&absakk)) { + +/* Column K is zero or contains a NaN: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = k - imax; + jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * a_dim1], + lda); + rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); + if (imax > 1) { + i__1 = imax - 1; + jmax = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], + abs(d__1)); + rowmax = std::max(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >= + alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + + kk = k - kstep + 1; + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + i__1 = kp - 1; + dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], + &c__1); + i__1 = kk - kp - 1; + dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + t = a[kk + kk * a_dim1]; + a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = t; + if (kstep == 2) { + t = a[k - 1 + k * a_dim1]; + a[k - 1 + k * a_dim1] = a[kp + k * a_dim1]; + a[kp + k * a_dim1] = t; + } + } + +/* Update the leading submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ + +/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */ + + r1 = 1. / a[k + k * a_dim1]; + i__1 = k - 1; + d__1 = -r1; + dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[ + a_offset], lda); + +/* Store U(k) in column k */ + + i__1 = k - 1; + dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + +/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ + +/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */ +/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */ + + if (k > 2) { + + d12 = a[k - 1 + k * a_dim1]; + d22 = a[k - 1 + (k - 1) * a_dim1] / d12; + d11 = a[k + k * a_dim1] / d12; + t = 1. / (d11 * d22 - 1.); + d12 = t / d12; + + for (j = k - 2; j >= 1; --j) { + wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k + * a_dim1]); + wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]); + for (i__ = j; i__ >= 1; --i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + + k * a_dim1] * wk - a[i__ + (k - 1) * + a_dim1] * wkm1; +/* L20: */ + } + a[j + k * a_dim1] = wk; + a[j + (k - 1) * a_dim1] = wkm1; +/* L30: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + + } else { + +/* Factorize A as L*D*L' using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2 */ + + k = 1; +L40: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L70; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (d__1 = a[k + k * a_dim1], abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k < *n) { + i__1 = *n - k; + imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1); + colmax = (d__1 = a[imax + k * a_dim1], abs(d__1)); + } else { + colmax = 0.; + } + + if (std::max(absakk,colmax) == 0. || disnan_(&absakk)) { + +/* Column K is zero or contains a NaN: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = imax - k; + jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda); + rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1], + &c__1); +/* Computing MAX */ + d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1], + abs(d__1)); + rowmax = std::max(d__2,d__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >= + alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + + kk = k + kstep - 1; + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the trailing */ +/* submatrix A(k:n,k:n) */ + + if (kp < *n) { + i__1 = *n - kp; + dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + i__1 = kp - kk - 1; + dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + t = a[kk + kk * a_dim1]; + a[kk + kk * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = t; + if (kstep == 2) { + t = a[k + 1 + k * a_dim1]; + a[k + 1 + k * a_dim1] = a[kp + k * a_dim1]; + a[kp + k * a_dim1] = t; + } + } + +/* Update the trailing submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + + if (k < *n) { + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ + +/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */ + + d11 = 1. / a[k + k * a_dim1]; + i__1 = *n - k; + d__1 = -d11; + dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, & + a[k + 1 + (k + 1) * a_dim1], lda); + +/* Store L(k) in column K */ + + i__1 = *n - k; + dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1); + } + } else { + +/* 2-by-2 pivot block D(k) */ + + if (k < *n - 1) { + +/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ + +/* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))' */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th */ +/* columns of L */ + + d21 = a[k + 1 + k * a_dim1]; + d11 = a[k + 1 + (k + 1) * a_dim1] / d21; + d22 = a[k + k * a_dim1] / d21; + t = 1. / (d11 * d22 - 1.); + d21 = t / d21; + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + + wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]); + wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k + * a_dim1]); + + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + + k * a_dim1] * wk - a[i__ + (k + 1) * + a_dim1] * wkp1; +/* L50: */ + } + + a[j + k * a_dim1] = wk; + a[j + (k + 1) * a_dim1] = wkp1; + +/* L60: */ + } + } + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L40; + + } + +L70: + + return 0; + +/* End of DSYTF2 */ + +} /* dsytf2_ */ + +/* Subroutine */ int dsytrd_(const char *uplo, integer *n, double *a, integer * + lda, double *d__, double *e, double *tau, double * + work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + static double c_b22 = -1.; + static double c_b23 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, nb, kk, nx, iws; + integer nbmin, iinfo; + bool upper; + integer ldwork, lwkopt; + bool lquery; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYTRD reduces a real symmetric matrix A to real symmetric */ +/* tridiagonal form T by an orthogonal similarity transformation: */ +/* Q**T * A * Q = T. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ +/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */ +/* of A are overwritten by the corresponding elements of the */ +/* tridiagonal matrix T, and the elements above the first */ +/* superdiagonal, with the array TAU, represent the orthogonal */ +/* matrix Q as a product of elementary reflectors; if UPLO */ +/* = 'L', the diagonal and first subdiagonal of A are over- */ +/* written by the corresponding elements of the tridiagonal */ +/* matrix T, and the elements below the first subdiagonal, 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,N). */ + +/* D (output) DOUBLE PRECISION array, dimension (N) */ +/* The diagonal elements of the tridiagonal matrix T: */ +/* D(i) = A(i,i). */ + +/* E (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The off-diagonal elements of the tridiagonal matrix T: */ +/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ + +/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */ +/* The scalar factors of the elementary reflectors (see Further */ +/* Details). */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= 1. */ +/* For optimum performance LWORK >= N*NB, where NB is the */ +/* optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Further Details */ +/* =============== */ + +/* If UPLO = 'U', the matrix Q is represented as a product of elementary */ +/* reflectors */ + +/* Q = H(n-1) . . . H(2) H(1). */ + +/* 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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */ +/* A(1:i-1,i+1), and tau in TAU(i). */ + +/* If UPLO = 'L', the matrix Q is represented as a product of elementary */ +/* reflectors */ + +/* Q = H(1) H(2) . . . H(n-1). */ + +/* 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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */ +/* and tau in TAU(i). */ + +/* The contents of A on exit are illustrated by the following examples */ +/* with n = 5: */ + +/* if UPLO = 'U': if UPLO = 'L': */ + +/* ( d e v2 v3 v4 ) ( d ) */ +/* ( d e v3 v4 ) ( e d ) */ +/* ( d e v4 ) ( v1 e d ) */ +/* ( d e ) ( v1 v2 e d ) */ +/* ( d ) ( v1 v2 v3 e d ) */ + +/* where d and e denote diagonal and off-diagonal elements of T, and vi */ +/* denotes an element of the vector defining H(i). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --d__; + --e; + --tau; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else if (*lwork < 1 && ! lquery) { + *info = -9; + } + + if (*info == 0) { + +/* Determine the block size. */ + + nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); + lwkopt = *n * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRD", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + work[1] = 1.; + return 0; + } + + nx = *n; + iws = 1; + if (nb > 1 && nb < *n) { + +/* Determine when to cross over from blocked to unblocked code */ +/* (last block is always handled by unblocked code). */ + +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__3, "DSYTRD", uplo, n, &c_n1, &c_n1, & + c_n1); + nx = std::max(i__1,i__2); + if (nx < *n) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: determine the */ +/* minimum value of NB, and reduce NB or force use of */ +/* unblocked code by setting NX = N. */ + +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = std::max(i__1,1_integer); + nbmin = ilaenv_(&c__2, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1); + if (nb < nbmin) { + nx = *n; + } + } + } else { + nx = *n; + } + } else { + nb = 1; + } + + if (upper) { + +/* Reduce the upper triangle of A. */ +/* Columns 1:kk are handled by the unblocked method. */ + + kk = *n - (*n - nx + nb - 1) / nb * nb; + i__1 = kk + 1; + i__2 = -nb; + for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { + +/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ +/* matrix W which is needed to update the unreduced part of */ +/* the matrix */ + + i__3 = i__ + nb - 1; + dlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], & + work[1], &ldwork); + +/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */ +/* update of the form: A := A - V*W' - W*V' */ + + i__3 = i__ - 1; + dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 + + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda); + +/* Copy superdiagonal elements back into A, and diagonal */ +/* elements into D */ + + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j - 1 + j * a_dim1] = e[j - 1]; + d__[j] = a[j + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + +/* Use unblocked code to reduce the last or only block */ + + dsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo); + } else { + +/* Reduce the lower triangle of A */ + + i__2 = *n - nx; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + +/* Reduce columns i:i+nb-1 to tridiagonal form and form the */ +/* matrix W which is needed to update the unreduced part of */ +/* the matrix */ + + i__3 = *n - i__ + 1; + dlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], & + tau[i__], &work[1], &ldwork); + +/* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */ +/* an update of the form: A := A - V*W' - W*V' */ + + i__3 = *n - i__ - nb + 1; + dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + + i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[ + i__ + nb + (i__ + nb) * a_dim1], lda); + +/* Copy subdiagonal elements back into A, and diagonal */ +/* elements into D */ + + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + a[j + 1 + j * a_dim1] = e[j]; + d__[j] = a[j + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + +/* Use unblocked code to reduce the last or only block */ + + i__1 = *n - i__ + 1; + dsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], + &tau[i__], &iinfo); + } + + work[1] = (double) lwkopt; + return 0; + +/* End of DSYTRD */ + +} /* dsytrd_ */ + +/* Subroutine */ int dsytrf_(const char *uplo, integer *n, double *a, integer * + lda, integer *ipiv, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer j, k, kb, nb, iws; + + integer nbmin, iinfo; + bool upper; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYTRF computes the factorization of a real symmetric matrix A using */ +/* the Bunch-Kaufman diagonal pivoting method. The form of the */ +/* factorization is */ + +/* A = U*D*U**T or A = L*D*L**T */ + +/* where U (or L) is a product of permutation and unit upper (lower) */ +/* triangular matrices, and D is symmetric and block diagonal with */ +/* 1-by-1 and 2-by-2 diagonal blocks. */ + +/* This is the blocked version of the algorithm, calling Level 3 BLAS. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, the block diagonal matrix D and the multipliers used */ +/* to obtain the factor U or L (see below for further details). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (output) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D. */ +/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The length of WORK. LWORK >=1. For best performance */ +/* LWORK >= N*NB, where NB is the block size returned by ILAENV. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* has been completed, but the block diagonal matrix D is */ +/* exactly singular, and division by zero will occur if it */ +/* is used to solve a system of equations. */ + +/* Further Details */ +/* =============== */ + +/* If UPLO = 'U', then A = U*D*U', where */ +/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ + +/* ( I v 0 ) k-s */ +/* U(k) = ( 0 I 0 ) s */ +/* ( 0 0 I ) n-k */ +/* k-s s n-k */ + +/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */ + +/* If UPLO = 'L', then A = L*D*L', where */ +/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */ + +/* ( I 0 0 ) k-1 */ +/* L(k) = ( 0 I 0 ) s */ +/* ( 0 v I ) n-k-s+1 */ +/* k-1 s n-k-s+1 */ + +/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ + +/* ===================================================================== */ + +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } else if (*lwork < 1 && ! lquery) { + *info = -7; + } + + if (*info == 0) { + +/* Determine the block size */ + + nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1); + lwkopt = *n * nb; + work[1] = (double) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + + nbmin = 2; + ldwork = *n; + if (nb > 1 && nb < *n) { + iws = ldwork * nb; + if (*lwork < iws) { +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = std::max(i__1,1_integer); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DSYTRF", uplo, n, &c_n1, &c_n1, & + c_n1); + nbmin = std::max(i__1,i__2); + } + } else { + iws = 1; + } + if (nb < nbmin) { + nb = *n; + } + + if (upper) { + +/* Factorize A as U*D*U' using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* KB, where KB is the number of columns factorized by DLASYF; */ +/* KB is either NB or NB-1, or K for the last block */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L40; + } + + if (k > nb) { + +/* Factorize columns k-kb+1:k of A and use blocked code to */ +/* update columns 1:k-kb */ + + dlasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1], + &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns 1:k of A */ + + dsytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo); + kb = k; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kb; + goto L10; + + } else { + +/* Factorize A as L*D*L' using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* KB, where KB is the number of columns factorized by DLASYF; */ +/* KB is either NB or NB-1, or N-K+1 for the last block */ + + k = 1; +L20: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L40; + } + + if (k <= *n - nb) { + +/* Factorize columns k:k+kb-1 of A and use blocked code to */ +/* update columns k+kb:n */ + + i__1 = *n - k + 1; + dlasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], + &work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns k:n of A */ + + i__1 = *n - k + 1; + dsytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo); + kb = *n - k + 1; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo + k - 1; + } + +/* Adjust IPIV */ + + i__1 = k + kb - 1; + for (j = k; j <= i__1; ++j) { + if (ipiv[j] > 0) { + ipiv[j] = ipiv[j] + k - 1; + } else { + ipiv[j] = ipiv[j] - k + 1; + } +/* L30: */ + } + +/* Increase K and return to the start of the main loop */ + + k += kb; + goto L20; + + } + +L40: + work[1] = (double) lwkopt; + return 0; + +/* End of DSYTRF */ + +} /* dsytrf_ */ + +/* Subroutine */ int dsytri_(const char *uplo, integer *n, double *a, integer * + lda, integer *ipiv, double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b11 = -1.; + static double c_b13 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1; + double d__1; + + /* Local variables */ + double d__; + integer k; + double t, ak; + integer kp; + double akp1; + double temp, akkp1; + integer kstep; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYTRI computes the inverse of a real symmetric indefinite matrix */ +/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ +/* DSYTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the details of the factorization are stored */ +/* as an upper or lower triangular matrix. */ +/* = 'U': Upper triangular, form is A = U*D*U**T; */ +/* = 'L': Lower triangular, form is A = L*D*L**T. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the block diagonal matrix D and the multipliers */ +/* used to obtain the factor U or L as computed by DSYTRF. */ + +/* On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* matrix. If UPLO = 'U', the upper triangular part of the */ +/* inverse is formed and the part of A below the diagonal is not */ +/* referenced; if UPLO = 'L' the lower triangular part of the */ +/* inverse is formed and the part of A above the diagonal is */ +/* not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSYTRF. */ + +/* 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 */ +/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* inverse could not be computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRI", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U'. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L30: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L40; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * + a_dim1 + 1], &c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1)); + ak = a[k + k * a_dim1] / t; + akp1 = a[k + 1 + (k + 1) * a_dim1] / t; + akkp1 = a[k + (k + 1) * a_dim1] / t; + d__ = t * (ak * akp1 - 1.); + a[k + k * a_dim1] = akp1 / d__; + a[k + 1 + (k + 1) * a_dim1] = ak / d__; + a[k + (k + 1) * a_dim1] = -akkp1 / d__; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * + a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], & + c__1, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k - 1; + dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & + c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & + a[(k + 1) * a_dim1 + 1], &c__1); + } + kstep = 2; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the leading */ +/* submatrix A(1:k+1,1:k+1) */ + + i__1 = kp - 1; + dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + i__1 = k - kp - 1; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * + a_dim1], lda); + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + if (kstep == 2) { + temp = a[k + (k + 1) * a_dim1]; + a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1]; + a[kp + (k + 1) * a_dim1] = temp; + } + } + + k += kstep; + goto L30; +L40: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L'. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L50: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L60; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & + c__1); + i__1 = *n - k; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + + k * a_dim1], &c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1)); + ak = a[k - 1 + (k - 1) * a_dim1] / t; + akp1 = a[k + k * a_dim1] / t; + akkp1 = a[k + (k - 1) * a_dim1] / t; + d__ = t * (ak * akp1 - 1.); + a[k - 1 + (k - 1) * a_dim1] = akp1 / d__; + a[k + k * a_dim1] = ak / d__; + a[k + (k - 1) * a_dim1] = -akkp1 / d__; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & + c__1); + i__1 = *n - k; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + + k * a_dim1], &c__1); + i__1 = *n - k; + a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1] +, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1); + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & + c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1] +, &c__1); + i__1 = *n - k; + a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & + a[k + 1 + (k - 1) * a_dim1], &c__1); + } + kstep = 2; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the trailing */ +/* submatrix A(k-1:n,k-1:n) */ + + if (kp < *n) { + i__1 = *n - kp; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * + a_dim1], &c__1); + } + i__1 = kp - k - 1; + dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + if (kstep == 2) { + temp = a[k + (k - 1) * a_dim1]; + a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1]; + a[kp + (k - 1) * a_dim1] = temp; + } + } + + k -= kstep; + goto L50; +L60: + ; + } + + return 0; + +/* End of DSYTRI */ + +} /* dsytri_ */ + +/* Subroutine */ int dsytrs_(const char *uplo, integer *n, integer *nrhs, + double *a, integer *lda, integer *ipiv, double *b, integer * + ldb, integer *info) +{ + /* Table of constant values */ + static double c_b7 = -1.; + static integer c__1 = 1; + static double c_b19 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + double d__1; + + /* Local variables */ + integer j, k; + double ak, bk; + integer kp; + double akm1, bkm1; + double akm1k; + double denom; + bool upper; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DSYTRS solves a system of linear equations A*X = B with a real */ +/* symmetric matrix A using the factorization A = U*D*U**T or */ +/* A = L*D*L**T computed by DSYTRF. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the details of the factorization are stored */ +/* as an upper or lower triangular matrix. */ +/* = 'U': Upper triangular, form is A = U*D*U**T; */ +/* = 'L': Lower triangular, form is A = L*D*L**T. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The block diagonal matrix D and the multipliers used to */ +/* obtain the factor U or L as computed by DSYTRF. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* IPIV (input) INTEGER array, dimension (N) */ +/* Details of the interchanges and the block structure of D */ +/* as determined by DSYTRF. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U*D*U'. */ + +/* First solve U*D*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L10: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L30; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / a[k + k * a_dim1]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K-1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k - 1) { + dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in columns K-1 and K of A. */ + + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k - + 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + akm1k = a[k - 1 + k * a_dim1]; + akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k; + ak = a[k + k * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k - 1 + j * b_dim1] / akm1k; + bk = b[k + j * b_dim1] / akm1k; + b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L20: */ + } + k += -2; + } + + goto L10; +L30: + +/* Next solve U'*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L40: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(U'(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * + a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * + a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[(k + + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + b_dim1], + ldb); + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += 2; + } + + goto L40; +L50: + + ; + } else { + +/* Solve A*X = B, where A = L*D*L'. */ + +/* First solve L*D*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L60: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L80; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k + + b_dim1], ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / a[k + k * a_dim1]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K+1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k + 1) { + dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k < *n - 1) { + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k + + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1, + &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + akm1k = a[k + 1 + k * a_dim1]; + akm1 = a[k + k * a_dim1] / akm1k; + ak = a[k + 1 + (k + 1) * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k + j * b_dim1] / akm1k; + bk = b[k + 1 + j * b_dim1] / akm1k; + b[k + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L70: */ + } + k += 2; + } + + goto L60; +L80: + +/* Next solve L'*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L90: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L100; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(L'(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + + b_dim1], ldb); + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[ + k - 1 + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of DSYTRS */ + +} /* dsytrs_ */ diff --git a/external/clapack/lapack_dt.cpp b/external/clapack/lapack_dt.cpp new file mode 100644 index 00000000..fcbc1b0a --- /dev/null +++ b/external/clapack/lapack_dt.cpp @@ -0,0 +1,17343 @@ +#include "clapack.h" +#include "f2cP.h" + +/* Subroutine */ int dtbcon_(const char *norm, const char *uplo, const char *diag, integer *n, + integer *kd, double *ab, integer *ldab, double *rcond, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, i__1; + double d__1; + + /* Local variables */ + integer ix, kase, kase1; + double scale; + integer isave[3]; + double anorm; + bool upper; + double xnorm; + double ainvnm; + bool onenrm; + char normin[1]; + double smlnum; + bool nounit; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTBCON estimates the reciprocal of the condition number of a */ +/* triangular band matrix A, in either the 1-norm or the infinity-norm. */ + +/* The norm of A is computed and an estimate is obtained for */ +/* norm(inv(A)), then the reciprocal of the condition number is */ +/* computed as */ +/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies whether the 1-norm condition number or the */ +/* infinity-norm condition number is required: */ +/* = '1' or 'O': 1-norm; */ +/* = 'I': Infinity-norm. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals or subdiagonals of the */ +/* triangular band matrix A. KD >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The upper or lower triangular band matrix A, stored in the */ +/* first kd+1 rows of the array. The j-th column of A is stored */ +/* in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ +/* If DIAG = 'U', the diagonal elements of A are not referenced */ +/* and are assumed to be 1. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTBCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.; + return 0; + } + + *rcond = 0.; + smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = dlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + dlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + + 1], info) + ; + } else { + +/* Multiply by inv(A'). */ + + dlatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset] +, ldab, &work[1], &scale, &work[(*n << 1) + 1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + xnorm = (d__1 = work[ix], abs(d__1)); + if (scale < xnorm * smlnum || scale == 0.) { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of DTBCON */ + +} /* dtbcon_ */ + +/* Subroutine */ int dtbrfs_(const char *uplo, const char *trans, const char *diag, integer *n, + integer *kd, integer *nrhs, double *ab, integer *ldab, double + *b, integer *ldb, double *x, integer *ldx, double *ferr, + double *berr, double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b19 = -1.; + + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, + i__2, i__3, i__4, i__5; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s, xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + bool upper; + double safmin; + bool notran; + char transt[1]; + bool nounit; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTBRFS provides error bounds and backward error estimates for the */ +/* solution to a system of linear equations with a triangular band */ +/* coefficient matrix. */ + +/* The solution matrix X must be computed by DTBTRS or some other */ +/* means before entering this routine. DTBRFS does not do iterative */ +/* refinement because doing so cannot improve the backward error. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals or subdiagonals of the */ +/* triangular band matrix A. KD >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The upper or lower triangular band matrix A, stored in the */ +/* first kd+1 rows of the array. The j-th column of A is stored */ +/* in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ +/* If DIAG = 'U', the diagonal elements of A are not referenced */ +/* and are assumed to be 1. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* The solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -10; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTBRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *kd + 2; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A', depending on TRANS. */ + + dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*n + 1], + &c__1); + daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k; + for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) { + work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k * + ab_dim1], abs(d__1)) * xk; +/* L30: */ + } +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MAX */ + i__5 = 1, i__3 = k - *kd; + i__4 = k - 1; + for (i__ = std::max(i__5,i__3); i__ <= i__4; ++i__) { + work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k * + ab_dim1], abs(d__1)) * xk; +/* L50: */ + } + work[k] += xk; +/* L60: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MIN */ + i__5 = *n, i__3 = k + *kd; + i__4 = std::min(i__5,i__3); + for (i__ = k; i__ <= i__4; ++i__) { + work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1] + , abs(d__1)) * xk; +/* L70: */ + } +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MIN */ + i__5 = *n, i__3 = k + *kd; + i__4 = std::min(i__5,i__3); + for (i__ = k + 1; i__ <= i__4; ++i__) { + work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1] + , abs(d__1)) * xk; +/* L90: */ + } + work[k] += xk; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A')*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; +/* Computing MAX */ + i__4 = 1, i__5 = k - *kd; + i__3 = k; + for (i__ = std::max(i__4,i__5); i__ <= i__3; ++i__) { + s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1], + abs(d__1)) * (d__2 = x[i__ + j * x_dim1], + abs(d__2)); +/* L110: */ + } + work[k] += s; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k - 1; + for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) { + s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1], + abs(d__1)) * (d__2 = x[i__ + j * x_dim1], + abs(d__2)); +/* L130: */ + } + work[k] += s; +/* L140: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = std::min(i__3,i__4); + for (i__ = k; i__ <= i__5; ++i__) { + s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs( + d__1)) * (d__2 = x[i__ + j * x_dim1], abs( + d__2)); +/* L150: */ + } + work[k] += s; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = std::min(i__3,i__4); + for (i__ = k + 1; i__ <= i__5; ++i__) { + s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs( + d__1)) * (d__2 = x[i__ + j * x_dim1], abs( + d__2)); +/* L170: */ + } + work[k] += s; +/* L180: */ + } + } + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)'). */ + + dtbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[ + *n + 1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[* + n + 1], &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L240: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of DTBRFS */ + +} /* dtbrfs_ */ + +/* Subroutine */ int dtbtrs_(const char *uplo, const char *trans, const char *diag, integer *n, + integer *kd, integer *nrhs, double *ab, integer *ldab, double + *b, integer *ldb, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer j; + bool upper; + bool nounit; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTBTRS solves a triangular system of the form */ + +/* A * X = B or A**T * X = B, */ + +/* where A is a triangular band matrix of order N, and B is an */ +/* N-by NRHS matrix. A check is made to verify that A is nonsingular. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* KD (input) INTEGER */ +/* The number of superdiagonals or subdiagonals of the */ +/* triangular band matrix A. KD >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ +/* The upper or lower triangular band matrix A, stored in the */ +/* first kd+1 rows of AB. The j-th column of A is stored */ +/* in the j-th column of the array AB as follows: */ +/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ +/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ +/* If DIAG = 'U', the diagonal elements of A are not referenced */ +/* and are assumed to be 1. */ + +/* LDAB (input) INTEGER */ +/* The leading dimension of the array AB. LDAB >= KD+1. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, if INFO = 0, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* indicating that the matrix is singular and the */ +/* solutions X have not been computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTBTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + if (upper) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ab[*kd + 1 + *info * ab_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } else { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ab[*info * ab_dim1 + 1] == 0.) { + return 0; + } +/* L20: */ + } + } + } + *info = 0; + +/* Solve A * X = B or A' * X = B. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1 + + 1], &c__1); +/* L30: */ + } + + return 0; + +/* End of DTBTRS */ + +} /* dtbtrs_ */ + +int dtfsm_(const char *transr, const char *side, const char *uplo, const char *trans, + const char *diag, integer *m, integer *n, double *alpha, double *a, double *b, integer *ldb) +{ + /* Table of constant values */ + static double c_b23 = -1.; + static double c_b27 = 1.; + + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k, m1, m2, n1, n2, info; + bool normaltransr, lside, lower, misodd, nisodd, notrans; + + +/* -- LAPACK routine (version 3.2.1) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- April 2009 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* Level 3 BLAS like routine for A in RFP Format. */ + +/* DTFSM solves the matrix equation */ + +/* op( A )*X = alpha*B or X*op( A ) = alpha*B */ + +/* where alpha is a scalar, X and B are m by n matrices, 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'. */ + +/* A is in Rectangular Full Packed (RFP) Format. */ + +/* The matrix X is overwritten on B. */ + +/* Arguments */ +/* ========== */ + +/* TRANSR - (input) CHARACTER */ +/* = 'N': The Normal Form of RFP A is stored; */ +/* = 'T': The Transpose Form of RFP A is stored. */ + +/* SIDE - (input) CHARACTER */ +/* On entry, SIDE specifies whether op( A ) appears on the left */ +/* or right of X as follows: */ + +/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */ + +/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ + +/* Unchanged on exit. */ + +/* UPLO - (input) CHARACTER */ +/* On entry, UPLO specifies whether the RFP matrix A came from */ +/* an upper or lower triangular matrix as follows: */ +/* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */ +/* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */ + +/* Unchanged on exit. */ + +/* TRANS - (input) CHARACTER */ +/* On entry, TRANS specifies the form of op( A ) to be used */ +/* in the matrix multiplication as follows: */ + +/* TRANS = 'N' or 'n' op( A ) = A. */ + +/* TRANS = 'T' or 't' op( A ) = A'. */ + +/* Unchanged on exit. */ + +/* DIAG - (input) CHARACTER */ +/* On entry, DIAG specifies whether or not RFP 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 - (input) INTEGER. */ +/* On entry, M specifies the number of rows of B. M must be at */ +/* least zero. */ +/* Unchanged on exit. */ + +/* N - (input) INTEGER. */ +/* On entry, N specifies the number of columns of B. N must be */ +/* at least zero. */ +/* Unchanged on exit. */ + +/* ALPHA - (input) 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 - (input) DOUBLE PRECISION array, dimension (NT); */ +/* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. */ +/* RFP Format is described by TRANSR, UPLO and N as follows: */ +/* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */ +/* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */ +/* TRANSR = 'T' then RFP is the transpose of RFP A as */ +/* defined when TRANSR = 'N'. The contents of RFP A are defined */ +/* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT */ +/* elements of upper packed A either in normal or */ +/* transpose Format. If UPLO = 'L' the RFP A contains */ +/* the NT elements of lower packed A either in normal or */ +/* transpose Format. The LDA of RFP A is (N+1)/2 when */ +/* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */ +/* even and is N when is odd. */ +/* See the Note below for more details. Unchanged on exit. */ + +/* B - (input/ouptut) DOUBLE PRECISION array, DIMENSION (LDB,N) */ +/* Before entry, the leading m by n part of the array B must */ +/* contain the right-hand side matrix B, and on exit is */ +/* overwritten by the solution matrix X. */ + +/* LDB - (input) 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. */ + +/* Further Details */ +/* =============== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* Reference */ +/* ========= */ + +/* ===================================================================== */ + +/* .. */ +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb - 1 - 0 + 1; + b_offset = 0 + b_dim1 * 0; + b -= b_offset; + + /* Function Body */ + info = 0; + normaltransr = lsame_(transr, "N"); + lside = lsame_(side, "L"); + lower = lsame_(uplo, "L"); + notrans = lsame_(trans, "N"); + if (! normaltransr && ! lsame_(transr, "T")) { + info = -1; + } else if (! lside && ! lsame_(side, "R")) { + info = -2; + } else if (! lower && ! lsame_(uplo, "U")) { + info = -3; + } else if (! notrans && ! lsame_(trans, "T")) { + info = -4; + } else if (! lsame_(diag, "N") && ! lsame_(diag, + "U")) { + info = -5; + } else if (*m < 0) { + info = -6; + } else if (*n < 0) { + info = -7; + } else if (*ldb < std::max(1_integer,*m)) { + info = -11; + } + if (info != 0) { + i__1 = -info; + xerbla_("DTFSM ", &i__1); + return 0; + } + +/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Quick return when ALPHA.EQ.(0D+0) */ + + if (*alpha == 0.) { + i__1 = *n - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *m - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + return 0; + } + + if (lside) { + +/* SIDE = 'L' */ + +/* A is M-by-M. */ +/* If M is odd, set NISODD = .TRUE., and M1 and M2. */ +/* If M is even, NISODD = .FALSE., and M. */ + + if (*m % 2 == 0) { + misodd = false; + k = *m / 2; + } else { + misodd = true; + if (lower) { + m2 = *m / 2; + m1 = *m - m2; + } else { + m1 = *m / 2; + m2 = *m - m1; + } + } + + + if (misodd) { + +/* SIDE = 'L' and N is odd */ + + if (normaltransr) { + +/* SIDE = 'L', N is odd, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'N' */ + + if (*m == 1) { + dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &b[b_offset], ldb); + } else { + dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &b[b_offset], ldb); + dgemm_("N", "N", &m2, n, &m1, &c_b23, &a[m1], m, &b[b_offset], ldb, alpha, &b[m1], ldb); + dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[*m], m, &b[m1], ldb); + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'T' */ + + if (*m == 1) { + dtrsm_("L", "L", "T", diag, &m1, n, alpha, a, m, &b[b_offset], ldb); + } else { + dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m], m, &b[m1], ldb); + dgemm_("T", "N", &m1, n, &m2, &c_b23, &a[m1], m, &b[m1], ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, a, m, &b[b_offset], ldb); + } + + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'N' */ + + dtrsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m, &b[b_offset], ldb); + dgemm_("T", "N", &m2, n, &m1, &c_b23, a, m, &b[b_offset], ldb, alpha, &b[m1], ldb); + dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[m1], m, &b[m1], ldb); + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'T' */ + + dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m, &b[m1], ldb); + dgemm_("N", "N", &m1, n, &m2, &c_b23, a, m, &b[m1], ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, &a[m2], m, &b[b_offset], ldb); + + } + + } + + } else { + +/* SIDE = 'L', N is odd, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'N' */ + + if (*m == 1) { + dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb); + } else { + dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb); + dgemm_("T", "N", &m2, n, &m1, &c_b23, &a[m1 * m1], &m1, &b[b_offset], ldb, alpha, &b[m1], ldb); + dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[1], &m1, &b[m1], ldb); + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'T' */ + + if (*m == 1) { + dtrsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb); + } else { + dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[1], &m1, &b[m1], ldb); + dgemm_("N", "N", &m1, n, &m2, &c_b23, &a[m1 * m1], &m1, &b[m1], ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, a, &m1, &b[b_offset], ldb); + } + + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'N' */ + + dtrsm_("L", "U", "T", diag, &m1, n, alpha, &a[m2 * m2], &m2, &b[b_offset], ldb); + dgemm_("N", "N", &m2, n, &m1, &c_b23, a, &m2, &b[b_offset], ldb, alpha, &b[m1], ldb); + dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[m1 * m2], &m2, &b[m1], ldb); + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'T' */ + + dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[m1 * m2], &m2, &b[m1], ldb); + dgemm_("T", "N", &m1, n, &m2, &c_b23, a, &m2, &b[m1], ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, &a[m2 * m2], &m2, &b[b_offset], ldb); + + } + + } + + } + + } else { + +/* SIDE = 'L' and N is even */ + + if (normaltransr) { + +/* SIDE = 'L', N is even, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'N' */ + + i__1 = *m + 1; + dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[1], &i__1, &b[b_offset], ldb); + i__1 = *m + 1; + dgemm_("N", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, &b[b_offset], ldb, alpha, &b[k], ldb); + i__1 = *m + 1; + dtrsm_("L", "U", "T", diag, &k, n, &c_b27, a, &i__1, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'T' */ + + i__1 = *m + 1; + dtrsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, &b[k], ldb); + i__1 = *m + 1; + dgemm_("T", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, &b[k], ldb, alpha, &b[b_offset], ldb); + i__1 = *m + 1; + dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[1], &i__1, &b[b_offset], ldb); + + } + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'N' */ + + i__1 = *m + 1; + dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], &i__1, &b[b_offset], ldb); + i__1 = *m + 1; + dgemm_("T", "N", &k, n, &k, &c_b23, a, &i__1, &b[b_offset], ldb, alpha, &b[k], ldb); + i__1 = *m + 1; + dtrsm_("L", "U", "T", diag, &k, n, &c_b27, &a[k], &i__1, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'T' */ + i__1 = *m + 1; + dtrsm_("L", "U", "N", diag, &k, n, alpha, &a[k], &i__1, &b[k], ldb); + i__1 = *m + 1; + dgemm_("N", "N", &k, n, &k, &c_b23, a, &i__1, &b[k], ldb, alpha, &b[b_offset], ldb); + i__1 = *m + 1; + dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[k + 1], &i__1, &b[b_offset], ldb); + + } + + } + + } else { + +/* SIDE = 'L', N is even, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'N' */ + + dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k], &k, &b[b_offset], ldb); + dgemm_("T", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &k, &b[b_offset], ldb, alpha, &b[k], ldb); + dtrsm_("L", "L", "N", diag, &k, n, &c_b27, a, &k, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'T' */ + + dtrsm_("L", "L", "T", diag, &k, n, alpha, a, &k, &b[k], ldb); + dgemm_("N", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &k, &b[k], ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k], &k, &b[b_offset], ldb); + + } + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'N' */ + + dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k * (k + 1)], &k, &b[b_offset], ldb); + dgemm_("N", "N", &k, n, &k, &c_b23, a, &k, &b[b_offset], ldb, alpha, &b[k], ldb); + dtrsm_("L", "L", "N", diag, &k, n, &c_b27, &a[k * k], &k, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'T' */ + + dtrsm_("L", "L", "T", diag, &k, n, alpha, &a[k * k], &k, &b[k], ldb); + dgemm_("T", "N", &k, n, &k, &c_b23, a, &k, &b[k], ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k * (k + 1)], &k, &b[b_offset], ldb); + + } + + } + + } + + } + + } else { + +/* SIDE = 'R' */ + +/* A is N-by-N. */ +/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ +/* If N is even, NISODD = .FALSE., and K. */ + + if (*n % 2 == 0) { + nisodd = false; + k = *n / 2; + } else { + nisodd = true; + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + } + + if (nisodd) { + +/* SIDE = 'R' and N is odd */ + + if (normaltransr) { + +/* SIDE = 'R', N is odd, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'N' */ + + dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[*n], n, &b[n1 * b_dim1], ldb); + dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, &a[n1], n, alpha, b, ldb); + dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, a, n, b, ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'T' */ + + dtrsm_("R", "L", "T", diag, m, &n1, alpha, a, n, b, ldb); + dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, &a[n1], n, alpha, &b[n1 * b_dim1], ldb); + dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[*n], n, &b[n1 * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'N' */ + + dtrsm_("R", "L", "T", diag, m, &n1, alpha, &a[n2], n, b, ldb); + dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, a, n, alpha, &b[n1 * b_dim1], ldb); + dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[n1], n, &b[n1 * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'T' */ + + dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[n1], n, &b[n1 * b_dim1], ldb); + dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, a, n, alpha, b, ldb); + dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, &a[n2], n, b, ldb); + + } + + } + + } else { + +/* SIDE = 'R', N is odd, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'N' */ + + dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1, &b[n1 * b_dim1], ldb); + dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, &a[n1 * n1], &n1, alpha, b, ldb); + dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, a, &n1, b, ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'T' */ + + dtrsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b, ldb); + dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, &a[n1 * n1], &n1, alpha, &b[n1 * b_dim1], ldb); + dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[1], &n1, &b[n1 * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'N' */ + + dtrsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2], &n2, b, ldb); + dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, a, &n2, alpha, &b[n1 * b_dim1], ldb); + dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[n1 * n2], &n2, &b[n1 * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'T' */ + + dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2], &n2, &b[n1 * b_dim1], ldb); + dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, a, &n2, alpha, b, ldb); + dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, &a[n2 * n2], &n2, b, ldb); + + } + + } + + } + + } else { + +/* SIDE = 'R' and N is even */ + + if (normaltransr) { + +/* SIDE = 'R', N is even, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'N' */ + + i__1 = *n + 1; + dtrsm_("R", "U", "T", diag, m, &k, alpha, a, &i__1, &b[k * b_dim1], ldb); + i__1 = *n + 1; + dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, &a[k + 1], &i__1, alpha, b, ldb); + i__1 = *n + 1; + dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[1], &i__1, b, ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'T' */ + + i__1 = *n + 1; + dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[1], &i__1, b, ldb); + i__1 = *n + 1; + dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, &a[k + 1], &i__1, alpha, &b[k * b_dim1], ldb); + i__1 = *n + 1; + dtrsm_("R", "U", "N", diag, m, &k, &c_b27, a, &i__1, &b[k * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'N' */ + + i__1 = *n + 1; + dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[k + 1], &i__1, b, ldb); + i__1 = *n + 1; + dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, a, &i__1, alpha, &b[k * b_dim1], ldb); + i__1 = *n + 1; + dtrsm_("R", "U", "N", diag, m, &k, &c_b27, &a[k], &i__1, &b[k * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'T' */ + + i__1 = *n + 1; + dtrsm_("R", "U", "T", diag, m, &k, alpha, &a[k], &i__1, &b[k * b_dim1], ldb); + i__1 = *n + 1; + dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, a, &i__1, alpha, b, ldb); + i__1 = *n + 1; + dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[k + 1], &i__1, b, ldb); + + } + + } + + } else { + +/* SIDE = 'R', N is even, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'N' */ + + dtrsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k * b_dim1], ldb); + dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, &a[(k + 1) * k], &k, alpha, b, ldb); + dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[k], &k, b, ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'T' */ + + dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k, b, ldb); + dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, &a[(k + 1) * k], &k, alpha, &b[k * b_dim1], ldb); + dtrsm_("R", "L", "T", diag, m, &k, &c_b27, a, &k, &b[k * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'N' */ + + dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) * k], &k, b, ldb); + dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, a, &k, alpha, &b[k * b_dim1], ldb); + dtrsm_("R", "L", "T", diag, m, &k, &c_b27, &a[k * k], &k, &b[k * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'T' */ + + dtrsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], &k, &b[k * b_dim1], ldb); + dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, a, &k, alpha, b, ldb); + dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[(k + 1) * k], &k, b, ldb); + + } + + } + + } + + } + } + + return 0; + +/* End of DTFSM */ + +} /* dtfsm_ */ + +int dtftri_(const char *transr, const char *uplo, const char *diag, integer *n, double *a, integer *info) +{ + /* Table of constant values */ + static double c_b13 = -1.; + static double c_b18 = 1.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer k, n1, n2; + bool normaltransr, lower, nisodd; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTFTRI computes the inverse of a triangular matrix A stored in RFP */ +/* format. */ + +/* This is a Level 3 BLAS version of the algorithm. */ + +/* Arguments */ +/* ========= */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': The Normal TRANSR of RFP A is stored; */ +/* = 'T': The Transpose TRANSR of RFP A is stored. */ + +/* UPLO (input) CHARACTER */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* DIAG (input) CHARACTER */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (0:nt-1); */ +/* nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian */ +/* Positive Definite matrix A in RFP format. RFP format is */ +/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ +/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ +/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */ +/* the transpose of RFP A as defined when */ +/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ +/* follows: If UPLO = 'U' the RFP A contains the nt elements of */ +/* upper packed A; If UPLO = 'L' the RFP A contains the nt */ +/* elements of lower packed A. The LDA of RFP A is (N+1)/2 when */ +/* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */ +/* even and N is odd. See the Note below for more details. */ + +/* On exit, the (triangular) inverse of the original matrix, in */ +/* the same storage format. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* matrix is singular and its inverse can not be computed. */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (! lsame_(diag, "N") && ! lsame_(diag, + "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTFTRI", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = false; + } else { + nisodd = true; + } + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(n1) */ + + dtrtri_("L", diag, &n1, a, n, info); + if (*info > 0) { + return 0; + } + dtrmm_("R", "L", "N", diag, &n2, &n1, &c_b13, a, n, &a[n1], n); + dtrtri_("U", diag, &n2, &a[*n], n, info) + ; + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + dtrmm_("L", "U", "T", diag, &n2, &n1, &c_b18, &a[*n], n, &a[ + n1], n); + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ +/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ +/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ + + dtrtri_("L", diag, &n1, &a[n2], n, info) + ; + if (*info > 0) { + return 0; + } + dtrmm_("L", "L", "T", diag, &n1, &n2, &c_b13, &a[n2], n, a, n); + dtrtri_("U", diag, &n2, &a[n1], n, info) + ; + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + dtrmm_("R", "U", "N", diag, &n1, &n2, &c_b18, &a[n1], n, a, n); + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is odd */ +/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */ + + dtrtri_("U", diag, &n1, a, &n1, info); + if (*info > 0) { + return 0; + } + dtrmm_("L", "U", "N", diag, &n1, &n2, &c_b13, a, &n1, &a[n1 * n1], &n1); + dtrtri_("L", diag, &n2, &a[1], &n1, info); + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + dtrmm_("R", "L", "T", diag, &n1, &n2, &c_b18, &a[1], &n1, &a[n1 * n1], &n1); + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */ + + dtrtri_("U", diag, &n1, &a[n2 * n2], &n2, info); + if (*info > 0) { + return 0; + } + dtrmm_("R", "U", "T", diag, &n2, &n1, &c_b13, &a[n2 * n2], &n2, a, &n2); + dtrtri_("L", diag, &n2, &a[n1 * n2], &n2, info); + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + dtrmm_("L", "L", "N", diag, &n2, &n1, &c_b18, &a[n1 * n2], &n2, a, &n2); + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + i__1 = *n + 1; + dtrtri_("L", diag, &k, &a[1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("R", "L", "N", diag, &k, &k, &c_b13, &a[1], &i__1, &a[k + 1], &i__2); + i__1 = *n + 1; + dtrtri_("U", diag, &k, a, &i__1, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("L", "U", "T", diag, &k, &k, &c_b18, a, &i__1, &a[k + 1], &i__2) + ; + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + i__1 = *n + 1; + dtrtri_("L", diag, &k, &a[k + 1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("L", "L", "T", diag, &k, &k, &c_b13, &a[k + 1], &i__1, a, &i__2); + i__1 = *n + 1; + dtrtri_("U", diag, &k, &a[k], &i__1, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("R", "U", "N", diag, &k, &k, &c_b18, &a[k], &i__1, a, &i__2); + } + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + dtrtri_("U", diag, &k, &a[k], &k, info); + if (*info > 0) { + return 0; + } + dtrmm_("L", "U", "N", diag, &k, &k, &c_b13, &a[k], &k, &a[k * (k + 1)], &k); + dtrtri_("L", diag, &k, a, &k, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + dtrmm_("R", "L", "T", diag, &k, &k, &c_b18, a, &k, &a[k * (k + 1)], &k) + ; + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + dtrtri_("U", diag, &k, &a[k * (k + 1)], &k, info); + if (*info > 0) { + return 0; + } + dtrmm_("R", "U", "T", diag, &k, &k, &c_b13, &a[k * (k + 1)], &k, a, &k); + dtrtri_("L", diag, &k, &a[k * k], &k, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + dtrmm_("L", "L", "N", diag, &k, &k, &c_b18, &a[k * k], &k, a, &k); + } + } + } + + return 0; + +/* End of DTFTRI */ + +} /* dtftri_ */ + +int dtfttp_(const char *transr, const char *uplo, integer *n, double *arf, double *ap, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, n1, n2, ij, jp, js, lda, ijp; + bool normaltransr, lower, nisodd; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTFTTP copies a triangular matrix A from rectangular full packed */ +/* format (TF) to standard packed format (TP). */ + +/* Arguments */ +/* ========= */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': ARF is in Normal format; */ +/* = 'T': ARF is in Transpose format; */ + +/* UPLO (input) CHARACTER */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* ARF (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* On entry, the upper or lower triangular matrix A stored in */ +/* RFP format. For a further discussion see Notes below. */ + +/* AP (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* On exit, the upper or lower triangular matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTFTTP", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (normaltransr) { + ap[0] = arf[0]; + } else { + ap[0] = arf[0]; + } + return 0; + } + +/* Size of array ARF(0:NT-1) */ + + // nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + +/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ +/* where noe = 0 if n is even, noe = 1 if n is odd */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = false; + lda = *n + 1; + } else { + nisodd = true; + lda = *n; + } + +/* ARF^C has lda rows and n+1-noe cols */ + + if (! normaltransr) { + lda = (*n + 1) / 2; + } + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */ + + ijp = 0; + jp = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + jp; + ap[ijp] = arf[ij]; + ++ijp; + } + jp += lda; + } + i__1 = n2 - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = n2; + for (j = i__ + 1; j <= i__2; ++j) { + ij = i__ + j * lda; + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ +/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ +/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ + + ijp = 0; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + ij = n2 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + ap[ijp] = arf[ij]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = n1; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is odd */ +/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */ +/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */ + + ijp = 0; + i__1 = n2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = *n * lda - 1; + i__3 = lda; + for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= i__2; ij += i__3) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + js = 1; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + n2 - j - 1; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */ +/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */ + + ijp = 0; + js = n2 * lda; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + i__1 = n1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (n1 + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += i__2) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + ijp = 0; + jp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + 1 + jp; + ap[ijp] = arf[ij]; + ++ijp; + } + jp += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = k - 1; + for (j = i__; j <= i__2; ++j) { + ij = i__ + j * lda; + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + ijp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + ij = k + 1 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + ap[ijp] = arf[ij]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + ijp = 0; + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = (*n + 1) * lda - 1; + i__3 = lda; + for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : ij <= i__2; ij += i__3) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + js = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + k - j - 1; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + ijp = 0; + js = (k + 1) * lda; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (k + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += i__2) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } + + } + + } + + return 0; + +/* End of DTFTTP */ + +} /* dtfttp_ */ + +int dtfttr_(const char *transr, const char *uplo, integer *n, double *arf, double *a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2; + bool normaltransr, lower, nisodd; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTFTTR copies a triangular matrix A from rectangular full packed */ +/* format (TF) to standard full format (TR). */ + +/* Arguments */ +/* ========= */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': ARF is in Normal format; */ +/* = 'T': ARF is in Transpose format. */ + +/* UPLO (input) CHARACTER */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrices ARF and A. N >= 0. */ + +/* ARF (input) DOUBLE PRECISION array, dimension (N*(N+1)/2). */ +/* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */ +/* matrix A in RFP format. See the "Notes" below for more */ +/* details. */ + +/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On exit, the triangular matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of the array A contains */ +/* the upper triangular matrix, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of the array A contains */ +/* the lower triangular matrix, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* Reference */ +/* ========= */ + +/* ===================================================================== */ + +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda - 1 - 0 + 1; + a_offset = 0 + a_dim1 * 0; + a -= a_offset; + + /* Function Body */ + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTFTTR", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + if (*n == 1) { + a[0] = arf[0]; + } + return 0; + } + +/* Size of array ARF(0:nt-1) */ + + nt = *n * (*n + 1) / 2; + +/* set N1 and N2 depending on LOWER: for N even N1=N2=K */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ +/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ +/* N--by--(N+1)/2. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = false; + if (! lower) { + np1x2 = *n + *n + 2; + } + } else { + nisodd = true; + if (! lower) { + nx2 = *n + *n; + } + } + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = n2 + j; + for (i__ = n1; i__ <= i__2; ++i__) { + a[n2 + j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n; + i__1 = n1; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = n1 - 1; + for (l = j - n1; l <= i__2; ++l) { + a[j - n1 + l * a_dim1] = arf[ij]; + ++ij; + } + ij -= nx2; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = n1 + j; i__ <= i__2; ++i__) { + a[i__ + (n1 + j) * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = *n - 1; + for (j = n2; j <= i__1; ++j) { + i__2 = n1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = n1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = n1; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (l = n2 + j; l <= i__2; ++l) { + a[n2 + j + l * a_dim1] = arf[ij]; + ++ij; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + for (i__ = k; i__ <= i__2; ++i__) { + a[k + j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n - 1; + i__1 = k; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = k - 1; + for (l = j - k; l <= i__2; ++l) { + a[j - k + l * a_dim1] = arf[ij]; + ++ij; + } + ij -= np1x2; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + j = k; + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = k + 1 + j; i__ <= i__2; ++i__) { + a[i__ + (k + 1 + j) * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = *n - 1; + for (j = k - 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = k; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (l = k + 1 + j; l <= i__2; ++l) { + a[k + 1 + j + l * a_dim1] = arf[ij]; + ++ij; + } + } +/* Note that here, on exit of the loop, J = K-1 */ + i__1 = j; + for (i__ = 0; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + + } + + } + + } + + return 0; + +/* End of DTFTTR */ + +} /* dtfttr_ */ + +/* Subroutine */ int dtgevc_(const char *side, const char *howmny, bool *select, + integer *n, double *s, integer *lds, double *p, integer *ldp, + double *vl, integer *ldvl, double *vr, integer *ldvr, integer + *mm, integer *m, double *work, integer *info) +{ + /* Table of constant values */ + static bool c_true = true; + static integer c__2 = 2; + static double c_b34 = 1.; + static integer c__1 = 1; + static double c_b36 = 0.; + static bool c_false = false; + + /* System generated locals */ + integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2, i__3, i__4, i__5; + double d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + integer i__, j, ja, jc, je, na, im, jr, jw, nw; + double big; + bool lsa, lsb; + double ulp, sum[4] /* was [2][2] */; + integer ibeg, ieig, iend; + double dmin__, temp, xmax, sump[4] /* was [2][2] */, sums[4] + /* was [2][2] */; + double cim2a, cim2b, cre2a, cre2b, temp2, bdiag[2], acoef, scale; + bool ilall; + integer iside; + double sbeta; + bool il2by2; + integer iinfo; + double small; + bool compl_x; // djmw changed variable from "compl" to compl_x because the c++ compiler protested. + double anorm, bnorm; + bool compr; + double temp2i; + double temp2r; + bool ilabad, ilbbad; + double acoefa, bcoefa, cimaga, cimagb; + bool ilback; + double bcoefi, ascale, bscale, creala, crealb; + double bcoefr, salfar, safmin; + double xscale, bignum; + bool ilcomp, ilcplx; + integer ihwmny; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + + +/* Purpose */ +/* ======= */ + +/* DTGEVC computes some or all of the right and/or left eigenvectors of */ +/* a pair of real matrices (S,P), where S is a quasi-triangular matrix */ +/* and P is upper triangular. Matrix pairs of this type are produced by */ +/* the generalized Schur factorization of a matrix pair (A,B): */ + +/* A = Q*S*Z**T, B = Q*P*Z**T */ + +/* as computed by DGGHRD + DHGEQZ. */ + +/* The right eigenvector x and the left eigenvector y of (S,P) */ +/* corresponding to an eigenvalue w are defined by: */ + +/* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */ + +/* where y**H denotes the conjugate tranpose of y. */ +/* The eigenvalues are not input to this routine, but are computed */ +/* directly from the diagonal blocks of S and P. */ + +/* This routine returns the matrices X and/or Y of right and left */ +/* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */ +/* where Z and Q are input matrices. */ +/* If Q and Z are the orthogonal factors from the generalized Schur */ +/* factorization of a matrix pair (A,B), then Z*X and Q*Y */ +/* are the matrices of right and left eigenvectors of (A,B). */ + +/* Arguments */ +/* ========= */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'R': compute right eigenvectors only; */ +/* = 'L': compute left eigenvectors only; */ +/* = 'B': compute both right and left eigenvectors. */ + +/* HOWMNY (input) CHARACTER*1 */ +/* = 'A': compute all right and/or left eigenvectors; */ +/* = 'B': compute all right and/or left eigenvectors, */ +/* backtransformed by the matrices in VR and/or VL; */ +/* = 'S': compute selected right and/or left eigenvectors, */ +/* specified by the bool array SELECT. */ + +/* SELECT (input) LOGICAL array, dimension (N) */ +/* If HOWMNY='S', SELECT specifies the eigenvectors to be */ +/* computed. If w(j) is a real eigenvalue, the corresponding */ +/* real eigenvector is computed if SELECT(j) is .TRUE.. */ +/* If w(j) and w(j+1) are the real and imaginary parts of a */ +/* complex eigenvalue, the corresponding complex eigenvector */ +/* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., */ +/* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is */ +/* set to .FALSE.. */ +/* Not referenced if HOWMNY = 'A' or 'B'. */ + +/* N (input) INTEGER */ +/* The order of the matrices S and P. N >= 0. */ + +/* S (input) DOUBLE PRECISION array, dimension (LDS,N) */ +/* The upper quasi-triangular matrix S from a generalized Schur */ +/* factorization, as computed by DHGEQZ. */ + +/* LDS (input) INTEGER */ +/* The leading dimension of array S. LDS >= max(1,N). */ + +/* P (input) DOUBLE PRECISION array, dimension (LDP,N) */ +/* The upper triangular matrix P from a generalized Schur */ +/* factorization, as computed by DHGEQZ. */ +/* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks */ +/* of S must be in positive diagonal form. */ + +/* LDP (input) INTEGER */ +/* The leading dimension of array P. LDP >= max(1,N). */ + +/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */ +/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* of left Schur vectors returned by DHGEQZ). */ +/* On exit, if SIDE = 'L' or 'B', VL contains: */ +/* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */ +/* if HOWMNY = 'B', the matrix Q*Y; */ +/* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */ +/* SELECT, stored consecutively in the columns of */ +/* VL, in the same order as their eigenvalues. */ + +/* A complex eigenvector corresponding to a complex eigenvalue */ +/* is stored in two consecutive columns, the first holding the */ +/* real part, and the second the imaginary part. */ + +/* Not referenced if SIDE = 'R'. */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of array VL. LDVL >= 1, and if */ +/* SIDE = 'L' or 'B', LDVL >= N. */ + +/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */ +/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* contain an N-by-N matrix Z (usually the orthogonal matrix Z */ +/* of right Schur vectors returned by DHGEQZ). */ + +/* On exit, if SIDE = 'R' or 'B', VR contains: */ +/* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */ +/* if HOWMNY = 'B' or 'b', the matrix Z*X; */ +/* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) */ +/* specified by SELECT, stored consecutively in the */ +/* columns of VR, in the same order as their */ +/* eigenvalues. */ + +/* A complex eigenvector corresponding to a complex eigenvalue */ +/* is stored in two consecutive columns, the first holding the */ +/* real part and the second the imaginary part. */ + +/* Not referenced if SIDE = 'L'. */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the array VR. LDVR >= 1, and if */ +/* SIDE = 'R' or 'B', LDVR >= N. */ + +/* MM (input) INTEGER */ +/* The number of columns in the arrays VL and/or VR. MM >= M. */ + +/* M (output) INTEGER */ +/* The number of columns in the arrays VL and/or VR actually */ +/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */ +/* is set to N. Each selected real eigenvector occupies one */ +/* column and each selected complex eigenvector occupies two */ +/* columns. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit. */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex */ +/* eigenvalue. */ + +/* Further Details */ +/* =============== */ + +/* Allocation of workspace: */ +/* ---------- -- --------- */ + +/* WORK( j ) = 1-norm of j-th column of A, above the diagonal */ +/* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal */ +/* WORK( 2*N+1:3*N ) = real part of eigenvector */ +/* WORK( 3*N+1:4*N ) = imaginary part of eigenvector */ +/* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector */ +/* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector */ + +/* Rowwise vs. columnwise solution methods: */ +/* ------- -- ---------- -------- ------- */ + +/* Finding a generalized eigenvector consists basically of solving the */ +/* singular triangular system */ + +/* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) */ + +/* Consider finding the i-th right eigenvector (assume all eigenvalues */ +/* are real). The equation to be solved is: */ +/* n i */ +/* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 */ +/* k=j k=j */ + +/* where C = (A - w B) (The components v(i+1:n) are 0.) */ + +/* The "rowwise" method is: */ + +/* (1) v(i) := 1 */ +/* for j = i-1,. . .,1: */ +/* i */ +/* (2) compute s = - sum C(j,k) v(k) and */ +/* k=j+1 */ + +/* (3) v(j) := s / C(j,j) */ + +/* Step 2 is sometimes called the "dot product" step, since it is an */ +/* inner product between the j-th row and the portion of the eigenvector */ +/* that has been computed so far. */ + +/* The "columnwise" method consists basically in doing the sums */ +/* for all the rows in parallel. As each v(j) is computed, the */ +/* contribution of v(j) times the j-th column of C is added to the */ +/* partial sums. Since FORTRAN arrays are stored columnwise, this has */ +/* the advantage that at each step, the elements of C that are accessed */ +/* are adjacent to one another, whereas with the rowwise method, the */ +/* elements accessed at a step are spaced LDS (and LDP) words apart. */ + +/* When finding left eigenvectors, the matrix in question is the */ +/* transpose of the one in storage, so the rowwise method then */ +/* actually accesses columns of A and B at each step, and so is the */ +/* preferred method. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and Test the input parameters */ + + /* Parameter adjustments */ + --select; + s_dim1 = *lds; + s_offset = 1 + s_dim1; + s -= s_offset; + p_dim1 = *ldp; + p_offset = 1 + p_dim1; + p -= p_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(howmny, "A")) { + ihwmny = 1; + ilall = true; + ilback = false; + } else if (lsame_(howmny, "S")) { + ihwmny = 2; + ilall = false; + ilback = false; + } else if (lsame_(howmny, "B")) { + ihwmny = 3; + ilall = true; + ilback = true; + } else { + ihwmny = -1; + ilall = true; + } + + if (lsame_(side, "R")) { + iside = 1; + compl_x = false; + compr = true; + } else if (lsame_(side, "L")) { + iside = 2; + compl_x = true; + compr = false; + } else if (lsame_(side, "B")) { + iside = 3; + compl_x = true; + compr = true; + } else { + iside = -1; + } + + *info = 0; + if (iside < 0) { + *info = -1; + } else if (ihwmny < 0) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lds < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldp < std::max(1_integer,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGEVC", &i__1); + return 0; + } + +/* Count the number of eigenvectors to be computed */ + + if (! ilall) { + im = 0; + ilcplx = false; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (ilcplx) { + ilcplx = false; + goto L10; + } + if (j < *n) { + if (s[j + 1 + j * s_dim1] != 0.) { + ilcplx = true; + } + } + if (ilcplx) { + if (select[j] || select[j + 1]) { + im += 2; + } + } else { + if (select[j]) { + ++im; + } + } +L10: + ; + } + } else { + im = *n; + } + +/* Check 2-by-2 diagonal blocks of A, B */ + + ilabad = false; + ilbbad = false; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + if (s[j + 1 + j * s_dim1] != 0.) { + if (p[j + j * p_dim1] == 0. || p[j + 1 + (j + 1) * p_dim1] == 0. + || p[j + (j + 1) * p_dim1] != 0.) { + ilbbad = true; + } + if (j < *n - 1) { + if (s[j + 2 + (j + 1) * s_dim1] != 0.) { + ilabad = true; + } + } + } +/* L20: */ + } + + if (ilabad) { + *info = -5; + } else if (ilbbad) { + *info = -7; + } else if (compl_x && *ldvl < *n || *ldvl < 1) { + *info = -10; + } else if (compr && *ldvr < *n || *ldvr < 1) { + *info = -12; + } else if (*mm < im) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGEVC", &i__1); + return 0; + } + +/* Quick return if possible */ + + *m = im; + if (*n == 0) { + return 0; + } + +/* Machine Constants */ + + safmin = dlamch_("Safe minimum"); + big = 1. / safmin; + dlabad_(&safmin, &big); + ulp = dlamch_("Epsilon") * dlamch_("Base"); + small = safmin * *n / ulp; + big = 1. / small; + bignum = 1. / (safmin * *n); + +/* Compute the 1-norm of each column of the strictly upper triangular */ +/* part (i.e., excluding all elements belonging to the diagonal */ +/* blocks) of A and B to check for possible overflow in the */ +/* triangular solver. */ + + anorm = (d__1 = s[s_dim1 + 1], abs(d__1)); + if (*n > 1) { + anorm += (d__1 = s[s_dim1 + 2], abs(d__1)); + } + bnorm = (d__1 = p[p_dim1 + 1], abs(d__1)); + work[1] = 0.; + work[*n + 1] = 0.; + + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + temp = 0.; + temp2 = 0.; + if (s[j + (j - 1) * s_dim1] == 0.) { + iend = j - 1; + } else { + iend = j - 2; + } + i__2 = iend; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += (d__1 = s[i__ + j * s_dim1], abs(d__1)); + temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1)); +/* L30: */ + } + work[j] = temp; + work[*n + j] = temp2; +/* Computing MIN */ + i__3 = j + 1; + i__2 = std::min(i__3,*n); + for (i__ = iend + 1; i__ <= i__2; ++i__) { + temp += (d__1 = s[i__ + j * s_dim1], abs(d__1)); + temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1)); +/* L40: */ + } + anorm = std::max(anorm,temp); + bnorm = std::max(bnorm,temp2); +/* L50: */ + } + ascale = 1. / std::max(anorm,safmin); + bscale = 1. / std::max(bnorm,safmin); + +/* Left eigenvectors */ + + if (compl_x) { + ieig = 0; + +/* Main loop over eigenvalues */ + + ilcplx = false; + i__1 = *n; + for (je = 1; je <= i__1; ++je) { + +/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ +/* (b) this would be the second of a complex pair. */ +/* Check for complex eigenvalue, so as to be sure of which */ +/* entry(-ies) of SELECT to look at. */ + + if (ilcplx) { + ilcplx = false; + goto L220; + } + nw = 1; + if (je < *n) { + if (s[je + 1 + je * s_dim1] != 0.) { + ilcplx = true; + nw = 2; + } + } + if (ilall) { + ilcomp = true; + } else if (ilcplx) { + ilcomp = select[je] || select[je + 1]; + } else { + ilcomp = select[je]; + } + if (! ilcomp) { + goto L220; + } + +/* Decide if (a) singular pencil, (b) real eigenvalue, or */ +/* (c) complex eigenvalue. */ + + if (! ilcplx) { + if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && ( + d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) { + +/* Singular matrix pencil -- return unit eigenvector */ + + ++ieig; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + ieig * vl_dim1] = 0.; +/* L60: */ + } + vl[ieig + ieig * vl_dim1] = 1.; + goto L220; + } + } + +/* Clear vector */ + + i__2 = nw * *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = 0.; +/* L70: */ + } +/* T */ +/* Compute coefficients in ( a A - b B ) y = 0 */ +/* a is ACOEF */ +/* b is BCOEFR + i*BCOEFI */ + + if (! ilcplx) { + +/* Real eigenvalue */ + +/* Computing MAX */ + d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4 + = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale, + d__3 = std::max(d__3,d__4); + temp = 1. / std::max(d__3,safmin); + salfar = temp * s[je + je * s_dim1] * ascale; + sbeta = temp * p[je + je * p_dim1] * bscale; + acoef = sbeta * ascale; + bcoefr = salfar * bscale; + bcoefi = 0.; + +/* Scale to avoid underflow */ + + scale = 1.; + lsa = abs(sbeta) >= safmin && abs(acoef) < small; + lsb = abs(salfar) >= safmin && abs(bcoefr) < small; + if (lsa) { + scale = small / abs(sbeta) * std::min(anorm,big); + } + if (lsb) { +/* Computing MAX */ + d__1 = scale, d__2 = small / abs(salfar) * std::min(bnorm,big); + scale = std::max(d__1,d__2); + } + if (lsa || lsb) { +/* Computing MIN */ +/* Computing MAX */ + d__3 = 1., d__4 = abs(acoef), d__3 = std::max(d__3,d__4), d__4 + = abs(bcoefr); + d__1 = scale, d__2 = 1. / (safmin * std::max(d__3,d__4)); + scale = std::min(d__1,d__2); + if (lsa) { + acoef = ascale * (scale * sbeta); + } else { + acoef = scale * acoef; + } + if (lsb) { + bcoefr = bscale * (scale * salfar); + } else { + bcoefr = scale * bcoefr; + } + } + acoefa = abs(acoef); + bcoefa = abs(bcoefr); + +/* First component is 1 */ + + work[(*n << 1) + je] = 1.; + xmax = 1.; + } else { + +/* Complex eigenvalue */ + + d__1 = safmin * 100.; + dlag2_(&s[je + je * s_dim1], lds, &p[je + je * p_dim1], ldp, & + d__1, &acoef, &temp, &bcoefr, &temp2, &bcoefi); + bcoefi = -bcoefi; + if (bcoefi == 0.) { + *info = je; + return 0; + } + +/* Scale to avoid over/underflow */ + + acoefa = abs(acoef); + bcoefa = abs(bcoefr) + abs(bcoefi); + scale = 1.; + if (acoefa * ulp < safmin && acoefa >= safmin) { + scale = safmin / ulp / acoefa; + } + if (bcoefa * ulp < safmin && bcoefa >= safmin) { +/* Computing MAX */ + d__1 = scale, d__2 = safmin / ulp / bcoefa; + scale = std::max(d__1,d__2); + } + if (safmin * acoefa > ascale) { + scale = ascale / (safmin * acoefa); + } + if (safmin * bcoefa > bscale) { +/* Computing MIN */ + d__1 = scale, d__2 = bscale / (safmin * bcoefa); + scale = std::min(d__1,d__2); + } + if (scale != 1.) { + acoef = scale * acoef; + acoefa = abs(acoef); + bcoefr = scale * bcoefr; + bcoefi = scale * bcoefi; + bcoefa = abs(bcoefr) + abs(bcoefi); + } + +/* Compute first two components of eigenvector */ + + temp = acoef * s[je + 1 + je * s_dim1]; + temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * + p_dim1]; + temp2i = -bcoefi * p[je + je * p_dim1]; + if (abs(temp) > abs(temp2r) + abs(temp2i)) { + work[(*n << 1) + je] = 1.; + work[*n * 3 + je] = 0.; + work[(*n << 1) + je + 1] = -temp2r / temp; + work[*n * 3 + je + 1] = -temp2i / temp; + } else { + work[(*n << 1) + je + 1] = 1.; + work[*n * 3 + je + 1] = 0.; + temp = acoef * s[je + (je + 1) * s_dim1]; + work[(*n << 1) + je] = (bcoefr * p[je + 1 + (je + 1) * + p_dim1] - acoef * s[je + 1 + (je + 1) * s_dim1]) / + temp; + work[*n * 3 + je] = bcoefi * p[je + 1 + (je + 1) * p_dim1] + / temp; + } +/* Computing MAX */ + d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 = + work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(* + n << 1) + je + 1], abs(d__3)) + (d__4 = work[*n * 3 + + je + 1], abs(d__4)); + xmax = std::max(d__5,d__6); + } + +/* Computing MAX */ + d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 = + std::max(d__1,d__2); + dmin__ = std::max(d__1,safmin); + +/* T */ +/* Triangular solve of (a A - b B) y = 0 */ + +/* T */ +/* (rowwise in (a A - b B) , or columnwise in (a A - b B) ) */ + + il2by2 = false; + + i__2 = *n; + for (j = je + nw; j <= i__2; ++j) { + if (il2by2) { + il2by2 = false; + goto L160; + } + + na = 1; + bdiag[0] = p[j + j * p_dim1]; + if (j < *n) { + if (s[j + 1 + j * s_dim1] != 0.) { + il2by2 = true; + bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; + na = 2; + } + } + +/* Check whether scaling is necessary for dot products */ + + xscale = 1. / std::max(1.,xmax); +/* Computing MAX */ + d__1 = work[j], d__2 = work[*n + j], d__1 = std::max(d__1,d__2), + d__2 = acoefa * work[j] + bcoefa * work[*n + j]; + temp = std::max(d__1,d__2); + if (il2by2) { +/* Computing MAX */ + d__1 = temp, d__2 = work[j + 1], d__1 = std::max(d__1,d__2), + d__2 = work[*n + j + 1], d__1 = std::max(d__1,d__2), + d__2 = acoefa * work[j + 1] + bcoefa * work[*n + + j + 1]; + temp = std::max(d__1,d__2); + } + if (temp > bignum * xscale) { + i__3 = nw - 1; + for (jw = 0; jw <= i__3; ++jw) { + i__4 = j - 1; + for (jr = je; jr <= i__4; ++jr) { + work[(jw + 2) * *n + jr] = xscale * work[(jw + 2) + * *n + jr]; +/* L80: */ + } +/* L90: */ + } + xmax *= xscale; + } + +/* Compute dot products */ + +/* j-1 */ +/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */ +/* k=je */ + +/* To reduce the op count, this is done as */ + +/* _ j-1 _ j-1 */ +/* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) */ +/* k=je k=je */ + +/* which may cause underflow problems if A or B are close */ +/* to underflow. (E.g., less than SMALL.) */ + + +/* A series of compiler directives to defeat vectorization */ +/* for the next loop */ + +/* $PL$ CMCHAR=' ' */ +/* DIR$ NEXTSCALAR */ +/* $DIR SCALAR */ +/* DIR$ NEXT SCALAR */ +/* VD$L NOVECTOR */ +/* DEC$ NOVECTOR */ +/* VD$ NOVECTOR */ +/* VDIR NOVECTOR */ +/* VOCL LOOP,SCALAR */ +/* IBM PREFER SCALAR */ +/* $PL$ CMCHAR='*' */ + + i__3 = nw; + for (jw = 1; jw <= i__3; ++jw) { + +/* $PL$ CMCHAR=' ' */ +/* DIR$ NEXTSCALAR */ +/* $DIR SCALAR */ +/* DIR$ NEXT SCALAR */ +/* VD$L NOVECTOR */ +/* DEC$ NOVECTOR */ +/* VD$ NOVECTOR */ +/* VDIR NOVECTOR */ +/* VOCL LOOP,SCALAR */ +/* IBM PREFER SCALAR */ +/* $PL$ CMCHAR='*' */ + + i__4 = na; + for (ja = 1; ja <= i__4; ++ja) { + sums[ja + (jw << 1) - 3] = 0.; + sump[ja + (jw << 1) - 3] = 0.; + + i__5 = j - 1; + for (jr = je; jr <= i__5; ++jr) { + sums[ja + (jw << 1) - 3] += s[jr + (j + ja - 1) * + s_dim1] * work[(jw + 1) * *n + jr]; + sump[ja + (jw << 1) - 3] += p[jr + (j + ja - 1) * + p_dim1] * work[(jw + 1) * *n + jr]; +/* L100: */ + } +/* L110: */ + } +/* L120: */ + } + +/* $PL$ CMCHAR=' ' */ +/* DIR$ NEXTSCALAR */ +/* $DIR SCALAR */ +/* DIR$ NEXT SCALAR */ +/* VD$L NOVECTOR */ +/* DEC$ NOVECTOR */ +/* VD$ NOVECTOR */ +/* VDIR NOVECTOR */ +/* VOCL LOOP,SCALAR */ +/* IBM PREFER SCALAR */ +/* $PL$ CMCHAR='*' */ + + i__3 = na; + for (ja = 1; ja <= i__3; ++ja) { + if (ilcplx) { + sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ + ja - 1] - bcoefi * sump[ja + 1]; + sum[ja + 1] = -acoef * sums[ja + 1] + bcoefr * sump[ + ja + 1] + bcoefi * sump[ja - 1]; + } else { + sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ + ja - 1]; + } +/* L130: */ + } + +/* T */ +/* Solve ( a A - b B ) y = SUM(,) */ +/* with scaling and perturbation of the denominator */ + + dlaln2_(&c_true, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1] +, lds, bdiag, &bdiag[1], sum, &c__2, &bcoefr, &bcoefi, + &work[(*n << 1) + j], n, &scale, &temp, &iinfo); + if (scale < 1.) { + i__3 = nw - 1; + for (jw = 0; jw <= i__3; ++jw) { + i__4 = j - 1; + for (jr = je; jr <= i__4; ++jr) { + work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * + *n + jr]; +/* L140: */ + } +/* L150: */ + } + xmax = scale * xmax; + } + xmax = std::max(xmax,temp); +L160: + ; + } + +/* Copy eigenvector to VL, back transforming if */ +/* HOWMNY='B'. */ + + ++ieig; + if (ilback) { + i__2 = nw - 1; + for (jw = 0; jw <= i__2; ++jw) { + i__3 = *n + 1 - je; + dgemv_("N", n, &i__3, &c_b34, &vl[je * vl_dim1 + 1], ldvl, + &work[(jw + 2) * *n + je], &c__1, &c_b36, &work[( + jw + 4) * *n + 1], &c__1); +/* L170: */ + } + dlacpy_(" ", n, &nw, &work[(*n << 2) + 1], n, &vl[je * + vl_dim1 + 1], ldvl); + ibeg = 1; + } else { + dlacpy_(" ", n, &nw, &work[(*n << 1) + 1], n, &vl[ieig * + vl_dim1 + 1], ldvl); + ibeg = je; + } + +/* Scale eigenvector */ + + xmax = 0.; + if (ilcplx) { + i__2 = *n; + for (j = ibeg; j <= i__2; ++j) { +/* Computing MAX */ + d__3 = xmax, d__4 = (d__1 = vl[j + ieig * vl_dim1], abs( + d__1)) + (d__2 = vl[j + (ieig + 1) * vl_dim1], + abs(d__2)); + xmax = std::max(d__3,d__4); +/* L180: */ + } + } else { + i__2 = *n; + for (j = ibeg; j <= i__2; ++j) { +/* Computing MAX */ + d__2 = xmax, d__3 = (d__1 = vl[j + ieig * vl_dim1], abs( + d__1)); + xmax = std::max(d__2,d__3); +/* L190: */ + } + } + + if (xmax > safmin) { + xscale = 1. / xmax; + + i__2 = nw - 1; + for (jw = 0; jw <= i__2; ++jw) { + i__3 = *n; + for (jr = ibeg; jr <= i__3; ++jr) { + vl[jr + (ieig + jw) * vl_dim1] = xscale * vl[jr + ( + ieig + jw) * vl_dim1]; +/* L200: */ + } +/* L210: */ + } + } + ieig = ieig + nw - 1; + +L220: + ; + } + } + +/* Right eigenvectors */ + + if (compr) { + ieig = im + 1; + +/* Main loop over eigenvalues */ + + ilcplx = false; + for (je = *n; je >= 1; --je) { + +/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ +/* (b) this would be the second of a complex pair. */ +/* Check for complex eigenvalue, so as to be sure of which */ +/* entry(-ies) of SELECT to look at -- if complex, SELECT(JE) */ +/* or SELECT(JE-1). */ +/* If this is a complex pair, the 2-by-2 diagonal block */ +/* corresponding to the eigenvalue is in rows/columns JE-1:JE */ + + if (ilcplx) { + ilcplx = false; + goto L500; + } + nw = 1; + if (je > 1) { + if (s[je + (je - 1) * s_dim1] != 0.) { + ilcplx = true; + nw = 2; + } + } + if (ilall) { + ilcomp = true; + } else if (ilcplx) { + ilcomp = select[je] || select[je - 1]; + } else { + ilcomp = select[je]; + } + if (! ilcomp) { + goto L500; + } + +/* Decide if (a) singular pencil, (b) real eigenvalue, or */ +/* (c) complex eigenvalue. */ + + if (! ilcplx) { + if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && ( + d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) { + +/* Singular matrix pencil -- unit eigenvector */ + + --ieig; + i__1 = *n; + for (jr = 1; jr <= i__1; ++jr) { + vr[jr + ieig * vr_dim1] = 0.; +/* L230: */ + } + vr[ieig + ieig * vr_dim1] = 1.; + goto L500; + } + } + +/* Clear vector */ + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = 0.; +/* L240: */ + } +/* L250: */ + } + +/* Compute coefficients in ( a A - b B ) x = 0 */ +/* a is ACOEF */ +/* b is BCOEFR + i*BCOEFI */ + + if (! ilcplx) { + +/* Real eigenvalue */ + +/* Computing MAX */ + d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4 + = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale, + d__3 = std::max(d__3,d__4); + temp = 1. / std::max(d__3,safmin); + salfar = temp * s[je + je * s_dim1] * ascale; + sbeta = temp * p[je + je * p_dim1] * bscale; + acoef = sbeta * ascale; + bcoefr = salfar * bscale; + bcoefi = 0.; + +/* Scale to avoid underflow */ + + scale = 1.; + lsa = abs(sbeta) >= safmin && abs(acoef) < small; + lsb = abs(salfar) >= safmin && abs(bcoefr) < small; + if (lsa) { + scale = small / abs(sbeta) * std::min(anorm,big); + } + if (lsb) { +/* Computing MAX */ + d__1 = scale, d__2 = small / abs(salfar) * std::min(bnorm,big); + scale = std::max(d__1,d__2); + } + if (lsa || lsb) { +/* Computing MIN */ +/* Computing MAX */ + d__3 = 1., d__4 = abs(acoef), d__3 = std::max(d__3,d__4), d__4 + = abs(bcoefr); + d__1 = scale, d__2 = 1. / (safmin * std::max(d__3,d__4)); + scale = std::min(d__1,d__2); + if (lsa) { + acoef = ascale * (scale * sbeta); + } else { + acoef = scale * acoef; + } + if (lsb) { + bcoefr = bscale * (scale * salfar); + } else { + bcoefr = scale * bcoefr; + } + } + acoefa = abs(acoef); + bcoefa = abs(bcoefr); + +/* First component is 1 */ + + work[(*n << 1) + je] = 1.; + xmax = 1.; + +/* Compute contribution from column JE of A and B to sum */ +/* (See "Further Details", above.) */ + + i__1 = je - 1; + for (jr = 1; jr <= i__1; ++jr) { + work[(*n << 1) + jr] = bcoefr * p[jr + je * p_dim1] - + acoef * s[jr + je * s_dim1]; +/* L260: */ + } + } else { + +/* Complex eigenvalue */ + + d__1 = safmin * 100.; + dlag2_(&s[je - 1 + (je - 1) * s_dim1], lds, &p[je - 1 + (je - + 1) * p_dim1], ldp, &d__1, &acoef, &temp, &bcoefr, & + temp2, &bcoefi); + if (bcoefi == 0.) { + *info = je - 1; + return 0; + } + +/* Scale to avoid over/underflow */ + + acoefa = abs(acoef); + bcoefa = abs(bcoefr) + abs(bcoefi); + scale = 1.; + if (acoefa * ulp < safmin && acoefa >= safmin) { + scale = safmin / ulp / acoefa; + } + if (bcoefa * ulp < safmin && bcoefa >= safmin) { +/* Computing MAX */ + d__1 = scale, d__2 = safmin / ulp / bcoefa; + scale = std::max(d__1,d__2); + } + if (safmin * acoefa > ascale) { + scale = ascale / (safmin * acoefa); + } + if (safmin * bcoefa > bscale) { +/* Computing MIN */ + d__1 = scale, d__2 = bscale / (safmin * bcoefa); + scale = std::min(d__1,d__2); + } + if (scale != 1.) { + acoef = scale * acoef; + acoefa = abs(acoef); + bcoefr = scale * bcoefr; + bcoefi = scale * bcoefi; + bcoefa = abs(bcoefr) + abs(bcoefi); + } + +/* Compute first two components of eigenvector */ +/* and contribution to sums */ + + temp = acoef * s[je + (je - 1) * s_dim1]; + temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * + p_dim1]; + temp2i = -bcoefi * p[je + je * p_dim1]; + if (abs(temp) >= abs(temp2r) + abs(temp2i)) { + work[(*n << 1) + je] = 1.; + work[*n * 3 + je] = 0.; + work[(*n << 1) + je - 1] = -temp2r / temp; + work[*n * 3 + je - 1] = -temp2i / temp; + } else { + work[(*n << 1) + je - 1] = 1.; + work[*n * 3 + je - 1] = 0.; + temp = acoef * s[je - 1 + je * s_dim1]; + work[(*n << 1) + je] = (bcoefr * p[je - 1 + (je - 1) * + p_dim1] - acoef * s[je - 1 + (je - 1) * s_dim1]) / + temp; + work[*n * 3 + je] = bcoefi * p[je - 1 + (je - 1) * p_dim1] + / temp; + } + +/* Computing MAX */ + d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 = + work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(* + n << 1) + je - 1], abs(d__3)) + (d__4 = work[*n * 3 + + je - 1], abs(d__4)); + xmax = std::max(d__5,d__6); + +/* Compute contribution from columns JE and JE-1 */ +/* of A and B to the sums. */ + + creala = acoef * work[(*n << 1) + je - 1]; + cimaga = acoef * work[*n * 3 + je - 1]; + crealb = bcoefr * work[(*n << 1) + je - 1] - bcoefi * work[*n + * 3 + je - 1]; + cimagb = bcoefi * work[(*n << 1) + je - 1] + bcoefr * work[*n + * 3 + je - 1]; + cre2a = acoef * work[(*n << 1) + je]; + cim2a = acoef * work[*n * 3 + je]; + cre2b = bcoefr * work[(*n << 1) + je] - bcoefi * work[*n * 3 + + je]; + cim2b = bcoefi * work[(*n << 1) + je] + bcoefr * work[*n * 3 + + je]; + i__1 = je - 2; + for (jr = 1; jr <= i__1; ++jr) { + work[(*n << 1) + jr] = -creala * s[jr + (je - 1) * s_dim1] + + crealb * p[jr + (je - 1) * p_dim1] - cre2a * s[ + jr + je * s_dim1] + cre2b * p[jr + je * p_dim1]; + work[*n * 3 + jr] = -cimaga * s[jr + (je - 1) * s_dim1] + + cimagb * p[jr + (je - 1) * p_dim1] - cim2a * s[jr + + je * s_dim1] + cim2b * p[jr + je * p_dim1]; +/* L270: */ + } + } + +/* Computing MAX */ + d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 = + std::max(d__1,d__2); + dmin__ = std::max(d__1,safmin); + +/* Columnwise triangular solve of (a A - b B) x = 0 */ + + il2by2 = false; + for (j = je - nw; j >= 1; --j) { + +/* If a 2-by-2 block, is in position j-1:j, wait until */ +/* next iteration to process it (when it will be j:j+1) */ + + if (! il2by2 && j > 1) { + if (s[j + (j - 1) * s_dim1] != 0.) { + il2by2 = true; + goto L370; + } + } + bdiag[0] = p[j + j * p_dim1]; + if (il2by2) { + na = 2; + bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; + } else { + na = 1; + } + +/* Compute x(j) (and x(j+1), if 2-by-2 block) */ + + dlaln2_(&c_false, &na, &nw, &dmin__, &acoef, &s[j + j * + s_dim1], lds, bdiag, &bdiag[1], &work[(*n << 1) + j], + n, &bcoefr, &bcoefi, sum, &c__2, &scale, &temp, & + iinfo); + if (scale < 1.) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = je; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * + *n + jr]; +/* L280: */ + } +/* L290: */ + } + } +/* Computing MAX */ + d__1 = scale * xmax; + xmax = std::max(d__1,temp); + + i__1 = nw; + for (jw = 1; jw <= i__1; ++jw) { + i__2 = na; + for (ja = 1; ja <= i__2; ++ja) { + work[(jw + 1) * *n + j + ja - 1] = sum[ja + (jw << 1) + - 3]; +/* L300: */ + } +/* L310: */ + } + +/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */ + + if (j > 1) { + +/* Check whether scaling is necessary for sum. */ + + xscale = 1. / std::max(1.,xmax); + temp = acoefa * work[j] + bcoefa * work[*n + j]; + if (il2by2) { +/* Computing MAX */ + d__1 = temp, d__2 = acoefa * work[j + 1] + bcoefa * + work[*n + j + 1]; + temp = std::max(d__1,d__2); + } +/* Computing MAX */ + d__1 = std::max(temp,acoefa); + temp = std::max(d__1,bcoefa); + if (temp > bignum * xscale) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = je; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = xscale * work[(jw + + 2) * *n + jr]; +/* L320: */ + } +/* L330: */ + } + xmax *= xscale; + } + +/* Compute the contributions of the off-diagonals of */ +/* column j (and j+1, if 2-by-2 block) of A and B to the */ +/* sums. */ + + + i__1 = na; + for (ja = 1; ja <= i__1; ++ja) { + if (ilcplx) { + creala = acoef * work[(*n << 1) + j + ja - 1]; + cimaga = acoef * work[*n * 3 + j + ja - 1]; + crealb = bcoefr * work[(*n << 1) + j + ja - 1] - + bcoefi * work[*n * 3 + j + ja - 1]; + cimagb = bcoefi * work[(*n << 1) + j + ja - 1] + + bcoefr * work[*n * 3 + j + ja - 1]; + i__2 = j - 1; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = work[(*n << 1) + jr] - + creala * s[jr + (j + ja - 1) * s_dim1] + + crealb * p[jr + (j + ja - 1) * + p_dim1]; + work[*n * 3 + jr] = work[*n * 3 + jr] - + cimaga * s[jr + (j + ja - 1) * s_dim1] + + cimagb * p[jr + (j + ja - 1) * + p_dim1]; +/* L340: */ + } + } else { + creala = acoef * work[(*n << 1) + j + ja - 1]; + crealb = bcoefr * work[(*n << 1) + j + ja - 1]; + i__2 = j - 1; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = work[(*n << 1) + jr] - + creala * s[jr + (j + ja - 1) * s_dim1] + + crealb * p[jr + (j + ja - 1) * + p_dim1]; +/* L350: */ + } + } +/* L360: */ + } + } + il2by2 = false; +L370: + ; + } + +/* Copy eigenvector to VR, back transforming if */ +/* HOWMNY='B'. */ + + ieig -= nw; + if (ilback) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 4) * *n + jr] = work[(jw + 2) * *n + 1] * + vr[jr + vr_dim1]; +/* L380: */ + } + +/* A series of compiler directives to defeat */ +/* vectorization for the next loop */ + + + i__2 = je; + for (jc = 2; jc <= i__2; ++jc) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + work[(jw + 4) * *n + jr] += work[(jw + 2) * *n + + jc] * vr[jr + jc * vr_dim1]; +/* L390: */ + } +/* L400: */ + } +/* L410: */ + } + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 4) * *n + + jr]; +/* L420: */ + } +/* L430: */ + } + + iend = *n; + } else { + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 2) * *n + + jr]; +/* L440: */ + } +/* L450: */ + } + + iend = je; + } + +/* Scale eigenvector */ + + xmax = 0.; + if (ilcplx) { + i__1 = iend; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + d__3 = xmax, d__4 = (d__1 = vr[j + ieig * vr_dim1], abs( + d__1)) + (d__2 = vr[j + (ieig + 1) * vr_dim1], + abs(d__2)); + xmax = std::max(d__3,d__4); +/* L460: */ + } + } else { + i__1 = iend; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + d__2 = xmax, d__3 = (d__1 = vr[j + ieig * vr_dim1], abs( + d__1)); + xmax = std::max(d__2,d__3); +/* L470: */ + } + } + + if (xmax > safmin) { + xscale = 1. / xmax; + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = iend; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = xscale * vr[jr + ( + ieig + jw) * vr_dim1]; +/* L480: */ + } +/* L490: */ + } + } +L500: + ; + } + } + + return 0; + +/* End of DTGEVC */ + +} /* dtgevc_ */ + +/* Subroutine */ int dtgex2_(bool *wantq, bool *wantz, integer *n, + double *a, integer *lda, double *b, integer *ldb, double * + q, integer *ldq, double *z__, integer *ldz, integer *j1, integer * + n1, integer *n2, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__4 = 4; + static double c_b5 = 0.; + static integer c__1 = 1; + static integer c__2 = 2; + static double c_b42 = 1.; + static double c_b48 = -1.; + static integer c__0 = 0; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2; + double d__1; + + /* Local variables */ + double f, g; + integer i__, m; + double s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2] + , ar[2], sa, sb, li[16] /* was [4][4] */, ir[16] /* + was [4][4] */, ss, ws, eps; + bool weak; + double ddum; + integer idum; + double taul[4], dsum; + double taur[4], scpy[16] /* was [4][4] */, tcpy[16] /* was [4][4] */; + double scale, bqra21, brqa21; + double licop[16] /* was [4][4] */; + integer linfo; + double ircop[16] /* was [4][4] */, dnorm; + integer iwork[4]; + double dscale; + bool dtrong; + double thresh, smlnum; + + +/* -- LAPACK auxiliary routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */ +/* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */ +/* (A, B) by an orthogonal equivalence transformation. */ + +/* (A, B) must be in generalized real Schur canonical form (as returned */ +/* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ +/* diagonal blocks. B is upper triangular. */ + +/* Optionally, the matrices Q and Z of generalized Schur vectors are */ +/* updated. */ + +/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */ +/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */ + + +/* Arguments */ +/* ========= */ + +/* WANTQ (input) LOGICAL */ +/* .TRUE. : update the left transformation matrix Q; */ +/* .FALSE.: do not update Q. */ + +/* WANTZ (input) LOGICAL */ +/* .TRUE. : update the right transformation matrix Z; */ +/* .FALSE.: do not update Z. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION arrays, dimensions (LDA,N) */ +/* On entry, the matrix A in the pair (A, B). */ +/* On exit, the updated matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION arrays, dimensions (LDB,N) */ +/* On entry, the matrix B in the pair (A, B). */ +/* On exit, the updated matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ +/* On exit, the updated matrix Q. */ +/* Not referenced if WANTQ = .FALSE.. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= 1. */ +/* If WANTQ = .TRUE., LDQ >= N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */ +/* On exit, the updated matrix Z. */ +/* Not referenced if WANTZ = .FALSE.. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1. */ +/* If WANTZ = .TRUE., LDZ >= N. */ + +/* J1 (input) INTEGER */ +/* The index to the first block (A11, B11). 1 <= J1 <= N. */ + +/* N1 (input) INTEGER */ +/* The order of the first block (A11, B11). N1 = 0, 1 or 2. */ + +/* N2 (input) INTEGER */ +/* The order of the second block (A22, B22). N2 = 0, 1 or 2. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)). */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */ + +/* INFO (output) INTEGER */ +/* =0: Successful exit */ +/* >0: If INFO = 1, the transformed matrix (A, B) would be */ +/* too far from generalized Schur form; the blocks are */ +/* not swapped and (A, B) and (Q, Z) are unchanged. */ +/* The problem of swapping is too ill-conditioned. */ +/* <0: If INFO = -16: LWORK is too small. Appropriate value */ +/* for LWORK is returned in WORK(1). */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* In the current code both weak and strong stability tests are */ +/* performed. The user can omit the strong stability test by changing */ +/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */ +/* details. */ + +/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ + +/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* Estimation: Theory, Algorithms and Software, */ +/* Report UMINF - 94.04, Department of Computing Science, Umea */ +/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* Note 87. To appear in Numerical Algorithms, 1996. */ + +/* ===================================================================== */ +/* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO */ +/* loops. Sven Hammarling, 1/5/02. */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 1 || *n1 <= 0 || *n2 <= 0) { + return 0; + } + if (*n1 > *n || *j1 + *n1 > *n) { + return 0; + } + m = *n1 + *n2; +/* Computing MAX */ + i__1 = 1, i__2 = *n * m, i__1 = std::max(i__1,i__2), i__2 = m * m << 1; + if (*lwork < std::max(i__1,i__2)) { + *info = -16; +/* Computing MAX */ + i__1 = 1, i__2 = *n * m, i__1 = std::max(i__1,i__2), i__2 = m * m << 1; + work[1] = (double) std::max(i__1,i__2); + return 0; + } + + weak = false; + dtrong = false; + +/* Make a local copy of selected block */ + + dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4); + dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4); + dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4); + dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4); + +/* Compute threshold for testing acceptance of swapping. */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + dscale = 0.; + dsum = 1.; + dlacpy_("Full", &m, &m, s, &c__4, &work[1], &m); + i__1 = m * m; + dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum); + dlacpy_("Full", &m, &m, t, &c__4, &work[1], &m); + i__1 = m * m; + dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum); + dnorm = dscale * sqrt(dsum); +/* Computing MAX */ + d__1 = eps * 10. * dnorm; + thresh = std::max(d__1,smlnum); + + if (m == 2) { + +/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */ + +/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */ +/* using Givens rotations and perform the swap tentatively. */ + + f = s[5] * t[0] - t[5] * s[0]; + g = s[5] * t[4] - t[5] * s[4]; + sb = abs(t[5]); + sa = abs(s[5]); + dlartg_(&f, &g, &ir[4], ir, &ddum); + ir[1] = -ir[4]; + ir[5] = ir[0]; + drot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]); + drot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]); + if (sa >= sb) { + dlartg_(s, &s[1], li, &li[1], &ddum); + } else { + dlartg_(t, &t[1], li, &li[1], &ddum); + } + drot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]); + drot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]); + li[5] = li[0]; + li[4] = -li[1]; + +/* Weak stability test: */ +/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */ + + ws = abs(s[1]) + abs(t[1]); + weak = ws <= thresh; + if (! weak) { + goto L70; + } + + if (true) { + +/* Strong stability test: */ +/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */ + + dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m + + 1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + dscale = 0.; + dsum = 1.; + i__1 = m * m; + dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + + dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m + + 1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + i__1 = m * m; + dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + ss = dscale * sqrt(dsum); + dtrong = ss <= thresh; + if (! dtrong) { + goto L70; + } + } + +/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ +/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ + + i__1 = *j1 + 1; + drot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], + &c__1, ir, &ir[1]); + i__1 = *j1 + 1; + drot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], + &c__1, ir, &ir[1]); + i__1 = *n - *j1 + 1; + drot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], + lda, li, &li[1]); + i__1 = *n - *j1 + 1; + drot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], + ldb, li, &li[1]); + +/* Set N1-by-N2 (2,1) - blocks to ZERO. */ + + a[*j1 + 1 + *j1 * a_dim1] = 0.; + b[*j1 + 1 + *j1 * b_dim1] = 0.; + +/* Accumulate transformations into Q and Z if requested. */ + + if (*wantz) { + drot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + + 1], &c__1, ir, &ir[1]); + } + if (*wantq) { + drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], + &c__1, li, &li[1]); + } + +/* Exit with INFO = 0 if swap was successfully performed. */ + + return 0; + + } else { + +/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */ +/* and 2-by-2 blocks. */ + +/* Solve the generalized Sylvester equation */ +/* S11 * R - L * S22 = SCALE * S12 */ +/* T11 * R - L * T22 = SCALE * T12 */ +/* for R and L. Solutions in LI and IR. */ + + dlacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4); + dlacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + ( + *n1 + 1 << 2) - 5], &c__4); + dtgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5] +, &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, & + t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, & + dsum, &dscale, iwork, &idum, &linfo); + +/* Compute orthogonal matrix QL: */ + +/* QL' * LI = [ TL ] */ +/* [ 0 ] */ +/* where */ +/* LI = [ -L ] */ +/* [ SCALE * identity(N2) ] */ + + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + dscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1); + li[*n1 + i__ + (i__ << 2) - 5] = scale; +/* L10: */ + } + dgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + dorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + +/* Compute orthogonal matrix RQ: */ + +/* IR * RQ' = [ 0 TR], */ + +/* where IR = [ SCALE * identity(N1), R ] */ + + i__1 = *n1; + for (i__ = 1; i__ <= i__1; ++i__) { + ir[*n2 + i__ + (i__ << 2) - 5] = scale; +/* L20: */ + } + dgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + dorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + +/* Perform the swapping tentatively: */ + + dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, + s, &c__4); + dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, + t, &c__4); + dlacpy_("F", &m, &m, s, &c__4, scpy, &c__4); + dlacpy_("F", &m, &m, t, &c__4, tcpy, &c__4); + dlacpy_("F", &m, &m, ir, &c__4, ircop, &c__4); + dlacpy_("F", &m, &m, li, &c__4, licop, &c__4); + +/* Triangularize the B-part by an RQ factorization. */ +/* Apply transformation (from left) to A-part, giving S. */ + + dgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + dormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], & + linfo); + if (linfo != 0) { + goto L70; + } + dormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], & + linfo); + if (linfo != 0) { + goto L70; + } + +/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */ + + dscale = 0.; + dsum = 1.; + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + dlassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum); +/* L30: */ + } + brqa21 = dscale * sqrt(dsum); + +/* Triangularize the B-part by a QR factorization. */ +/* Apply transformation (from right) to A-part, giving S. */ + + dgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + dorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1] +, info); + dorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[ + 1], info); + if (linfo != 0) { + goto L70; + } + +/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */ + + dscale = 0.; + dsum = 1.; + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + dlassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, & + dsum); +/* L40: */ + } + bqra21 = dscale * sqrt(dsum); + +/* Decide which method to use. */ +/* Weak stability test: */ +/* F-norm(S21) <= O(EPS * F-norm((S, T))) */ + + if (bqra21 <= brqa21 && bqra21 <= thresh) { + dlacpy_("F", &m, &m, scpy, &c__4, s, &c__4); + dlacpy_("F", &m, &m, tcpy, &c__4, t, &c__4); + dlacpy_("F", &m, &m, ircop, &c__4, ir, &c__4); + dlacpy_("F", &m, &m, licop, &c__4, li, &c__4); + } else if (brqa21 >= thresh) { + goto L70; + } + +/* Set lower triangle of B-part to zero */ + + i__1 = m - 1; + i__2 = m - 1; + dlaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4); + + if (true) { + +/* Strong stability test: */ +/* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */ + + dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m + + 1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + dscale = 0.; + dsum = 1.; + i__1 = m * m; + dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + + dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m + + 1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + i__1 = m * m; + dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + ss = dscale * sqrt(dsum); + dtrong = ss <= thresh; + if (! dtrong) { + goto L70; + } + + } + +/* If the swap is accepted ("weakly" and "strongly"), apply the */ +/* transformations and set N1-by-N2 (2,1)-block to zero. */ + + dlaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4); + +/* copy back M-by-M diagonal block starting at index J1 of (A, B) */ + + dlacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda) + ; + dlacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb) + ; + dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4); + +/* Standardize existing 2-by-2 blocks. */ + + i__1 = m * m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L50: */ + } + work[1] = 1.; + t[0] = 1.; + idum = *lwork - m * m - 2; + if (*n2 > 1) { + dlagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb, + ar, ai, be, &work[1], &work[2], t, &t[1]); + work[m + 1] = -work[2]; + work[m + 2] = work[1]; + t[*n2 + (*n2 << 2) - 5] = t[0]; + t[4] = -t[1]; + } + work[m * m] = 1.; + t[m + (m << 2) - 5] = 1.; + + if (*n1 > 1) { + dlagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 + + (*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1], + &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[* + n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]); + work[m * m] = work[*n2 * m + *n2 + 1]; + work[m * m - 1] = -work[*n2 * m + *n2 + 2]; + t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5]; + t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5]; + } + dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + * + n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2); + dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) * + a_dim1], lda); + dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + * + n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2); + dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) * + b_dim1], ldb); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, & + work[m * m + 1], &m); + dlacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4); + dgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1], + lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], + n2); + dlacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1], + lda); + dgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1], + ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], + n2); + dlacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1], + ldb); + dgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, & + work[1], &m); + dlacpy_("Full", &m, &m, &work[1], &m, ir, &c__4); + +/* Accumulate transformations into Q and Z if requested. */ + + if (*wantq) { + dgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li, + &c__4, &c_b5, &work[1], n); + dlacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq); + + } + + if (*wantz) { + dgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz, + ir, &c__4, &c_b5, &work[1], n); + dlacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz); + + } + +/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ +/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ + + i__ = *j1 + m; + if (i__ <= *n) { + i__1 = *n - i__ + 1; + dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ * + a_dim1], lda, &c_b5, &work[1], &m); + i__1 = *n - i__ + 1; + dlacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1], + lda); + i__1 = *n - i__ + 1; + dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ * + b_dim1], lda, &c_b5, &work[1], &m); + i__1 = *n - i__ + 1; + dlacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1], + ldb); + } + i__ = *j1 - 1; + if (i__ > 0) { + dgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda, + ir, &c__4, &c_b5, &work[1], &i__); + dlacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1], + lda); + dgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb, + ir, &c__4, &c_b5, &work[1], &i__); + dlacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1], + ldb); + } + +/* Exit with INFO = 0 if swap was successfully performed. */ + + return 0; + + } + +/* Exit with INFO = 1 if swap was rejected. */ + +L70: + + *info = 1; + return 0; + +/* End of DTGEX2 */ + +} /* dtgex2_ */ + +/* Subroutine */ int dtgexc_(bool *wantq, bool *wantz, integer *n, + double *a, integer *lda, double *b, integer *ldb, double * + q, integer *ldq, double *z__, integer *ldz, integer *ifst, + integer *ilst, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1; + + /* Local variables */ + integer nbf, nbl, here, lwmin; + integer nbnext; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTGEXC reorders the generalized real Schur decomposition of a real */ +/* matrix pair (A,B) using an orthogonal equivalence transformation */ + +/* (A, B) = Q * (A, B) * Z', */ + +/* so that the diagonal block of (A, B) with row index IFST is moved */ +/* to row ILST. */ + +/* (A, B) must be in generalized real Schur canonical form (as returned */ +/* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ +/* diagonal blocks. B is upper triangular. */ + +/* Optionally, the matrices Q and Z of generalized Schur vectors are */ +/* updated. */ + +/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */ +/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */ + + +/* Arguments */ +/* ========= */ + +/* WANTQ (input) LOGICAL */ +/* .TRUE. : update the left transformation matrix Q; */ +/* .FALSE.: do not update Q. */ + +/* WANTZ (input) LOGICAL */ +/* .TRUE. : update the right transformation matrix Z; */ +/* .FALSE.: do not update Z. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the matrix A in generalized real Schur canonical */ +/* form. */ +/* On exit, the updated matrix A, again in generalized */ +/* real Schur canonical form. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ +/* On entry, the matrix B in generalized real Schur canonical */ +/* form (A,B). */ +/* On exit, the updated matrix B, again in generalized */ +/* real Schur canonical form (A,B). */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ +/* On exit, the updated matrix Q. */ +/* If WANTQ = .FALSE., Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= 1. */ +/* If WANTQ = .TRUE., LDQ >= N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* On entry, if WANTZ = .TRUE., the orthogonal matrix Z. */ +/* On exit, the updated matrix Z. */ +/* If WANTZ = .FALSE., Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1. */ +/* If WANTZ = .TRUE., LDZ >= N. */ + +/* IFST (input/output) INTEGER */ +/* ILST (input/output) INTEGER */ +/* Specify the reordering of the diagonal blocks of (A, B). */ +/* The block with row index IFST is moved to row ILST, by a */ +/* sequence of swapping between adjacent blocks. */ +/* On exit, if IFST pointed on entry to the second row of */ +/* a 2-by-2 block, it is changed to point to the first row; */ +/* ILST always points to the first row of the block in its */ +/* final position (which may differ from its input value by */ +/* +1 or -1). 1 <= IFST, ILST <= N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* =0: successful exit. */ +/* <0: if INFO = -i, the i-th argument had an illegal value. */ +/* =1: The transformed matrix pair (A, B) would be too far */ +/* from generalized Schur form; the problem is ill- */ +/* conditioned. (A, B) may have been partially reordered, */ +/* and ILST points to the first row of the current */ +/* position of the block being moved. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test input arguments. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldq < 1 || *wantq && *ldq < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldz < 1 || *wantz && *ldz < std::max(1_integer,*n)) { + *info = -11; + } else if (*ifst < 1 || *ifst > *n) { + *info = -12; + } else if (*ilst < 1 || *ilst > *n) { + *info = -13; + } + + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + } else { + lwmin = (*n << 2) + 16; + } + work[1] = (double) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -15; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGEXC", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + +/* Determine the first row of the specified block and find out */ +/* if it is 1-by-1 or 2-by-2. */ + + if (*ifst > 1) { + if (a[*ifst + (*ifst - 1) * a_dim1] != 0.) { + --(*ifst); + } + } + nbf = 1; + if (*ifst < *n) { + if (a[*ifst + 1 + *ifst * a_dim1] != 0.) { + nbf = 2; + } + } + +/* Determine the first row of the final block */ +/* and find out if it is 1-by-1 or 2-by-2. */ + + if (*ilst > 1) { + if (a[*ilst + (*ilst - 1) * a_dim1] != 0.) { + --(*ilst); + } + } + nbl = 1; + if (*ilst < *n) { + if (a[*ilst + 1 + *ilst * a_dim1] != 0.) { + nbl = 2; + } + } + if (*ifst == *ilst) { + return 0; + } + + if (*ifst < *ilst) { + +/* Update ILST. */ + + if (nbf == 2 && nbl == 1) { + --(*ilst); + } + if (nbf == 1 && nbl == 2) { + ++(*ilst); + } + + here = *ifst; + +L10: + +/* Swap with next one below. */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1-by-1 or 2-by-2. */ + + nbnext = 1; + if (here + nbf + 1 <= *n) { + if (a[here + nbf + 1 + (here + nbf) * a_dim1] != 0.) { + nbnext = 2; + } + } + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &here, &nbf, &nbnext, + &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += nbnext; + +/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */ + + if (nbf == 2) { + if (a[here + 1 + here * a_dim1] == 0.) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1-by-1 blocks, each of which */ +/* must be swapped individually. */ + + nbnext = 1; + if (here + 3 <= *n) { + if (a[here + 3 + (here + 2) * a_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here + 1; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &c__1, & + nbnext, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1-by-1 blocks. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, + &q[q_offset], ldq, &z__[z_offset], ldz, &here, &c__1, + &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + + } else { + +/* Recompute NBNEXT in case of 2-by-2 split. */ + + if (a[here + 2 + (here + 1) * a_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2-by-2 block did not split. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &nbnext, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += 2; + } else { + +/* 2-by-2 block did split. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + } + + } + } + if (here < *ilst) { + goto L10; + } + } else { + here = *ifst; + +L20: + +/* Swap with next one below. */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1-by-1 or 2-by-2. */ + + nbnext = 1; + if (here >= 3) { + if (a[here - 1 + (here - 2) * a_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &nbf, + &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here -= nbnext; + +/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */ + + if (nbf == 2) { + if (a[here + 1 + here * a_dim1] == 0.) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1-by-1 blocks, each of which */ +/* must be swapped individually. */ + + nbnext = 1; + if (here >= 3) { + if (a[here - 1 + (here - 2) * a_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, & + c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1-by-1 blocks. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, + &q[q_offset], ldq, &z__[z_offset], ldz, &here, & + nbnext, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + } else { + +/* Recompute NBNEXT in case of 2-by-2 split. */ + + if (a[here + (here - 1) * a_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2-by-2 block did not split. */ + + i__1 = here - 1; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + i__1, &c__2, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += -2; + } else { + +/* 2-by-2 block did split. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + } + } + } + if (here > *ilst) { + goto L20; + } + } + *ilst = here; + work[1] = (double) lwmin; + return 0; + +/* End of DTGEXC */ + +} /* dtgexc_ */ + +/* Subroutine */ int dtgsen_(integer *ijob, bool *wantq, bool *wantz, + bool *select, integer *n, double *a, integer *lda, double * + b, integer *ldb, double *alphar, double *alphai, double * + beta, double *q, integer *ldq, double *z__, integer *ldz, + integer *m, double *pl, double *pr, double *dif, + double *work, integer *lwork, integer *iwork, integer *liwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__2 = 2; + static double c_b28 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, k, n1, n2, kk, ks, mn2, ijb; + double eps; + integer kase; + bool pair; + integer ierr; + double dsum; + bool swap; + integer isave[3]; + bool wantd; + integer lwmin; + bool wantp; + bool wantd1, wantd2; + double dscale, rdscal; + integer liwmin; + double smlnum; + bool lquery; + + +/* -- LAPACK routine (version 3.1.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* January 2007 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTGSEN reorders the generalized real Schur decomposition of a real */ +/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */ +/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */ +/* appears in the leading diagonal blocks of the upper quasi-triangular */ +/* matrix A and the upper triangular B. The leading columns of Q and */ +/* Z form orthonormal bases of the corresponding left and right eigen- */ +/* spaces (deflating subspaces). (A, B) must be in generalized real */ +/* Schur canonical form (as returned by DGGES), i.e. A is block upper */ +/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */ +/* triangular. */ + +/* DTGSEN also computes the generalized eigenvalues */ + +/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */ + +/* of the reordered matrix pair (A, B). */ + +/* Optionally, DTGSEN computes the estimates of reciprocal condition */ +/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */ +/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */ +/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */ +/* the selected cluster and the eigenvalues outside the cluster, resp., */ +/* and norms of "projections" onto left and right eigenspaces w.r.t. */ +/* the selected cluster in the (1,1)-block. */ + +/* Arguments */ +/* ========= */ + +/* IJOB (input) INTEGER */ +/* Specifies whether condition numbers are required for the */ +/* cluster of eigenvalues (PL and PR) or the deflating subspaces */ +/* (Difu and Difl): */ +/* =0: Only reorder w.r.t. SELECT. No extras. */ +/* =1: Reciprocal of norms of "projections" onto left and right */ +/* eigenspaces w.r.t. the selected cluster (PL and PR). */ +/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */ +/* (DIF(1:2)). */ +/* =3: Estimate of Difu and Difl. 1-norm-based estimate */ +/* (DIF(1:2)). */ +/* About 5 times as expensive as IJOB = 2. */ +/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */ +/* version to get it all. */ +/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */ + +/* WANTQ (input) LOGICAL */ +/* .TRUE. : update the left transformation matrix Q; */ +/* .FALSE.: do not update Q. */ + +/* WANTZ (input) LOGICAL */ +/* .TRUE. : update the right transformation matrix Z; */ +/* .FALSE.: do not update Z. */ + +/* SELECT (input) LOGICAL array, dimension (N) */ +/* SELECT specifies the eigenvalues in the selected cluster. */ +/* To select a real eigenvalue w(j), SELECT(j) must be set to */ +/* .TRUE.. To select a complex conjugate pair of eigenvalues */ +/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ +/* either SELECT(j) or SELECT(j+1) or both must be set to */ +/* .TRUE.; a complex conjugate pair of eigenvalues must be */ +/* either both included in the cluster or both excluded. */ + +/* N (input) INTEGER */ +/* The order of the matrices A and B. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */ +/* On entry, the upper quasi-triangular matrix A, with (A, B) in */ +/* generalized real Schur canonical form. */ +/* On exit, A is overwritten by the reordered matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */ +/* On entry, the upper triangular matrix B, with (A, B) in */ +/* generalized real Schur canonical form. */ +/* On exit, B is overwritten by the reordered matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */ +/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */ +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */ +/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */ +/* form (S,T) that would result if the 2-by-2 diagonal blocks of */ +/* the real generalized Schur form of (A,B) were further reduced */ +/* to triangular form using complex unitary transformations. */ +/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* positive, then the j-th and (j+1)-st eigenvalues are a */ +/* complex conjugate pair, with ALPHAI(j+1) negative. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */ +/* On exit, Q has been postmultiplied by the left orthogonal */ +/* transformation matrix which reorder (A, B); The leading M */ +/* columns of Q form orthonormal bases for the specified pair of */ +/* left eigenspaces (deflating subspaces). */ +/* If WANTQ = .FALSE., Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= 1; */ +/* and if WANTQ = .TRUE., LDQ >= N. */ + +/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */ +/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */ +/* On exit, Z has been postmultiplied by the left orthogonal */ +/* transformation matrix which reorder (A, B); The leading M */ +/* columns of Z form orthonormal bases for the specified pair of */ +/* left eigenspaces (deflating subspaces). */ +/* If WANTZ = .FALSE., Z is not referenced. */ + +/* LDZ (input) INTEGER */ +/* The leading dimension of the array Z. LDZ >= 1; */ +/* If WANTZ = .TRUE., LDZ >= N. */ + +/* M (output) INTEGER */ +/* The dimension of the specified pair of left and right eigen- */ +/* spaces (deflating subspaces). 0 <= M <= N. */ + +/* PL (output) DOUBLE PRECISION */ +/* PR (output) DOUBLE PRECISION */ +/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */ +/* reciprocal of the norm of "projections" onto left and right */ +/* eigenspaces with respect to the selected cluster. */ +/* 0 < PL, PR <= 1. */ +/* If M = 0 or M = N, PL = PR = 1. */ +/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */ + +/* DIF (output) DOUBLE PRECISION array, dimension (2). */ +/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */ +/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */ +/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */ +/* estimates of Difu and Difl. */ +/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */ +/* If IJOB = 0 or 1, DIF is not referenced. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, */ +/* dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= 4*N+16. */ +/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */ +/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* IF IJOB = 0, IWORK is not referenced. Otherwise, */ +/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. LIWORK >= 1. */ +/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */ +/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal size of the IWORK array, */ +/* returns this value as the first entry of the IWORK array, and */ +/* no error message related to LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* =0: Successful exit. */ +/* <0: If INFO = -i, the i-th argument had an illegal value. */ +/* =1: Reordering of (A, B) failed because the transformed */ +/* matrix pair (A, B) would be too far from generalized */ +/* Schur form; the problem is very ill-conditioned. */ +/* (A, B) may have been partially reordered. */ +/* If requested, 0 is returned in DIF(*), PL and PR. */ + +/* Further Details */ +/* =============== */ + +/* DTGSEN first collects the selected eigenvalues by computing */ +/* orthogonal U and W that move them to the top left corner of (A, B). */ +/* In other words, the selected eigenvalues are the eigenvalues of */ +/* (A11, B11) in: */ + +/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */ +/* ( 0 A22),( 0 B22) n2 */ +/* n1 n2 n1 n2 */ + +/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */ +/* of U and W span the specified pair of left and right eigenspaces */ +/* (deflating subspaces) of (A, B). */ + +/* If (A, B) has been obtained from the generalized real Schur */ +/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */ +/* reordered generalized real Schur form of (C, D) is given by */ + +/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */ + +/* and the first n1 columns of Q*U and Z*W span the corresponding */ +/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */ + +/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */ +/* then its value may differ significantly from its value before */ +/* reordering. */ + +/* The reciprocal condition numbers of the left and right eigenspaces */ +/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */ +/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */ + +/* The Difu and Difl are defined as: */ + +/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */ +/* and */ +/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */ + +/* where sigma-min(Zu) is the smallest singular value of the */ +/* (2*n1*n2)-by-(2*n1*n2) matrix */ + +/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */ +/* [ kron(In2, B11) -kron(B22', In1) ]. */ + +/* Here, Inx is the identity matrix of size nx and A22' is the */ +/* transpose of A22. kron(X, Y) is the Kronecker product between */ +/* the matrices X and Y. */ + +/* When DIF(2) is small, small changes in (A, B) can cause large changes */ +/* in the deflating subspace. An approximate (asymptotic) bound on the */ +/* maximum angular error in the computed deflating subspaces is */ + +/* EPS * norm((A, B)) / DIF(2), */ + +/* where EPS is the machine precision. */ + +/* The reciprocal norm of the projectors on the left and right */ +/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */ +/* They are computed as follows. First we compute L and R so that */ +/* P*(A, B)*Q is block diagonal, where */ + +/* P = ( I -L ) n1 Q = ( I R ) n1 */ +/* ( 0 I ) n2 and ( 0 I ) n2 */ +/* n1 n2 n1 n2 */ + +/* and (L, R) is the solution to the generalized Sylvester equation */ + +/* A11*R - L*A22 = -A12 */ +/* B11*R - L*B22 = -B12 */ + +/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */ +/* An approximate (asymptotic) bound on the average absolute error of */ +/* the selected eigenvalues is */ + +/* EPS * norm((A, B)) / PL. */ + +/* There are also global error bounds which valid for perturbations up */ +/* to a certain restriction: A lower bound (x) on the smallest */ +/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */ +/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */ +/* (i.e. (A + E, B + F), is */ + +/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */ + +/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */ + +/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */ +/* (L', R') and unperturbed (L, R) left and right deflating subspaces */ +/* associated with the selected cluster in the (1,1)-blocks can be */ +/* bounded as */ + +/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */ +/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */ + +/* See LAPACK User's Guide section 4.11 or the following references */ +/* for more information. */ + +/* Note that if the default method for computing the Frobenius-norm- */ +/* based estimate DIF is not wanted (see DLATDF), then the parameter */ +/* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */ +/* (IJOB = 2 will be used)). See DTGSYL for more details. */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* References */ +/* ========== */ + +/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ + +/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* Estimation: Theory, Algorithms and Software, */ +/* Report UMINF - 94.04, Department of Computing Science, Umea */ +/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* Note 87. To appear in Numerical Algorithms, 1996. */ + +/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* for Solving the Generalized Sylvester Equation and Estimating the */ +/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* Department of Computing Science, Umea University, S-901 87 Umea, */ +/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */ +/* 1996. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alphar; + --alphai; + --beta; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1; + z__ -= z_offset; + --dif; + --work; + --iwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + + if (*ijob < 0 || *ijob > 5) { + *info = -1; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldq < 1 || *wantq && *ldq < *n) { + *info = -14; + } else if (*ldz < 1 || *wantz && *ldz < *n) { + *info = -16; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSEN", &i__1); + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + ierr = 0; + + wantp = *ijob == 1 || *ijob >= 4; + wantd1 = *ijob == 2 || *ijob == 4; + wantd2 = *ijob == 3 || *ijob == 5; + wantd = wantd1 || wantd2; + +/* Set M to the dimension of the specified pair of deflating */ +/* subspaces. */ + + *m = 0; + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = false; + } else { + if (k < *n) { + if (a[k + 1 + k * a_dim1] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = true; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + + if (*ijob == 1 || *ijob == 2 || *ijob == 4) { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16, i__1 = std::max(i__1,i__2), i__2 = (*m << + 1) * (*n - *m); + lwmin = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n + 6; + liwmin = std::max(i__1,i__2); + } else if (*ijob == 3 || *ijob == 5) { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16, i__1 = std::max(i__1,i__2), i__2 = (*m << + 2) * (*n - *m); + lwmin = std::max(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = std::max(i__1,i__2), i__2 = + *n + 6; + liwmin = std::max(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16; + lwmin = std::max(i__1,i__2); + liwmin = 1; + } + + work[1] = (double) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -22; + } else if (*liwork < liwmin && ! lquery) { + *info = -24; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSEN", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*m == *n || *m == 0) { + if (wantp) { + *pl = 1.; + *pr = 1.; + } + if (wantd) { + dscale = 0.; + dsum = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum); + dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum); +/* L20: */ + } + dif[1] = dscale * sqrt(dsum); + dif[2] = dif[1]; + } + goto L60; + } + +/* Collect the selected blocks at the top-left corner of (A, B). */ + + ks = 0; + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = false; + } else { + + swap = select[k]; + if (k < *n) { + if (a[k + 1 + k * a_dim1] != 0.) { + pair = true; + swap = swap || select[k + 1]; + } + } + + if (swap) { + ++ks; + +/* Swap the K-th block to position KS. */ +/* Perform the reordering of diagonal blocks in (A, B) */ +/* by orthogonal transformation matrices and update */ +/* Q and Z accordingly (if requested): */ + + kk = k; + if (k != ks) { + dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk, + &ks, &work[1], lwork, &ierr); + } + + if (ierr > 0) { + +/* Swap is rejected: exit. */ + + *info = 1; + if (wantp) { + *pl = 0.; + *pr = 0.; + } + if (wantd) { + dif[1] = 0.; + dif[2] = 0.; + } + goto L60; + } + + if (pair) { + ++ks; + } + } + } +/* L30: */ + } + if (wantp) { + +/* Solve generalized Sylvester equation for R and L */ +/* and compute PL and PR. */ + + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 0; + dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1); + dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 + + 1], &n1); + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1] +, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ * + b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], & + work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); + +/* Estimate the reciprocal of norms of "projections" onto left */ +/* and right eigenspaces. */ + + rdscal = 0.; + dsum = 1.; + i__1 = n1 * n2; + dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum); + *pl = rdscal * sqrt(dsum); + if (*pl == 0.) { + *pl = 1.; + } else { + *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl)); + } + rdscal = 0.; + dsum = 1.; + i__1 = n1 * n2; + dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum); + *pr = rdscal * sqrt(dsum); + if (*pr == 0.) { + *pr = 1.; + } else { + *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr)); + } + } + + if (wantd) { + +/* Compute estimates of Difu and Difl. */ + + if (wantd1) { + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 3; + +/* Frobenius norm-based Difu-estimate. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * + a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + + i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, & + dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], & + ierr); + +/* Frobenius norm-based Difl-estimate. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[ + a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1], + ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale, + &dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], & + ierr); + } else { + + +/* Compute 1-norm-based estimates of Difu and Difl using */ +/* reversed communication with DLACN2. In each step a */ +/* generalized Sylvester equation or a transposed variant */ +/* is solved. */ + + kase = 0; + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 0; + mn2 = (n1 << 1) * n2; + +/* 1-norm-based estimate of Difu. */ + +L40: + dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase, + isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve generalized Sylvester equation. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + + i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } else { + +/* Solve the transposed variant. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + + i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } + goto L40; + } + dif[1] = dscale / dif[1]; + +/* 1-norm-based estimate of Difl. */ + +L50: + dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase, + isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve generalized Sylvester equation. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, + &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * + b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + + 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } else { + +/* Solve the transposed variant. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, + &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * + b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + + 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } + goto L50; + } + dif[2] = dscale / dif[2]; + + } + } + +L60: + +/* Compute generalized eigenvalues of reordered pair (A, B) and */ +/* normalize the generalized Schur form. */ + + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = false; + } else { + + if (k < *n) { + if (a[k + 1 + k * a_dim1] != 0.) { + pair = true; + } + } + + if (pair) { + +/* Compute the eigenvalue(s) at position K. */ + + work[1] = a[k + k * a_dim1]; + work[2] = a[k + 1 + k * a_dim1]; + work[3] = a[k + (k + 1) * a_dim1]; + work[4] = a[k + 1 + (k + 1) * a_dim1]; + work[5] = b[k + k * b_dim1]; + work[6] = b[k + 1 + k * b_dim1]; + work[7] = b[k + (k + 1) * b_dim1]; + work[8] = b[k + 1 + (k + 1) * b_dim1]; + d__1 = smlnum * eps; + dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], & + beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]); + alphai[k + 1] = -alphai[k]; + + } else { + + if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) { + +/* If B(K,K) is negative, make it positive */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[k + i__ * a_dim1] = -a[k + i__ * a_dim1]; + b[k + i__ * b_dim1] = -b[k + i__ * b_dim1]; + q[i__ + k * q_dim1] = -q[i__ + k * q_dim1]; +/* L70: */ + } + } + + alphar[k] = a[k + k * a_dim1]; + alphai[k] = 0.; + beta[k] = b[k + k * b_dim1]; + + } + } +/* L80: */ + } + + work[1] = (double) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DTGSEN */ + +} /* dtgsen_ */ + +/* Subroutine */ int dtgsja_(const char *jobu, const char *jobv, const char *jobq, integer *m, + integer *p, integer *n, integer *k, integer *l, double *a, + integer *lda, double *b, integer *ldb, double *tola, + double *tolb, double *alpha, double *beta, double *u, + integer *ldu, double *v, integer *ldv, double *q, integer * + ldq, double *work, integer *ncycle, integer *info) +{ + /* Table of constant values */ + static double c_b13 = 0.; + static double c_b14 = 1.; + static integer c__1 = 1; + static double c_b43 = -1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; + double d__1; + + /* Local variables */ + integer i__, j; + double a1, a2, a3, b1, b2, b3, csq, csu, csv, snq, rwk, snu, snv; + double gamma; + bool initq, initu, initv, wantq, upper; + double error, ssmin; + bool wantu, wantv; + integer kcycle; + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTGSJA computes the generalized singular value decomposition (GSVD) */ +/* of two real upper triangular (or trapezoidal) matrices A and B. */ + +/* On entry, it is assumed that matrices A and B have the following */ +/* forms, which may be obtained by the preprocessing subroutine DGGSVP */ +/* from a general M-by-N matrix A and P-by-N matrix B: */ + +/* N-K-L K L */ +/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* L ( 0 0 A23 ) */ +/* M-K-L ( 0 0 0 ) */ + +/* N-K-L K L */ +/* A = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* M-K ( 0 0 A23 ) */ + +/* N-K-L K L */ +/* B = L ( 0 0 B13 ) */ +/* P-L ( 0 0 0 ) */ + +/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* otherwise A23 is (M-K)-by-L upper trapezoidal. */ + +/* On exit, */ + +/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */ + +/* where U, V and Q are orthogonal matrices, Z' denotes the transpose */ +/* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are */ +/* ``diagonal'' matrices, which are of the following structures: */ + +/* If M-K-L >= 0, */ + +/* K L */ +/* D1 = K ( I 0 ) */ +/* L ( 0 C ) */ +/* M-K-L ( 0 0 ) */ + +/* K L */ +/* D2 = L ( 0 S ) */ +/* P-L ( 0 0 ) */ + +/* N-K-L K L */ +/* ( 0 R ) = K ( 0 R11 R12 ) K */ +/* L ( 0 0 R22 ) L */ + +/* where */ + +/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* C**2 + S**2 = I. */ + +/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */ + +/* If M-K-L < 0, */ + +/* K M-K K+L-M */ +/* D1 = K ( I 0 0 ) */ +/* M-K ( 0 C 0 ) */ + +/* K M-K K+L-M */ +/* D2 = M-K ( 0 S 0 ) */ +/* K+L-M ( 0 0 I ) */ +/* P-L ( 0 0 0 ) */ + +/* N-K-L K M-K K+L-M */ +/* ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* M-K ( 0 0 R22 R23 ) */ +/* K+L-M ( 0 0 0 R33 ) */ + +/* where */ +/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* S = diag( BETA(K+1), ... , BETA(M) ), */ +/* C**2 + S**2 = I. */ + +/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */ +/* ( 0 R22 R23 ) */ +/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */ + +/* The computation of the orthogonal transformation matrices U, V or Q */ +/* is optional. These matrices may either be formed explicitly, or they */ +/* may be postmultiplied into input matrices U1, V1, or Q1. */ + +/* Arguments */ +/* ========= */ + +/* JOBU (input) CHARACTER*1 */ +/* = 'U': U must contain an orthogonal matrix U1 on entry, and */ +/* the product U1*U is returned; */ +/* = 'I': U is initialized to the unit matrix, and the */ +/* orthogonal matrix U is returned; */ +/* = 'N': U is not computed. */ + +/* JOBV (input) CHARACTER*1 */ +/* = 'V': V must contain an orthogonal matrix V1 on entry, and */ +/* the product V1*V is returned; */ +/* = 'I': V is initialized to the unit matrix, and the */ +/* orthogonal matrix V is returned; */ +/* = 'N': V is not computed. */ + +/* JOBQ (input) CHARACTER*1 */ +/* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */ +/* the product Q1*Q is returned; */ +/* = 'I': Q is initialized to the unit matrix, and the */ +/* orthogonal matrix Q is returned; */ +/* = 'N': Q is not computed. */ + +/* M (input) INTEGER */ +/* The number of rows of the matrix A. M >= 0. */ + +/* P (input) INTEGER */ +/* The number of rows of the matrix B. P >= 0. */ + +/* N (input) INTEGER */ +/* The number of columns of the matrices A and B. N >= 0. */ + +/* K (input) INTEGER */ +/* L (input) INTEGER */ +/* K and L specify the subblocks in the input matrices A and B: */ +/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */ +/* of A and B, whose GSVD is going to be computed by DTGSJA. */ +/* See Further details. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the M-by-N matrix A. */ +/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */ +/* matrix R or part of R. See Purpose for details. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */ +/* On entry, the P-by-N matrix B. */ +/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */ +/* a part of R. See Purpose for details. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,P). */ + +/* TOLA (input) DOUBLE PRECISION */ +/* TOLB (input) DOUBLE PRECISION */ +/* TOLA and TOLB are the convergence criteria for the Jacobi- */ +/* Kogbetliantz iteration procedure. Generally, they are the */ +/* same as used in the preprocessing step, say */ +/* TOLA = max(M,N)*norm(A)*MAZHEPS, */ +/* TOLB = max(P,N)*norm(B)*MAZHEPS. */ + +/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */ +/* BETA (output) DOUBLE PRECISION array, dimension (N) */ +/* On exit, ALPHA and BETA contain the generalized singular */ +/* value pairs of A and B; */ +/* ALPHA(1:K) = 1, */ +/* BETA(1:K) = 0, */ +/* and if M-K-L >= 0, */ +/* ALPHA(K+1:K+L) = diag(C), */ +/* BETA(K+1:K+L) = diag(S), */ +/* or if M-K-L < 0, */ +/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */ +/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */ +/* Furthermore, if K+L < N, */ +/* ALPHA(K+L+1:N) = 0 and */ +/* BETA(K+L+1:N) = 0. */ + +/* U (input/output) DOUBLE PRECISION array, dimension (LDU,M) */ +/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */ +/* the orthogonal matrix returned by DGGSVP). */ +/* On exit, */ +/* if JOBU = 'I', U contains the orthogonal matrix U; */ +/* if JOBU = 'U', U contains the product U1*U. */ +/* If JOBU = 'N', U is not referenced. */ + +/* LDU (input) INTEGER */ +/* The leading dimension of the array U. LDU >= max(1,M) if */ +/* JOBU = 'U'; LDU >= 1 otherwise. */ + +/* V (input/output) DOUBLE PRECISION array, dimension (LDV,P) */ +/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */ +/* the orthogonal matrix returned by DGGSVP). */ +/* On exit, */ +/* if JOBV = 'I', V contains the orthogonal matrix V; */ +/* if JOBV = 'V', V contains the product V1*V. */ +/* If JOBV = 'N', V is not referenced. */ + +/* LDV (input) INTEGER */ +/* The leading dimension of the array V. LDV >= max(1,P) if */ +/* JOBV = 'V'; LDV >= 1 otherwise. */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */ +/* the orthogonal matrix returned by DGGSVP). */ +/* On exit, */ +/* if JOBQ = 'I', Q contains the orthogonal matrix Q; */ +/* if JOBQ = 'Q', Q contains the product Q1*Q. */ +/* If JOBQ = 'N', Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N) if */ +/* JOBQ = 'Q'; LDQ >= 1 otherwise. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ + +/* NCYCLE (output) INTEGER */ +/* The number of cycles required for convergence. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* = 1: the procedure does not converge after MAXIT cycles. */ + +/* Internal Parameters */ +/* =================== */ + +/* MAXIT INTEGER */ +/* MAXIT specifies the total loops that the iterative procedure */ +/* may take. If after MAXIT cycles, the routine fails to */ +/* converge, we return INFO = 1. */ + +/* Further Details */ +/* =============== */ + +/* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */ +/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */ +/* matrix B13 to the form: */ + +/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */ + +/* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose */ +/* of Z. C1 and S1 are diagonal matrices satisfying */ + +/* C1**2 + S1**2 = I, */ + +/* and R1 is an L-by-L nonsingular upper triangular matrix. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ + +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --work; + + /* Function Body */ + initu = lsame_(jobu, "I"); + wantu = initu || lsame_(jobu, "U"); + + initv = lsame_(jobv, "I"); + wantv = initv || lsame_(jobv, "V"); + + initq = lsame_(jobq, "I"); + wantq = initq || lsame_(jobq, "Q"); + + *info = 0; + if (! (initu || wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (initv || wantv || lsame_(jobv, "N"))) + { + *info = -2; + } else if (! (initq || wantq || lsame_(jobq, "N"))) + { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < std::max(1_integer,*m)) { + *info = -10; + } else if (*ldb < std::max(1_integer,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -18; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -20; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -22; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSJA", &i__1); + return 0; + } + +/* Initialize U, V and Q, if necessary */ + + if (initu) { + dlaset_("Full", m, m, &c_b13, &c_b14, &u[u_offset], ldu); + } + if (initv) { + dlaset_("Full", p, p, &c_b13, &c_b14, &v[v_offset], ldv); + } + if (initq) { + dlaset_("Full", n, n, &c_b13, &c_b14, &q[q_offset], ldq); + } + +/* Loop until convergence */ + + upper = false; + for (kcycle = 1; kcycle <= 40; ++kcycle) { + + upper = ! upper; + + i__1 = *l - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *l; + for (j = i__ + 1; j <= i__2; ++j) { + + a1 = 0.; + a2 = 0.; + a3 = 0.; + if (*k + i__ <= *m) { + a1 = a[*k + i__ + (*n - *l + i__) * a_dim1]; + } + if (*k + j <= *m) { + a3 = a[*k + j + (*n - *l + j) * a_dim1]; + } + + b1 = b[i__ + (*n - *l + i__) * b_dim1]; + b3 = b[j + (*n - *l + j) * b_dim1]; + + if (upper) { + if (*k + i__ <= *m) { + a2 = a[*k + i__ + (*n - *l + j) * a_dim1]; + } + b2 = b[i__ + (*n - *l + j) * b_dim1]; + } else { + if (*k + j <= *m) { + a2 = a[*k + j + (*n - *l + i__) * a_dim1]; + } + b2 = b[j + (*n - *l + i__) * b_dim1]; + } + + dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, & + csv, &snv, &csq, &snq); + +/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */ + + if (*k + j <= *m) { + drot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k + + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu); + } + +/* Update I-th and J-th rows of matrix B: V'*B */ + + drot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - * + l + 1) * b_dim1], ldb, &csv, &snv); + +/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */ +/* A and B: A*Q and B*Q */ + +/* Computing MIN */ + i__4 = *k + *l; + i__3 = std::min(i__4,*m); + drot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - * + l + i__) * a_dim1 + 1], &c__1, &csq, &snq); + + drot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l + + i__) * b_dim1 + 1], &c__1, &csq, &snq); + + if (upper) { + if (*k + i__ <= *m) { + a[*k + i__ + (*n - *l + j) * a_dim1] = 0.; + } + b[i__ + (*n - *l + j) * b_dim1] = 0.; + } else { + if (*k + j <= *m) { + a[*k + j + (*n - *l + i__) * a_dim1] = 0.; + } + b[j + (*n - *l + i__) * b_dim1] = 0.; + } + +/* Update orthogonal matrices U, V, Q, if desired. */ + + if (wantu && *k + j <= *m) { + drot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) * + u_dim1 + 1], &c__1, &csu, &snu); + } + + if (wantv) { + drot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1], + &c__1, &csv, &snv); + } + + if (wantq) { + drot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - * + l + i__) * q_dim1 + 1], &c__1, &csq, &snq); + } + +/* L10: */ + } +/* L20: */ + } + + if (! upper) { + +/* The matrices A13 and B13 were lower triangular at the start */ +/* of the cycle, and are now upper triangular. */ + +/* Convergence test: test the parallelism of the corresponding */ +/* rows of A and B. */ + + error = 0.; +/* Computing MIN */ + i__2 = *l, i__3 = *m - *k; + i__1 = std::min(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *l - i__ + 1; + dcopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, & + work[1], &c__1); + i__2 = *l - i__ + 1; + dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[* + l + 1], &c__1); + i__2 = *l - i__ + 1; + dlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin); + error = std::max(error,ssmin); +/* L30: */ + } + + if (abs(error) <= std::min(*tola,*tolb)) { + goto L50; + } + } + +/* End of cycle loop */ + +/* L40: */ + } + +/* The algorithm has not converged after MAXIT cycles. */ + + *info = 1; + goto L100; + +L50: + +/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */ +/* Compute the generalized singular value pairs (ALPHA, BETA), and */ +/* set the triangular matrix R to array A. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + alpha[i__] = 1.; + beta[i__] = 0.; +/* L60: */ + } + +/* Computing MIN */ + i__2 = *l, i__3 = *m - *k; + i__1 = std::min(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + + a1 = a[*k + i__ + (*n - *l + i__) * a_dim1]; + b1 = b[i__ + (*n - *l + i__) * b_dim1]; + + if (a1 != 0.) { + gamma = b1 / a1; + +/* change sign if necessary */ + + if (gamma < 0.) { + i__2 = *l - i__ + 1; + dscal_(&i__2, &c_b43, &b[i__ + (*n - *l + i__) * b_dim1], ldb) + ; + if (wantv) { + dscal_(p, &c_b43, &v[i__ * v_dim1 + 1], &c__1); + } + } + + d__1 = abs(gamma); + dlartg_(&d__1, &c_b14, &beta[*k + i__], &alpha[*k + i__], &rwk); + + if (alpha[*k + i__] >= beta[*k + i__]) { + i__2 = *l - i__ + 1; + d__1 = 1. / alpha[*k + i__]; + dscal_(&i__2, &d__1, &a[*k + i__ + (*n - *l + i__) * a_dim1], + lda); + } else { + i__2 = *l - i__ + 1; + d__1 = 1. / beta[*k + i__]; + dscal_(&i__2, &d__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb); + i__2 = *l - i__ + 1; + dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + + i__ + (*n - *l + i__) * a_dim1], lda); + } + + } else { + + alpha[*k + i__] = 0.; + beta[*k + i__] = 1.; + i__2 = *l - i__ + 1; + dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + + i__ + (*n - *l + i__) * a_dim1], lda); + + } + +/* L70: */ + } + +/* Post-assignment */ + + i__1 = *k + *l; + for (i__ = *m + 1; i__ <= i__1; ++i__) { + alpha[i__] = 0.; + beta[i__] = 1.; +/* L80: */ + } + + if (*k + *l < *n) { + i__1 = *n; + for (i__ = *k + *l + 1; i__ <= i__1; ++i__) { + alpha[i__] = 0.; + beta[i__] = 0.; +/* L90: */ + } + } + +L100: + *ncycle = kcycle; + return 0; + +/* End of DTGSJA */ + +} /* dtgsja_ */ + +/* Subroutine */ int dtgsna_(const char *job, const char *howmny, bool *select, + integer *n, double *a, integer *lda, double *b, integer *ldb, + double *vl, integer *ldvl, double *vr, integer *ldvr, + double *s, double *dif, integer *mm, integer *m, double * + work, integer *lwork, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b19 = 1.; + static double c_b21 = 0.; + static integer c__2 = 2; + static bool c_false = false; + static integer c__3 = 3; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, k; + double c1, c2; + integer n1, n2, ks, iz; + double eps, beta, cond; + bool pair; + integer ierr; + double uhav, uhbv; + integer ifst; + double lnrm; + integer ilst; + double rnrm; + double root1, root2, scale; + double uhavi, uhbvi, tmpii; + integer lwmin; + bool wants; + double tmpir, tmpri, dummy[1], tmprr; + double dummy1[1]; + double alphai, alphar; + bool wantbh, wantdf, somcon; + double alprqt; + double smlnum; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTGSNA estimates reciprocal condition numbers for specified */ +/* eigenvalues and/or eigenvectors of a matrix pair (A, B) in */ +/* generalized real Schur canonical form (or of any matrix pair */ +/* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where */ +/* Z' denotes the transpose of Z. */ + +/* (A, B) must be in generalized real Schur form (as returned by DGGES), */ +/* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal */ +/* blocks. B is upper triangular. */ + + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* Specifies whether condition numbers are required for */ +/* eigenvalues (S) or eigenvectors (DIF): */ +/* = 'E': for eigenvalues only (S); */ +/* = 'V': for eigenvectors only (DIF); */ +/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */ + +/* HOWMNY (input) CHARACTER*1 */ +/* = 'A': compute condition numbers for all eigenpairs; */ +/* = 'S': compute condition numbers for selected eigenpairs */ +/* specified by the array SELECT. */ + +/* SELECT (input) LOGICAL array, dimension (N) */ +/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ +/* condition numbers are required. To select condition numbers */ +/* for the eigenpair corresponding to a real eigenvalue w(j), */ +/* SELECT(j) must be set to .TRUE.. To select condition numbers */ +/* corresponding to a complex conjugate pair of eigenvalues w(j) */ +/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */ +/* set to .TRUE.. */ +/* If HOWMNY = 'A', SELECT is not referenced. */ + +/* N (input) INTEGER */ +/* The order of the square matrix pair (A, B). N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The upper quasi-triangular matrix A in the pair (A,B). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */ +/* The upper triangular matrix B in the pair (A,B). */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* VL (input) DOUBLE PRECISION array, dimension (LDVL,M) */ +/* If JOB = 'E' or 'B', VL must contain left eigenvectors of */ +/* (A, B), corresponding to the eigenpairs specified by HOWMNY */ +/* and SELECT. The eigenvectors must be stored in consecutive */ +/* columns of VL, as returned by DTGEVC. */ +/* If JOB = 'V', VL is not referenced. */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the array VL. LDVL >= 1. */ +/* If JOB = 'E' or 'B', LDVL >= N. */ + +/* VR (input) DOUBLE PRECISION array, dimension (LDVR,M) */ +/* If JOB = 'E' or 'B', VR must contain right eigenvectors of */ +/* (A, B), corresponding to the eigenpairs specified by HOWMNY */ +/* and SELECT. The eigenvectors must be stored in consecutive */ +/* columns ov VR, as returned by DTGEVC. */ +/* If JOB = 'V', VR is not referenced. */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the array VR. LDVR >= 1. */ +/* If JOB = 'E' or 'B', LDVR >= N. */ + +/* S (output) DOUBLE PRECISION array, dimension (MM) */ +/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */ +/* selected eigenvalues, stored in consecutive elements of the */ +/* array. For a complex conjugate pair of eigenvalues two */ +/* consecutive elements of S are set to the same value. Thus */ +/* S(j), DIF(j), and the j-th columns of VL and VR all */ +/* correspond to the same eigenpair (but not in general the */ +/* j-th eigenpair, unless all eigenpairs are selected). */ +/* If JOB = 'V', S is not referenced. */ + +/* DIF (output) DOUBLE PRECISION array, dimension (MM) */ +/* If JOB = 'V' or 'B', the estimated reciprocal condition */ +/* numbers of the selected eigenvectors, stored in consecutive */ +/* elements of the array. For a complex eigenvector two */ +/* consecutive elements of DIF are set to the same value. If */ +/* the eigenvalues cannot be reordered to compute DIF(j), DIF(j) */ +/* is set to 0; this can only occur when the true value would be */ +/* very small anyway. */ +/* If JOB = 'E', DIF is not referenced. */ + +/* MM (input) INTEGER */ +/* The number of elements in the arrays S and DIF. MM >= M. */ + +/* M (output) INTEGER */ +/* The number of elements of the arrays S and DIF used to store */ +/* the specified condition numbers; for each selected real */ +/* eigenvalue one element is used, and for each selected complex */ +/* conjugate pair of eigenvalues, two elements are used. */ +/* If HOWMNY = 'A', M is set to N. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,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). */ +/* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (N + 6) */ +/* If JOB = 'E', IWORK is not referenced. */ + +/* INFO (output) INTEGER */ +/* =0: Successful exit */ +/* <0: If INFO = -i, the i-th argument had an illegal value */ + + +/* Further Details */ +/* =============== */ + +/* The reciprocal of the condition number of a generalized eigenvalue */ +/* w = (a, b) is defined as */ + +/* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v)) */ + +/* where u and v are the left and right eigenvectors of (A, B) */ +/* corresponding to w; |z| denotes the absolute value of the complex */ +/* number, and norm(u) denotes the 2-norm of the vector u. */ +/* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv) */ +/* of the matrix pair (A, B). If both a and b equal zero, then (A B) is */ +/* singular and S(I) = -1 is returned. */ + +/* An approximate error bound on the chordal distance between the i-th */ +/* computed generalized eigenvalue w and the corresponding exact */ +/* eigenvalue lambda is */ + +/* chord(w, lambda) <= EPS * norm(A, B) / S(I) */ + +/* where EPS is the machine precision. */ + +/* The reciprocal of the condition number DIF(i) of right eigenvector u */ +/* and left eigenvector v corresponding to the generalized eigenvalue w */ +/* is defined as follows: */ + +/* a) If the i-th eigenvalue w = (a,b) is real */ + +/* Suppose U and V are orthogonal transformations such that */ + +/* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 */ +/* ( 0 S22 ),( 0 T22 ) n-1 */ +/* 1 n-1 1 n-1 */ + +/* Then the reciprocal condition number DIF(i) is */ + +/* Difl((a, b), (S22, T22)) = sigma-min( Zl ), */ + +/* where sigma-min(Zl) denotes the smallest singular value of the */ +/* 2(n-1)-by-2(n-1) matrix */ + +/* Zl = [ kron(a, In-1) -kron(1, S22) ] */ +/* [ kron(b, In-1) -kron(1, T22) ] . */ + +/* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the */ +/* Kronecker product between the matrices X and Y. */ + +/* Note that if the default method for computing DIF(i) is wanted */ +/* (see DLATDF), then the parameter DIFDRI (see below) should be */ +/* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). */ +/* See DTGSYL for more details. */ + +/* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, */ + +/* Suppose U and V are orthogonal transformations such that */ + +/* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 */ +/* ( 0 S22 ),( 0 T22) n-2 */ +/* 2 n-2 2 n-2 */ + +/* and (S11, T11) corresponds to the complex conjugate eigenvalue */ +/* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such */ +/* that */ + +/* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 ) */ +/* ( 0 s22 ) ( 0 t22 ) */ + +/* where the generalized eigenvalues w = s11/t11 and */ +/* conjg(w) = s22/t22. */ + +/* Then the reciprocal condition number DIF(i) is bounded by */ + +/* min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) */ + +/* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where */ +/* Z1 is the complex 2-by-2 matrix */ + +/* Z1 = [ s11 -s22 ] */ +/* [ t11 -t22 ], */ + +/* This is done by computing (using real arithmetic) the */ +/* roots of the characteristical polynomial det(Z1' * Z1 - lambda I), */ +/* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes */ +/* the determinant of X. */ + +/* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an */ +/* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) */ + +/* Z2 = [ kron(S11', In-2) -kron(I2, S22) ] */ +/* [ kron(T11', In-2) -kron(I2, T22) ] */ + +/* Note that if the default method for computing DIF is wanted (see */ +/* DLATDF), then the parameter DIFDRI (see below) should be changed */ +/* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL */ +/* for more details. */ + +/* For each eigenvalue/vector specified by SELECT, DIF stores a */ +/* Frobenius norm-based estimate of Difl. */ + +/* An approximate error bound for the i-th computed eigenvector VL(i) or */ +/* VR(i) is given by */ + +/* EPS * norm(A, B) / DIF(i). */ + +/* See ref. [2-3] for more details and further references. */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* References */ +/* ========== */ + +/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ + +/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* Estimation: Theory, Algorithms and Software, */ +/* Report UMINF - 94.04, Department of Computing Science, Umea */ +/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* Note 87. To appear in Numerical Algorithms, 1996. */ + +/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* for Solving the Generalized Sylvester Equation and Estimating the */ +/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* Department of Computing Science, Umea University, S-901 87 Umea, */ +/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ +/* No 1, 1996. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --s; + --dif; + --work; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantdf = lsame_(job, "V") || wantbh; + + somcon = lsame_(howmny, "S"); + + *info = 0; + lquery = *lwork == -1; + + if (! wants && ! wantdf) { + *info = -1; + } else if (! lsame_(howmny, "A") && ! somcon) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } else if (wants && *ldvl < *n) { + *info = -10; + } else if (wants && *ldvr < *n) { + *info = -12; + } else { + +/* Set M to the number of eigenpairs for which condition numbers */ +/* are required, and test MM. */ + + if (somcon) { + *m = 0; + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = false; + } else { + if (k < *n) { + if (a[k + 1 + k * a_dim1] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = true; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*n == 0) { + lwmin = 1; + } else if (lsame_(job, "V") || lsame_(job, + "B")) { + lwmin = (*n << 1) * (*n + 2) + 16; + } else { + lwmin = *n; + } + work[1] = (double) lwmin; + + if (*mm < *m) { + *info = -15; + } else if (*lwork < lwmin && ! lquery) { + *info = -18; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSNA", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + ks = 0; + pair = false; + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. */ + + if (pair) { + pair = false; + goto L20; + } else { + if (k < *n) { + pair = a[k + 1 + k * a_dim1] != 0.; + } + } + +/* Determine whether condition numbers are required for the k-th */ +/* eigenpair. */ + + if (somcon) { + if (pair) { + if (! select[k] && ! select[k + 1]) { + goto L20; + } + } else { + if (! select[k]) { + goto L20; + } + } + } + + ++ks; + + if (wants) { + +/* Compute the reciprocal condition number of the k-th */ +/* eigenvalue. */ + + if (pair) { + +/* Complex eigenvalue pair. */ + + d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); + rnrm = dlapy2_(&d__1, &d__2); + d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); + lnrm = dlapy2_(&d__1, &d__2); + dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[(ks + 1) * + vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1); + tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + uhav = tmprr + tmpii; + uhavi = tmpir - tmpri; + dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[(ks + 1) * + vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1); + tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + uhbv = tmprr + tmpii; + uhbvi = tmpir - tmpri; + uhav = dlapy2_(&uhav, &uhavi); + uhbv = dlapy2_(&uhbv, &uhbvi); + cond = dlapy2_(&uhav, &uhbv); + s[ks] = cond / (rnrm * lnrm); + s[ks + 1] = s[ks]; + + } else { + +/* Real eigenvalue. */ + + rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + uhav = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1) + ; + dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + uhbv = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1) + ; + cond = dlapy2_(&uhav, &uhbv); + if (cond == 0.) { + s[ks] = -1.; + } else { + s[ks] = cond / (rnrm * lnrm); + } + } + } + + if (wantdf) { + if (*n == 1) { + dif[ks] = dlapy2_(&a[a_dim1 + 1], &b[b_dim1 + 1]); + goto L20; + } + +/* Estimate the reciprocal condition number of the k-th */ +/* eigenvectors. */ + if (pair) { + +/* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). */ +/* Compute the eigenvalue(s) at position K. */ + + work[1] = a[k + k * a_dim1]; + work[2] = a[k + 1 + k * a_dim1]; + work[3] = a[k + (k + 1) * a_dim1]; + work[4] = a[k + 1 + (k + 1) * a_dim1]; + work[5] = b[k + k * b_dim1]; + work[6] = b[k + 1 + k * b_dim1]; + work[7] = b[k + (k + 1) * b_dim1]; + work[8] = b[k + 1 + (k + 1) * b_dim1]; + d__1 = smlnum * eps; + dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta, dummy1, + &alphar, dummy, &alphai); + alprqt = 1.; + c1 = (alphar * alphar + alphai * alphai + beta * beta) * 2.; + c2 = beta * 4. * beta * alphai * alphai; + root1 = c1 + sqrt(c1 * c1 - c2 * 4.); + root2 = c2 / root1; + root1 /= 2.; +/* Computing MIN */ + d__1 = sqrt(root1), d__2 = sqrt(root2); + cond = std::min(d__1,d__2); + } + +/* Copy the matrix (A, B) to the array WORK and swap the */ +/* diagonal block beginning at A(k,k) to the (1,1) position. */ + + dlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n); + dlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n); + ifst = k; + ilst = 1; + + i__2 = *lwork - (*n << 1) * *n; + dtgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n, + dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &work[(*n * * + n << 1) + 1], &i__2, &ierr); + + if (ierr > 0) { + +/* Ill-conditioned problem - swap rejected. */ + + dif[ks] = 0.; + } else { + +/* Reordering successful, solve generalized Sylvester */ +/* equation for R and L, */ +/* A22 * R - L * A11 = A12 */ +/* B22 * R - L * B11 = B12, */ +/* and compute estimate of Difl((A11,B11), (A22, B22)). */ + + n1 = 1; + if (work[2] != 0.) { + n1 = 2; + } + n2 = *n - n1; + if (n2 == 0) { + dif[ks] = cond; + } else { + i__ = *n * *n + 1; + iz = (*n << 1) * *n + 1; + i__2 = *lwork - (*n << 1) * *n; + dtgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n, + &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1 + + i__], n, &work[i__], n, &work[n1 + i__], n, & + scale, &dif[ks], &work[iz + 1], &i__2, &iwork[1], + &ierr); + + if (pair) { +/* Computing MIN */ + d__1 = std::max(1.,alprqt) * dif[ks]; + dif[ks] = std::min(d__1,cond); + } + } + } + if (pair) { + dif[ks + 1] = dif[ks]; + } + } + if (pair) { + ++ks; + } + +L20: + ; + } + work[1] = (double) lwmin; + return 0; + +/* End of DTGSNA */ + +} /* dtgsna_ */ + +/* Subroutine */ int dtgsy2_(const char *trans, integer *ijob, integer *m, integer * + n, double *a, integer *lda, double *b, integer *ldb, + double *c__, integer *ldc, double *d__, integer *ldd, + double *e, integer *lde, double *f, integer *ldf, double * + scale, double *rdsum, double *rdscal, integer *iwork, integer + *pq, integer *info) +{ + /* Table of constant values */ + static integer c__8 = 8; + static integer c__1 = 1; + static double c_b27 = -1.; + static double c_b42 = 1.; + static double c_b56 = 0.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, p, q; + double z__[64] /* was [8][8] */; + integer ie, je, mb, nb, ii, jj, is, js; + double rhs[8]; + integer isp1, jsp1; + integer ierr, zdim, ipiv[8], jpiv[8]; + double alpha; + double scaloc; + bool notran; + + +/* -- LAPACK auxiliary routine (version 3.1.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* January 2007 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTGSY2 solves the generalized Sylvester equation: */ + +/* A * R - L * B = scale * C (1) */ +/* D * R - L * E = scale * F, */ + +/* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, */ +/* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */ +/* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) */ +/* must be in generalized Schur canonical form, i.e. A, B are upper */ +/* quasi triangular and D, E are upper triangular. The solution (R, L) */ +/* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor */ +/* chosen to avoid overflow. */ + +/* In matrix notation solving equation (1) corresponds to solve */ +/* Z*x = scale*b, where Z is defined as */ + +/* Z = [ kron(In, A) -kron(B', Im) ] (2) */ +/* [ kron(In, D) -kron(E', Im) ], */ + +/* Ik is the identity matrix of size k and X' is the transpose of X. */ +/* kron(X, Y) is the Kronecker product between the matrices X and Y. */ +/* In the process of solving (1), we solve a number of such systems */ +/* where Dim(In), Dim(In) = 1 or 2. */ + +/* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, */ +/* which is equivalent to solve for R and L in */ + +/* A' * R + D' * L = scale * C (3) */ +/* R * B' + L * E' = scale * -F */ + +/* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */ +/* sigma_min(Z) using reverse communicaton with DLACON. */ + +/* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL */ +/* of an upper bound on the separation between to matrix pairs. Then */ +/* the input (A, D), (B, E) are sub-pencils of the matrix pair in */ +/* DTGSYL. See DTGSYL for details. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* = 'N', solve the generalized Sylvester equation (1). */ +/* = 'T': solve the 'transposed' system (3). */ + +/* IJOB (input) INTEGER */ +/* Specifies what kind of functionality to be performed. */ +/* = 0: solve (1) only. */ +/* = 1: A contribution from this subsystem to a Frobenius */ +/* norm-based estimate of the separation between two matrix */ +/* pairs is computed. (look ahead strategy is used). */ +/* = 2: A contribution from this subsystem to a Frobenius */ +/* norm-based estimate of the separation between two matrix */ +/* pairs is computed. (DGECON on sub-systems is used.) */ +/* Not referenced if TRANS = 'T'. */ + +/* M (input) INTEGER */ +/* On entry, M specifies the order of A and D, and the row */ +/* dimension of C, F, R and L. */ + +/* N (input) INTEGER */ +/* On entry, N specifies the order of B and E, and the column */ +/* dimension of C, F, R and L. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA, M) */ +/* On entry, A contains an upper quasi triangular matrix. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the matrix A. LDA >= max(1, M). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */ +/* On entry, B contains an upper quasi triangular matrix. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the matrix B. LDB >= max(1, N). */ + +/* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */ +/* On entry, C contains the right-hand-side of the first matrix */ +/* equation in (1). */ +/* On exit, if IJOB = 0, C has been overwritten by the */ +/* solution R. */ + +/* LDC (input) INTEGER */ +/* The leading dimension of the matrix C. LDC >= max(1, M). */ + +/* D (input) DOUBLE PRECISION array, dimension (LDD, M) */ +/* On entry, D contains an upper triangular matrix. */ + +/* LDD (input) INTEGER */ +/* The leading dimension of the matrix D. LDD >= max(1, M). */ + +/* E (input) DOUBLE PRECISION array, dimension (LDE, N) */ +/* On entry, E contains an upper triangular matrix. */ + +/* LDE (input) INTEGER */ +/* The leading dimension of the matrix E. LDE >= max(1, N). */ + +/* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) */ +/* On entry, F contains the right-hand-side of the second matrix */ +/* equation in (1). */ +/* On exit, if IJOB = 0, F has been overwritten by the */ +/* solution L. */ + +/* LDF (input) INTEGER */ +/* The leading dimension of the matrix F. LDF >= max(1, M). */ + +/* SCALE (output) DOUBLE PRECISION */ +/* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */ +/* R and L (C and F on entry) will hold the solutions to a */ +/* slightly perturbed system but the input matrices A, B, D and */ +/* E have not been changed. If SCALE = 0, R and L will hold the */ +/* solutions to the homogeneous system with C = F = 0. Normally, */ +/* SCALE = 1. */ + +/* RDSUM (input/output) DOUBLE PRECISION */ +/* On entry, the sum of squares of computed contributions to */ +/* the Dif-estimate under computation by DTGSYL, where the */ +/* scaling factor RDSCAL (see below) has been factored out. */ +/* On exit, the corresponding sum of squares updated with the */ +/* contributions from the current sub-system. */ +/* If TRANS = 'T' RDSUM is not touched. */ +/* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. */ + +/* RDSCAL (input/output) DOUBLE PRECISION */ +/* On entry, scaling factor used to prevent overflow in RDSUM. */ +/* On exit, RDSCAL is updated w.r.t. the current contributions */ +/* in RDSUM. */ +/* If TRANS = 'T', RDSCAL is not touched. */ +/* NOTE: RDSCAL only makes sense when DTGSY2 is called by */ +/* DTGSYL. */ + +/* IWORK (workspace) INTEGER array, dimension (M+N+2) */ + +/* PQ (output) INTEGER */ +/* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and */ +/* 8-by-8) solved by this routine. */ + +/* INFO (output) INTEGER */ +/* On exit, if INFO is set to */ +/* =0: Successful exit */ +/* <0: If INFO = -i, the i-th argument had an illegal value. */ +/* >0: The matrix pairs (A, D) and (B, E) have common or very */ +/* close eigenvalues. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* ===================================================================== */ +/* Replaced various illegal calls to DCOPY by calls to DLASET. */ +/* Sven Hammarling, 27/5/02. */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1; + f -= f_offset; + --iwork; + + /* Function Body */ + *info = 0; + ierr = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T")) { + *info = -1; + } else if (notran) { + if (*ijob < 0 || *ijob > 2) { + *info = -2; + } + } + if (*info == 0) { + if (*m <= 0) { + *info = -3; + } else if (*n <= 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*m)) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } else if (*ldd < std::max(1_integer,*m)) { + *info = -12; + } else if (*lde < std::max(1_integer,*n)) { + *info = -14; + } else if (*ldf < std::max(1_integer,*m)) { + *info = -16; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSY2", &i__1); + return 0; + } + +/* Determine block structure of A */ + + *pq = 0; + p = 0; + i__ = 1; +L10: + if (i__ > *m) { + goto L20; + } + ++p; + iwork[p] = i__; + if (i__ == *m) { + goto L20; + } + if (a[i__ + 1 + i__ * a_dim1] != 0.) { + i__ += 2; + } else { + ++i__; + } + goto L10; +L20: + iwork[p + 1] = *m + 1; + +/* Determine block structure of B */ + + q = p + 1; + j = 1; +L30: + if (j > *n) { + goto L40; + } + ++q; + iwork[q] = j; + if (j == *n) { + goto L40; + } + if (b[j + 1 + j * b_dim1] != 0.) { + j += 2; + } else { + ++j; + } + goto L30; +L40: + iwork[q + 1] = *n + 1; + *pq = p * (q - p - 1); + + if (notran) { + +/* Solve (I, J) - subsystem */ +/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ +/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ +/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */ + + *scale = 1.; + scaloc = 1.; + i__1 = q; + for (j = p + 2; j <= i__1; ++j) { + js = iwork[j]; + jsp1 = js + 1; + je = iwork[j + 1] - 1; + nb = je - js + 1; + for (i__ = p; i__ >= 1; --i__) { + + is = iwork[i__]; + isp1 = is + 1; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + zdim = mb * nb << 1; + + if (mb == 1 && nb == 1) { + +/* Build a 2-by-2 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = d__[is + is * d_dim1]; + z__[8] = -b[js + js * b_dim1]; + z__[9] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = f[is + js * f_dim1]; + +/* Solve Z * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + if (*ijob == 0) { + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L50: */ + } + *scale *= scaloc; + } + } else { + dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + f[is + js * f_dim1] = rhs[1]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + alpha = -rhs[0]; + i__2 = is - 1; + daxpy_(&i__2, &alpha, &a[is * a_dim1 + 1], &c__1, & + c__[js * c_dim1 + 1], &c__1); + i__2 = is - 1; + daxpy_(&i__2, &alpha, &d__[is * d_dim1 + 1], &c__1, & + f[js * f_dim1 + 1], &c__1); + } + if (j < q) { + i__2 = *n - je; + daxpy_(&i__2, &rhs[1], &b[js + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + daxpy_(&i__2, &rhs[1], &e[js + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + } + + } else if (mb == 1 && nb == 2) { + +/* Build a 4-by-4 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = 0.; + z__[2] = d__[is + is * d_dim1]; + z__[3] = 0.; + + z__[8] = 0.; + z__[9] = a[is + is * a_dim1]; + z__[10] = 0.; + z__[11] = d__[is + is * d_dim1]; + + z__[16] = -b[js + js * b_dim1]; + z__[17] = -b[js + jsp1 * b_dim1]; + z__[18] = -e[js + js * e_dim1]; + z__[19] = -e[js + jsp1 * e_dim1]; + + z__[24] = -b[jsp1 + js * b_dim1]; + z__[25] = -b[jsp1 + jsp1 * b_dim1]; + z__[26] = 0.; + z__[27] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[is + jsp1 * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[is + jsp1 * f_dim1]; + +/* Solve Z * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + if (*ijob == 0) { + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L60: */ + } + *scale *= scaloc; + } + } else { + dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[is + jsp1 * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[is + jsp1 * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + dger_(&i__2, &nb, &c_b27, &a[is * a_dim1 + 1], &c__1, + rhs, &c__1, &c__[js * c_dim1 + 1], ldc); + i__2 = is - 1; + dger_(&i__2, &nb, &c_b27, &d__[is * d_dim1 + 1], & + c__1, rhs, &c__1, &f[js * f_dim1 + 1], ldf); + } + if (j < q) { + i__2 = *n - je; + daxpy_(&i__2, &rhs[2], &b[js + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + daxpy_(&i__2, &rhs[2], &e[js + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + i__2 = *n - je; + daxpy_(&i__2, &rhs[3], &b[jsp1 + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + daxpy_(&i__2, &rhs[3], &e[jsp1 + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + } + + } else if (mb == 2 && nb == 1) { + +/* Build a 4-by-4 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[isp1 + is * a_dim1]; + z__[2] = d__[is + is * d_dim1]; + z__[3] = 0.; + + z__[8] = a[is + isp1 * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[10] = d__[is + isp1 * d_dim1]; + z__[11] = d__[isp1 + isp1 * d_dim1]; + + z__[16] = -b[js + js * b_dim1]; + z__[17] = 0.; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.; + + z__[24] = 0.; + z__[25] = -b[js + js * b_dim1]; + z__[26] = 0.; + z__[27] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[isp1 + js * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[isp1 + js * f_dim1]; + +/* Solve Z * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + if (*ijob == 0) { + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + } else { + dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[isp1 + js * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[isp1 + js * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + dgemv_("N", &i__2, &mb, &c_b27, &a[is * a_dim1 + 1], + lda, rhs, &c__1, &c_b42, &c__[js * c_dim1 + 1] +, &c__1); + i__2 = is - 1; + dgemv_("N", &i__2, &mb, &c_b27, &d__[is * d_dim1 + 1], + ldd, rhs, &c__1, &c_b42, &f[js * f_dim1 + 1], + &c__1); + } + if (j < q) { + i__2 = *n - je; + dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &b[js + (je + + 1) * b_dim1], ldb, &c__[is + (je + 1) * + c_dim1], ldc); + i__2 = *n - je; + dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &e[js + (je + + 1) * e_dim1], lde, &f[is + (je + 1) * + f_dim1], ldf); + } + + } else if (mb == 2 && nb == 2) { + +/* Build an 8-by-8 system Z * x = RHS */ + + dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8); + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[isp1 + is * a_dim1]; + z__[4] = d__[is + is * d_dim1]; + + z__[8] = a[is + isp1 * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[12] = d__[is + isp1 * d_dim1]; + z__[13] = d__[isp1 + isp1 * d_dim1]; + + z__[18] = a[is + is * a_dim1]; + z__[19] = a[isp1 + is * a_dim1]; + z__[22] = d__[is + is * d_dim1]; + + z__[26] = a[is + isp1 * a_dim1]; + z__[27] = a[isp1 + isp1 * a_dim1]; + z__[30] = d__[is + isp1 * d_dim1]; + z__[31] = d__[isp1 + isp1 * d_dim1]; + + z__[32] = -b[js + js * b_dim1]; + z__[34] = -b[js + jsp1 * b_dim1]; + z__[36] = -e[js + js * e_dim1]; + z__[38] = -e[js + jsp1 * e_dim1]; + + z__[41] = -b[js + js * b_dim1]; + z__[43] = -b[js + jsp1 * b_dim1]; + z__[45] = -e[js + js * e_dim1]; + z__[47] = -e[js + jsp1 * e_dim1]; + + z__[48] = -b[jsp1 + js * b_dim1]; + z__[50] = -b[jsp1 + jsp1 * b_dim1]; + z__[54] = -e[jsp1 + jsp1 * e_dim1]; + + z__[57] = -b[jsp1 + js * b_dim1]; + z__[59] = -b[jsp1 + jsp1 * b_dim1]; + z__[63] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + k = 1; + ii = mb * nb + 1; + i__2 = nb - 1; + for (jj = 0; jj <= i__2; ++jj) { + dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, & + rhs[k - 1], &c__1); + dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[ + ii - 1], &c__1); + k += mb; + ii += mb; +/* L80: */ + } + +/* Solve Z * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + if (*ijob == 0) { + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L90: */ + } + *scale *= scaloc; + } + } else { + dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + k = 1; + ii = mb * nb + 1; + i__2 = nb - 1; + for (jj = 0; jj <= i__2; ++jj) { + dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) * + c_dim1], &c__1); + dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) * + f_dim1], &c__1); + k += mb; + ii += mb; +/* L100: */ + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &a[is * + a_dim1 + 1], lda, rhs, &mb, &c_b42, &c__[js * + c_dim1 + 1], ldc); + i__2 = is - 1; + dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &d__[is * + d_dim1 + 1], ldd, rhs, &mb, &c_b42, &f[js * + f_dim1 + 1], ldf); + } + if (j < q) { + k = mb * nb + 1; + i__2 = *n - je; + dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1], + &mb, &b[js + (je + 1) * b_dim1], ldb, &c_b42, + &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1], + &mb, &e[js + (je + 1) * e_dim1], lde, &c_b42, + &f[is + (je + 1) * f_dim1], ldf); + } + + } + +/* L110: */ + } +/* L120: */ + } + } else { + +/* Solve (I, J) - subsystem */ +/* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */ +/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */ +/* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 */ + + *scale = 1.; + scaloc = 1.; + i__1 = p; + for (i__ = 1; i__ <= i__1; ++i__) { + + is = iwork[i__]; + isp1 = is + 1; + ie = i__; + mb = ie - is + 1; + i__2 = p + 2; + for (j = q; j >= i__2; --j) { + + js = iwork[j]; + jsp1 = js + 1; + je = iwork[j + 1] - 1; + nb = je - js + 1; + zdim = mb * nb << 1; + if (mb == 1 && nb == 1) { + +/* Build a 2-by-2 system Z' * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = -b[js + js * b_dim1]; + z__[8] = d__[is + is * d_dim1]; + z__[9] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = f[is + js * f_dim1]; + +/* Solve Z' * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L130: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + f[is + js * f_dim1] = rhs[1]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + alpha = rhs[0]; + i__3 = js - 1; + daxpy_(&i__3, &alpha, &b[js * b_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + alpha = rhs[1]; + i__3 = js - 1; + daxpy_(&i__3, &alpha, &e[js * e_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + } + if (i__ < p) { + alpha = -rhs[0]; + i__3 = *m - ie; + daxpy_(&i__3, &alpha, &a[is + (ie + 1) * a_dim1], lda, + &c__[ie + 1 + js * c_dim1], &c__1); + alpha = -rhs[1]; + i__3 = *m - ie; + daxpy_(&i__3, &alpha, &d__[is + (ie + 1) * d_dim1], + ldd, &c__[ie + 1 + js * c_dim1], &c__1); + } + + } else if (mb == 1 && nb == 2) { + +/* Build a 4-by-4 system Z' * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = 0.; + z__[2] = -b[js + js * b_dim1]; + z__[3] = -b[jsp1 + js * b_dim1]; + + z__[8] = 0.; + z__[9] = a[is + is * a_dim1]; + z__[10] = -b[js + jsp1 * b_dim1]; + z__[11] = -b[jsp1 + jsp1 * b_dim1]; + + z__[16] = d__[is + is * d_dim1]; + z__[17] = 0.; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.; + + z__[24] = 0.; + z__[25] = d__[is + is * d_dim1]; + z__[26] = -e[js + jsp1 * e_dim1]; + z__[27] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[is + jsp1 * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[is + jsp1 * f_dim1]; + +/* Solve Z' * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L140: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[is + jsp1 * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[is + jsp1 * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + daxpy_(&i__3, rhs, &b[js * b_dim1 + 1], &c__1, &f[is + + f_dim1], ldf); + i__3 = js - 1; + daxpy_(&i__3, &rhs[1], &b[jsp1 * b_dim1 + 1], &c__1, & + f[is + f_dim1], ldf); + i__3 = js - 1; + daxpy_(&i__3, &rhs[2], &e[js * e_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + i__3 = js - 1; + daxpy_(&i__3, &rhs[3], &e[jsp1 * e_dim1 + 1], &c__1, & + f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + dger_(&i__3, &nb, &c_b27, &a[is + (ie + 1) * a_dim1], + lda, rhs, &c__1, &c__[ie + 1 + js * c_dim1], + ldc); + i__3 = *m - ie; + dger_(&i__3, &nb, &c_b27, &d__[is + (ie + 1) * d_dim1] +, ldd, &rhs[2], &c__1, &c__[ie + 1 + js * + c_dim1], ldc); + } + + } else if (mb == 2 && nb == 1) { + +/* Build a 4-by-4 system Z' * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[is + isp1 * a_dim1]; + z__[2] = -b[js + js * b_dim1]; + z__[3] = 0.; + + z__[8] = a[isp1 + is * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[10] = 0.; + z__[11] = -b[js + js * b_dim1]; + + z__[16] = d__[is + is * d_dim1]; + z__[17] = d__[is + isp1 * d_dim1]; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.; + + z__[24] = 0.; + z__[25] = d__[isp1 + isp1 * d_dim1]; + z__[26] = 0.; + z__[27] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[isp1 + js * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[isp1 + js * f_dim1]; + +/* Solve Z' * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L150: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[isp1 + js * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[isp1 + js * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + dger_(&mb, &i__3, &c_b42, rhs, &c__1, &b[js * b_dim1 + + 1], &c__1, &f[is + f_dim1], ldf); + i__3 = js - 1; + dger_(&mb, &i__3, &c_b42, &rhs[2], &c__1, &e[js * + e_dim1 + 1], &c__1, &f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + dgemv_("T", &mb, &i__3, &c_b27, &a[is + (ie + 1) * + a_dim1], lda, rhs, &c__1, &c_b42, &c__[ie + 1 + + js * c_dim1], &c__1); + i__3 = *m - ie; + dgemv_("T", &mb, &i__3, &c_b27, &d__[is + (ie + 1) * + d_dim1], ldd, &rhs[2], &c__1, &c_b42, &c__[ie + + 1 + js * c_dim1], &c__1); + } + + } else if (mb == 2 && nb == 2) { + +/* Build an 8-by-8 system Z' * x = RHS */ + + dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8); + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[is + isp1 * a_dim1]; + z__[4] = -b[js + js * b_dim1]; + z__[6] = -b[jsp1 + js * b_dim1]; + + z__[8] = a[isp1 + is * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[13] = -b[js + js * b_dim1]; + z__[15] = -b[jsp1 + js * b_dim1]; + + z__[18] = a[is + is * a_dim1]; + z__[19] = a[is + isp1 * a_dim1]; + z__[20] = -b[js + jsp1 * b_dim1]; + z__[22] = -b[jsp1 + jsp1 * b_dim1]; + + z__[26] = a[isp1 + is * a_dim1]; + z__[27] = a[isp1 + isp1 * a_dim1]; + z__[29] = -b[js + jsp1 * b_dim1]; + z__[31] = -b[jsp1 + jsp1 * b_dim1]; + + z__[32] = d__[is + is * d_dim1]; + z__[33] = d__[is + isp1 * d_dim1]; + z__[36] = -e[js + js * e_dim1]; + + z__[41] = d__[isp1 + isp1 * d_dim1]; + z__[45] = -e[js + js * e_dim1]; + + z__[50] = d__[is + is * d_dim1]; + z__[51] = d__[is + isp1 * d_dim1]; + z__[52] = -e[js + jsp1 * e_dim1]; + z__[54] = -e[jsp1 + jsp1 * e_dim1]; + + z__[59] = d__[isp1 + isp1 * d_dim1]; + z__[61] = -e[js + jsp1 * e_dim1]; + z__[63] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + k = 1; + ii = mb * nb + 1; + i__3 = nb - 1; + for (jj = 0; jj <= i__3; ++jj) { + dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, & + rhs[k - 1], &c__1); + dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[ + ii - 1], &c__1); + k += mb; + ii += mb; +/* L160: */ + } + + +/* Solve Z' * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L170: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + k = 1; + ii = mb * nb + 1; + i__3 = nb - 1; + for (jj = 0; jj <= i__3; ++jj) { + dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) * + c_dim1], &c__1); + dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) * + f_dim1], &c__1); + k += mb; + ii += mb; +/* L180: */ + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &c__[is + + js * c_dim1], ldc, &b[js * b_dim1 + 1], ldb, & + c_b42, &f[is + f_dim1], ldf); + i__3 = js - 1; + dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &f[is + js * + f_dim1], ldf, &e[js * e_dim1 + 1], lde, & + c_b42, &f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &a[is + (ie + + 1) * a_dim1], lda, &c__[is + js * c_dim1], + ldc, &c_b42, &c__[ie + 1 + js * c_dim1], ldc); + i__3 = *m - ie; + dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &d__[is + ( + ie + 1) * d_dim1], ldd, &f[is + js * f_dim1], + ldf, &c_b42, &c__[ie + 1 + js * c_dim1], ldc); + } + + } + +/* L190: */ + } +/* L200: */ + } + + } + return 0; + +/* End of DTGSY2 */ + +} /* dtgsy2_ */ + +/* Subroutine */ int dtgsyl_(const char *trans, integer *ijob, integer *m, integer * + n, double *a, integer *lda, double *b, integer *ldb, + double *c__, integer *ldc, double *d__, integer *ldd, + double *e, integer *lde, double *f, integer *ldf, double * + scale, double *dif, double *work, integer *lwork, integer * + iwork, integer *info) +{ + /* Table of constant values */ + + static integer c__2 = 2; + static integer c_n1 = -1; + static integer c__5 = 5; + static double c_b14 = 0.; + static integer c__1 = 1; + static double c_b51 = -1.; + static double c_b52 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3, + i__4; + + /* Local variables */ + integer i__, j, k, p, q, ie, je, mb, nb, is, js, pq; + double dsum; + integer ppqq; + integer ifunc, linfo, lwmin; + double scale2; + double dscale, scaloc; + integer iround; + bool notran; + integer isolve; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTGSYL solves the generalized Sylvester equation: */ + +/* A * R - L * B = scale * C (1) */ +/* D * R - L * E = scale * F */ + +/* where R and L are unknown m-by-n matrices, (A, D), (B, E) and */ +/* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */ +/* respectively, with real entries. (A, D) and (B, E) must be in */ +/* generalized (real) Schur canonical form, i.e. A, B are upper quasi */ +/* triangular and D, E are upper triangular. */ + +/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */ +/* scaling factor chosen to avoid overflow. */ + +/* In matrix notation (1) is equivalent to solve Zx = scale b, where */ +/* Z is defined as */ + +/* Z = [ kron(In, A) -kron(B', Im) ] (2) */ +/* [ kron(In, D) -kron(E', Im) ]. */ + +/* Here Ik is the identity matrix of size k and X' is the transpose of */ +/* X. kron(X, Y) is the Kronecker product between the matrices X and Y. */ + +/* If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b, */ +/* which is equivalent to solve for R and L in */ + +/* A' * R + D' * L = scale * C (3) */ +/* R * B' + L * E' = scale * (-F) */ + +/* This case (TRANS = 'T') is used to compute an one-norm-based estimate */ +/* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */ +/* and (B,E), using DLACON. */ + +/* If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate */ +/* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */ +/* reciprocal of the smallest singular value of Z. See [1-2] for more */ +/* information. */ + +/* This is a level 3 BLAS algorithm. */ + +/* Arguments */ +/* ========= */ + +/* TRANS (input) CHARACTER*1 */ +/* = 'N', solve the generalized Sylvester equation (1). */ +/* = 'T', solve the 'transposed' system (3). */ + +/* IJOB (input) INTEGER */ +/* Specifies what kind of functionality to be performed. */ +/* =0: solve (1) only. */ +/* =1: The functionality of 0 and 3. */ +/* =2: The functionality of 0 and 4. */ +/* =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */ +/* (look ahead strategy IJOB = 1 is used). */ +/* =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */ +/* ( DGECON on sub-systems is used ). */ +/* Not referenced if TRANS = 'T'. */ + +/* M (input) INTEGER */ +/* The order of the matrices A and D, and the row dimension of */ +/* the matrices C, F, R and L. */ + +/* N (input) INTEGER */ +/* The order of the matrices B and E, and the column dimension */ +/* of the matrices C, F, R and L. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA, M) */ +/* The upper quasi triangular matrix A. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1, M). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */ +/* The upper quasi triangular matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1, N). */ + +/* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */ +/* On entry, C contains the right-hand-side of the first matrix */ +/* equation in (1) or (3). */ +/* On exit, if IJOB = 0, 1 or 2, C has been overwritten by */ +/* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */ +/* the solution achieved during the computation of the */ +/* Dif-estimate. */ + +/* LDC (input) INTEGER */ +/* The leading dimension of the array C. LDC >= max(1, M). */ + +/* D (input) DOUBLE PRECISION array, dimension (LDD, M) */ +/* The upper triangular matrix D. */ + +/* LDD (input) INTEGER */ +/* The leading dimension of the array D. LDD >= max(1, M). */ + +/* E (input) DOUBLE PRECISION array, dimension (LDE, N) */ +/* The upper triangular matrix E. */ + +/* LDE (input) INTEGER */ +/* The leading dimension of the array E. LDE >= max(1, N). */ + +/* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) */ +/* On entry, F contains the right-hand-side of the second matrix */ +/* equation in (1) or (3). */ +/* On exit, if IJOB = 0, 1 or 2, F has been overwritten by */ +/* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */ +/* the solution achieved during the computation of the */ +/* Dif-estimate. */ + +/* LDF (input) INTEGER */ +/* The leading dimension of the array F. LDF >= max(1, M). */ + +/* DIF (output) DOUBLE PRECISION */ +/* On exit DIF is the reciprocal of a lower bound of the */ +/* reciprocal of the Dif-function, i.e. DIF is an upper bound of */ +/* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). */ +/* IF IJOB = 0 or TRANS = 'T', DIF is not touched. */ + +/* SCALE (output) DOUBLE PRECISION */ +/* On exit SCALE is the scaling factor in (1) or (3). */ +/* If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */ +/* to a slightly perturbed system but the input matrices A, B, D */ +/* and E have not been changed. If SCALE = 0, C and F hold the */ +/* solutions R and L, respectively, to the homogeneous system */ +/* with C = F = 0. Normally, SCALE = 1. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK > = 1. */ +/* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (M+N+6) */ + +/* INFO (output) INTEGER */ +/* =0: successful exit */ +/* <0: If INFO = -i, the i-th argument had an illegal value. */ +/* >0: (A, D) and (B, E) have common or close eigenvalues. */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* Umea University, S-901 87 Umea, Sweden. */ + +/* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* for Solving the Generalized Sylvester Equation and Estimating the */ +/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* Department of Computing Science, Umea University, S-901 87 Umea, */ +/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ +/* No 1, 1996. */ + +/* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */ +/* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */ +/* Appl., 15(4):1045-1060, 1994 */ + +/* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */ +/* Condition Estimators for Solving the Generalized Sylvester */ +/* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */ +/* July 1989, pp 745-751. */ + +/* ===================================================================== */ +/* Replaced various illegal calls to DCOPY by calls to DLASET. */ +/* Sven Hammarling, 1/5/02. */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1; + f -= f_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + + if (! notran && ! lsame_(trans, "T")) { + *info = -1; + } else if (notran) { + if (*ijob < 0 || *ijob > 4) { + *info = -2; + } + } + if (*info == 0) { + if (*m <= 0) { + *info = -3; + } else if (*n <= 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*m)) { + *info = -6; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -10; + } else if (*ldd < std::max(1_integer,*m)) { + *info = -12; + } else if (*lde < std::max(1_integer,*n)) { + *info = -14; + } else if (*ldf < std::max(1_integer,*m)) { + *info = -16; + } + } + + if (*info == 0) { + if (notran) { + if (*ijob == 1 || *ijob == 2) { +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * *n; + lwmin = std::max(i__1,i__2); + } else { + lwmin = 1; + } + } else { + lwmin = 1; + } + work[1] = (double) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -20; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSYL", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *scale = 1.; + if (notran) { + if (*ijob != 0) { + *dif = 0.; + } + } + return 0; + } + +/* Determine optimal block sizes MB and NB */ + + mb = ilaenv_(&c__2, "DTGSYL", trans, m, n, &c_n1, &c_n1); + nb = ilaenv_(&c__5, "DTGSYL", trans, m, n, &c_n1, &c_n1); + + isolve = 1; + ifunc = 0; + if (notran) { + if (*ijob >= 3) { + ifunc = *ijob - 2; + dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc) + ; + dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (*ijob >= 1) { + isolve = 2; + } + } + + if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) { + + i__1 = isolve; + for (iround = 1; iround <= i__1; ++iround) { + +/* Use unblocked Level 2 solver */ + + dscale = 0.; + dsum = 1.; + pq = 0; + dtgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb, + &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset], + lde, &f[f_offset], ldf, scale, &dsum, &dscale, &iwork[1], + &pq, info); + if (dscale != 0.) { + if (*ijob == 1 || *ijob == 3) { + *dif = sqrt((double) ((*m << 1) * *n)) / (dscale * + sqrt(dsum)); + } else { + *dif = sqrt((double) pq) / (dscale * sqrt(dsum)); + } + } + + if (isolve == 2 && iround == 1) { + if (notran) { + ifunc = *ijob; + } + scale2 = *scale; + dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); + dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); + dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc); + dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (isolve == 2 && iround == 2) { + dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); + dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); + *scale = scale2; + } +/* L30: */ + } + + return 0; + } + +/* Determine block structure of A */ + + p = 0; + i__ = 1; +L40: + if (i__ > *m) { + goto L50; + } + ++p; + iwork[p] = i__; + i__ += mb; + if (i__ >= *m) { + goto L50; + } + if (a[i__ + (i__ - 1) * a_dim1] != 0.) { + ++i__; + } + goto L40; +L50: + + iwork[p + 1] = *m + 1; + if (iwork[p] == iwork[p + 1]) { + --p; + } + +/* Determine block structure of B */ + + q = p + 1; + j = 1; +L60: + if (j > *n) { + goto L70; + } + ++q; + iwork[q] = j; + j += nb; + if (j >= *n) { + goto L70; + } + if (b[j + (j - 1) * b_dim1] != 0.) { + ++j; + } + goto L60; +L70: + + iwork[q + 1] = *n + 1; + if (iwork[q] == iwork[q + 1]) { + --q; + } + + if (notran) { + + i__1 = isolve; + for (iround = 1; iround <= i__1; ++iround) { + +/* Solve (I, J)-subsystem */ +/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ +/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ +/* for I = P, P - 1,..., 1; J = 1, 2,..., Q */ + + dscale = 0.; + dsum = 1.; + pq = 0; + *scale = 1.; + i__2 = q; + for (j = p + 2; j <= i__2; ++j) { + js = iwork[j]; + je = iwork[j + 1] - 1; + nb = je - js + 1; + for (i__ = p; i__ >= 1; --i__) { + is = iwork[i__]; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + ppqq = 0; + dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], + lda, &b[js + js * b_dim1], ldb, &c__[is + js * + c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js + + js * e_dim1], lde, &f[is + js * f_dim1], ldf, & + scaloc, &dsum, &dscale, &iwork[q + 2], &ppqq, & + linfo); + if (linfo > 0) { + *info = linfo; + } + + pq += ppqq; + if (scaloc != 1.) { + i__3 = js - 1; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L80: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = is - 1; + dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + i__4 = is - 1; + dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L90: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = *m - ie; + dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], + &c__1); + i__4 = *m - ie; + dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], & + c__1); +/* L100: */ + } + i__3 = *n; + for (k = je + 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L110: */ + } + *scale *= scaloc; + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__3 = is - 1; + dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &a[is * + a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc, + &c_b52, &c__[js * c_dim1 + 1], ldc); + i__3 = is - 1; + dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &d__[is * + d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc, + &c_b52, &f[js * f_dim1 + 1], ldf); + } + if (j < q) { + i__3 = *n - je; + dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &b[js + (je + 1) * b_dim1], + ldb, &c_b52, &c__[is + (je + 1) * c_dim1], + ldc); + i__3 = *n - je; + dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &e[js + (je + 1) * e_dim1], + lde, &c_b52, &f[is + (je + 1) * f_dim1], ldf); + } +/* L120: */ + } +/* L130: */ + } + if (dscale != 0.) { + if (*ijob == 1 || *ijob == 3) { + *dif = sqrt((double) ((*m << 1) * *n)) / (dscale * + sqrt(dsum)); + } else { + *dif = sqrt((double) pq) / (dscale * sqrt(dsum)); + } + } + if (isolve == 2 && iround == 1) { + if (notran) { + ifunc = *ijob; + } + scale2 = *scale; + dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); + dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); + dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc); + dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (isolve == 2 && iround == 2) { + dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); + dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); + *scale = scale2; + } +/* L150: */ + } + + } else { + +/* Solve transposed (I, J)-subsystem */ +/* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) */ +/* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J) */ +/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */ + + *scale = 1.; + i__1 = p; + for (i__ = 1; i__ <= i__1; ++i__) { + is = iwork[i__]; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + i__2 = p + 2; + for (j = q; j >= i__2; --j) { + js = iwork[j]; + je = iwork[j + 1] - 1; + nb = je - js + 1; + dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, & + b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc, + &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1], + lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, & + dscale, &iwork[q + 2], &ppqq, &linfo); + if (linfo > 0) { + *info = linfo; + } + if (scaloc != 1.) { + i__3 = js - 1; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L160: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = is - 1; + dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &c__1); + i__4 = is - 1; + dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L170: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = *m - ie; + dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], & + c__1); + i__4 = *m - ie; + dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &c__1) + ; +/* L180: */ + } + i__3 = *n; + for (k = je + 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L190: */ + } + *scale *= scaloc; + } + +/* Substitute R(I, J) and L(I, J) into remaining equation. */ + + if (j > p + 2) { + i__3 = js - 1; + dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &c__[is + js * + c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b52, & + f[is + f_dim1], ldf); + i__3 = js - 1; + dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b52, & + f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &a[is + (ie + 1) + * a_dim1], lda, &c__[is + js * c_dim1], ldc, & + c_b52, &c__[ie + 1 + js * c_dim1], ldc); + i__3 = *m - ie; + dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &d__[is + (ie + + 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, & + c_b52, &c__[ie + 1 + js * c_dim1], ldc); + } +/* L200: */ + } +/* L210: */ + } + + } + + work[1] = (double) lwmin; + + return 0; + +/* End of DTGSYL */ + +} /* dtgsyl_ */ + +/* Subroutine */ int dtpcon_(const char *norm, const char *uplo, const char *diag, integer *n, + double *ap, double *rcond, double *work, integer *iwork, + integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1; + double d__1; + + /* Local variables */ + integer ix, kase, kase1; + double scale; + integer isave[3]; + double anorm; + bool upper; + double xnorm; + double ainvnm; + bool onenrm; + char normin[1]; + double smlnum; + bool nounit; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPCON estimates the reciprocal of the condition number of a packed */ +/* triangular matrix A, in either the 1-norm or the infinity-norm. */ + +/* The norm of A is computed and an estimate is obtained for */ +/* norm(inv(A)), then the reciprocal of the condition number is */ +/* computed as */ +/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies whether the 1-norm condition number or the */ +/* infinity-norm condition number is required: */ +/* = '1' or 'O': 1-norm; */ +/* = 'I': Infinity-norm. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangular matrix A, packed columnwise in */ +/* a linear array. The j-th column of A is stored in the array */ +/* AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* If DIAG = 'U', the diagonal elements of A are not referenced */ +/* and are assumed to be 1. */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --iwork; + --work; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.; + return 0; + } + + *rcond = 0.; + smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = dlantp_(norm, uplo, diag, n, &ap[1], &work[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + dlatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ + 1], &scale, &work[(*n << 1) + 1], info); + } else { + +/* Multiply by inv(A'). */ + + dlatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1], + &scale, &work[(*n << 1) + 1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + xnorm = (d__1 = work[ix], abs(d__1)); + if (scale < xnorm * smlnum || scale == 0.) { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of DTPCON */ + +} /* dtpcon_ */ + +/* Subroutine */ int dtprfs_(const char *uplo, const char *trans, const char *diag, integer *n, + integer *nrhs, double *ap, double *b, integer *ldb, + double *x, integer *ldx, double *ferr, double *berr, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b19 = -1.; + + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s; + integer kc; + double xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + bool upper; + double safmin; + bool notran; + char transt[1]; + bool nounit; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPRFS provides error bounds and backward error estimates for the */ +/* solution to a system of linear equations with a triangular packed */ +/* coefficient matrix. */ + +/* The solution matrix X must be computed by DTPTRS or some other */ +/* means before entering this routine. DTPRFS does not do iterative */ +/* refinement because doing so cannot improve the backward error. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangular matrix A, packed columnwise in */ +/* a linear array. The j-th column of A is stored in the array */ +/* AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* If DIAG = 'U', the diagonal elements of A are not referenced */ +/* and are assumed to be 1. */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* The solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A', depending on TRANS. */ + + dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dtpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); + daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1)) + * xk; +/* L30: */ + } + kc += k; +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1)) + * xk; +/* L50: */ + } + work[k] += xk; + kc += k; +/* L60: */ + } + } + } else { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1)) + * xk; +/* L70: */ + } + kc = kc + *n - k + 1; +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1)) + * xk; +/* L90: */ + } + work[k] += xk; + kc = kc + *n - k + 1; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A')*abs(X) + abs(B). */ + + if (upper) { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2 + = x[i__ + j * x_dim1], abs(d__2)); +/* L110: */ + } + work[k] += s; + kc += k; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2 + = x[i__ + j * x_dim1], abs(d__2)); +/* L130: */ + } + work[k] += s; + kc += k; +/* L140: */ + } + } + } else { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2 + = x[i__ + j * x_dim1], abs(d__2)); +/* L150: */ + } + work[k] += s; + kc = kc + *n - k + 1; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2 + = x[i__ + j * x_dim1], abs(d__2)); +/* L170: */ + } + work[k] += s; + kc = kc + *n - k + 1; +/* L180: */ + } + } + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)'). */ + + dtpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + dtpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L240: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of DTPRFS */ + +} /* dtprfs_ */ + +/* Subroutine */ int dtptri_(const char *uplo, const char *diag, integer *n, double * + ap, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer j, jc, jj; + double ajj; + bool upper; + integer jclast; + bool nounit; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPTRI computes the inverse of a real upper or lower triangular */ +/* matrix A stored in packed format. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* On entry, the upper or lower triangular matrix A, stored */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* See below for further details. */ +/* On exit, the (triangular) inverse of the original matrix, in */ +/* the same packed storage format. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* matrix is singular and its inverse can not be computed. */ + +/* Further Details */ +/* =============== */ + +/* A triangular matrix A can be transferred to packed storage using one */ +/* of the following program segments: */ + +/* UPLO = 'U': UPLO = 'L': */ + +/* JC = 1 JC = 1 */ +/* DO 2 J = 1, N DO 2 J = 1, N */ +/* DO 1 I = 1, J DO 1 I = J, N */ +/* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */ +/* 1 CONTINUE 1 CONTINUE */ +/* JC = JC + J JC = JC + N - J + 1 */ +/* 2 CONTINUE 2 CONTINUE */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPTRI", &i__1); + return 0; + } + +/* Check for singularity if non-unit. */ + + if (nounit) { + if (upper) { + jj = 0; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + jj += *info; + if (ap[jj] == 0.) { + return 0; + } +/* L10: */ + } + } else { + jj = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jj] == 0.) { + return 0; + } + jj = jj + *n - *info + 1; +/* L20: */ + } + } + *info = 0; + } + + if (upper) { + +/* Compute inverse of upper triangular matrix. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + ap[jc + j - 1] = 1. / ap[jc + j - 1]; + ajj = -ap[jc + j - 1]; + } else { + ajj = -1.; + } + +/* Compute elements 1:j-1 of j-th column. */ + + i__2 = j - 1; + dtpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & + c__1); + i__2 = j - 1; + dscal_(&i__2, &ajj, &ap[jc], &c__1); + jc += j; +/* L30: */ + } + + } else { + +/* Compute inverse of lower triangular matrix. */ + + jc = *n * (*n + 1) / 2; + for (j = *n; j >= 1; --j) { + if (nounit) { + ap[jc] = 1. / ap[jc]; + ajj = -ap[jc]; + } else { + ajj = -1.; + } + if (j < *n) { + +/* Compute elements j+1:n of j-th column. */ + + i__1 = *n - j; + dtpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ + jc + 1], &c__1); + i__1 = *n - j; + dscal_(&i__1, &ajj, &ap[jc + 1], &c__1); + } + jclast = jc; + jc = jc - *n + j - 2; +/* L40: */ + } + } + + return 0; + +/* End of DTPTRI */ + +} /* dtptri_ */ + +/* Subroutine */ int dtptrs_(const char *uplo, const char *trans, const char *diag, integer *n, + integer *nrhs, double *ap, double *b, integer *ldb, integer * + info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + integer j, jc; + bool upper; + bool nounit; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPTRS solves a triangular system of the form */ + +/* A * X = B or A**T * X = B, */ + +/* where A is a triangular matrix of order N stored in packed format, */ +/* and B is an N-by-NRHS matrix. A check is made to verify that A is */ +/* nonsingular. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* The upper or lower triangular matrix A, packed columnwise in */ +/* a linear array. The j-th column of A is stored in the array */ +/* AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, if INFO = 0, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* indicating that the matrix is singular and the */ +/* solutions X have not been computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + if (upper) { + jc = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jc + *info - 1] == 0.) { + return 0; + } + jc += *info; +/* L10: */ + } + } else { + jc = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jc] == 0.) { + return 0; + } + jc = jc + *n - *info + 1; +/* L20: */ + } + } + } + *info = 0; + +/* Solve A * x = b or A' * x = b. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + dtpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1); +/* L30: */ + } + + return 0; + +/* End of DTPTRS */ + +} /* dtptrs_ */ + +int dtpttf_(const char *transr, const char *uplo, integer *n, double *ap, double *arf, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k, n1, n2, ij, jp, js, lda, ijp; + bool normaltransr, lower, nisodd; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. */ +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ + +/* Purpose */ +/* ======= */ + +/* DTPTTF copies a triangular matrix A from standard packed format (TP) */ +/* to rectangular full packed format (TF). */ + +/* Arguments */ +/* ========= */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': ARF in Normal format is wanted; */ +/* = 'T': ARF in Conjugate-transpose format is wanted. */ + +/* UPLO (input) CHARACTER */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* On entry, the upper or lower triangular matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* On exit, the upper or lower triangular matrix A stored in */ +/* RFP format. For a further discussion see Notes below. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPTTF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (normaltransr) { + arf[0] = ap[0]; + } else { + arf[0] = ap[0]; + } + return 0; + } + +/* Size of array ARF(0:NT-1) */ + + // nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + +/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ +/* where noe = 0 if n is even, noe = 1 if n is odd */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = false; + lda = *n + 1; + } else { + nisodd = true; + lda = *n; + } + +/* ARF^C has lda rows and n+1-noe cols */ + + if (! normaltransr) { + lda = (*n + 1) / 2; + } + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ijp = 0; + jp = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + jp; + arf[ij] = ap[ijp]; + ++ijp; + } + jp += lda; + } + i__1 = n2 - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = n2; + for (j = i__ + 1; j <= i__2; ++j) { + ij = i__ + j * lda; + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ijp = 0; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + ij = n2 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = ap[ijp]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = n1; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ijp = 0; + i__1 = n2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = *n * lda - 1; + i__3 = lda; + for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= + i__2; ij += i__3) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + js = 1; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + n2 - j - 1; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ijp = 0; + js = n2 * lda; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + i__1 = n1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (n1 + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ijp = 0; + jp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + 1 + jp; + arf[ij] = ap[ijp]; + ++ijp; + } + jp += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = k - 1; + for (j = i__; j <= i__2; ++j) { + ij = i__ + j * lda; + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ijp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + ij = k + 1 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = ap[ijp]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ijp = 0; + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = (*n + 1) * lda - 1; + i__3 = lda; + for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : + ij <= i__2; ij += i__3) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + js = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + k - j - 1; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ijp = 0; + js = (k + 1) * lda; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (k + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } + + } + + } + + return 0; + +/* End of DTPTTF */ + +} /* dtpttf_ */ + +int dtpttr_(const char *uplo, integer *n, double *ap, double *a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k; + bool lower; + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTPTTR copies a triangular matrix A from standard packed format (TP) */ +/* to standard full format (TR). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER */ +/* = 'U': A is upper triangular. */ +/* = 'L': A is lower triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* On entry, the upper or lower triangular matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* A (output) DOUBLE PRECISION array, dimension ( LDA, N ) */ +/* On exit, the triangular matrix A. If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lower && ! lsame_(uplo, "U")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPTTR", &i__1); + return 0; + } + + if (lower) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ++k; + a[i__ + j * a_dim1] = ap[k]; + } + } + } else { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++k; + a[i__ + j * a_dim1] = ap[k]; + } + } + } + + + return 0; + +/* End of DTPTTR */ + +} /* dtpttr_ */ + +/* Subroutine */ int dtrcon_(const char *norm, const char *uplo, const char *diag, integer *n, + double *a, integer *lda, double *rcond, double *work, + integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1; + double d__1; + + /* Local variables */ + integer ix, kase, kase1; + double scale; + integer isave[3]; + double anorm; + bool upper; + double xnorm; + double ainvnm; + bool onenrm; + char normin[1]; + double smlnum; + bool nounit; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRCON estimates the reciprocal of the condition number of a */ +/* triangular matrix A, in either the 1-norm or the infinity-norm. */ + +/* The norm of A is computed and an estimate is obtained for */ +/* norm(inv(A)), then the reciprocal of the condition number is */ +/* computed as */ +/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ + +/* Arguments */ +/* ========= */ + +/* NORM (input) CHARACTER*1 */ +/* Specifies whether the 1-norm condition number or the */ +/* infinity-norm condition number is required: */ +/* = '1' or 'O': 1-norm; */ +/* = 'I': Infinity-norm. */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of the array A contains the upper */ +/* triangular matrix, and the strictly lower triangular part of */ +/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* triangular part of the array A contains the lower triangular */ +/* matrix, and the strictly upper triangular part of A is not */ +/* referenced. If DIAG = 'U', the diagonal elements of A are */ +/* also not referenced and are assumed to be 1. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* RCOND (output) DOUBLE PRECISION */ +/* The reciprocal of the condition number of the matrix A, */ +/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < std::max(1_integer,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRCON", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.; + return 0; + } + + *rcond = 0.; + smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], + lda, &work[1], &scale, &work[(*n << 1) + 1], info); + } else { + +/* Multiply by inv(A'). */ + + dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, + &work[1], &scale, &work[(*n << 1) + 1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + xnorm = (d__1 = work[ix], abs(d__1)); + if (scale < xnorm * smlnum || scale == 0.) { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of DTRCON */ + +} /* dtrcon_ */ + +/* Subroutine */ int dtrevc_(const char *side, const char *howmny, bool *select, + integer *n, double *t, integer *ldt, double *vl, integer * + ldvl, double *vr, integer *ldvr, integer *mm, integer *m, + double *work, integer *info) +{ + /* Table of constant values */ + static bool c_false = false; + static integer c__1 = 1; + static double c_b22 = 1.; + static double c_b25 = 0.; + static integer c__2 = 2; + static bool c_true = true; + + /* System generated locals */ + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3; + double d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, j, k; + double x[4] /* was [2][2] */; + integer j1, j2, n2, ii, ki, ip, is; + double wi, wr, rec, ulp, beta, emax; + bool pair; + bool allv; + integer ierr; + double unfl, ovfl, smin; + bool over; + double vmax; + integer jnxt; + double scale; + double remax; + bool leftv, bothv; + double vcrit; + bool somev; + double xnorm; + double bignum; + bool rightv; + double smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTREVC computes some or all of the right and/or left eigenvectors of */ +/* a real upper quasi-triangular matrix T. */ +/* Matrices of this type are produced by the Schur factorization of */ +/* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. */ + +/* The right eigenvector x and the left eigenvector y of T corresponding */ +/* to an eigenvalue w are defined by: */ + +/* T*x = w*x, (y**H)*T = w*(y**H) */ + +/* where y**H denotes the conjugate transpose of y. */ +/* The eigenvalues are not input to this routine, but are read directly */ +/* from the diagonal blocks of T. */ + +/* This routine returns the matrices X and/or Y of right and left */ +/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ +/* input matrix. If Q is the orthogonal factor that reduces a matrix */ +/* A to Schur form T, then Q*X and Q*Y are the matrices of right and */ +/* left eigenvectors of A. */ + +/* Arguments */ +/* ========= */ + +/* SIDE (input) CHARACTER*1 */ +/* = 'R': compute right eigenvectors only; */ +/* = 'L': compute left eigenvectors only; */ +/* = 'B': compute both right and left eigenvectors. */ + +/* HOWMNY (input) CHARACTER*1 */ +/* = 'A': compute all right and/or left eigenvectors; */ +/* = 'B': compute all right and/or left eigenvectors, */ +/* backtransformed by the matrices in VR and/or VL; */ +/* = 'S': compute selected right and/or left eigenvectors, */ +/* as indicated by the logical array SELECT. */ + +/* SELECT (input/output) LOGICAL array, dimension (N) */ +/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ +/* computed. */ +/* If w(j) is a real eigenvalue, the corresponding real */ +/* eigenvector is computed if SELECT(j) is .TRUE.. */ +/* If w(j) and w(j+1) are the real and imaginary parts of a */ +/* complex eigenvalue, the corresponding complex eigenvector is */ +/* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */ +/* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */ +/* .FALSE.. */ +/* Not referenced if HOWMNY = 'A' or 'B'. */ + +/* N (input) INTEGER */ +/* The order of the matrix T. N >= 0. */ + +/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */ +/* The upper quasi-triangular matrix T in Schur canonical form. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the array T. LDT >= max(1,N). */ + +/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */ +/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* of Schur vectors returned by DHSEQR). */ +/* On exit, if SIDE = 'L' or 'B', VL contains: */ +/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ +/* if HOWMNY = 'B', the matrix Q*Y; */ +/* if HOWMNY = 'S', the left eigenvectors of T specified by */ +/* SELECT, stored consecutively in the columns */ +/* of VL, in the same order as their */ +/* eigenvalues. */ +/* A complex eigenvector corresponding to a complex eigenvalue */ +/* is stored in two consecutive columns, the first holding the */ +/* real part, and the second the imaginary part. */ +/* Not referenced if SIDE = 'R'. */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the array VL. LDVL >= 1, and if */ +/* SIDE = 'L' or 'B', LDVL >= N. */ + +/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */ +/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* of Schur vectors returned by DHSEQR). */ +/* On exit, if SIDE = 'R' or 'B', VR contains: */ +/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ +/* if HOWMNY = 'B', the matrix Q*X; */ +/* if HOWMNY = 'S', the right eigenvectors of T specified by */ +/* SELECT, stored consecutively in the columns */ +/* of VR, in the same order as their */ +/* eigenvalues. */ +/* A complex eigenvector corresponding to a complex eigenvalue */ +/* is stored in two consecutive columns, the first holding the */ +/* real part and the second the imaginary part. */ +/* Not referenced if SIDE = 'L'. */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the array VR. LDVR >= 1, and if */ +/* SIDE = 'R' or 'B', LDVR >= N. */ + +/* MM (input) INTEGER */ +/* The number of columns in the arrays VL and/or VR. MM >= M. */ + +/* M (output) INTEGER */ +/* The number of columns in the arrays VL and/or VR actually */ +/* used to store the eigenvectors. */ +/* If HOWMNY = 'A' or 'B', M is set to N. */ +/* Each selected real eigenvector occupies one column and each */ +/* selected complex eigenvector occupies two columns. */ + +/* 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 algorithm used in this program is basically backward (forward) */ +/* substitution, with scaling to make the the code robust against */ +/* possible overflow. */ + +/* Each eigenvector is normalized so that the element of largest */ +/* magnitude has magnitude 1; here the magnitude of a complex number */ +/* (x,y) is taken to be |x| + |y|. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --work; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + allv = lsame_(howmny, "A"); + over = lsame_(howmny, "B"); + somev = lsame_(howmny, "S"); + + *info = 0; + if (! rightv && ! leftv) { + *info = -1; + } else if (! allv && ! over && ! somev) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -10; + } else { + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors, standardize the array SELECT if necessary, and */ +/* test MM. */ + + if (somev) { + *m = 0; + pair = false; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (pair) { + pair = false; + select[j] = false; + } else { + if (j < *n) { + if (t[j + 1 + j * t_dim1] == 0.) { + if (select[j]) { + ++(*m); + } + } else { + pair = true; + if (select[j] || select[j + 1]) { + select[j] = true; + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*mm < *m) { + *info = -11; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTREVC", &i__1); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Set the constants to control overflow. */ + + unfl = dlamch_("Safe minimum"); + ovfl = 1. / unfl; + dlabad_(&unfl, &ovfl); + ulp = dlamch_("Precision"); + smlnum = unfl * (*n / ulp); + bignum = (1. - ulp) / smlnum; + +/* Compute 1-norm of each column of strictly upper triangular */ +/* part of T to control overflow in triangular solver. */ + + work[1] = 0.; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + work[j] = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1)); +/* L20: */ + } +/* L30: */ + } + +/* Index IP is used to specify the real or complex eigenvalue: */ +/* IP = 0, real eigenvalue, */ +/* 1, first of conjugate complex pair: (wr,wi) */ +/* -1, second of conjugate complex pair: (wr,wi) */ + + n2 = *n << 1; + + if (rightv) { + +/* Compute right eigenvectors. */ + + ip = 0; + is = *m; + for (ki = *n; ki >= 1; --ki) { + + if (ip == 1) { + goto L130; + } + if (ki == 1) { + goto L40; + } + if (t[ki + (ki - 1) * t_dim1] == 0.) { + goto L40; + } + ip = -1; + +L40: + if (somev) { + if (ip == 0) { + if (! select[ki]) { + goto L130; + } + } else { + if (! select[ki - 1]) { + goto L130; + } + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.; + if (ip != 0) { + wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) * + sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2))); + } +/* Computing MAX */ + d__1 = ulp * (abs(wr) + abs(wi)); + smin = std::max(d__1,smlnum); + + if (ip == 0) { + +/* Real right eigenvector */ + + work[ki + *n] = 1.; + +/* Form right-hand side */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + work[k + *n] = -t[k + ki * t_dim1]; +/* L50: */ + } + +/* Solve the upper quasi-triangular system: */ +/* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */ + + jnxt = ki - 1; + for (j = ki - 1; j >= 1; --j) { + if (j > jnxt) { + goto L60; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale X(1,1) to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[*n + 1], &c__1); + } + work[j + *n] = x[0]; + +/* Update right-hand side */ + + i__1 = j - 1; + d__1 = -x[0]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b22, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & + work[j - 1 + *n], n, &wr, &c_b25, x, &c__2, & + scale, &xnorm, &ierr); + +/* Scale X(1,1) and X(2,1) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.) { +/* Computing MAX */ + d__1 = work[j - 1], d__2 = work[j]; + beta = std::max(d__1,d__2); + if (beta > bignum / xnorm) { + x[0] /= xnorm; + x[1] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[*n + 1], &c__1); + } + work[j - 1 + *n] = x[0]; + work[j + *n] = x[1]; + +/* Update right-hand side */ + + i__1 = j - 2; + d__1 = -x[0]; + daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[*n + 1], &c__1); + i__1 = j - 2; + d__1 = -x[1]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + } +L60: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { + dcopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], & + c__1); + + ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); + remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1)); + dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + vr[k + is * vr_dim1] = 0.; +/* L70: */ + } + } else { + if (ki > 1) { + i__1 = ki - 1; + dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[*n + 1], &c__1, &work[ki + *n], &vr[ki * + vr_dim1 + 1], &c__1); + } + + ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1); + remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1)); + dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } + + } else { + +/* Complex right eigenvector. */ + +/* Initial solve */ +/* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. */ +/* [ (T(KI,KI-1) T(KI,KI) ) ] */ + + if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >= (d__2 = t[ + ki + (ki - 1) * t_dim1], abs(d__2))) { + work[ki - 1 + *n] = 1.; + work[ki + n2] = wi / t[ki - 1 + ki * t_dim1]; + } else { + work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1]; + work[ki + n2] = 1.; + } + work[ki + *n] = 0.; + work[ki - 1 + n2] = 0.; + +/* Form right-hand side */ + + i__1 = ki - 2; + for (k = 1; k <= i__1; ++k) { + work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) * + t_dim1]; + work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1]; +/* L80: */ + } + +/* Solve upper quasi-triangular system: */ +/* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) */ + + jnxt = ki - 2; + for (j = ki - 2; j >= 1; --j) { + if (j > jnxt) { + goto L90; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &wi, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale X(1,1) and X(1,2) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + x[2] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[*n + 1], &c__1); + dscal_(&ki, &scale, &work[n2 + 1], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; + +/* Update the right-hand side */ + + i__1 = j - 1; + d__1 = -x[0]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + i__1 = j - 1; + d__1 = -x[2]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + n2 + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b22, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & + work[j - 1 + *n], n, &wr, &wi, x, &c__2, & + scale, &xnorm, &ierr); + +/* Scale X to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.) { +/* Computing MAX */ + d__1 = work[j - 1], d__2 = work[j]; + beta = std::max(d__1,d__2); + if (beta > bignum / xnorm) { + rec = 1. / xnorm; + x[0] *= rec; + x[2] *= rec; + x[1] *= rec; + x[3] *= rec; + scale *= rec; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[*n + 1], &c__1); + dscal_(&ki, &scale, &work[n2 + 1], &c__1); + } + work[j - 1 + *n] = x[0]; + work[j + *n] = x[1]; + work[j - 1 + n2] = x[2]; + work[j + n2] = x[3]; + +/* Update the right-hand side */ + + i__1 = j - 2; + d__1 = -x[0]; + daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[*n + 1], &c__1); + i__1 = j - 2; + d__1 = -x[1]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + i__1 = j - 2; + d__1 = -x[2]; + daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[n2 + 1], &c__1); + i__1 = j - 2; + d__1 = -x[3]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + n2 + 1], &c__1); + } +L90: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { + dcopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1 + + 1], &c__1); + dcopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], & + c__1); + + emax = 0.; + i__1 = ki; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1] + , abs(d__1)) + (d__2 = vr[k + is * vr_dim1], + abs(d__2)); + emax = std::max(d__3,d__4); +/* L100: */ + } + + remax = 1. / emax; + dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1); + dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + vr[k + (is - 1) * vr_dim1] = 0.; + vr[k + is * vr_dim1] = 0.; +/* L110: */ + } + + } else { + + if (ki > 2) { + i__1 = ki - 2; + dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[( + ki - 1) * vr_dim1 + 1], &c__1); + i__1 = ki - 2; + dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[n2 + 1], &c__1, &work[ki + n2], &vr[ki * + vr_dim1 + 1], &c__1); + } else { + dscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1 + + 1], &c__1); + dscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], & + c__1); + } + + emax = 0.; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1] + , abs(d__1)) + (d__2 = vr[k + ki * vr_dim1], + abs(d__2)); + emax = std::max(d__3,d__4); +/* L120: */ + } + remax = 1. / emax; + dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1); + dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } + } + + --is; + if (ip != 0) { + --is; + } +L130: + if (ip == 1) { + ip = 0; + } + if (ip == -1) { + ip = 1; + } +/* L140: */ + } + } + + if (leftv) { + +/* Compute left eigenvectors. */ + + ip = 0; + is = 1; + i__1 = *n; + for (ki = 1; ki <= i__1; ++ki) { + + if (ip == -1) { + goto L250; + } + if (ki == *n) { + goto L150; + } + if (t[ki + 1 + ki * t_dim1] == 0.) { + goto L150; + } + ip = 1; + +L150: + if (somev) { + if (! select[ki]) { + goto L250; + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.; + if (ip != 0) { + wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) * + sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2))); + } +/* Computing MAX */ + d__1 = ulp * (abs(wr) + abs(wi)); + smin = std::max(d__1,smlnum); + + if (ip == 0) { + +/* Real left eigenvector. */ + + work[ki + *n] = 1.; + +/* Form right-hand side */ + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + *n] = -t[ki + k * t_dim1]; +/* L160: */ + } + +/* Solve the quasi-triangular system: */ +/* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK */ + + vmax = 1.; + vcrit = bignum; + + jnxt = ki + 1; + i__2 = *n; + for (j = ki + 1; j <= i__2; ++j) { + if (j < jnxt) { + goto L170; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + + if (work[j] > vcrit) { + rec = 1. / vmax; + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + *n], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__3 = j - ki - 1; + work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1], + &c__1, &work[ki + 1 + *n], &c__1); + +/* Solve (T(J,J)-WR)'*X = WORK */ + + dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + *n], &c__1); + } + work[j + *n] = x[0]; +/* Computing MAX */ + d__2 = (d__1 = work[j + *n], abs(d__1)); + vmax = std::max(d__2,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + +/* Computing MAX */ + d__1 = work[j], d__2 = work[j + 1]; + beta = std::max(d__1,d__2); + if (beta > vcrit) { + rec = 1. / vmax; + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + *n], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__3 = j - ki - 1; + work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1], + &c__1, &work[ki + 1 + *n], &c__1); + + i__3 = j - ki - 1; + work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 1 + (j + 1) * + t_dim1], &c__1, &work[ki + 1 + *n], &c__1); + +/* Solve */ +/* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) */ +/* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) */ + + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + *n], &c__1); + } + work[j + *n] = x[0]; + work[j + 1 + *n] = x[1]; + +/* Computing MAX */ + d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2 + = work[j + 1 + *n], abs(d__2)), d__3 = std::max( + d__3,d__4); + vmax = std::max(d__3,vmax); + vcrit = bignum / vmax; + + } +L170: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { + i__2 = *n - ki + 1; + dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + + i__2 = *n - ki + 1; + ii = idamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - + 1; + remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1)); + i__2 = *n - ki + 1; + dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + vl[k + is * vl_dim1] = 0.; +/* L180: */ + } + + } else { + + if (ki < *n) { + i__2 = *n - ki; + dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 1) * vl_dim1 + + 1], ldvl, &work[ki + 1 + *n], &c__1, &work[ + ki + *n], &vl[ki * vl_dim1 + 1], &c__1); + } + + ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1); + remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1)); + dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + + } + + } else { + +/* Complex left eigenvector. */ + +/* Initial solve: */ +/* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. */ +/* ((T(KI+1,KI) T(KI+1,KI+1)) ) */ + + if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >= (d__2 = + t[ki + 1 + ki * t_dim1], abs(d__2))) { + work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1]; + work[ki + 1 + n2] = 1.; + } else { + work[ki + *n] = 1.; + work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1]; + } + work[ki + 1 + *n] = 0.; + work[ki + n2] = 0.; + +/* Form right-hand side */ + + i__2 = *n; + for (k = ki + 2; k <= i__2; ++k) { + work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1]; + work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1] + ; +/* L190: */ + } + +/* Solve complex quasi-triangular system: */ +/* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 */ + + vmax = 1.; + vcrit = bignum; + + jnxt = ki + 2; + i__2 = *n; + for (j = ki + 2; j <= i__2; ++j) { + if (j < jnxt) { + goto L200; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when */ +/* forming the right-hand side elements. */ + + if (work[j] > vcrit) { + rec = 1. / vmax; + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + n2], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__3 = j - ki - 2; + work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + *n], &c__1); + i__3 = j - ki - 2; + work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + n2], &c__1); + +/* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 */ + + d__1 = -wi; + dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + n2], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; +/* Computing MAX */ + d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2 + = work[j + n2], abs(d__2)), d__3 = std::max(d__3, + d__4); + vmax = std::max(d__3,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side elements. */ + +/* Computing MAX */ + d__1 = work[j], d__2 = work[j + 1]; + beta = std::max(d__1,d__2); + if (beta > vcrit) { + rec = 1. / vmax; + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + n2], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__3 = j - ki - 2; + work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + *n], &c__1); + + i__3 = j - ki - 2; + work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + n2], &c__1); + + i__3 = j - ki - 2; + work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 2 + (j + 1) * + t_dim1], &c__1, &work[ki + 2 + *n], &c__1); + + i__3 = j - ki - 2; + work[j + 1 + n2] -= ddot_(&i__3, &t[ki + 2 + (j + 1) * + t_dim1], &c__1, &work[ki + 2 + n2], &c__1); + +/* Solve 2-by-2 complex linear equation */ +/* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B */ +/* ([T(j+1,j) T(j+1,j+1)] ) */ + + d__1 = -wi; + dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + n2], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; + work[j + 1 + *n] = x[1]; + work[j + 1 + n2] = x[3]; +/* Computing MAX */ + d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = std::max(d__1, + d__2), d__2 = abs(x[1]), d__1 = std::max(d__1,d__2) + , d__2 = abs(x[3]), d__1 = std::max(d__1,d__2); + vmax = std::max(d__1,vmax); + vcrit = bignum / vmax; + + } +L200: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { + i__2 = *n - ki + 1; + dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + i__2 = *n - ki + 1; + dcopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) * + vl_dim1], &c__1); + + emax = 0.; + i__2 = *n; + for (k = ki; k <= i__2; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs( + d__1)) + (d__2 = vl[k + (is + 1) * vl_dim1], + abs(d__2)); + emax = std::max(d__3,d__4); +/* L220: */ + } + remax = 1. / emax; + i__2 = *n - ki + 1; + dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); + i__2 = *n - ki + 1; + dscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1) + ; + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + vl[k + is * vl_dim1] = 0.; + vl[k + (is + 1) * vl_dim1] = 0.; +/* L230: */ + } + } else { + if (ki < *n - 1) { + i__2 = *n - ki - 1; + dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + *n], &c__1, &work[ + ki + *n], &vl[ki * vl_dim1 + 1], &c__1); + i__2 = *n - ki - 1; + dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + n2], &c__1, &work[ + ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], & + c__1); + } else { + dscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], & + c__1); + dscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + + 1], &c__1); + } + + emax = 0.; + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs( + d__1)) + (d__2 = vl[k + (ki + 1) * vl_dim1], + abs(d__2)); + emax = std::max(d__3,d__4); +/* L240: */ + } + remax = 1. / emax; + dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1); + + } + + } + + ++is; + if (ip != 0) { + ++is; + } +L250: + if (ip == -1) { + ip = 0; + } + if (ip == 1) { + ip = -1; + } + +/* L260: */ + } + + } + + return 0; + +/* End of DTREVC */ + +} /* dtrevc_ */ + +/* Subroutine */ int dtrexc_(const char *compq, integer *n, double *t, integer * + ldt, double *q, integer *ldq, integer *ifst, integer *ilst, + double *work, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c__2 = 2; + + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1; + + /* Local variables */ + integer nbf, nbl, here; + bool wantq; + integer nbnext; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTREXC reorders the real Schur factorization of a real matrix */ +/* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is */ +/* moved to row ILST. */ + +/* The real Schur form T is reordered by an orthogonal similarity */ +/* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors */ +/* is updated by postmultiplying it with Z. */ + +/* T must be in Schur canonical form (as returned by DHSEQR), that is, */ +/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* 2-by-2 diagonal block has its diagonal elements equal and its */ +/* off-diagonal elements of opposite sign. */ + +/* Arguments */ +/* ========= */ + +/* COMPQ (input) CHARACTER*1 */ +/* = 'V': update the matrix Q of Schur vectors; */ +/* = 'N': do not update Q. */ + +/* N (input) INTEGER */ +/* The order of the matrix T. N >= 0. */ + +/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */ +/* On entry, the upper quasi-triangular matrix T, in Schur */ +/* Schur canonical form. */ +/* On exit, the reordered upper quasi-triangular matrix, again */ +/* in Schur canonical form. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the array T. LDT >= max(1,N). */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ +/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */ +/* orthogonal transformation matrix Z which reorders T. */ +/* If COMPQ = 'N', Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. LDQ >= max(1,N). */ + +/* IFST (input/output) INTEGER */ +/* ILST (input/output) INTEGER */ +/* Specify the reordering of the diagonal blocks of T. */ +/* The block with row index IFST is moved to row ILST, by a */ +/* sequence of transpositions between adjacent blocks. */ +/* On exit, if IFST pointed on entry to the second row of a */ +/* 2-by-2 block, it is changed to point to the first row; ILST */ +/* always points to the first row of the block in its final */ +/* position (which may differ from its input value by +1 or -1). */ +/* 1 <= IFST <= N; 1 <= ILST <= N. */ + +/* 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 */ +/* = 1: two adjacent blocks were too close to swap (the problem */ +/* is very ill-conditioned); T may have been partially */ +/* reordered, and ILST points to the first row of the */ +/* current position of the block being moved. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test the input arguments. */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --work; + + /* Function Body */ + *info = 0; + wantq = lsame_(compq, "V"); + if (! wantq && ! lsame_(compq, "N")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldt < std::max(1_integer,*n)) { + *info = -4; + } else if (*ldq < 1 || wantq && *ldq < std::max(1_integer,*n)) { + *info = -6; + } else if (*ifst < 1 || *ifst > *n) { + *info = -7; + } else if (*ilst < 1 || *ilst > *n) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTREXC", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + +/* Determine the first row of specified block */ +/* and find out it is 1 by 1 or 2 by 2. */ + + if (*ifst > 1) { + if (t[*ifst + (*ifst - 1) * t_dim1] != 0.) { + --(*ifst); + } + } + nbf = 1; + if (*ifst < *n) { + if (t[*ifst + 1 + *ifst * t_dim1] != 0.) { + nbf = 2; + } + } + +/* Determine the first row of the final block */ +/* and find out it is 1 by 1 or 2 by 2. */ + + if (*ilst > 1) { + if (t[*ilst + (*ilst - 1) * t_dim1] != 0.) { + --(*ilst); + } + } + nbl = 1; + if (*ilst < *n) { + if (t[*ilst + 1 + *ilst * t_dim1] != 0.) { + nbl = 2; + } + } + + if (*ifst == *ilst) { + return 0; + } + + if (*ifst < *ilst) { + +/* Update ILST */ + + if (nbf == 2 && nbl == 1) { + --(*ilst); + } + if (nbf == 1 && nbl == 2) { + ++(*ilst); + } + + here = *ifst; + +L10: + +/* Swap block with next one below */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1 by 1 or 2 by 2 */ + + nbnext = 1; + if (here + nbf + 1 <= *n) { + if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) { + nbnext = 2; + } + } + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, & + nbf, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += nbnext; + +/* Test if 2 by 2 block breaks into two 1 by 1 blocks */ + + if (nbf == 2) { + if (t[here + 1 + here * t_dim1] == 0.) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1 by 1 blocks each of which */ +/* must be swapped individually */ + + nbnext = 1; + if (here + 3 <= *n) { + if (t[here + 3 + (here + 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here + 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + c__1, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1 by 1 blocks, no problems possible */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &nbnext, &work[1], info); + ++here; + } else { + +/* Recompute NBNEXT in case 2 by 2 split */ + + if (t[here + 2 + (here + 1) * t_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2 by 2 Block did not split */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += 2; + } else { + +/* 2 by 2 Block did split */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &c__1, &work[1], info); + i__1 = here + 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__1, &c__1, &work[1], info); + here += 2; + } + } + } + if (here < *ilst) { + goto L10; + } + + } else { + + here = *ifst; +L20: + +/* Swap block with next one above */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1 by 1 or 2 by 2 */ + + nbnext = 1; + if (here >= 3) { + if (t[here - 1 + (here - 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + nbnext, &nbf, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here -= nbnext; + +/* Test if 2 by 2 block breaks into two 1 by 1 blocks */ + + if (nbf == 2) { + if (t[here + 1 + here * t_dim1] == 0.) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1 by 1 blocks each of which */ +/* must be swapped individually */ + + nbnext = 1; + if (here >= 3) { + if (t[here - 1 + (here - 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + nbnext, &c__1, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1 by 1 blocks, no problems possible */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &nbnext, &c__1, &work[1], info); + --here; + } else { + +/* Recompute NBNEXT in case 2 by 2 split */ + + if (t[here + (here - 1) * t_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2 by 2 Block did not split */ + + i__1 = here - 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__2, &c__1, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += -2; + } else { + +/* 2 by 2 Block did split */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &c__1, &work[1], info); + i__1 = here - 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__1, &c__1, &work[1], info); + here += -2; + } + } + } + if (here > *ilst) { + goto L20; + } + } + *ilst = here; + + return 0; + +/* End of DTREXC */ + +} /* dtrexc_ */ + +/* Subroutine */ int dtrrfs_(const char *uplo, const char *trans, const char *diag, integer *n, + integer *nrhs, double *a, integer *lda, double *b, integer * + ldb, double *x, integer *ldx, double *ferr, double *berr, + double *work, integer *iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b19 = -1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, + i__3; + double d__1, d__2, d__3; + + /* Local variables */ + integer i__, j, k; + double s, xk; + integer nz; + double eps; + integer kase; + double safe1, safe2; + integer isave[3]; + bool upper; + double safmin; + bool notran; + char transt[1]; + bool nounit; + double lstres; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRRFS provides error bounds and backward error estimates for the */ +/* solution to a system of linear equations with a triangular */ +/* coefficient matrix. */ + +/* The solution matrix X must be computed by DTRTRS or some other */ +/* means before entering this routine. DTRRFS does not do iterative */ +/* refinement because doing so cannot improve the backward error. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrices B and X. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of the array A contains the upper */ +/* triangular matrix, and the strictly lower triangular part of */ +/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* triangular part of the array A contains the lower triangular */ +/* matrix, and the strictly upper triangular part of A is not */ +/* referenced. If DIAG = 'U', the diagonal elements of A are */ +/* also not referenced and are assumed to be 1. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* The right hand side matrix B. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* The solution matrix X. */ + +/* LDX (input) INTEGER */ +/* The leading dimension of the array X. LDX >= max(1,N). */ + +/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The estimated forward error bound for each solution vector */ +/* X(j) (the j-th column of the solution matrix X). */ +/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* is an estimated upper bound for the magnitude of the largest */ +/* element in (X(j) - XTRUE) divided by the magnitude of the */ +/* largest element in X(j). The estimate is as reliable as */ +/* the estimate for RCOND, and is almost always a slight */ +/* overestimate of the true error. */ + +/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ +/* The componentwise relative backward error of each solution */ +/* vector X(j) (i.e., the smallest relative change in */ +/* any element of A or B that makes X(j) an exact solution). */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ + +/* IWORK (workspace) INTEGER array, dimension (N) */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldx < std::max(1_integer,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRRFS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A', depending on TRANS. */ + + dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1); + daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs( + d__1)) * xk; +/* L30: */ + } +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs( + d__1)) * xk; +/* L50: */ + } + work[k] += xk; +/* L60: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs( + d__1)) * xk; +/* L70: */ + } +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs( + d__1)) * xk; +/* L90: */ + } + work[k] += xk; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A')*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L110: */ + } + work[k] += s; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L130: */ + } + work[k] += s; +/* L140: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L150: */ + } + work[k] += s; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L170: */ + } + work[k] += s; +/* L180: */ + } + } + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = std::max(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = std::max(d__2,d__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)'). */ + + dtrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1] +, &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], + &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = std::max(d__2,d__3); +/* L240: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of DTRRFS */ + +} /* dtrrfs_ */ + +/* Subroutine */ int dtrsen_(const char *job, const char *compq, bool *select, integer + *n, double *t, integer *ldt, double *q, integer *ldq, + double *wr, double *wi, integer *m, double *s, double + *sep, double *work, integer *lwork, integer *iwork, integer * + liwork, integer *info) +{ + /* Table of constant values */ + static integer c_n1 = -1; + + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer k, n1, n2, kk, nn, ks; + double est; + integer kase; + bool pair; + integer ierr; + bool swap; + double scale; + integer isave[3], lwmin; + bool wantq, wants; + double rnorm; + bool wantbh; + integer liwmin; + bool wantsp, lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRSEN reorders the real Schur factorization of a real matrix */ +/* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */ +/* the leading diagonal blocks of the upper quasi-triangular matrix T, */ +/* and the leading columns of Q form an orthonormal basis of the */ +/* corresponding right invariant subspace. */ + +/* Optionally the routine computes the reciprocal condition numbers of */ +/* the cluster of eigenvalues and/or the invariant subspace. */ + +/* T must be in Schur canonical form (as returned by DHSEQR), that is, */ +/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* 2-by-2 diagonal block has its diagonal elemnts equal and its */ +/* off-diagonal elements of opposite sign. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* Specifies whether condition numbers are required for the */ +/* cluster of eigenvalues (S) or the invariant subspace (SEP): */ +/* = 'N': none; */ +/* = 'E': for eigenvalues only (S); */ +/* = 'V': for invariant subspace only (SEP); */ +/* = 'B': for both eigenvalues and invariant subspace (S and */ +/* SEP). */ + +/* COMPQ (input) CHARACTER*1 */ +/* = 'V': update the matrix Q of Schur vectors; */ +/* = 'N': do not update Q. */ + +/* SELECT (input) LOGICAL array, dimension (N) */ +/* SELECT specifies the eigenvalues in the selected cluster. To */ +/* select a real eigenvalue w(j), SELECT(j) must be set to */ +/* .TRUE.. To select a complex conjugate pair of eigenvalues */ +/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ +/* either SELECT(j) or SELECT(j+1) or both must be set to */ +/* .TRUE.; a complex conjugate pair of eigenvalues must be */ +/* either both included in the cluster or both excluded. */ + +/* N (input) INTEGER */ +/* The order of the matrix T. N >= 0. */ + +/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */ +/* On entry, the upper quasi-triangular matrix T, in Schur */ +/* canonical form. */ +/* On exit, T is overwritten by the reordered matrix T, again in */ +/* Schur canonical form, with the selected eigenvalues in the */ +/* leading diagonal blocks. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the array T. LDT >= max(1,N). */ + +/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */ +/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ +/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */ +/* orthogonal transformation matrix which reorders T; the */ +/* leading M columns of Q form an orthonormal basis for the */ +/* specified invariant subspace. */ +/* If COMPQ = 'N', Q is not referenced. */ + +/* LDQ (input) INTEGER */ +/* The leading dimension of the array Q. */ +/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */ + +/* WR (output) DOUBLE PRECISION array, dimension (N) */ +/* WI (output) DOUBLE PRECISION array, dimension (N) */ +/* The real and imaginary parts, respectively, of the reordered */ +/* eigenvalues of T. The eigenvalues are stored in the same */ +/* order as on the diagonal of T, with WR(i) = T(i,i) and, if */ +/* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */ +/* WI(i+1) = -WI(i). Note that if a complex eigenvalue is */ +/* sufficiently ill-conditioned, then its value may differ */ +/* significantly from its value before reordering. */ + +/* M (output) INTEGER */ +/* The dimension of the specified invariant subspace. */ +/* 0 < = M <= N. */ + +/* S (output) DOUBLE PRECISION */ +/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */ +/* condition number for the selected cluster of eigenvalues. */ +/* S cannot underestimate the true reciprocal condition number */ +/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */ +/* If JOB = 'N' or 'V', S is not referenced. */ + +/* SEP (output) DOUBLE PRECISION */ +/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */ +/* condition number of the specified invariant subspace. If */ +/* M = 0 or N, SEP = norm(T). */ +/* If JOB = 'N' or 'E', SEP is not referenced. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. */ +/* If JOB = 'N', LWORK >= max(1,N); */ +/* if JOB = 'E', LWORK >= max(1,M*(N-M)); */ +/* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */ +/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ + +/* LIWORK (input) INTEGER */ +/* The dimension of the array IWORK. */ +/* If JOB = 'N' or 'E', LIWORK >= 1; */ +/* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). */ + +/* If LIWORK = -1, then a workspace query is assumed; the */ +/* routine only calculates the optimal size of the IWORK array, */ +/* returns this value as the first entry of the IWORK array, and */ +/* no error message related to LIWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* = 1: reordering of T failed because some eigenvalues are too */ +/* close to separate (the problem is very ill-conditioned); */ +/* T may have been partially reordered, and WR and WI */ +/* contain the eigenvalues in the same order as in T; S and */ +/* SEP (if requested) are set to zero. */ + +/* Further Details */ +/* =============== */ + +/* DTRSEN first collects the selected eigenvalues by computing an */ +/* orthogonal transformation Z to move them to the top left corner of T. */ +/* In other words, the selected eigenvalues are the eigenvalues of T11 */ +/* in: */ + +/* Z'*T*Z = ( T11 T12 ) n1 */ +/* ( 0 T22 ) n2 */ +/* n1 n2 */ + +/* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns */ +/* of Z span the specified invariant subspace of T. */ + +/* If T has been obtained from the real Schur factorization of a matrix */ +/* A = Q*T*Q', then the reordered real Schur factorization of A is given */ +/* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span */ +/* the corresponding invariant subspace of A. */ + +/* The reciprocal condition number of the average of the eigenvalues of */ +/* T11 may be returned in S. S lies between 0 (very badly conditioned) */ +/* and 1 (very well conditioned). It is computed as follows. First we */ +/* compute R so that */ + +/* P = ( I R ) n1 */ +/* ( 0 0 ) n2 */ +/* n1 n2 */ + +/* is the projector on the invariant subspace associated with T11. */ +/* R is the solution of the Sylvester equation: */ + +/* T11*R - R*T22 = T12. */ + +/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */ +/* the two-norm of M. Then S is computed as the lower bound */ + +/* (1 + F-norm(R)**2)**(-1/2) */ + +/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */ +/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */ +/* sqrt(N). */ + +/* An approximate error bound for the computed average of the */ +/* eigenvalues of T11 is */ + +/* EPS * norm(T) / S */ + +/* where EPS is the machine precision. */ + +/* The reciprocal condition number of the right invariant subspace */ +/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */ +/* SEP is defined as the separation of T11 and T22: */ + +/* sep( T11, T22 ) = sigma-min( C ) */ + +/* where sigma-min(C) is the smallest singular value of the */ +/* n1*n2-by-n1*n2 matrix */ + +/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */ + +/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */ +/* product. We estimate sigma-min(C) by the reciprocal of an estimate of */ +/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */ +/* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */ + +/* When SEP is small, small changes in T can cause large changes in */ +/* the invariant subspace. An approximate bound on the maximum angular */ +/* error in the computed right invariant subspace is */ + +/* EPS * norm(T) / SEP */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --wr; + --wi; + --work; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantsp = lsame_(job, "V") || wantbh; + wantq = lsame_(compq, "V"); + + *info = 0; + lquery = *lwork == -1; + if (! lsame_(job, "N") && ! wants && ! wantsp) { + *info = -1; + } else if (! lsame_(compq, "N") && ! wantq) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -8; + } else { + +/* Set M to the dimension of the specified invariant subspace, */ +/* and test LWORK and LIWORK. */ + + *m = 0; + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = false; + } else { + if (k < *n) { + if (t[k + 1 + k * t_dim1] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = true; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + + n1 = *m; + n2 = *n - *m; + nn = n1 * n2; + + if (wantsp) { +/* Computing MAX */ + i__1 = 1, i__2 = nn << 1; + lwmin = std::max(i__1,i__2); + liwmin = std::max(1_integer,nn); + } else if (lsame_(job, "N")) { + lwmin = std::max(1_integer,*n); + liwmin = 1; + } else if (lsame_(job, "E")) { + lwmin = std::max(1_integer,nn); + liwmin = 1; + } + + if (*lwork < lwmin && ! lquery) { + *info = -15; + } else if (*liwork < liwmin && ! lquery) { + *info = -17; + } + } + + if (*info == 0) { + work[1] = (double) lwmin; + iwork[1] = liwmin; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRSEN", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*m == *n || *m == 0) { + if (wants) { + *s = 1.; + } + if (wantsp) { + *sep = dlange_("1", n, n, &t[t_offset], ldt, &work[1]); + } + goto L40; + } + +/* Collect the selected blocks at the top-left corner of T. */ + + ks = 0; + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = false; + } else { + swap = select[k]; + if (k < *n) { + if (t[k + 1 + k * t_dim1] != 0.) { + pair = true; + swap = swap || select[k + 1]; + } + } + if (swap) { + ++ks; + +/* Swap the K-th block to position KS. */ + + ierr = 0; + kk = k; + if (k != ks) { + dtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + kk, &ks, &work[1], &ierr); + } + if (ierr == 1 || ierr == 2) { + +/* Blocks too close to swap: exit. */ + + *info = 1; + if (wants) { + *s = 0.; + } + if (wantsp) { + *sep = 0.; + } + goto L40; + } + if (pair) { + ++ks; + } + } + } +/* L20: */ + } + + if (wants) { + +/* Solve Sylvester equation for R: */ + +/* T11*R - R*T22 = scale*T12 */ + + dlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1); + dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr); + +/* Estimate the reciprocal of the condition number of the cluster */ +/* of eigenvalues. */ + + rnorm = dlange_("F", &n1, &n2, &work[1], &n1, &work[1]); + if (rnorm == 0.) { + *s = 1.; + } else { + *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm)); + } + } + + if (wantsp) { + +/* Estimate sep(T11,T22). */ + + est = 0.; + kase = 0; +L30: + dlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve T11*R - R*T22 = scale*X. */ + + dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & + ierr); + } else { + +/* Solve T11'*R - R*T22' = scale*X. */ + + dtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & + ierr); + } + goto L30; + } + + *sep = scale / est; + } + +L40: + +/* Store the output eigenvalues in WR and WI. */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + wr[k] = t[k + k * t_dim1]; + wi[k] = 0.; +/* L50: */ + } + i__1 = *n - 1; + for (k = 1; k <= i__1; ++k) { + if (t[k + 1 + k * t_dim1] != 0.) { + wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], abs(d__1))) * sqrt(( + d__2 = t[k + 1 + k * t_dim1], abs(d__2))); + wi[k + 1] = -wi[k]; + } +/* L60: */ + } + + work[1] = (double) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DTRSEN */ + +} /* dtrsen_ */ + +/* Subroutine */ int dtrsna_(const char *job, const char *howmny, bool *select, + integer *n, double *t, integer *ldt, double *vl, integer * + ldvl, double *vr, integer *ldvr, double *s, double *sep, + integer *mm, integer *m, double *work, integer *ldwork, integer * + iwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static bool c_true = true; + static bool c_false = false; + + /* System generated locals */ + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, + work_dim1, work_offset, i__1, i__2; + double d__1, d__2; + + /* Local variables */ + integer i__, j, k, n2; + double cs; + integer nn, ks; + double sn, mu, eps, est; + integer kase; + double cond; + bool pair; + integer ierr; + double dumm, prod; + integer ifst; + double lnrm; + integer ilst; + double rnrm; + double prod1, prod2, scale, delta; + integer isave[3]; + bool wants; + double dummy[1]; + double bignum; + bool wantbh; + bool somcon; + double smlnum; + bool wantsp; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRSNA estimates reciprocal condition numbers for specified */ +/* eigenvalues and/or right eigenvectors of a real upper */ +/* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q */ +/* orthogonal). */ + +/* T must be in Schur canonical form (as returned by DHSEQR), that is, */ +/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* 2-by-2 diagonal block has its diagonal elements equal and its */ +/* off-diagonal elements of opposite sign. */ + +/* Arguments */ +/* ========= */ + +/* JOB (input) CHARACTER*1 */ +/* Specifies whether condition numbers are required for */ +/* eigenvalues (S) or eigenvectors (SEP): */ +/* = 'E': for eigenvalues only (S); */ +/* = 'V': for eigenvectors only (SEP); */ +/* = 'B': for both eigenvalues and eigenvectors (S and SEP). */ + +/* HOWMNY (input) CHARACTER*1 */ +/* = 'A': compute condition numbers for all eigenpairs; */ +/* = 'S': compute condition numbers for selected eigenpairs */ +/* specified by the array SELECT. */ + +/* SELECT (input) LOGICAL array, dimension (N) */ +/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ +/* condition numbers are required. To select condition numbers */ +/* for the eigenpair corresponding to a real eigenvalue w(j), */ +/* SELECT(j) must be set to .TRUE.. To select condition numbers */ +/* corresponding to a complex conjugate pair of eigenvalues w(j) */ +/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */ +/* set to .TRUE.. */ +/* If HOWMNY = 'A', SELECT is not referenced. */ + +/* N (input) INTEGER */ +/* The order of the matrix T. N >= 0. */ + +/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */ +/* The upper quasi-triangular matrix T, in Schur canonical form. */ + +/* LDT (input) INTEGER */ +/* The leading dimension of the array T. LDT >= max(1,N). */ + +/* VL (input) DOUBLE PRECISION array, dimension (LDVL,M) */ +/* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */ +/* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */ +/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ +/* must be stored in consecutive columns of VL, as returned by */ +/* DHSEIN or DTREVC. */ +/* If JOB = 'V', VL is not referenced. */ + +/* LDVL (input) INTEGER */ +/* The leading dimension of the array VL. */ +/* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */ + +/* VR (input) DOUBLE PRECISION array, dimension (LDVR,M) */ +/* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */ +/* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */ +/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ +/* must be stored in consecutive columns of VR, as returned by */ +/* DHSEIN or DTREVC. */ +/* If JOB = 'V', VR is not referenced. */ + +/* LDVR (input) INTEGER */ +/* The leading dimension of the array VR. */ +/* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */ + +/* S (output) DOUBLE PRECISION array, dimension (MM) */ +/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */ +/* selected eigenvalues, stored in consecutive elements of the */ +/* array. For a complex conjugate pair of eigenvalues two */ +/* consecutive elements of S are set to the same value. Thus */ +/* S(j), SEP(j), and the j-th columns of VL and VR all */ +/* correspond to the same eigenpair (but not in general the */ +/* j-th eigenpair, unless all eigenpairs are selected). */ +/* If JOB = 'V', S is not referenced. */ + +/* SEP (output) DOUBLE PRECISION array, dimension (MM) */ +/* If JOB = 'V' or 'B', the estimated reciprocal condition */ +/* numbers of the selected eigenvectors, stored in consecutive */ +/* elements of the array. For a complex eigenvector two */ +/* consecutive elements of SEP are set to the same value. If */ +/* the eigenvalues cannot be reordered to compute SEP(j), SEP(j) */ +/* is set to 0; this can only occur when the true value would be */ +/* very small anyway. */ +/* If JOB = 'E', SEP is not referenced. */ + +/* MM (input) INTEGER */ +/* The number of elements in the arrays S (if JOB = 'E' or 'B') */ +/* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */ + +/* M (output) INTEGER */ +/* The number of elements of the arrays S and/or SEP actually */ +/* used to store the estimated condition numbers. */ +/* If HOWMNY = 'A', M is set to N. */ + +/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6) */ +/* If JOB = 'E', WORK is not referenced. */ + +/* LDWORK (input) INTEGER */ +/* The leading dimension of the array WORK. */ +/* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */ + +/* IWORK (workspace) INTEGER array, dimension (2*(N-1)) */ +/* If JOB = 'E', IWORK is not referenced. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Further Details */ +/* =============== */ + +/* The reciprocal of the condition number of an eigenvalue lambda is */ +/* defined as */ + +/* S(lambda) = |v'*u| / (norm(u)*norm(v)) */ + +/* where u and v are the right and left eigenvectors of T corresponding */ +/* to lambda; v' denotes the conjugate-transpose of v, and norm(u) */ +/* denotes the Euclidean norm. These reciprocal condition numbers always */ +/* lie between zero (very badly conditioned) and one (very well */ +/* conditioned). If n = 1, S(lambda) is defined to be 1. */ + +/* An approximate error bound for a computed eigenvalue W(i) is given by */ + +/* EPS * norm(T) / S(i) */ + +/* where EPS is the machine precision. */ + +/* The reciprocal of the condition number of the right eigenvector u */ +/* corresponding to lambda is defined as follows. Suppose */ + +/* T = ( lambda c ) */ +/* ( 0 T22 ) */ + +/* Then the reciprocal condition number is */ + +/* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */ + +/* where sigma-min denotes the smallest singular value. We approximate */ +/* the smallest singular value by the reciprocal of an estimate of the */ +/* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */ +/* defined to be abs(T(1,1)). */ + +/* An approximate error bound for a computed right eigenvector VR(i) */ +/* is given by */ + +/* EPS * norm(T) / SEP(i) */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1; + vr -= vr_offset; + --s; + --sep; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1; + work -= work_offset; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantsp = lsame_(job, "V") || wantbh; + + somcon = lsame_(howmny, "S"); + + *info = 0; + if (! wants && ! wantsp) { + *info = -1; + } else if (! lsame_(howmny, "A") && ! somcon) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < std::max(1_integer,*n)) { + *info = -6; + } else if (*ldvl < 1 || wants && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || wants && *ldvr < *n) { + *info = -10; + } else { + +/* Set M to the number of eigenpairs for which condition numbers */ +/* are required, and test MM. */ + + if (somcon) { + *m = 0; + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = false; + } else { + if (k < *n) { + if (t[k + 1 + k * t_dim1] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = true; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*mm < *m) { + *info = -13; + } else if (*ldwork < 1 || wantsp && *ldwork < *n) { + *info = -16; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRSNA", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (somcon) { + if (! select[1]) { + return 0; + } + } + if (wants) { + s[1] = 1.; + } + if (wantsp) { + sep[1] = (d__1 = t[t_dim1 + 1], abs(d__1)); + } + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + + ks = 0; + pair = false; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */ + + if (pair) { + pair = false; + goto L60; + } else { + if (k < *n) { + pair = t[k + 1 + k * t_dim1] != 0.; + } + } + +/* Determine whether condition numbers are required for the k-th */ +/* eigenpair. */ + + if (somcon) { + if (pair) { + if (! select[k] && ! select[k + 1]) { + goto L60; + } + } else { + if (! select[k]) { + goto L60; + } + } + } + + ++ks; + + if (wants) { + +/* Compute the reciprocal condition number of the k-th */ +/* eigenvalue. */ + + if (! pair) { + +/* Real eigenvalue. */ + + prod = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * + vl_dim1 + 1], &c__1); + rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + s[ks] = abs(prod) / (rnrm * lnrm); + } else { + +/* Complex eigenvalue. */ + + prod1 = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * + vl_dim1 + 1], &c__1); + prod1 += ddot_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1, &vl[(ks + + 1) * vl_dim1 + 1], &c__1); + prod2 = ddot_(n, &vl[ks * vl_dim1 + 1], &c__1, &vr[(ks + 1) * + vr_dim1 + 1], &c__1); + prod2 -= ddot_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1, &vr[ks * + vr_dim1 + 1], &c__1); + d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); + rnrm = dlapy2_(&d__1, &d__2); + d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); + lnrm = dlapy2_(&d__1, &d__2); + cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm); + s[ks] = cond; + s[ks + 1] = cond; + } + } + + if (wantsp) { + +/* Estimate the reciprocal condition number of the k-th */ +/* eigenvector. */ + +/* Copy the matrix T to the array WORK and swap the diagonal */ +/* block beginning at T(k,k) to the (1,1) position. */ + + dlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], + ldwork); + ifst = k; + ilst = 1; + dtrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, & + ifst, &ilst, &work[(*n + 1) * work_dim1 + 1], &ierr); + + if (ierr == 1 || ierr == 2) { + +/* Could not swap because blocks not well separated */ + + scale = 1.; + est = bignum; + } else { + +/* Reordering successful */ + + if (work[work_dim1 + 2] == 0.) { + +/* Form C = T22 - lambda*I in WORK(2:N,2:N). */ + + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__ + i__ * work_dim1] -= work[work_dim1 + 1]; +/* L20: */ + } + n2 = 1; + nn = *n - 1; + } else { + +/* Triangularize the 2 by 2 block by unitary */ +/* transformation U = [ cs i*ss ] */ +/* [ i*ss cs ]. */ +/* such that the (1,1) position of WORK is complex */ +/* eigenvalue lambda with positive imaginary part. (2,2) */ +/* position of WORK is the complex eigenvalue lambda */ +/* with negative imaginary part. */ + + mu = sqrt((d__1 = work[(work_dim1 << 1) + 1], abs(d__1))) + * sqrt((d__2 = work[work_dim1 + 2], abs(d__2))); + delta = dlapy2_(&mu, &work[work_dim1 + 2]); + cs = mu / delta; + sn = -work[work_dim1 + 2] / delta; + +/* Form */ + +/* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] */ +/* [ mu ] */ +/* [ .. ] */ +/* [ .. ] */ +/* [ mu ] */ +/* where C' is conjugate transpose of complex matrix C, */ +/* and RWORK is stored starting in the N+1-st column of */ +/* WORK. */ + + i__2 = *n; + for (j = 3; j <= i__2; ++j) { + work[j * work_dim1 + 2] = cs * work[j * work_dim1 + 2] + ; + work[j + j * work_dim1] -= work[work_dim1 + 1]; +/* L30: */ + } + work[(work_dim1 << 1) + 2] = 0.; + + work[(*n + 1) * work_dim1 + 1] = mu * 2.; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__ + (*n + 1) * work_dim1] = sn * work[(i__ + 1) + * work_dim1 + 1]; +/* L40: */ + } + n2 = 2; + nn = *n - 1 << 1; + } + +/* Estimate norm(inv(C')) */ + + est = 0.; + kase = 0; +L50: + dlacn2_(&nn, &work[(*n + 2) * work_dim1 + 1], &work[(*n + 4) * + work_dim1 + 1], &iwork[1], &est, &kase, isave); + if (kase != 0) { + if (kase == 1) { + if (n2 == 1) { + +/* Real eigenvalue: solve C'*x = scale*c. */ + + i__2 = *n - 1; + dlaqtr_(&c_true, &c_true, &i__2, &work[(work_dim1 + << 1) + 2], ldwork, dummy, &dumm, &scale, + &work[(*n + 4) * work_dim1 + 1], &work[(* + n + 6) * work_dim1 + 1], &ierr); + } else { + +/* Complex eigenvalue: solve */ +/* C'*(p+iq) = scale*(c+id) in real arithmetic. */ + + i__2 = *n - 1; + dlaqtr_(&c_true, &c_false, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, &work[(*n + + 1) * work_dim1 + 1], &mu, &scale, &work[(* + n + 4) * work_dim1 + 1], &work[(*n + 6) * + work_dim1 + 1], &ierr); + } + } else { + if (n2 == 1) { + +/* Real eigenvalue: solve C*x = scale*c. */ + + i__2 = *n - 1; + dlaqtr_(&c_false, &c_true, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, dummy, & + dumm, &scale, &work[(*n + 4) * work_dim1 + + 1], &work[(*n + 6) * work_dim1 + 1], & + ierr); + } else { + +/* Complex eigenvalue: solve */ +/* C*(p+iq) = scale*(c+id) in real arithmetic. */ + + i__2 = *n - 1; + dlaqtr_(&c_false, &c_false, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, &work[(*n + + 1) * work_dim1 + 1], &mu, &scale, &work[(* + n + 4) * work_dim1 + 1], &work[(*n + 6) * + work_dim1 + 1], &ierr); + + } + } + + goto L50; + } + } + + sep[ks] = scale / std::max(est,smlnum); + if (pair) { + sep[ks + 1] = sep[ks]; + } + } + + if (pair) { + ++ks; + } + +L60: + ; + } + return 0; + +/* End of DTRSNA */ + +} /* dtrsna_ */ + +/* Subroutine */ int dtrsyl_(const char *trana, const char *tranb, integer *isgn, integer + *m, integer *n, double *a, integer *lda, double *b, integer * + ldb, double *c__, integer *ldc, double *scale, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static bool c_false = false; + static integer c__2 = 2; + static double c_b26 = 1.; + static double c_b30 = 0.; + static bool c_true = true; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4; + double d__1, d__2; + + /* Local variables */ + integer j, k, l; + double x[4] /* was [2][2] */; + integer k1, k2, l1, l2; + double a11, db, da11, vec[4] /* was [2][2] */, dum[1], eps, sgn; + integer ierr; + double smin, suml, sumr; + integer knext, lnext; + double xnorm; + double scaloc; + double bignum; + bool notrna, notrnb; + double smlnum; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRSYL solves the real Sylvester matrix equation: */ + +/* op(A)*X + X*op(B) = scale*C or */ +/* op(A)*X - X*op(B) = scale*C, */ + +/* where op(A) = A or A**T, and A and B are both upper quasi- */ +/* triangular. A is M-by-M and B is N-by-N; the right hand side C and */ +/* the solution X are M-by-N; and scale is an output scale factor, set */ +/* <= 1 to avoid overflow in X. */ + +/* A and B must be in Schur canonical form (as returned by DHSEQR), that */ +/* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; */ +/* each 2-by-2 diagonal block has its diagonal elements equal and its */ +/* off-diagonal elements of opposite sign. */ + +/* Arguments */ +/* ========= */ + +/* TRANA (input) CHARACTER*1 */ +/* Specifies the option op(A): */ +/* = 'N': op(A) = A (No transpose) */ +/* = 'T': op(A) = A**T (Transpose) */ +/* = 'C': op(A) = A**H (Conjugate transpose = Transpose) */ + +/* TRANB (input) CHARACTER*1 */ +/* Specifies the option op(B): */ +/* = 'N': op(B) = B (No transpose) */ +/* = 'T': op(B) = B**T (Transpose) */ +/* = 'C': op(B) = B**H (Conjugate transpose = Transpose) */ + +/* ISGN (input) INTEGER */ +/* Specifies the sign in the equation: */ +/* = +1: solve op(A)*X + X*op(B) = scale*C */ +/* = -1: solve op(A)*X - X*op(B) = scale*C */ + +/* M (input) INTEGER */ +/* The order of the matrix A, and the number of rows in the */ +/* matrices X and C. M >= 0. */ + +/* N (input) INTEGER */ +/* The order of the matrix B, and the number of columns in the */ +/* matrices X and C. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,M) */ +/* The upper quasi-triangular matrix A, in Schur canonical form. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */ +/* The upper quasi-triangular matrix B, in Schur canonical form. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */ +/* On entry, the M-by-N right hand side matrix C. */ +/* On exit, C is overwritten by the solution matrix X. */ + +/* LDC (input) INTEGER */ +/* The leading dimension of the array C. LDC >= max(1,M) */ + +/* SCALE (output) DOUBLE PRECISION */ +/* The scale factor, scale, set <= 1 to avoid overflow in X. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* = 1: A and B have common or very close eigenvalues; perturbed */ +/* values were used to solve the equation (but the matrices */ +/* A and B are unchanged). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Local Arrays .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Decode and Test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + + /* Function Body */ + notrna = lsame_(trana, "N"); + notrnb = lsame_(tranb, "N"); + + *info = 0; + if (! notrna && ! lsame_(trana, "T") && ! lsame_( + trana, "C")) { + *info = -1; + } else if (! notrnb && ! lsame_(tranb, "T") && ! + lsame_(tranb, "C")) { + *info = -2; + } else if (*isgn != 1 && *isgn != -1) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*m)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } else if (*ldc < std::max(1_integer,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRSYL", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Set constants to control overflow */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = smlnum * (double) (*m * *n) / eps; + bignum = 1. / smlnum; + +/* Computing MAX */ + d__1 = smlnum, d__2 = eps * dlange_("M", m, m, &a[a_offset], lda, dum), d__1 = std::max(d__1,d__2), d__2 = eps * dlange_("M", n, n, + &b[b_offset], ldb, dum); + smin = std::max(d__1,d__2); + + *scale = 1.; + sgn = (double) (*isgn); + + if (notrna && notrnb) { + +/* Solve A*X + ISGN*X*B = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* bottom-left corner column by column by */ + +/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* M L-1 */ +/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. */ +/* I=K+1 J=1 */ + +/* Start column loop (index = L) */ +/* L1 (L2) : column index of the first (first) row of X(K,L). */ + + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L60; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L). */ + + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L50; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L20: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L30: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, & + c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + dlasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 + + k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, + &c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L50: + ; + } + +L60: + ; + } + + } else if (! notrna && notrnb) { + +/* Solve A' *X + ISGN*X*B = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* upper-left corner column by column by */ + +/* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* K-1 L-1 */ +/* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] */ +/* I=1 J=1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L120; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = 1; + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (k < knext) { + goto L110; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L80: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L90: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + dlasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L100: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L110: + ; + } +L120: + ; + } + + } else if (! notrna && ! notrnb) { + +/* Solve A'*X + ISGN*X*B' = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* top-right corner column by column by */ + +/* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */ + +/* Where */ +/* K-1 N */ +/* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */ +/* I=1 J=L+1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L180; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = 1; + i__1 = *m; + for (k = 1; k <= i__1; ++k) { + if (k < knext) { + goto L170; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l1; +/* Computing MIN */ + i__3 = l1 + 1; +/* Computing MIN */ + i__4 = l1 + 1; + sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, + &b[l1 + std::min(i__4, *n)* b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L130: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, + &b[l1 + std::min(i__4, *n)* b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc, + &b[l1 + std::min(i__4, *n)* b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L140: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, + &b[l1 + std::min(i__4, *n)* b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, + &b[l2 + std::min(i__4, *n)* b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L150: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, + &b[l1 + std::min(i__4, *n)* b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc, + &b[l2 + std::min(i__4, *n)* b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc, + &b[l1 + std::min(i__4, *n)* b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc, + &b[l2 + std::min(i__4, *n)* b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + dlasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 * + a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L160: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L170: + ; + } +L180: + ; + } + + } else if (notrna && ! notrnb) { + +/* Solve A*X + ISGN*X*B' = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* bottom-right corner column by column by */ + +/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */ + +/* Where */ +/* M N */ +/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */ +/* I=K+1 J=L+1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L240; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L230; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); + i__1 = *n - l1; +/* Computing MIN */ + i__2 = l1 + 1; +/* Computing MIN */ + i__3 = l1 + 1; + sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, + &b[l1 + std::min(i__3, *n)* b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L190: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, + &b[l1 + std::min(i__3, *n)* b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc, + &b[l1 + std::min(i__3, *n)* b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L200: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, + &b[l1 + std::min(i__3, *n)* b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, + &b[l2 + std::min(i__3, *n)* b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L210: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, + &b[l1 + std::min(i__3, *n)* b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc, + &b[l2 + std::min(i__3, *n)* b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc, + &b[l1 + std::min(i__3, *n)* b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, & + c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc, + &b[l2 + std::min(i__3, *n)* b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + dlasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L220: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L230: + ; + } +L240: + ; + } + + } + + return 0; + +/* End of DTRSYL */ + +} /* dtrsyl_ */ + +/* Subroutine */ int dtrti2_(const char *uplo, const char *diag, integer *n, double * + a, integer *lda, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer j; + double ajj; + bool upper; + bool nounit; + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRTI2 computes the inverse of a real upper or lower triangular */ +/* matrix. */ + +/* This is the Level 2 BLAS version of the algorithm. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the matrix A is upper or lower triangular. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* DIAG (input) CHARACTER*1 */ +/* Specifies whether or not the matrix A is unit triangular. */ +/* = 'N': Non-unit triangular */ +/* = 'U': Unit triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the triangular matrix A. If UPLO = 'U', the */ +/* leading n by n upper triangular part of the array A contains */ +/* the upper triangular matrix, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n by n lower triangular part of the array A contains */ +/* the lower triangular matrix, and the strictly upper */ +/* triangular part of A is not referenced. If DIAG = 'U', the */ +/* diagonal elements of A are also not referenced and are */ +/* assumed to be 1. */ + +/* On exit, the (triangular) inverse of the original matrix, in */ +/* the same storage format. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -k, the k-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTI2", &i__1); + return 0; + } + + if (upper) { + +/* Compute inverse of upper triangular matrix. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.; + } + +/* Compute elements 1:j-1 of j-th column. */ + + i__2 = j - 1; + dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, & + a[j * a_dim1 + 1], &c__1); + i__2 = j - 1; + dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Compute inverse of lower triangular matrix. */ + + for (j = *n; j >= 1; --j) { + if (nounit) { + a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.; + } + if (j < *n) { + +/* Compute elements j+1:n of j-th column. */ + + i__1 = *n - j; + dtrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j + + 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1); + i__1 = *n - j; + dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); + } +/* L20: */ + } + } + + return 0; + +/* End of DTRTI2 */ + +} /* dtrti2_ */ + +/* Subroutine */ int dtrtri_(const char *uplo, const char *diag, integer *n, double * + a, integer *lda, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__2 = 2; + static double c_b18 = 1.; + static double c_b22 = -1.; + + /* System generated locals */ + char * a__1[2]; + integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5; + char ch__1[3] = { 0 }; + + /* Local variables */ + integer j, jb, nb, nn; + bool upper; + bool nounit; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRTRI computes the inverse of a real upper or lower triangular */ +/* matrix A. */ + +/* This is the Level 3 BLAS version of the algorithm. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the triangular matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of the array A contains */ +/* the upper triangular matrix, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of the array A contains */ +/* the lower triangular matrix, and the strictly upper */ +/* triangular part of A is not referenced. If DIAG = 'U', the */ +/* diagonal elements of A are also not referenced and are */ +/* assumed to be 1. */ +/* On exit, the (triangular) inverse of the original matrix, in */ +/* the same storage format. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* matrix is singular and its inverse can not be computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTRI", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity if non-unit. */ + + if (nounit) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + *info = 0; + } + +/* Determine the block size for this environment. */ + +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = const_cast (uplo); + i__2[1] = 1, a__1[1] = const_cast (diag); + s_cat(ch__1, a__1, i__2, &c__2, 2_integer); + nb = ilaenv_(&c__1, "DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dtrti2_(uplo, diag, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute inverse of upper triangular matrix */ + + i__1 = *n; + i__3 = nb; + for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { +/* Computing MIN */ + i__4 = nb, i__5 = *n - j + 1; + jb = std::min(i__4,i__5); + +/* Compute rows 1:j-1 of current block column */ + + i__4 = j - 1; + dtrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, & + c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda); + i__4 = j - 1; + dtrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, & + c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], + lda); + +/* Compute inverse of current diagonal block */ + + dtrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info); +/* L20: */ + } + } else { + +/* Compute inverse of lower triangular matrix */ + + nn = (*n - 1) / nb * nb + 1; + i__3 = -nb; + for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { +/* Computing MIN */ + i__1 = nb, i__4 = *n - j + 1; + jb = std::min(i__1,i__4); + if (j + jb <= *n) { + +/* Compute rows j+jb:n of current block column */ + + i__1 = *n - j - jb + 1; + dtrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb, + &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j + + jb + j * a_dim1], lda); + i__1 = *n - j - jb + 1; + dtrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb, + &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j * + a_dim1], lda); + } + +/* Compute inverse of current diagonal block */ + + dtrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info); +/* L30: */ + } + } + } + + return 0; + +/* End of DTRTRI */ + +} /* dtrtri_ */ + +/* Subroutine */ int dtrtrs_(const char *uplo, const char *trans, const char *diag, integer *n, + integer *nrhs, double *a, integer *lda, double *b, integer * + ldb, integer *info) +{ + /* Table of constant values */ + static double c_b12 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + bool nounit; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRTRS solves a triangular system of the form */ + +/* A * X = B or A**T * X = B, */ + +/* where A is a triangular matrix of order N, and B is an N-by-NRHS */ +/* matrix. A check is made to verify that A is nonsingular. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* = 'U': A is upper triangular; */ +/* = 'L': A is lower triangular. */ + +/* TRANS (input) CHARACTER*1 */ +/* Specifies the form of the system of equations: */ +/* = 'N': A * X = B (No transpose) */ +/* = 'T': A**T * X = B (Transpose) */ +/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ + +/* DIAG (input) CHARACTER*1 */ +/* = 'N': A is non-unit triangular; */ +/* = 'U': A is unit triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* NRHS (input) INTEGER */ +/* The number of right hand sides, i.e., the number of columns */ +/* of the matrix B. NRHS >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* upper triangular part of the array A contains the upper */ +/* triangular matrix, and the strictly lower triangular part of */ +/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* triangular part of the array A contains the lower triangular */ +/* matrix, and the strictly upper triangular part of A is not */ +/* referenced. If DIAG = 'U', the diagonal elements of A are */ +/* also not referenced and are assumed to be 1. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* On entry, the right hand side matrix B. */ +/* On exit, if INFO = 0, the solution matrix X. */ + +/* LDB (input) INTEGER */ +/* The leading dimension of the array B. LDB >= max(1,N). */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* indicating that the matrix is singular and the solutions */ +/* X have not been computed. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + + /* Function Body */ + *info = 0; + nounit = lsame_(diag, "N"); + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*lda < std::max(1_integer,*n)) { + *info = -7; + } else if (*ldb < std::max(1_integer,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTRS", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } + *info = 0; + +/* Solve A * x = b or A' * x = b. */ + + dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[ + b_offset], ldb); + + return 0; + +/* End of DTRTRS */ + +} /* dtrtrs_ */ + +int dtrttf_(const char *transr, const char *uplo, integer *n, double *a, integer *lda, double *arf, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2; + bool normaltransr, lower, nisodd; + + +/* -- LAPACK routine (version 3.2) -- */ + +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRTTF copies a triangular matrix A from standard full format (TR) */ +/* to rectangular full packed format (TF) . */ + +/* Arguments */ +/* ========= */ + +/* TRANSR (input) CHARACTER */ +/* = 'N': ARF in Normal form is wanted; */ +/* = 'T': ARF in Transpose form is wanted. */ + +/* UPLO (input) CHARACTER */ +/* = 'U': Upper triangle of A is stored; */ +/* = 'L': Lower triangle of A is stored. */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N). */ +/* On entry, the triangular matrix A. If UPLO = 'U', the */ +/* leading N-by-N upper triangular part of the array A contains */ +/* the upper triangular matrix, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of the array A contains */ +/* the lower triangular matrix, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the matrix A. LDA >= max(1,N). */ + +/* ARF (output) DOUBLE PRECISION array, dimension (NT). */ +/* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Notes */ +/* ===== */ + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* even. We give an example where N = 6. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 05 00 */ +/* 11 12 13 14 15 10 11 */ +/* 22 23 24 25 20 21 22 */ +/* 33 34 35 30 31 32 33 */ +/* 44 45 40 41 42 43 44 */ +/* 55 50 51 52 53 54 55 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* the transpose of the first three columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* the transpose of the last three columns of AP lower. */ +/* This covers the case N even and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 03 04 05 33 43 53 */ +/* 13 14 15 00 44 54 */ +/* 23 24 25 10 11 55 */ +/* 33 34 35 20 21 22 */ +/* 00 44 45 30 31 32 */ +/* 01 11 55 40 41 42 */ +/* 02 12 22 50 51 52 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + + +/* RFP A RFP A */ + +/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ + + +/* We first consider Rectangular Full Packed (RFP) Format when N is */ +/* odd. We give an example where N = 5. */ + +/* AP is Upper AP is Lower */ + +/* 00 01 02 03 04 00 */ +/* 11 12 13 14 10 11 */ +/* 22 23 24 20 21 22 */ +/* 33 34 30 31 32 33 */ +/* 44 40 41 42 43 44 */ + + +/* Let TRANSR = 'N'. RFP holds AP as follows: */ +/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* the transpose of the first two columns of AP upper. */ +/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* the transpose of the last two columns of AP lower. */ +/* This covers the case N odd and TRANSR = 'N'. */ + +/* RFP A RFP A */ + +/* 02 03 04 00 33 43 */ +/* 12 13 14 10 11 44 */ +/* 22 23 24 20 21 22 */ +/* 00 33 34 30 31 32 */ +/* 01 11 44 40 41 42 */ + +/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* transpose of RFP A above. One therefore gets: */ + +/* RFP A RFP A */ + +/* 02 12 22 00 01 00 10 20 30 40 50 */ +/* 03 13 23 33 11 33 11 21 31 41 51 */ +/* 04 14 24 34 44 43 44 22 32 42 52 */ + +/* Reference */ +/* ========= */ + +/* ===================================================================== */ + +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda - 1 - 0 + 1; + a_offset = 0 + a_dim1 * 0; + a -= a_offset; + + /* Function Body */ + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < std::max(1_integer,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTTF", &i__1); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + if (*n == 1) { + arf[0] = a[0]; + } + return 0; + } + +/* Size of array ARF(0:nt-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER: for N even N1=N2=K */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ +/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ +/* N--by--(N+1)/2. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = false; + if (! lower) { + np1x2 = *n + *n + 2; + } + } else { + nisodd = true; + if (! lower) { + nx2 = *n + *n; + } + } + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = n2 + j; + for (i__ = n1; i__ <= i__2; ++i__) { + arf[ij] = a[n2 + j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n; + i__1 = n1; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = n1 - 1; + for (l = j - n1; l <= i__2; ++l) { + arf[ij] = a[j - n1 + l * a_dim1]; + ++ij; + } + ij -= nx2; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = n1 + j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + (n1 + j) * a_dim1]; + ++ij; + } + } + i__1 = *n - 1; + for (j = n2; j <= i__1; ++j) { + i__2 = n1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = n1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = n1; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (l = n2 + j; l <= i__2; ++l) { + arf[ij] = a[n2 + j + l * a_dim1]; + ++ij; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + for (i__ = k; i__ <= i__2; ++i__) { + arf[ij] = a[k + j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n - 1; + i__1 = k; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = k - 1; + for (l = j - k; l <= i__2; ++l) { + arf[ij] = a[j - k + l * a_dim1]; + ++ij; + } + ij -= np1x2; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + j = k; + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = k + 1 + j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + (k + 1 + j) * a_dim1]; + ++ij; + } + } + i__1 = *n - 1; + for (j = k - 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = k; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (l = k + 1 + j; l <= i__2; ++l) { + arf[ij] = a[k + 1 + j + l * a_dim1]; + ++ij; + } + } +/* Note that here, on exit of the loop, J = K-1 */ + i__1 = j; + for (i__ = 0; i__ <= i__1; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + + } + + } + + } + + return 0; + +/* End of DTRTTF */ + +} /* dtrttf_ */ + +int dtrttp_(const char *uplo, integer *n, double *a, integer *lda, double *ap, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k; + bool lower; + + +/* -- LAPACK routine (version 3.2) -- */ +/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ +/* -- and Julien Langou of the Univ. of Colorado Denver -- */ +/* -- November 2008 -- */ + +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTRTTP copies a triangular matrix A from full format (TR) to standard */ +/* packed format (TP). */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER */ +/* = 'U': A is upper triangular. */ +/* = 'L': A is lower triangular. */ + +/* N (input) INTEGER */ +/* The order of the matrices AP and A. N >= 0. */ + +/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On exit, the triangular matrix A. If UPLO = 'U', the leading */ +/* N-by-N upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading N-by-N lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,N). */ + +/* AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2 */ +/* On exit, the upper or lower triangular matrix A, packed */ +/* columnwise in a linear array. The j-th column of A is stored */ +/* in the array AP as follows: */ +/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ap; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lower && ! lsame_(uplo, "U")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < std::max(1_integer,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTTP", &i__1); + return 0; + } + + if (lower) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ++k; + ap[k] = a[i__ + j * a_dim1]; + } + } + } else { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++k; + ap[k] = a[i__ + j * a_dim1]; + } + } + } + + + return 0; + +/* End of DTRTTP */ + +} /* dtrttp_ */ + +/* Subroutine */ int dtzrqf_(integer *m, integer *n, double *a, integer *lda, double *tau, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static double c_b8 = 1.; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + double d__1; + + /* Local variables */ + integer i__, k, m1; + +/* -- LAPACK routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* This routine is deprecated and has been replaced by routine DTZRZF. */ + +/* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */ +/* to upper triangular form by means of orthogonal transformations. */ + +/* The upper trapezoidal matrix A is factored as */ + +/* A = ( R 0 ) * Z, */ + +/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ +/* triangular matrix. */ + +/* 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 >= M. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the leading M-by-N upper trapezoidal part of the */ +/* array A must contain the matrix to be factorized. */ +/* On exit, the leading M-by-M upper triangular part of A */ +/* contains the upper triangular matrix R, and elements M+1 to */ +/* N of the first M rows of A, with the array TAU, represent the */ +/* orthogonal matrix Z as a product of M elementary reflectors. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1,M). */ + +/* TAU (output) DOUBLE PRECISION array, dimension (M) */ +/* The scalar factors of the elementary reflectors. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Further Details */ +/* =============== */ + +/* The factorization is obtained by Householder's method. The kth */ +/* transformation matrix, Z( k ), which is used to introduce zeros into */ +/* the ( m - k + 1 )th row of A, is given in the form */ + +/* Z( k ) = ( I 0 ), */ +/* ( 0 T( k ) ) */ + +/* where */ + +/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */ +/* ( 0 ) */ +/* ( z( k ) ) */ + +/* tau is a scalar and z( k ) is an ( n - m ) element vector. */ +/* tau and z( k ) are chosen to annihilate the elements of the kth row */ +/* of X. */ + +/* The scalar tau is returned in the kth element of TAU and the vector */ +/* u( k ) in the kth row of A, such that the elements of z( k ) are */ +/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* the upper triangular part of A. */ + +/* Z is given by */ + +/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTZRQF", &i__1); + return 0; + } + +/* Perform the factorization. */ + + if (*m == 0) { + return 0; + } + if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.; +/* L10: */ + } + } else { +/* Computing MIN */ + i__1 = *m + 1; + m1 = std::min(i__1,*n); + for (k = *m; k >= 1; --k) { + +/* Use a Householder reflection to zero the kth row of A. */ +/* First set up the reflection. */ + + i__1 = *n - *m + 1; + dlarfp_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[ + k]); + + if (tau[k] != 0. && k > 1) { + +/* We now perform the operation A := A*P( k ). */ + +/* Use the first ( k - 1 ) elements of TAU to store a( k ), */ +/* where a( k ) consists of the first ( k - 1 ) elements of */ +/* the kth column of A. Also let B denote the first */ +/* ( k - 1 ) rows of the last ( n - m ) columns of A. */ + + i__1 = k - 1; + dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1); + +/* Form w = a( k ) + B*z( k ) in TAU. */ + + i__1 = k - 1; + i__2 = *n - *m; + dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 + + 1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], & + c__1); + +/* Now form a( k ) := a( k ) - tau*w */ +/* and B := B - tau*w*z( k )'. */ + + i__1 = k - 1; + d__1 = -tau[k]; + daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + i__1 = k - 1; + i__2 = *n - *m; + d__1 = -tau[k]; + dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1] +, lda, &a[m1 * a_dim1 + 1], lda); + } +/* L20: */ + } + } + + return 0; + +/* End of DTZRQF */ + +} /* dtzrqf_ */ + +/* Subroutine */ int dtzrzf_(integer *m, integer *n, double *a, integer * + lda, double *tau, double *work, integer *lwork, integer *info) +{ + /* Table of constant values */ + static integer c__1 = 1; + static integer c_n1 = -1; + static integer c__3 = 3; + static integer c__2 = 2; + + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, m1, ib, nb, ki, kk, mu, nx, iws, nbmin; + integer ldwork, lwkopt; + bool lquery; + + +/* -- LAPACK routine (version 3.1) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */ +/* to upper triangular form by means of orthogonal transformations. */ + +/* The upper trapezoidal matrix A is factored as */ + +/* A = ( R 0 ) * Z, */ + +/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ +/* triangular matrix. */ + +/* 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 >= M. */ + +/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ +/* On entry, the leading M-by-N upper trapezoidal part of the */ +/* array A must contain the matrix to be factorized. */ +/* On exit, the leading M-by-M upper triangular part of A */ +/* contains the upper triangular matrix R, and elements M+1 to */ +/* N of the first M rows of A, with the array TAU, represent the */ +/* orthogonal matrix Z as a product of M elementary reflectors. */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(1_integer,M). */ + +/* TAU (output) DOUBLE PRECISION array, dimension (M) */ +/* The scalar factors of the elementary reflectors. */ + +/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ + +/* LWORK (input) INTEGER */ +/* The dimension of the array WORK. LWORK >= max(1_integer,M). */ +/* For optimum performance LWORK >= M*NB, where NB is */ +/* the optimal blocksize. */ + +/* If LWORK = -1, then a workspace query is assumed; the routine */ +/* only calculates the optimal size of the WORK array, returns */ +/* this value as the first entry of the WORK array, and no error */ +/* message related to LWORK is issued by XERBLA. */ + +/* INFO (output) INTEGER */ +/* = 0: successful exit */ +/* < 0: if INFO = -i, the i-th argument had an illegal value */ + +/* Further Details */ +/* =============== */ + +/* Based on contributions by */ +/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* The factorization is obtained by Householder's method. The kth */ +/* transformation matrix, Z( k ), which is used to introduce zeros into */ +/* the ( m - k + 1 )th row of A, is given in the form */ + +/* Z( k ) = ( I 0 ), */ +/* ( 0 T( k ) ) */ + +/* where */ + +/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */ +/* ( 0 ) */ +/* ( z( k ) ) */ + +/* tau is a scalar and z( k ) is an ( n - m ) element vector. */ +/* tau and z( k ) are chosen to annihilate the elements of the kth row */ +/* of X. */ + +/* The scalar tau is returned in the kth element of TAU and the vector */ +/* u( k ) in the kth row of A, such that the elements of z( k ) are */ +/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* the upper triangular part of A. */ + +/* Z is given by */ + +/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Subroutines .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < std::max(1_integer,*m)) { + *info = -4; + } + + if (*info == 0) { + if (*m == 0 || *m == *n) { + lwkopt = 1; + } else { + +/* Determine the block size. */ + + nb = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1); + lwkopt = *m * nb; + } + work[1] = (double) lwkopt; + + if (*lwork < std::max(1_integer,*m) && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTZRZF", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0) { + return 0; + } else if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.; +/* L10: */ + } + return 0; + } + + nbmin = 2; + nx = 1; + iws = *m; + if (nb > 1 && nb < *m) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGERQF", " ", m, n, &c_n1, &c_n1); + nx = std::max(i__1,i__2); + if (nx < *m) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGERQF", " ", m, n, &c_n1, & + c_n1); + nbmin = std::max(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *m && nx < *m) { + +/* Use blocked code initially. */ +/* The last kk rows are handled by the block method. */ + +/* Computing MIN */ + i__1 = *m + 1; + m1 = std::min(i__1,*n); + ki = (*m - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = *m, i__2 = ki + nb; + kk = std::min(i__1,i__2); + + i__1 = *m - kk + 1; + i__2 = -nb; + for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; + i__ += i__2) { +/* Computing MIN */ + i__3 = *m - i__ + 1; + ib = std::min(i__3,nb); + +/* Compute the TZ factorization of the current block */ +/* A(i:i+ib-1,i:n) */ + + i__3 = *n - i__ + 1; + i__4 = *n - *m; + dlatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1]); + if (i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *n - *m; + dlarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(1:i-1,i:n) from the right */ + + i__3 = i__ - 1; + i__4 = *n - i__ + 1; + i__5 = *n - *m; + dlarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3, + &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1], + &ldwork) + ; + } +/* L20: */ + } + mu = i__ + nb - 1; + } else { + mu = *m; + } + +/* Use unblocked code to factor the last or only block */ + + if (mu > 0) { + i__2 = *n - *m; + dlatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]); + } + + work[1] = (double) lwkopt; + + return 0; + +/* End of DTZRZF */ + +} /* dtzrzf_ */ diff --git a/external/espeak/error.cpp b/external/espeak/error.cpp index 9e26ec4d..185b0f76 100644 --- a/external/espeak/error.cpp +++ b/external/espeak/error.cpp @@ -162,12 +162,12 @@ espeak_ng_PrintStatusCodeMessage(espeak_ng_STATUS status, break; case ERROR_CONTEXT_VERSION: //fprintf(out, "Error: %s at '%s' (expected 0x%x, got 0x%x).\n", error, context->name, context->expected_version, context->version); - Melder_throw (U"Error: ", Melder_peek8to32 (error), U" at \"", Melder_peek8to32 (context->name), U"\" (expected ", context->expected_version, U", got ", context->version); + Melder_throw (U"eSpeak error: ", Melder_peek8to32 (error), U" at \"", Melder_peek8to32 (context->name), U"\" (expected ", context->expected_version, U", got ", context->version); break; } } else //fprintf(out, "Error: %s.\n", error); - Melder_throw (U"Error: ", Melder_peek8to32 (error)); + Melder_throw (U"eSpeak error: ", Melder_peek8to32 (error)); } #pragma GCC visibility pop diff --git a/external/portaudio/Makefile b/external/portaudio/Makefile index cdd17627..f1b2bb59 100644 --- a/external/portaudio/Makefile +++ b/external/portaudio/Makefile @@ -1,5 +1,5 @@ # Makefile of the library "external/portaudio" -# Paul Boersma, 21 October 2018 +# Paul Boersma, 19 August 2020 include ../../makefile.defs @@ -8,7 +8,7 @@ OBJECTS = \ pa_win_hostapis.o pa_win_util.o pa_win_wmme.o pa_win_waveformat.o \ pa_front.o pa_debugprint.o pa_cpuload.o \ pa_allocation.o pa_process.o pa_converters.o pa_dither.o \ - pa_stream.o + pa_stream.o patest_record.o .PHONY: all clean diff --git a/external/portaudio/READ_ME.TXT b/external/portaudio/READ_ME.TXT index 5cf20d72..f461b8de 100644 --- a/external/portaudio/READ_ME.TXT +++ b/external/portaudio/READ_ME.TXT @@ -1,6 +1,6 @@ Praats/external/portaudio/READ_ME.TXT -Paul Boersma, 17 November 2018 -This file describes the adaptations to the PortAudio v19 sources (2014/01) +Paul Boersma, 13 August 2020 +This file describes the adaptations to the PortAudio v19.06 sources (2016/10) that are needed to make them compatible with Praat. Deleted many lines in pa_***_hostapis.c. @@ -9,8 +9,6 @@ Deleted many lines in pa_***_hostapis.c. Duplicate pa_unix_util.c to pa_mac_util.c, but only for allocation and time functions. -Remove the hard-coded definition of SIZEOF_LONG from pa_types.h and instead use to define PaInt32 and the like. - Around pa_linux_alsa.c, do #if defined (UNIX) && defined (ALSA) ... diff --git a/external/portaudio/pa_allocation.c b/external/portaudio/pa_allocation.c index c78c2cf7..51fe15ab 100644 --- a/external/portaudio/pa_allocation.c +++ b/external/portaudio/pa_allocation.c @@ -1,5 +1,5 @@ /* - * $Id: pa_allocation.c 1097 2006-08-26 08:27:53Z rossb $ + * $Id$ * Portable Audio I/O Library allocation group implementation * memory allocation group for tracking allocation groups * diff --git a/external/portaudio/pa_allocation.h b/external/portaudio/pa_allocation.h index 811dd72e..bd1f4b0f 100644 --- a/external/portaudio/pa_allocation.h +++ b/external/portaudio/pa_allocation.h @@ -1,7 +1,7 @@ #ifndef PA_ALLOCATION_H #define PA_ALLOCATION_H /* - * $Id: pa_allocation.h 1339 2008-02-15 07:50:33Z rossb $ + * $Id$ * Portable Audio I/O Library allocation context header * memory allocation context for tracking allocation groups * diff --git a/external/portaudio/pa_converters.c b/external/portaudio/pa_converters.c index ef65b68a..2107f5e2 100644 --- a/external/portaudio/pa_converters.c +++ b/external/portaudio/pa_converters.c @@ -1,5 +1,5 @@ /* - * $Id: pa_converters.c 1748 2011-09-01 22:08:32Z philburk $ + * $Id$ * Portable Audio I/O Library sample conversion mechanism * * Based on the Open Source API proposed by Ross Bencina diff --git a/external/portaudio/pa_converters.h b/external/portaudio/pa_converters.h index 7ddfcaa3..469f075d 100644 --- a/external/portaudio/pa_converters.h +++ b/external/portaudio/pa_converters.h @@ -1,7 +1,7 @@ #ifndef PA_CONVERTERS_H #define PA_CONVERTERS_H /* - * $Id: pa_converters.h 1097 2006-08-26 08:27:53Z rossb $ + * $Id$ * Portable Audio I/O Library sample conversion mechanism * * Based on the Open Source API proposed by Ross Bencina diff --git a/external/portaudio/pa_cpuload.c b/external/portaudio/pa_cpuload.c index 4465a50b..4adf21ad 100644 --- a/external/portaudio/pa_cpuload.c +++ b/external/portaudio/pa_cpuload.c @@ -1,5 +1,5 @@ /* - * $Id: pa_cpuload.c 1577 2011-02-01 13:03:45Z rossb $ + * $Id$ * Portable Audio I/O Library CPU Load measurement functions * Portable CPU load measurement facility. * diff --git a/external/portaudio/pa_cpuload.h b/external/portaudio/pa_cpuload.h index 4a594430..2a323aa7 100644 --- a/external/portaudio/pa_cpuload.h +++ b/external/portaudio/pa_cpuload.h @@ -1,7 +1,7 @@ #ifndef PA_CPULOAD_H #define PA_CPULOAD_H /* - * $Id: pa_cpuload.h 1097 2006-08-26 08:27:53Z rossb $ + * $Id$ * Portable Audio I/O Library CPU Load measurement functions * Portable CPU load measurement facility. * diff --git a/external/portaudio/pa_debugprint.c b/external/portaudio/pa_debugprint.c index 67e414ad..f34d4bbf 100644 --- a/external/portaudio/pa_debugprint.c +++ b/external/portaudio/pa_debugprint.c @@ -1,123 +1,123 @@ -/* - * $Id: pa_log.c $ - * Portable Audio I/O Library Multi-Host API front end - * Validate function parameters and manage multiple host APIs. - * - * Based on the Open Source API proposed by Ross Bencina - * Copyright (c) 1999-2006 Ross Bencina, Phil Burk - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files - * (the "Software"), to deal in the Software without restriction, - * including without limitation the rights to use, copy, modify, merge, - * publish, distribute, sublicense, and/or sell copies of the Software, - * and to permit persons to whom the Software is furnished to do so, - * subject to the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR - * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/* - * The text above constitutes the entire PortAudio license; however, - * the PortAudio community also makes the following non-binding requests: - * - * Any person wishing to distribute modifications to the Software is - * requested to send the modifications to the original developer so that - * they can be incorporated into the canonical version. It is also - * requested that these non-binding requests be included along with the - * license above. - */ - -/** @file - @ingroup common_src - - @brief Implements log function. - - PaUtil_SetLogPrintFunction can be user called to replace the provided - DefaultLogPrint function, which writes to stderr. - One can NOT pass var_args across compiler/dll boundaries as it is not - "byte code/abi portable". So the technique used here is to allocate a local - a static array, write in it, then callback the user with a pointer to its - start. -*/ - -#include -#include - -#include "pa_debugprint.h" - -// for OutputDebugStringA -#if defined(_MSC_VER) && defined(PA_ENABLE_MSVC_DEBUG_OUTPUT) - #define WIN32_LEAN_AND_MEAN // exclude rare headers - #include "windows.h" -#endif - -// User callback -static PaUtilLogCallback userCB = NULL; - -// Sets user callback -void PaUtil_SetDebugPrintFunction(PaUtilLogCallback cb) -{ - userCB = cb; -} - -/* - If your platform doesnt have vsnprintf, you are stuck with a - VERY dangerous alternative, vsprintf (with no n) -*/ -#if _MSC_VER - /* Some Windows Mobile SDKs don't define vsnprintf but all define _vsnprintf (hopefully). - According to MSDN "vsnprintf is identical to _vsnprintf". So we use _vsnprintf with MSC. - */ - #define VSNPRINTF _vsnprintf -#else - #define VSNPRINTF vsnprintf -#endif - -#define PA_LOG_BUF_SIZE 2048 - -void PaUtil_DebugPrint( const char *format, ... ) -{ - // Optional logging into Output console of Visual Studio -#if defined(_MSC_VER) && defined(PA_ENABLE_MSVC_DEBUG_OUTPUT) - { - char buf[PA_LOG_BUF_SIZE]; - va_list ap; - va_start(ap, format); - VSNPRINTF(buf, sizeof(buf), format, ap); - buf[sizeof(buf)-1] = 0; - OutputDebugStringA(buf); - va_end(ap); - } -#endif - - // Output to User-Callback - if (userCB != NULL) - { - char strdump[PA_LOG_BUF_SIZE]; - va_list ap; - va_start(ap, format); - VSNPRINTF(strdump, sizeof(strdump), format, ap); - strdump[sizeof(strdump)-1] = 0; - userCB(strdump); - va_end(ap); - } - else - // Standard output to stderr - { - va_list ap; - va_start(ap, format); - vfprintf(stderr, format, ap); - va_end(ap); - fflush(stderr); - } -} +/* + * $Id: pa_log.c $ + * Portable Audio I/O Library Multi-Host API front end + * Validate function parameters and manage multiple host APIs. + * + * Based on the Open Source API proposed by Ross Bencina + * Copyright (c) 1999-2006 Ross Bencina, Phil Burk + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files + * (the "Software"), to deal in the Software without restriction, + * including without limitation the rights to use, copy, modify, merge, + * publish, distribute, sublicense, and/or sell copies of the Software, + * and to permit persons to whom the Software is furnished to do so, + * subject to the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR + * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF + * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + */ + +/* + * The text above constitutes the entire PortAudio license; however, + * the PortAudio community also makes the following non-binding requests: + * + * Any person wishing to distribute modifications to the Software is + * requested to send the modifications to the original developer so that + * they can be incorporated into the canonical version. It is also + * requested that these non-binding requests be included along with the + * license above. + */ + +/** @file + @ingroup common_src + + @brief Implements log function. + + PaUtil_SetLogPrintFunction can be user called to replace the provided + DefaultLogPrint function, which writes to stderr. + One can NOT pass var_args across compiler/dll boundaries as it is not + "byte code/abi portable". So the technique used here is to allocate a local + a static array, write in it, then callback the user with a pointer to its + start. +*/ + +#include +#include + +#include "pa_debugprint.h" + +// for OutputDebugStringA +#if defined(_MSC_VER) && defined(PA_ENABLE_MSVC_DEBUG_OUTPUT) + #define WIN32_LEAN_AND_MEAN // exclude rare headers + #include "windows.h" +#endif + +// User callback +static PaUtilLogCallback userCB = NULL; + +// Sets user callback +void PaUtil_SetDebugPrintFunction(PaUtilLogCallback cb) +{ + userCB = cb; +} + +/* + If your platform doesnt have vsnprintf, you are stuck with a + VERY dangerous alternative, vsprintf (with no n) +*/ +#if _MSC_VER + /* Some Windows Mobile SDKs don't define vsnprintf but all define _vsnprintf (hopefully). + According to MSDN "vsnprintf is identical to _vsnprintf". So we use _vsnprintf with MSC. + */ + #define VSNPRINTF _vsnprintf +#else + #define VSNPRINTF vsnprintf +#endif + +#define PA_LOG_BUF_SIZE 2048 + +void PaUtil_DebugPrint( const char *format, ... ) +{ + // Optional logging into Output console of Visual Studio +#if defined(_MSC_VER) && defined(PA_ENABLE_MSVC_DEBUG_OUTPUT) + { + char buf[PA_LOG_BUF_SIZE]; + va_list ap; + va_start(ap, format); + VSNPRINTF(buf, sizeof(buf), format, ap); + buf[sizeof(buf)-1] = 0; + OutputDebugStringA(buf); + va_end(ap); + } +#endif + + // Output to User-Callback + if (userCB != NULL) + { + char strdump[PA_LOG_BUF_SIZE]; + va_list ap; + va_start(ap, format); + VSNPRINTF(strdump, sizeof(strdump), format, ap); + strdump[sizeof(strdump)-1] = 0; + userCB(strdump); + va_end(ap); + } + else + // Standard output to stderr + { + va_list ap; + va_start(ap, format); + vfprintf(stderr, format, ap); + va_end(ap); + fflush(stderr); + } +} diff --git a/external/portaudio/pa_debugprint.h b/external/portaudio/pa_debugprint.h index f333addb..5fba7667 100644 --- a/external/portaudio/pa_debugprint.h +++ b/external/portaudio/pa_debugprint.h @@ -1,149 +1,149 @@ -#ifndef PA_LOG_H -#define PA_LOG_H -/* - * Log file redirector function - * Copyright (c) 1999-2006 Ross Bencina, Phil Burk - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files - * (the "Software"), to deal in the Software without restriction, - * including without limitation the rights to use, copy, modify, merge, - * publish, distribute, sublicense, and/or sell copies of the Software, - * and to permit persons to whom the Software is furnished to do so, - * subject to the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR - * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/* - * The text above constitutes the entire PortAudio license; however, - * the PortAudio community also makes the following non-binding requests: - * - * Any person wishing to distribute modifications to the Software is - * requested to send the modifications to the original developer so that - * they can be incorporated into the canonical version. It is also - * requested that these non-binding requests be included along with the - * license above. - */ - -/** @file - @ingroup common_src -*/ - - -#ifdef __cplusplus -extern "C" -{ -#endif /* __cplusplus */ - - - -void PaUtil_DebugPrint( const char *format, ... ); - - -/* - The basic format for log messages is described below. If you need to - add any log messages, please follow this format. - - Function entry (void function): - - "FunctionName called.\n" - - Function entry (non void function): - - "FunctionName called:\n" - "\tParam1Type param1: param1Value\n" - "\tParam2Type param2: param2Value\n" (etc...) - - - Function exit (no return value): - - "FunctionName returned.\n" - - Function exit (simple return value): - - "FunctionName returned:\n" - "\tReturnType: returnValue\n" - - If the return type is an error code, the error text is displayed in () - - If the return type is not an error code, but has taken a special value - because an error occurred, then the reason for the error is shown in [] - - If the return type is a struct ptr, the struct is dumped. - - See the code below for examples -*/ - -/** PA_DEBUG() provides a simple debug message printing facility. The macro - passes it's argument to a printf-like function called PaUtil_DebugPrint() - which prints to stderr and always flushes the stream after printing. - Because preprocessor macros cannot directly accept variable length argument - lists, calls to the macro must include an additional set of parenthesis, eg: - PA_DEBUG(("errorno: %d", 1001 )); -*/ - - -#ifdef PA_ENABLE_DEBUG_OUTPUT -#define PA_DEBUG(x) PaUtil_DebugPrint x ; -#else -#define PA_DEBUG(x) -#endif - - -#ifdef PA_LOG_API_CALLS -#define PA_LOGAPI(x) PaUtil_DebugPrint x - -#define PA_LOGAPI_ENTER(functionName) PaUtil_DebugPrint( functionName " called.\n" ) - -#define PA_LOGAPI_ENTER_PARAMS(functionName) PaUtil_DebugPrint( functionName " called:\n" ) - -#define PA_LOGAPI_EXIT(functionName) PaUtil_DebugPrint( functionName " returned.\n" ) - -#define PA_LOGAPI_EXIT_PAERROR( functionName, result ) \ - PaUtil_DebugPrint( functionName " returned:\n" ); \ - PaUtil_DebugPrint("\tPaError: %d ( %s )\n", result, Pa_GetErrorText( result ) ) - -#define PA_LOGAPI_EXIT_T( functionName, resultFormatString, result ) \ - PaUtil_DebugPrint( functionName " returned:\n" ); \ - PaUtil_DebugPrint("\t" resultFormatString "\n", result ) - -#define PA_LOGAPI_EXIT_PAERROR_OR_T_RESULT( functionName, positiveResultFormatString, result ) \ - PaUtil_DebugPrint( functionName " returned:\n" ); \ - if( result > 0 ) \ - PaUtil_DebugPrint("\t" positiveResultFormatString "\n", result ); \ - else \ - PaUtil_DebugPrint("\tPaError: %d ( %s )\n", result, Pa_GetErrorText( result ) ) -#else -#define PA_LOGAPI(x) -#define PA_LOGAPI_ENTER(functionName) -#define PA_LOGAPI_ENTER_PARAMS(functionName) -#define PA_LOGAPI_EXIT(functionName) -#define PA_LOGAPI_EXIT_PAERROR( functionName, result ) -#define PA_LOGAPI_EXIT_T( functionName, resultFormatString, result ) -#define PA_LOGAPI_EXIT_PAERROR_OR_T_RESULT( functionName, positiveResultFormatString, result ) -#endif - - -typedef void (*PaUtilLogCallback ) (const char *log); - -/** - Install user provided log function -*/ -void PaUtil_SetDebugPrintFunction(PaUtilLogCallback cb); - - - -#ifdef __cplusplus -} -#endif /* __cplusplus */ -#endif /* PA_LOG_H */ +#ifndef PA_LOG_H +#define PA_LOG_H +/* + * Log file redirector function + * Copyright (c) 1999-2006 Ross Bencina, Phil Burk + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files + * (the "Software"), to deal in the Software without restriction, + * including without limitation the rights to use, copy, modify, merge, + * publish, distribute, sublicense, and/or sell copies of the Software, + * and to permit persons to whom the Software is furnished to do so, + * subject to the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR + * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF + * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + */ + +/* + * The text above constitutes the entire PortAudio license; however, + * the PortAudio community also makes the following non-binding requests: + * + * Any person wishing to distribute modifications to the Software is + * requested to send the modifications to the original developer so that + * they can be incorporated into the canonical version. It is also + * requested that these non-binding requests be included along with the + * license above. + */ + +/** @file + @ingroup common_src +*/ + + +#ifdef __cplusplus +extern "C" +{ +#endif /* __cplusplus */ + + + +void PaUtil_DebugPrint( const char *format, ... ); + + +/* + The basic format for log messages is described below. If you need to + add any log messages, please follow this format. + + Function entry (void function): + + "FunctionName called.\n" + + Function entry (non void function): + + "FunctionName called:\n" + "\tParam1Type param1: param1Value\n" + "\tParam2Type param2: param2Value\n" (etc...) + + + Function exit (no return value): + + "FunctionName returned.\n" + + Function exit (simple return value): + + "FunctionName returned:\n" + "\tReturnType: returnValue\n" + + If the return type is an error code, the error text is displayed in () + + If the return type is not an error code, but has taken a special value + because an error occurred, then the reason for the error is shown in [] + + If the return type is a struct ptr, the struct is dumped. + + See the code below for examples +*/ + +/** PA_DEBUG() provides a simple debug message printing facility. The macro + passes it's argument to a printf-like function called PaUtil_DebugPrint() + which prints to stderr and always flushes the stream after printing. + Because preprocessor macros cannot directly accept variable length argument + lists, calls to the macro must include an additional set of parenthesis, eg: + PA_DEBUG(("errorno: %d", 1001 )); +*/ + + +#ifdef PA_ENABLE_DEBUG_OUTPUT +#define PA_DEBUG(x) PaUtil_DebugPrint x ; +#else +#define PA_DEBUG(x) +#endif + + +#ifdef PA_LOG_API_CALLS +#define PA_LOGAPI(x) PaUtil_DebugPrint x + +#define PA_LOGAPI_ENTER(functionName) PaUtil_DebugPrint( functionName " called.\n" ) + +#define PA_LOGAPI_ENTER_PARAMS(functionName) PaUtil_DebugPrint( functionName " called:\n" ) + +#define PA_LOGAPI_EXIT(functionName) PaUtil_DebugPrint( functionName " returned.\n" ) + +#define PA_LOGAPI_EXIT_PAERROR( functionName, result ) \ + PaUtil_DebugPrint( functionName " returned:\n" ); \ + PaUtil_DebugPrint("\tPaError: %d ( %s )\n", result, Pa_GetErrorText( result ) ) + +#define PA_LOGAPI_EXIT_T( functionName, resultFormatString, result ) \ + PaUtil_DebugPrint( functionName " returned:\n" ); \ + PaUtil_DebugPrint("\t" resultFormatString "\n", result ) + +#define PA_LOGAPI_EXIT_PAERROR_OR_T_RESULT( functionName, positiveResultFormatString, result ) \ + PaUtil_DebugPrint( functionName " returned:\n" ); \ + if( result > 0 ) \ + PaUtil_DebugPrint("\t" positiveResultFormatString "\n", result ); \ + else \ + PaUtil_DebugPrint("\tPaError: %d ( %s )\n", result, Pa_GetErrorText( result ) ) +#else +#define PA_LOGAPI(x) +#define PA_LOGAPI_ENTER(functionName) +#define PA_LOGAPI_ENTER_PARAMS(functionName) +#define PA_LOGAPI_EXIT(functionName) +#define PA_LOGAPI_EXIT_PAERROR( functionName, result ) +#define PA_LOGAPI_EXIT_T( functionName, resultFormatString, result ) +#define PA_LOGAPI_EXIT_PAERROR_OR_T_RESULT( functionName, positiveResultFormatString, result ) +#endif + + +typedef void (*PaUtilLogCallback ) (const char *log); + +/** + Install user provided log function +*/ +void PaUtil_SetDebugPrintFunction(PaUtilLogCallback cb); + + + +#ifdef __cplusplus +} +#endif /* __cplusplus */ +#endif /* PA_LOG_H */ diff --git a/external/portaudio/pa_dither.c b/external/portaudio/pa_dither.c index 7a1b1312..140e480a 100644 --- a/external/portaudio/pa_dither.c +++ b/external/portaudio/pa_dither.c @@ -1,5 +1,5 @@ /* - * $Id: pa_dither.c 1418 2009-10-12 21:00:53Z philburk $ + * $Id$ * Portable Audio I/O Library triangular dither generator * * Based on the Open Source API proposed by Ross Bencina diff --git a/external/portaudio/pa_dither.h b/external/portaudio/pa_dither.h index a5131b27..12ffc4fc 100644 --- a/external/portaudio/pa_dither.h +++ b/external/portaudio/pa_dither.h @@ -1,7 +1,7 @@ #ifndef PA_DITHER_H #define PA_DITHER_H /* - * $Id: pa_dither.h 1418 2009-10-12 21:00:53Z philburk $ + * $Id$ * Portable Audio I/O Library triangular dither generator * * Based on the Open Source API proposed by Ross Bencina diff --git a/external/portaudio/pa_endianness.h b/external/portaudio/pa_endianness.h index 84e904ca..9e8e0596 100644 --- a/external/portaudio/pa_endianness.h +++ b/external/portaudio/pa_endianness.h @@ -1,7 +1,7 @@ #ifndef PA_ENDIANNESS_H #define PA_ENDIANNESS_H /* - * $Id: pa_endianness.h 1324 2008-01-27 02:03:30Z bjornroche $ + * $Id$ * Portable Audio I/O Library current platform endianness macros * * Based on the Open Source API proposed by Ross Bencina diff --git a/external/portaudio/pa_front.c b/external/portaudio/pa_front.c index 301ed39d..188cee9e 100644 --- a/external/portaudio/pa_front.c +++ b/external/portaudio/pa_front.c @@ -1,5 +1,5 @@ /* - * $Id: pa_front.c 1880 2012-12-04 18:39:48Z rbencina $ + * $Id$ * Portable Audio I/O Library Multi-Host API front end * Validate function parameters and manage multiple host APIs. * @@ -27,26 +27,26 @@ */ /* - * The text above constitutes the entire PortAudio license; however, + * The text above constitutes the entire PortAudio license; however, * the PortAudio community also makes the following non-binding requests: * * Any person wishing to distribute modifications to the Software is * requested to send the modifications to the original developer so that - * they can be incorporated into the canonical version. It is also - * requested that these non-binding requests be included along with the + * they can be incorporated into the canonical version. It is also + * requested that these non-binding requests be included along with the * license above. */ /** @file @ingroup common_src - @brief Implements PortAudio API functions defined in portaudio.h, checks + @brief Implements PortAudio API functions defined in portaudio.h, checks some errors, delegates platform-specific behavior to host API implementations. - - Implements the functions defined in the PortAudio API (portaudio.h), - validates some parameters and checks for state inconsistencies before - forwarding API requests to specific Host API implementations (via the - interface declared in pa_hostapi.h), and Streams (via the interface + + Implements the functions defined in the PortAudio API (portaudio.h), + validates some parameters and checks for state inconsistencies before + forwarding API requests to specific Host API implementations (via the + interface declared in pa_hostapi.h), and Streams (via the interface declared in pa_stream.h). This file manages initialization and termination of Host API @@ -65,6 +65,7 @@ #include #include #include +#include /* needed for strtol() */ #include /* needed by PA_VALIDATE_ENDIANNESS */ #include "portaudio.h" @@ -76,25 +77,63 @@ #include "pa_trace.h" /* still usefull?*/ #include "pa_debugprint.h" +#ifndef PA_GIT_REVISION +#include "pa_gitrevision.h" +#endif + +/** + * This is incremented if we make incompatible API changes. + * This version scheme is based loosely on http://semver.org/ + */ +#define paVersionMajor 19 + +/** + * This is incremented when we add functionality in a backwards-compatible manner. + * Or it is set to zero when paVersionMajor is incremented. + */ +#define paVersionMinor 6 -#define PA_VERSION_ 1899 -#define PA_VERSION_TEXT_ "PortAudio V19-devel (built " __DATE__ " " __TIME__ ")" +/** + * This is incremented when we make backwards-compatible bug fixes. + * Or it is set to zero when paVersionMinor changes. + */ +#define paVersionSubMinor 0 +/** + * This is a combination of paVersionMajor, paVersionMinor and paVersionSubMinor. + * It will always increase so that version numbers can be compared as integers to + * see which is later. + */ +#define paVersion paMakeVersionNumber(paVersionMajor, paVersionMinor, paVersionSubMinor) +#define STRINGIFY(x) #x +#define TOSTRING(x) STRINGIFY(x) +#define PA_VERSION_STRING_ TOSTRING(paVersionMajor) "." TOSTRING(paVersionMinor) "." TOSTRING(paVersionSubMinor) +#define PA_VERSION_TEXT_ "PortAudio V" PA_VERSION_STRING_ "-devel, revision " TOSTRING(PA_GIT_REVISION) int Pa_GetVersion( void ) { - return PA_VERSION_; + return paVersion; } - const char* Pa_GetVersionText( void ) { return PA_VERSION_TEXT_; } +static PaVersionInfo versionInfo_ = { + /*.versionMajor =*/ paVersionMajor, + /*.versionMinor =*/ paVersionMinor, + /*.versionSubMinor =*/ paVersionSubMinor, + /*.versionControlRevision =*/ TOSTRING(PA_GIT_REVISION), + /*.versionText =*/ PA_VERSION_TEXT_ +}; +const PaVersionInfo* Pa_GetVersionInfo() +{ + return &versionInfo_; +} #define PA_LAST_HOST_ERROR_TEXT_LENGTH_ 1024 @@ -170,7 +209,7 @@ static PaError InitializeHostApis( void ) if( !hostApis_ ) { result = paInsufficientMemory; - goto error; + goto error; } hostApisCount_ = 0; @@ -196,11 +235,11 @@ static PaError InitializeHostApis( void ) assert( hostApi->info.defaultInputDevice < hostApi->info.deviceCount ); assert( hostApi->info.defaultOutputDevice < hostApi->info.deviceCount ); - /* the first successfully initialized host API with a default input *or* + /* the first successfully initialized host API with a default input *or* output device is used as the default host API. */ if( (defaultHostApiIndex_ == -1) && - ( hostApi->info.defaultInputDevice != paNoDevice + ( hostApi->info.defaultInputDevice != paNoDevice || hostApi->info.defaultOutputDevice != paNoDevice ) ) { defaultHostApiIndex_ = hostApisCount_; @@ -238,7 +277,7 @@ static PaError InitializeHostApis( void ) belongs and returns it. if is non-null, the host specific device index is returned in it. returns -1 if is out of range. - + */ static int FindHostApi( PaDeviceIndex device, int *hostSpecificDeviceIndex ) { @@ -328,7 +367,7 @@ PaError Pa_Initialize( void ) { PA_VALIDATE_TYPE_SIZES; PA_VALIDATE_ENDIANNESS; - + PaUtil_InitializeClock(); PaUtil_ResetTraceMessages(); @@ -351,7 +390,8 @@ PaError Pa_Terminate( void ) if( PA_IS_INITIALISED_ ) { - if( --initializationCount_ == 0 ) + // leave initializationCount_>0 so that Pa_CloseStream() can execute + if( initializationCount_ == 1 ) { CloseOpenStreams(); @@ -359,6 +399,7 @@ PaError Pa_Terminate( void ) PaUtil_DumpTraceMessages(); } + --initializationCount_; result = paNoError; } else @@ -415,11 +456,11 @@ const char *Pa_GetErrorText( PaError errorCode ) case paCanNotWriteToAnInputOnlyStream: result = "Can't write to an input only stream"; break; case paIncompatibleStreamHostApi: result = "Incompatible stream host API"; break; case paBadBufferPtr: result = "Bad buffer pointer"; break; - default: + default: if( errorCode > 0 ) - result = "Invalid error code (value greater than zero)"; + result = "Invalid error code (value greater than zero)"; else - result = "Invalid error code"; + result = "Invalid error code"; break; } return result; @@ -430,7 +471,7 @@ PaHostApiIndex Pa_HostApiTypeIdToHostApiIndex( PaHostApiTypeId type ) { PaHostApiIndex result; int i; - + PA_LOGAPI_ENTER_PARAMS( "Pa_HostApiTypeIdToHostApiIndex" ); PA_LOGAPI(("\tPaHostApiTypeId type: %d\n", type )); @@ -441,14 +482,14 @@ PaHostApiIndex Pa_HostApiTypeIdToHostApiIndex( PaHostApiTypeId type ) else { result = paHostApiNotFound; - + for( i=0; i < hostApisCount_; ++i ) { if( hostApis_[i]->info.type == type ) { result = i; break; - } + } } } @@ -463,7 +504,7 @@ PaError PaUtil_GetHostApiRepresentation( struct PaUtilHostApiRepresentation **ho { PaError result; int i; - + if( !PA_IS_INITIALISED_ ) { result = paNotInitialized; @@ -471,7 +512,7 @@ PaError PaUtil_GetHostApiRepresentation( struct PaUtilHostApiRepresentation **ho else { result = paHostApiNotFound; - + for( i=0; i < hostApisCount_; ++i ) { if( hostApis_[i]->info.type == type ) @@ -492,7 +533,7 @@ PaError PaUtil_DeviceIndexToHostApiDeviceIndex( { PaError result; PaDeviceIndex x; - + x = device - hostApi->privatePaFrontInfo.baseDeviceIndex; if( x < 0 || x >= hostApi->info.deviceCount ) @@ -577,7 +618,7 @@ const PaHostApiInfo* Pa_GetHostApiInfo( PaHostApiIndex hostApi ) else if( hostApi < 0 || hostApi >= hostApisCount_ ) { info = NULL; - + PA_LOGAPI(("Pa_GetHostApiInfo returned:\n" )); PA_LOGAPI(("\tPaHostApiInfo*: NULL [ hostApi out of range ]\n" )); @@ -686,7 +727,7 @@ PaDeviceIndex Pa_GetDefaultOutputDevice( void ) { PaHostApiIndex hostApi; PaDeviceIndex result; - + PA_LOGAPI_ENTER( "Pa_GetDefaultOutputDevice" ); hostApi = Pa_GetDefaultHostApi(); @@ -770,7 +811,7 @@ static int SampleFormatIsValid( PaSampleFormat format ) ValidateOpenStreamParameters() checks that parameters to Pa_OpenStream() conform to the expected values as described below. This function is also designed to be used with the proposed Pa_IsFormatSupported() function. - + There are basically two types of validation that could be performed: Generic conformance validation, and device capability mismatch validation. This function performs only generic conformance validation. @@ -779,21 +820,21 @@ static int SampleFormatIsValid( PaSampleFormat format ) combinations of parameters - for example, even if the sampleRate seems ok, it might not be for a duplex stream - we have no way of checking this in an API-neutral way, so we don't try. - + On success the function returns PaNoError and fills in hostApi, hostApiInputDeviceID, and hostApiOutputDeviceID fields. On failure the function returns an error code indicating the first encountered parameter error. - - + + If ValidateOpenStreamParameters() returns paNoError, the following assertions are guaranteed to be true. - + - at least one of inputParameters & outputParmeters is valid (not NULL) - if inputParameters & outputParameters are both valid, that inputParameters->device & outputParameters->device both use the same host api - + PaDeviceIndex inputParameters->device - is within range (0 to Pa_GetDeviceCount-1) Or: - is paUseHostApiSpecificDeviceSpecification and @@ -803,30 +844,30 @@ static int SampleFormatIsValid( PaSampleFormat format ) int inputParameters->channelCount - if inputParameters->device is not paUseHostApiSpecificDeviceSpecification, channelCount is > 0 - upper bound is NOT validated against device capabilities - + PaSampleFormat inputParameters->sampleFormat - is one of the sample formats defined in portaudio.h void *inputParameters->hostApiSpecificStreamInfo - if supplied its hostApi field matches the input device's host Api - + PaDeviceIndex outputParmeters->device - is within range (0 to Pa_GetDeviceCount-1) - + int outputParmeters->channelCount - if inputDevice is valid, channelCount is > 0 - upper bound is NOT validated against device capabilities - + PaSampleFormat outputParmeters->sampleFormat - is one of the sample formats defined in portaudio.h - + void *outputParmeters->hostApiSpecificStreamInfo - if supplied its hostApi field matches the output device's host Api - + double sampleRate - is not an 'absurd' rate (less than 1000. or greater than 384000.) - sampleRate is NOT validated against device capabilities - + PaStreamFlags streamFlags - unused platform neutral flags are zero - paNeverDropInput is only used for full-duplex callback streams with @@ -953,7 +994,7 @@ static PaError ValidateOpenStreamParameters( != (*hostApi)->info.type ) return paIncompatibleHostApiSpecificStreamInfo; } - } + } if( (inputParameters != NULL) && (outputParameters != NULL) ) { @@ -962,8 +1003,8 @@ static PaError ValidateOpenStreamParameters( return paBadIODeviceCombination; } } - - + + /* Check for absurd sample rates. */ if( (sampleRate < 1000.0) || (sampleRate > 384000.0) ) return paInvalidSampleRate; @@ -985,7 +1026,7 @@ static PaError ValidateOpenStreamParameters( if( framesPerBuffer != paFramesPerBufferUnspecified ) return paInvalidFlag; } - + return paNoError; } @@ -1025,7 +1066,7 @@ PaError Pa_IsFormatSupported( const PaStreamParameters *inputParameters, PA_LOGAPI(("\tPaTime outputParameters->suggestedLatency: %f\n", outputParameters->suggestedLatency )); PA_LOGAPI(("\tvoid *outputParameters->hostApiSpecificStreamInfo: 0x%p\n", outputParameters->hostApiSpecificStreamInfo )); } - + PA_LOGAPI(("\tdouble sampleRate: %g\n", sampleRate )); #endif @@ -1048,7 +1089,7 @@ PaError Pa_IsFormatSupported( const PaStreamParameters *inputParameters, PA_LOGAPI_EXIT_PAERROR( "Pa_IsFormatSupported", result ); return result; } - + if( inputParameters ) { @@ -1135,7 +1176,7 @@ PaError Pa_OpenStream( PaStream** stream, PA_LOGAPI(("\tPaTime outputParameters->suggestedLatency: %f\n", outputParameters->suggestedLatency )); PA_LOGAPI(("\tvoid *outputParameters->hostApiSpecificStreamInfo: 0x%p\n", outputParameters->hostApiSpecificStreamInfo )); } - + PA_LOGAPI(("\tdouble sampleRate: %g\n", sampleRate )); PA_LOGAPI(("\tunsigned long framesPerBuffer: %d\n", framesPerBuffer )); PA_LOGAPI(("\tPaStreamFlags streamFlags: 0x%x\n", streamFlags )); @@ -1182,7 +1223,7 @@ PaError Pa_OpenStream( PaStream** stream, PA_LOGAPI(("\tPaError: %d ( %s )\n", result, Pa_GetErrorText( result ) )); return result; } - + if( inputParameters ) { @@ -1256,8 +1297,8 @@ PaError Pa_OpenDefaultStream( PaStream** stream, { hostApiInputParameters.device = Pa_GetDefaultInputDevice(); if( hostApiInputParameters.device == paNoDevice ) - return paDeviceUnavailable; - + return paDeviceUnavailable; + hostApiInputParameters.channelCount = inputChannelCount; hostApiInputParameters.sampleFormat = sampleFormat; /* defaultHighInputLatency is used below instead of @@ -1265,7 +1306,7 @@ PaError Pa_OpenDefaultStream( PaStream** stream, stream to work reliably than it is for it to work with the lowest latency. */ - hostApiInputParameters.suggestedLatency = + hostApiInputParameters.suggestedLatency = Pa_GetDeviceInfo( hostApiInputParameters.device )->defaultHighInputLatency; hostApiInputParameters.hostApiSpecificStreamInfo = NULL; hostApiInputParametersPtr = &hostApiInputParameters; @@ -1279,7 +1320,7 @@ PaError Pa_OpenDefaultStream( PaStream** stream, { hostApiOutputParameters.device = Pa_GetDefaultOutputDevice(); if( hostApiOutputParameters.device == paNoDevice ) - return paDeviceUnavailable; + return paDeviceUnavailable; hostApiOutputParameters.channelCount = outputChannelCount; hostApiOutputParameters.sampleFormat = sampleFormat; @@ -1323,6 +1364,7 @@ PaError PaUtil_ValidateStreamPointer( PaStream* stream ) return paNoError; } + PaError Pa_CloseStream( PaStream* stream ) { PaUtilStreamInterface *interface; @@ -1662,7 +1704,7 @@ PaError Pa_WriteStream( PaStream* stream, else if( result == 1 ) { result = paStreamIsStopped; - } + } } } diff --git a/external/portaudio/pa_gitrevision.h b/external/portaudio/pa_gitrevision.h new file mode 100644 index 00000000..2a6cfca8 --- /dev/null +++ b/external/portaudio/pa_gitrevision.h @@ -0,0 +1 @@ +#define PA_GIT_REVISION 396fe4b6699ae929d3a685b3ef8a7e97396139a4 diff --git a/external/portaudio/pa_hostapi.h b/external/portaudio/pa_hostapi.h index d38b8fe9..54b527ea 100644 --- a/external/portaudio/pa_hostapi.h +++ b/external/portaudio/pa_hostapi.h @@ -1,7 +1,7 @@ #ifndef PA_HOSTAPI_H #define PA_HOSTAPI_H /* - * $Id: pa_hostapi.h 1880 2012-12-04 18:39:48Z rbencina $ + * $Id$ * Portable Audio I/O Library * host api representation * diff --git a/external/portaudio/pa_mac_core.c b/external/portaudio/pa_mac_core.c index 7910552a..f8c542be 100644 --- a/external/portaudio/pa_mac_core.c +++ b/external/portaudio/pa_mac_core.c @@ -125,83 +125,78 @@ static bool ensureChannelNameSize( int size ) */ const char *PaMacCore_GetChannelName( int device, int channelIndex, bool input ) { - struct PaUtilHostApiRepresentation *hostApi; - PaError err; - OSStatus error; - err = PaUtil_GetHostApiRepresentation( &hostApi, paCoreAudio ); - assert(err == paNoError); - if( err != paNoError ) - return NULL; - PaMacAUHAL *macCoreHostApi = (PaMacAUHAL*)hostApi; - AudioDeviceID hostApiDevice = macCoreHostApi->devIds[device]; - - UInt32 size = 0; - - error = AudioDeviceGetPropertyInfo( hostApiDevice, - channelIndex + 1, - input, - kAudioDevicePropertyChannelName, - &size, - NULL ); - if( error ) { - //try the CFString - CFStringRef name; - bool isDeviceName = false; - size = sizeof( name ); - error = AudioDeviceGetProperty( hostApiDevice, - channelIndex + 1, - input, - kAudioDevicePropertyChannelNameCFString, - &size, - &name ); - if( error ) { //as a last-ditch effort, get the device name. Later we'll append the channel number. - size = sizeof( name ); - error = AudioDeviceGetProperty( hostApiDevice, - channelIndex + 1, - input, - kAudioDevicePropertyDeviceNameCFString, - &size, - &name ); - if( error ) - return NULL; - isDeviceName = true; - } - if( isDeviceName ) { - name = CFStringCreateWithFormat( NULL, NULL, CFSTR( "%@: %d"), name, channelIndex + 1 ); - } - - CFIndex length = CFStringGetLength(name); - while( ensureChannelNameSize( length * sizeof(UniChar) + 1 ) ) { - if( CFStringGetCString( name, channelName, channelNameSize, kCFStringEncodingUTF8 ) ) { - if( isDeviceName ) - CFRelease( name ); - return channelName; - } - if( length == 0 ) - ++length; - length *= 2; - } - if( isDeviceName ) - CFRelease( name ); - return NULL; - } - - //continue with C string: - if( !ensureChannelNameSize( size ) ) - return NULL; - - error = AudioDeviceGetProperty( hostApiDevice, - channelIndex + 1, - input, - kAudioDevicePropertyChannelName, - &size, - channelName ); - - if( error ) { - ERR( error ); - return NULL; - } - return channelName; + struct PaUtilHostApiRepresentation *hostApi; + PaError err; + OSStatus error; + err = PaUtil_GetHostApiRepresentation( &hostApi, paCoreAudio ); + assert(err == paNoError); + if( err != paNoError ) + return NULL; + PaMacAUHAL *macCoreHostApi = (PaMacAUHAL*)hostApi; + AudioDeviceID hostApiDevice = macCoreHostApi->devIds[device]; + CFStringRef nameRef; + + /* First try with CFString */ + UInt32 size = sizeof(nameRef); + error = AudioDeviceGetProperty( hostApiDevice, + channelIndex + 1, + input, + kAudioDevicePropertyChannelNameCFString, + &size, + &nameRef ); + if( error ) + { + /* try the C String */ + size = 0; + error = AudioDeviceGetPropertyInfo( hostApiDevice, + channelIndex + 1, + input, + kAudioDevicePropertyChannelName, + &size, + NULL); + if( !error ) + { + if( !ensureChannelNameSize( size ) ) + return NULL; + + error = AudioDeviceGetProperty( hostApiDevice, + channelIndex + 1, + input, + kAudioDevicePropertyChannelName, + &size, + channelName ); + + + if( !error ) + return channelName; + } + + /* as a last-ditch effort, we use the device name and append the channel number. */ + nameRef = CFStringCreateWithFormat( NULL, NULL, CFSTR( "%s: %d"), hostApi->deviceInfos[device]->name, channelIndex + 1 ); + + + size = CFStringGetMaximumSizeForEncoding(CFStringGetLength(nameRef), kCFStringEncodingUTF8);; + if( !ensureChannelNameSize( size ) ) + { + CFRelease( nameRef ); + return NULL; + } + CFStringGetCString( nameRef, channelName, size+1, kCFStringEncodingUTF8 ); + CFRelease( nameRef ); + } + else + { + size = CFStringGetMaximumSizeForEncoding(CFStringGetLength(nameRef), kCFStringEncodingUTF8);; + if( !ensureChannelNameSize( size ) ) + { + CFRelease( nameRef ); + return NULL; + } + CFStringGetCString( nameRef, channelName, size+1, kCFStringEncodingUTF8 ); + CFRelease( nameRef ); + } + + return channelName; } @@ -312,7 +307,7 @@ static PaError OpenAndSetupOneAudioUnit( /* for setting errors. */ #define PA_AUHAL_SET_LAST_HOST_ERROR( errorCode, errorText ) \ - PaUtil_SetLastHostErrorInfo( paInDevelopment, errorCode, errorText ) + PaUtil_SetLastHostErrorInfo( paCoreAudio, errorCode, errorText ) /* * Callback called when starting or stopping a stream. @@ -358,9 +353,19 @@ static PaError gatherDeviceInfo(PaMacAUHAL *auhalHostApi) auhalHostApi->devIds = NULL; /* -- figure out how many devices there are -- */ - AudioHardwareGetPropertyInfo( kAudioHardwarePropertyDevices, - &propsize, - NULL ); + //AudioHardwareGetPropertyInfo( kAudioHardwarePropertyDevices, + // &propsize, + // NULL ); // ppgb 20200814: can lead to warning: [plugin] AddInstanceForFactory: No factory registered for id F8BB1C28-BAE8-11D6-9C31-00039315CD46 + if (true) {// this block ppgb 20200814 + //fprintf(stderr,"gatherDeviceInfo 1 %d\n",propsize); + AudioObjectPropertyAddress audioObjectPropertyAddress; + audioObjectPropertyAddress. mSelector = kAudioHardwarePropertyDevices; + audioObjectPropertyAddress. mScope = kAudioObjectPropertyScopeGlobal; + audioObjectPropertyAddress. mElement = 0; + AudioObjectGetPropertyDataSize( kAudioObjectSystemObject, & audioObjectPropertyAddress, 0, NULL, & propsize ); // ppgb 20200814 + // ppgb 20200814: can lead to warning: [plugin] AddInstanceForFactory: No factory registered for id ... + //fprintf(stderr,"gatherDeviceInfo 2 %d\n",propsize); + } auhalHostApi->devCount = propsize / sizeof( AudioDeviceID ); VDBUG( ( "Found %ld device(s).\n", auhalHostApi->devCount ) ); @@ -374,7 +379,7 @@ static PaError gatherDeviceInfo(PaMacAUHAL *auhalHostApi) AudioHardwareGetProperty( kAudioHardwarePropertyDevices, &propsize, auhalHostApi->devIds ); -#ifdef MAC_CORE_VERBOSE_DEBUG +#if defined (MAC_CORE_VERBOSE_DEBUG) { int i; for( i=0; idevCount; ++i ) @@ -657,6 +662,7 @@ static PaError InitializeDeviceInfo( PaMacAUHAL *auhalHostApi, Float64 sampleRate; char *name; PaError err = paNoError; + CFStringRef nameRef; UInt32 propSize; VVDBUG(("InitializeDeviceInfo(): macCoreDeviceId=%ld\n", macCoreDeviceId)); @@ -665,18 +671,37 @@ static PaError InitializeDeviceInfo( PaMacAUHAL *auhalHostApi, deviceInfo->structVersion = 2; deviceInfo->hostApi = hostApiIndex; - - /* Get the device name. Fail if we can't get it. */ - err = ERR(AudioDeviceGetPropertyInfo(macCoreDeviceId, 0, 0, kAudioDevicePropertyDeviceName, &propSize, NULL)); - if (err) - return err; - - name = PaUtil_GroupAllocateMemory(auhalHostApi->allocations,propSize); - if ( !name ) - return paInsufficientMemory; - err = ERR(AudioDeviceGetProperty(macCoreDeviceId, 0, 0, kAudioDevicePropertyDeviceName, &propSize, name)); + + /* Get the device name using CFString */ + propSize = sizeof(nameRef); + err = ERR(AudioDeviceGetProperty(macCoreDeviceId, 0, 0, kAudioDevicePropertyDeviceNameCFString, &propSize, &nameRef)); if (err) - return err; + { + /* Get the device name using c string. Fail if we can't get it. */ + err = ERR(AudioDeviceGetPropertyInfo(macCoreDeviceId, 0, 0, kAudioDevicePropertyDeviceName, &propSize, NULL)); + if (err) + return err; + + name = PaUtil_GroupAllocateMemory(auhalHostApi->allocations,propSize+1); + if ( !name ) + return paInsufficientMemory; + err = ERR(AudioDeviceGetProperty(macCoreDeviceId, 0, 0, kAudioDevicePropertyDeviceName, &propSize, name)); + if (err) + return err; + } + else + { + /* valid CFString so we just allocate a c string big enough to contain the data */ + propSize = CFStringGetMaximumSizeForEncoding(CFStringGetLength(nameRef), kCFStringEncodingUTF8); + name = PaUtil_GroupAllocateMemory(auhalHostApi->allocations, propSize+1); + if ( !name ) + { + CFRelease(nameRef); + return paInsufficientMemory; + } + CFStringGetCString(nameRef, name, propSize+1, kCFStringEncodingUTF8); + CFRelease(nameRef); + } deviceInfo->name = name; /* Try to get the default sample rate. Don't fail if we can't get this. */ @@ -720,11 +745,12 @@ PaError PaMacCore_Initialize( PaUtilHostApiRepresentation **hostApi, PaHostApiIn CFRunLoopRef theRunLoop = NULL; AudioObjectPropertyAddress theAddress = { kAudioHardwarePropertyRunLoop, kAudioObjectPropertyScopeGlobal, kAudioObjectPropertyElementMaster }; OSStatus osErr = AudioObjectSetPropertyData (kAudioObjectSystemObject, &theAddress, 0, NULL, sizeof(CFRunLoopRef), &theRunLoop); + // ppgb 20200814: can lead to warning: [plugin] AddInstanceForFactory: No factory registered for id F8BB1C28-BAE8-11D6-9C31-00039315CD46 if (osErr != noErr) { goto error; } } - + unixErr = initializeXRunListenerList(); if( 0 != unixErr ) { return UNIX_ERR(unixErr); @@ -1906,14 +1932,13 @@ static PaError OpenStream( struct PaUtilHostApiRepresentation *hostApi, /* * If input and output devs are different or we are doing SR conversion, - * we also need a - * ring buffer to store inpt data while waiting for output - * data. + * we also need a ring buffer to store input data while waiting for + * output data. */ if( (stream->outputUnit && (stream->inputUnit != stream->outputUnit)) || stream->inputSRConverter ) { - /* May want the ringSize ot initial position in + /* May want the ringSize or initial position in ring buffer to depend somewhat on sample rate change */ void *data; @@ -1936,7 +1961,15 @@ static PaError OpenStream( struct PaUtilHostApiRepresentation *hostApi, } /* now we can initialize the ring buffer */ - PaUtil_InitializeRingBuffer( &stream->inputRingBuffer, szfl*inputParameters->channelCount, ringSize, data ) ; + result = PaUtil_InitializeRingBuffer( &stream->inputRingBuffer, szfl*inputParameters->channelCount, ringSize, data ); + if( result != 0 ) + { + /* The only reason this should fail is if ringSize is not a power of 2, which we do not anticipate happening. */ + result = paUnanticipatedHostError; + free(data); + goto error; + } + /* advance the read point a little, so we are reading from the middle of the buffer */ if( stream->outputUnit ) @@ -1958,12 +1991,11 @@ static PaError OpenStream( struct PaUtilHostApiRepresentation *hostApi, stream->outputFramesPerBuffer, sampleRate ); result = initializeBlioRingBuffers( &stream->blio, - inputParameters?inputParameters->sampleFormat:0 , - outputParameters?outputParameters->sampleFormat:0 , - MAX(stream->inputFramesPerBuffer,stream->outputFramesPerBuffer), + inputParameters ? inputParameters->sampleFormat : 0, + outputParameters ? outputParameters->sampleFormat : 0, ringSize, - inputParameters?inputChannelCount:0 , - outputParameters?outputChannelCount:0 ) ; + inputParameters ? inputChannelCount : 0, + outputParameters ? outputChannelCount : 0 ) ; if( result != paNoError ) goto error; @@ -2248,7 +2280,7 @@ static OSStatus AudioIOProc( void *inRefCon, PaUtil_BeginBufferProcessing( &(stream->bufferProcessor), &timeInfo, stream->xrunFlags ); - stream->xrunFlags = 0; //FIXME: this flag also gets set outside by a callback, which calls the xrunCallback function. It should be in the same thread as the main audio callback, but the apple docs just use the word "usually" so it may be possible to lose an xrun notification, if that callback happens here. + stream->xrunFlags = 0; //FIXME: this flag also gets set outside by a callback, which calls the xrunCallback function. It should be in the same thread as the main audio callback, but the apple docs just use the word "usually" so it may be possible to loose an xrun notification, if that callback happens here. /* -- compute frames. do some checks -- */ assert( ioData->mNumberBuffers == 1 ); @@ -2262,9 +2294,10 @@ static OSStatus AudioIOProc( void *inRefCon, INPUT_ELEMENT, inNumberFrames, &stream->inputAudioBufferList ); - /* FEEDBACK: I'm not sure what to do when this call fails. There's nothing in the PA API to - * do about failures in the callback system. */ - assert( !err ); + if(err != noErr) + { + goto stop_stream; + } PaUtil_SetInputFrameCount( &(stream->bufferProcessor), frames ); PaUtil_SetInterleavedInputChannels( &(stream->bufferProcessor), @@ -2344,7 +2377,7 @@ static OSStatus AudioIOProc( void *inRefCon, &size, (void *)&data ); if( err == RING_BUFFER_EMPTY ) - { /*the ring buffer callback underflowed */ + { /* the ring buffer callback underflowed */ err = 0; bzero( ((char *)data) + size, sizeof(data)-size ); /* The ring buffer can underflow normally when the stream is stopping. @@ -2355,8 +2388,11 @@ static OSStatus AudioIOProc( void *inRefCon, } } ERR( err ); - assert( !err ); - + if(err != noErr) + { + goto stop_stream; + } + PaUtil_SetInputFrameCount( &(stream->bufferProcessor), frames ); PaUtil_SetInterleavedInputChannels( &(stream->bufferProcessor), 0, @@ -2452,6 +2488,7 @@ static OSStatus AudioIOProc( void *inRefCon, OSStatus err = 0; int chan = stream->inputAudioBufferList.mBuffers[0].mNumberChannels ; /* FIXME: looping here may not actually be necessary, but it was something I tried in testing. */ +//fprintf(stderr,"before AudioUnitRender: %d %d %d %d\n", chan, stream->inputAudioBufferList.mNumberBuffers, stream->inputAudioBufferList.mBuffers[0].mDataByteSize, inNumberFrames); do { err= AudioUnitRender(stream->inputUnit, ioActionFlags, @@ -2459,12 +2496,16 @@ static OSStatus AudioIOProc( void *inRefCon, INPUT_ELEMENT, inNumberFrames, &stream->inputAudioBufferList ); +//fprintf(stderr,"after AudioUnitRender: %d %d\n", inNumberFrames, err); if( err == -10874 ) inNumberFrames /= 2; } while( err == -10874 && inNumberFrames > 1 ); - /* FEEDBACK: I'm not sure what to do when this call fails */ ERR( err ); - assert( !err ); + if(err != noErr) + { + goto stop_stream; + } + if( stream->inputSRConverter || stream->outputUnit ) { /* If this is duplex or we use a converter, put the data @@ -2481,9 +2522,11 @@ static OSStatus AudioIOProc( void *inRefCon, { /* for simplex input w/o SR conversion, just pop the data into the buffer processor.*/ + //fprintf(stderr,"before PaUtil_BeginBufferProcessing\n"); PaUtil_BeginBufferProcessing( &(stream->bufferProcessor), &timeInfo, stream->xrunFlags ); + //fprintf(stderr,"after PaUtil_BeginBufferProcessing\n"); stream->xrunFlags = 0; PaUtil_SetInputFrameCount( &(stream->bufferProcessor), inNumberFrames); @@ -2491,9 +2534,11 @@ static OSStatus AudioIOProc( void *inRefCon, 0, stream->inputAudioBufferList.mBuffers[0].mData, chan ); + //fprintf(stderr,"before PaUtil_EndBufferProcessing: %f\n", ((float *) stream->inputAudioBufferList.mBuffers[0].mData) [0]); framesProcessed = PaUtil_EndBufferProcessing( &(stream->bufferProcessor), &callbackResult ); + //fprintf(stderr,"after PaUtil_EndBufferProcessing: %f\n", ((float *) stream->inputAudioBufferList.mBuffers[0].mData) [0]); } if( !stream->outputUnit && stream->inputSRConverter ) { @@ -2507,11 +2552,11 @@ static OSStatus AudioIOProc( void *inRefCon, * chunks, and let the BufferProcessor deal with the rest. * */ - /*This might be too big or small depending on SR conversion*/ + /* This might be too big or small depending on SR conversion. */ float data[ chan * inNumberFrames ]; OSStatus err; do - { /*Run the buffer processor until we are out of data*/ + { /* Run the buffer processor until we are out of data. */ UInt32 size; long f; @@ -2524,7 +2569,11 @@ static OSStatus AudioIOProc( void *inRefCon, (void *)data ); if( err != RING_BUFFER_EMPTY ) ERR( err ); - assert( err == 0 || err == RING_BUFFER_EMPTY ); + if( err != noErr && err != RING_BUFFER_EMPTY ) + { + goto stop_stream; + } + f = size / ( chan * sizeof(float) ); PaUtil_SetInputFrameCount( &(stream->bufferProcessor), f ); @@ -2547,23 +2596,23 @@ static OSStatus AudioIOProc( void *inRefCon, } } - switch( callbackResult ) - { - case paContinue: break; - case paComplete: - case paAbort: - stream->state = CALLBACK_STOPPED ; - if( stream->outputUnit ) - AudioOutputUnitStop(stream->outputUnit); - if( stream->inputUnit ) - AudioOutputUnitStop(stream->inputUnit); - break; - } + // Should we return successfully or fall through to stopping the stream? + if( callbackResult == paContinue ) + { + PaUtil_EndCpuLoadMeasurement( &stream->cpuLoadMeasurer, framesProcessed ); + return noErr; + } - PaUtil_EndCpuLoadMeasurement( &stream->cpuLoadMeasurer, framesProcessed ); - return noErr; -} +stop_stream: + stream->state = CALLBACK_STOPPED ; + if( stream->outputUnit ) + AudioOutputUnitStop(stream->outputUnit); + if( stream->inputUnit ) + AudioOutputUnitStop(stream->inputUnit); + PaUtil_EndCpuLoadMeasurement( &stream->cpuLoadMeasurer, framesProcessed ); + return noErr; +} /* When CloseStream() is called, the multi-api layer ensures that @@ -2692,18 +2741,10 @@ static ComponentResult BlockWhileAudioUnitIsRunning( AudioUnit audioUnit, AudioU return noErr; } -static PaError StopStream( PaStream *s ) +static PaError FinishStoppingStream( PaMacCoreStream *stream ) { - PaMacCoreStream *stream = (PaMacCoreStream*)s; OSStatus result = noErr; PaError paErr; - VVDBUG(("StopStream()\n")); - - VDBUG( ("Waiting for BLIO.\n") ); - waitUntilBlioWriteBufferIsFlushed( &stream->blio ); - VDBUG( ( "Stopping stream.\n" ) ); - - stream->state = STOPPING; #define ERR_WRAP(mac_err) do { result = mac_err ; if ( result != noErr ) return ERR(result) ; } while(0) /* -- stop and reset -- */ @@ -2755,12 +2796,34 @@ static PaError StopStream( PaStream *s ) #undef ERR_WRAP } +/* Block until buffer is empty then stop the stream. */ +static PaError StopStream( PaStream *s ) +{ + PaError paErr; + PaMacCoreStream *stream = (PaMacCoreStream*)s; + VVDBUG(("StopStream()\n")); + + /* Tell WriteStream to stop filling the buffer. */ + stream->state = STOPPING; + + if( stream->userOutChan > 0 ) /* Does this stream do output? */ + { + size_t maxHostFrames = MAX( stream->inputFramesPerBuffer, stream->outputFramesPerBuffer ); + VDBUG( ("Waiting for write buffer to be drained.\n") ); + paErr = waitUntilBlioWriteBufferIsEmpty( &stream->blio, stream->sampleRate, + maxHostFrames ); + VDBUG( ( "waitUntilBlioWriteBufferIsEmpty returned %d\n", paErr ) ); + } + return FinishStoppingStream( stream ); +} + +/* Immediately stop the stream. */ static PaError AbortStream( PaStream *s ) { - VVDBUG(("AbortStream()->StopStream()\n")); - VDBUG( ( "Aborting stream.\n" ) ); - /* We have nothing faster than StopStream. */ - return StopStream(s); + PaMacCoreStream *stream = (PaMacCoreStream*)s; + VDBUG( ( "AbortStream()\n" ) ); + stream->state = STOPPING; + return FinishStoppingStream( stream ); } diff --git a/external/portaudio/pa_mac_core_blocking.c b/external/portaudio/pa_mac_core_blocking.c index 606a5695..679c6ba0 100644 --- a/external/portaudio/pa_mac_core_blocking.c +++ b/external/portaudio/pa_mac_core_blocking.c @@ -1,593 +1,637 @@ -/* - * Implementation of the PortAudio API for Apple AUHAL - * - * PortAudio Portable Real-Time Audio Library - * Latest Version at: http://www.portaudio.com - * - * Written by Bjorn Roche of XO Audio LLC, from PA skeleton code. - * Portions copied from code by Dominic Mazzoni (who wrote a HAL implementation) - * - * Dominic's code was based on code by Phil Burk, Darren Gibbs, - * Gord Peters, Stephane Letz, and Greg Pfiel. - * - * The following people also deserve acknowledgements: - * - * Olivier Tristan for feedback and testing - * Glenn Zelniker and Z-Systems engineering for sponsoring the Blocking I/O - * interface. - * - * - * Based on the Open Source API proposed by Ross Bencina - * Copyright (c) 1999-2002 Ross Bencina, Phil Burk - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files - * (the "Software"), to deal in the Software without restriction, - * including without limitation the rights to use, copy, modify, merge, - * publish, distribute, sublicense, and/or sell copies of the Software, - * and to permit persons to whom the Software is furnished to do so, - * subject to the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR - * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/* - * The text above constitutes the entire PortAudio license; however, - * the PortAudio community also makes the following non-binding requests: - * - * Any person wishing to distribute modifications to the Software is - * requested to send the modifications to the original developer so that - * they can be incorporated into the canonical version. It is also - * requested that these non-binding requests be included along with the - * license above. - */ - -/** - @file - @ingroup hostapi_src - - This file contains the implementation - required for blocking I/O. It is separated from pa_mac_core.c simply to ease - development. -*/ - -#include "pa_mac_core_blocking.h" -#include "pa_mac_core_internal.h" -#include -#ifdef MOSX_USE_NON_ATOMIC_FLAG_BITS -# define OSAtomicOr32( a, b ) ( (*(b)) |= (a) ) -# define OSAtomicAnd32( a, b ) ( (*(b)) &= (a) ) -#else -# include -#endif - -/* - * This function determines the size of a particular sample format. - * if the format is not recognized, this returns zero. - */ -static size_t computeSampleSizeFromFormat( PaSampleFormat format ) -{ - switch( format & (~paNonInterleaved) ) { - case paFloat32: return 4; - case paInt32: return 4; - case paInt24: return 3; - case paInt16: return 2; - case paInt8: case paUInt8: return 1; - default: return 0; - } -} -/* - * Same as computeSampleSizeFromFormat, except that if - * the size is not a power of two, it returns the next power of two up - */ -static size_t computeSampleSizeFromFormatPow2( PaSampleFormat format ) -{ - switch( format & (~paNonInterleaved) ) { - case paFloat32: return 4; - case paInt32: return 4; - case paInt24: return 4; - case paInt16: return 2; - case paInt8: case paUInt8: return 1; - default: return 0; - } -} - - - -/* - * Functions for initializing, resetting, and destroying BLIO structures. - * - */ - -/* This should be called with the relevant info when initializing a stream for - callback. */ -PaError initializeBlioRingBuffers( - PaMacBlio *blio, - PaSampleFormat inputSampleFormat, - PaSampleFormat outputSampleFormat, - size_t framesPerBuffer, - long ringBufferSize, - int inChan, - int outChan ) -{ - void *data; - int result; - OSStatus err; - - /* zeroify things */ - bzero( blio, sizeof( PaMacBlio ) ); - /* this is redundant, but the buffers are used to check - if the bufffers have been initialized, so we do it explicitly. */ - blio->inputRingBuffer.buffer = NULL; - blio->outputRingBuffer.buffer = NULL; - - /* initialize simple data */ - blio->ringBufferFrames = ringBufferSize; - blio->inputSampleFormat = inputSampleFormat; - blio->inputSampleSizeActual = computeSampleSizeFromFormat(inputSampleFormat); - blio->inputSampleSizePow2 = computeSampleSizeFromFormatPow2(inputSampleFormat); - blio->outputSampleFormat = outputSampleFormat; - blio->outputSampleSizeActual = computeSampleSizeFromFormat(outputSampleFormat); - blio->outputSampleSizePow2 = computeSampleSizeFromFormatPow2(outputSampleFormat); - - blio->framesPerBuffer = framesPerBuffer; - blio->inChan = inChan; - blio->outChan = outChan; - blio->statusFlags = 0; - blio->errors = paNoError; -#ifdef PA_MAC_BLIO_MUTEX - blio->isInputEmpty = false; - blio->isOutputFull = false; -#endif - - /* setup ring buffers */ -#ifdef PA_MAC_BLIO_MUTEX - result = PaMacCore_SetUnixError( pthread_mutex_init(&(blio->inputMutex),NULL), 0 ); - if( result ) - goto error; - result = UNIX_ERR( pthread_cond_init( &(blio->inputCond), NULL ) ); - if( result ) - goto error; - result = UNIX_ERR( pthread_mutex_init(&(blio->outputMutex),NULL) ); - if( result ) - goto error; - result = UNIX_ERR( pthread_cond_init( &(blio->outputCond), NULL ) ); -#endif - if( inChan ) { - data = calloc( ringBufferSize, blio->inputSampleSizePow2*inChan ); - if( !data ) - { - result = paInsufficientMemory; - goto error; - } - - err = PaUtil_InitializeRingBuffer( - &blio->inputRingBuffer, - 1, ringBufferSize*blio->inputSampleSizePow2*inChan, - data ); - assert( !err ); - } - if( outChan ) { - data = calloc( ringBufferSize, blio->outputSampleSizePow2*outChan ); - if( !data ) - { - result = paInsufficientMemory; - goto error; - } - - err = PaUtil_InitializeRingBuffer( - &blio->outputRingBuffer, - 1, ringBufferSize*blio->outputSampleSizePow2*outChan, - data ); - assert( !err ); - } - - result = resetBlioRingBuffers( blio ); - if( result ) - goto error; - - return 0; - - error: - destroyBlioRingBuffers( blio ); - return result; -} - -#ifdef PA_MAC_BLIO_MUTEX -PaError blioSetIsInputEmpty( PaMacBlio *blio, bool isEmpty ) -{ - PaError result = paNoError; - if( isEmpty == blio->isInputEmpty ) - goto done; - - /* we need to update the value. Here's what we do: - * - Lock the mutex, so noone else can write. - * - update the value. - * - unlock. - * - broadcast to all listeners. - */ - result = UNIX_ERR( pthread_mutex_lock( &blio->inputMutex ) ); - if( result ) - goto done; - blio->isInputEmpty = isEmpty; - result = UNIX_ERR( pthread_mutex_unlock( &blio->inputMutex ) ); - if( result ) - goto done; - result = UNIX_ERR( pthread_cond_broadcast( &blio->inputCond ) ); - if( result ) - goto done; - - done: - return result; -} -PaError blioSetIsOutputFull( PaMacBlio *blio, bool isFull ) -{ - PaError result = paNoError; - if( isFull == blio->isOutputFull ) - goto done; - - /* we need to update the value. Here's what we do: - * - Lock the mutex, so noone else can write. - * - update the value. - * - unlock. - * - broadcast to all listeners. - */ - result = UNIX_ERR( pthread_mutex_lock( &blio->outputMutex ) ); - if( result ) - goto done; - blio->isOutputFull = isFull; - result = UNIX_ERR( pthread_mutex_unlock( &blio->outputMutex ) ); - if( result ) - goto done; - result = UNIX_ERR( pthread_cond_broadcast( &blio->outputCond ) ); - if( result ) - goto done; - - done: - return result; -} -#endif - -/* This should be called after stopping or aborting the stream, so that on next - start, the buffers will be ready. */ -PaError resetBlioRingBuffers( PaMacBlio *blio ) -{ -#ifdef PA_MAC__BLIO_MUTEX - int result; -#endif - blio->statusFlags = 0; - if( blio->outputRingBuffer.buffer ) { - PaUtil_FlushRingBuffer( &blio->outputRingBuffer ); - bzero( blio->outputRingBuffer.buffer, - blio->outputRingBuffer.bufferSize ); - /* Advance buffer */ - PaUtil_AdvanceRingBufferWriteIndex( &blio->outputRingBuffer, blio->ringBufferFrames*blio->outputSampleSizeActual*blio->outChan ); - //PaUtil_AdvanceRingBufferWriteIndex( &blio->outputRingBuffer, blio->outputRingBuffer.bufferSize ); - - /* Update isOutputFull. */ -#ifdef PA_MAC__BLIO_MUTEX - result = blioSetIsOutputFull( blio, toAdvance == blio->outputRingBuffer.bufferSize ); - if( result ) - goto error; -#endif -/* - printf( "------%d\n" , blio->framesPerBuffer ); - printf( "------%d\n" , blio->outChan ); - printf( "------%d\n" , blio->outputSampleSize ); - printf( "------%d\n" , blio->framesPerBuffer*blio->outChan*blio->outputSampleSize ); -*/ - } - if( blio->inputRingBuffer.buffer ) { - PaUtil_FlushRingBuffer( &blio->inputRingBuffer ); - bzero( blio->inputRingBuffer.buffer, - blio->inputRingBuffer.bufferSize ); - /* Update isInputEmpty. */ -#ifdef PA_MAC__BLIO_MUTEX - result = blioSetIsInputEmpty( blio, true ); - if( result ) - goto error; -#endif - } - return paNoError; -#ifdef PA_MAC__BLIO_MUTEX - error: - return result; -#endif -} - -/*This should be called when you are done with the blio. It can safely be called - multiple times if there are no exceptions. */ -PaError destroyBlioRingBuffers( PaMacBlio *blio ) -{ - PaError result = paNoError; - if( blio->inputRingBuffer.buffer ) { - free( blio->inputRingBuffer.buffer ); -#ifdef PA_MAC__BLIO_MUTEX - result = UNIX_ERR( pthread_mutex_destroy( & blio->inputMutex ) ); - if( result ) return result; - result = UNIX_ERR( pthread_cond_destroy( & blio->inputCond ) ); - if( result ) return result; -#endif - } - blio->inputRingBuffer.buffer = NULL; - if( blio->outputRingBuffer.buffer ) { - free( blio->outputRingBuffer.buffer ); -#ifdef PA_MAC__BLIO_MUTEX - result = UNIX_ERR( pthread_mutex_destroy( & blio->outputMutex ) ); - if( result ) return result; - result = UNIX_ERR( pthread_cond_destroy( & blio->outputCond ) ); - if( result ) return result; -#endif - } - blio->outputRingBuffer.buffer = NULL; - - return result; -} - -/* - * this is the BlioCallback function. It expects to recieve a PaMacBlio Object - * pointer as userData. - * - */ -int BlioCallback( const void *input, void *output, unsigned long frameCount, - const PaStreamCallbackTimeInfo* timeInfo, - PaStreamCallbackFlags statusFlags, - void *userData ) -{ - PaMacBlio *blio = (PaMacBlio*)userData; - long avail; - long toRead; - long toWrite; - long read; - long written; - - /* set flags returned by OS: */ - OSAtomicOr32( statusFlags, &blio->statusFlags ) ; - - /* --- Handle Input Buffer --- */ - if( blio->inChan ) { - avail = PaUtil_GetRingBufferWriteAvailable( &blio->inputRingBuffer ); - - /* check for underflow */ - if( avail < frameCount * blio->inputSampleSizeActual * blio->inChan ) - { - OSAtomicOr32( paInputOverflow, &blio->statusFlags ); - } - toRead = MIN( avail, frameCount * blio->inputSampleSizeActual * blio->inChan ); - - /* copy the data */ - /*printf( "reading %d\n", toRead );*/ - read = PaUtil_WriteRingBuffer( &blio->inputRingBuffer, input, toRead ); - assert( toRead == read ); -#ifdef PA_MAC__BLIO_MUTEX - /* Priority inversion. See notes below. */ - blioSetIsInputEmpty( blio, false ); -#endif - } - - - /* --- Handle Output Buffer --- */ - if( blio->outChan ) { - avail = PaUtil_GetRingBufferReadAvailable( &blio->outputRingBuffer ); - - /* check for underflow */ - if( avail < frameCount * blio->outputSampleSizeActual * blio->outChan ) - OSAtomicOr32( paOutputUnderflow, &blio->statusFlags ); - - toWrite = MIN( avail, frameCount * blio->outputSampleSizeActual * blio->outChan ); - - if( toWrite != frameCount * blio->outputSampleSizeActual * blio->outChan ) - bzero( ((char *)output)+toWrite, - frameCount * blio->outputSampleSizeActual * blio->outChan - toWrite ); - /* copy the data */ - /*printf( "writing %d\n", toWrite );*/ - written = PaUtil_ReadRingBuffer( &blio->outputRingBuffer, output, toWrite ); - assert( toWrite == written ); -#ifdef PA_MAC__BLIO_MUTEX - /* We have a priority inversion here. However, we will only have to - wait if this was true and is now false, which means we've got - some room in the buffer. - Hopefully problems will be minimized. */ - blioSetIsOutputFull( blio, false ); -#endif - } - - return paContinue; -} - -PaError ReadStream( PaStream* stream, - void *buffer, - unsigned long frames ) -{ - PaMacBlio *blio = & ((PaMacCoreStream*)stream) -> blio; - char *cbuf = (char *) buffer; - PaError ret = paNoError; - VVDBUG(("ReadStream()\n")); - - while( frames > 0 ) { - long avail; - long toRead; - do { - avail = PaUtil_GetRingBufferReadAvailable( &blio->inputRingBuffer ); -/* - printf( "Read Buffer is %%%g full: %ld of %ld.\n", - 100 * (float)avail / (float) blio->inputRingBuffer.bufferSize, - avail, blio->inputRingBuffer.bufferSize ); -*/ - if( avail == 0 ) { -#ifdef PA_MAC_BLIO_MUTEX - /**block when empty*/ - ret = UNIX_ERR( pthread_mutex_lock( &blio->inputMutex ) ); - if( ret ) - return ret; - while( blio->isInputEmpty ) { - ret = UNIX_ERR( pthread_cond_wait( &blio->inputCond, &blio->inputMutex ) ); - if( ret ) - return ret; - } - ret = UNIX_ERR( pthread_mutex_unlock( &blio->inputMutex ) ); - if( ret ) - return ret; -#else - Pa_Sleep( PA_MAC_BLIO_BUSY_WAIT_SLEEP_INTERVAL ); -#endif - } - } while( avail == 0 ); - toRead = MIN( avail, frames * blio->inputSampleSizeActual * blio->inChan ); - toRead -= toRead % blio->inputSampleSizeActual * blio->inChan ; - PaUtil_ReadRingBuffer( &blio->inputRingBuffer, (void *)cbuf, toRead ); - cbuf += toRead; - frames -= toRead / ( blio->inputSampleSizeActual * blio->inChan ); - - if( toRead == avail ) { -#ifdef PA_MAC_BLIO_MUTEX - /* we just emptied the buffer, so we need to mark it as empty. */ - ret = blioSetIsInputEmpty( blio, true ); - if( ret ) - return ret; - /* of course, in the meantime, the callback may have put some sats - in, so - so check for that, too, to avoid a race condition. */ - if( PaUtil_GetRingBufferReadAvailable( &blio->inputRingBuffer ) ) { - blioSetIsInputEmpty( blio, false ); - if( ret ) - return ret; - } -#endif - } - } - - /* Report either paNoError or paInputOverflowed. */ - /* may also want to report other errors, but this is non-standard. */ - ret = blio->statusFlags & paInputOverflow; - - /* report underflow only once: */ - if( ret ) { - OSAtomicAnd32( (uint32_t)(~paInputOverflow), &blio->statusFlags ); - ret = paInputOverflowed; - } - - return ret; -} - - -PaError WriteStream( PaStream* stream, - const void *buffer, - unsigned long frames ) -{ - PaMacBlio *blio = & ((PaMacCoreStream*)stream) -> blio; - char *cbuf = (char *) buffer; - PaError ret = paNoError; - VVDBUG(("WriteStream()\n")); - - while( frames > 0 ) { - long avail = 0; - long toWrite; - - do { - avail = PaUtil_GetRingBufferWriteAvailable( &blio->outputRingBuffer ); -/* - printf( "Write Buffer is %%%g full: %ld of %ld.\n", - 100 - 100 * (float)avail / (float) blio->outputRingBuffer.bufferSize, - avail, blio->outputRingBuffer.bufferSize ); -*/ - if( avail == 0 ) { -#ifdef PA_MAC_BLIO_MUTEX - /*block while full*/ - ret = UNIX_ERR( pthread_mutex_lock( &blio->outputMutex ) ); - if( ret ) - return ret; - while( blio->isOutputFull ) { - ret = UNIX_ERR( pthread_cond_wait( &blio->outputCond, &blio->outputMutex ) ); - if( ret ) - return ret; - } - ret = UNIX_ERR( pthread_mutex_unlock( &blio->outputMutex ) ); - if( ret ) - return ret; -#else - Pa_Sleep( PA_MAC_BLIO_BUSY_WAIT_SLEEP_INTERVAL ); -#endif - } - } while( avail == 0 ); - - toWrite = MIN( avail, frames * blio->outputSampleSizeActual * blio->outChan ); - toWrite -= toWrite % blio->outputSampleSizeActual * blio->outChan ; - PaUtil_WriteRingBuffer( &blio->outputRingBuffer, (void *)cbuf, toWrite ); - cbuf += toWrite; - frames -= toWrite / ( blio->outputSampleSizeActual * blio->outChan ); - -#ifdef PA_MAC_BLIO_MUTEX - if( toWrite == avail ) { - /* we just filled up the buffer, so we need to mark it as filled. */ - ret = blioSetIsOutputFull( blio, true ); - if( ret ) - return ret; - /* of course, in the meantime, we may have emptied the buffer, so - so check for that, too, to avoid a race condition. */ - if( PaUtil_GetRingBufferWriteAvailable( &blio->outputRingBuffer ) ) { - blioSetIsOutputFull( blio, false ); - if( ret ) - return ret; - } - } -#endif - } - - /* Report either paNoError or paOutputUnderflowed. */ - /* may also want to report other errors, but this is non-standard. */ - ret = blio->statusFlags & paOutputUnderflow; - - /* report underflow only once: */ - if( ret ) { - OSAtomicAnd32( (uint32_t)(~paOutputUnderflow), &blio->statusFlags ); - ret = paOutputUnderflowed; - } - - return ret; -} - -/* - * - */ -void waitUntilBlioWriteBufferIsFlushed( PaMacBlio *blio ) -{ - if( blio->outputRingBuffer.buffer ) { - long avail = PaUtil_GetRingBufferWriteAvailable( &blio->outputRingBuffer ); - while( avail != blio->outputRingBuffer.bufferSize ) { - if( avail == 0 ) - Pa_Sleep( PA_MAC_BLIO_BUSY_WAIT_SLEEP_INTERVAL ); - avail = PaUtil_GetRingBufferWriteAvailable( &blio->outputRingBuffer ); - } - } -} - - -signed long GetStreamReadAvailable( PaStream* stream ) -{ - PaMacBlio *blio = & ((PaMacCoreStream*)stream) -> blio; - VVDBUG(("GetStreamReadAvailable()\n")); - - return PaUtil_GetRingBufferReadAvailable( &blio->inputRingBuffer ) - / ( blio->inputSampleSizeActual * blio->inChan ); -} - - -signed long GetStreamWriteAvailable( PaStream* stream ) -{ - PaMacBlio *blio = & ((PaMacCoreStream*)stream) -> blio; - VVDBUG(("GetStreamWriteAvailable()\n")); - - return PaUtil_GetRingBufferWriteAvailable( &blio->outputRingBuffer ) - / ( blio->outputSampleSizeActual * blio->outChan ); -} - +/* + * Implementation of the PortAudio API for Apple AUHAL + * + * PortAudio Portable Real-Time Audio Library + * Latest Version at: http://www.portaudio.com + * + * Written by Bjorn Roche of XO Audio LLC, from PA skeleton code. + * Portions copied from code by Dominic Mazzoni (who wrote a HAL implementation) + * + * Dominic's code was based on code by Phil Burk, Darren Gibbs, + * Gord Peters, Stephane Letz, and Greg Pfiel. + * + * The following people also deserve acknowledgements: + * + * Olivier Tristan for feedback and testing + * Glenn Zelniker and Z-Systems engineering for sponsoring the Blocking I/O + * interface. + * + * + * Based on the Open Source API proposed by Ross Bencina + * Copyright (c) 1999-2002 Ross Bencina, Phil Burk + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files + * (the "Software"), to deal in the Software without restriction, + * including without limitation the rights to use, copy, modify, merge, + * publish, distribute, sublicense, and/or sell copies of the Software, + * and to permit persons to whom the Software is furnished to do so, + * subject to the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR + * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF + * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + */ + +/* + * The text above constitutes the entire PortAudio license; however, + * the PortAudio community also makes the following non-binding requests: + * + * Any person wishing to distribute modifications to the Software is + * requested to send the modifications to the original developer so that + * they can be incorporated into the canonical version. It is also + * requested that these non-binding requests be included along with the + * license above. + */ + +/** + @file + @ingroup hostapi_src + + This file contains the implementation + required for blocking I/O. It is separated from pa_mac_core.c simply to ease + development. +*/ + +#include "pa_mac_core_blocking.h" +#include "pa_mac_core_internal.h" +#include +#ifdef MOSX_USE_NON_ATOMIC_FLAG_BITS +# define OSAtomicOr32( a, b ) ( (*(b)) |= (a) ) +# define OSAtomicAnd32( a, b ) ( (*(b)) &= (a) ) +#else +# include +#endif + +/* + * This function determines the size of a particular sample format. + * if the format is not recognized, this returns zero. + */ +static size_t computeSampleSizeFromFormat( PaSampleFormat format ) +{ + switch( format & (~paNonInterleaved) ) { + case paFloat32: return 4; + case paInt32: return 4; + case paInt24: return 3; + case paInt16: return 2; + case paInt8: case paUInt8: return 1; + default: return 0; + } +} +/* + * Same as computeSampleSizeFromFormat, except that if + * the size is not a power of two, it returns the next power of two up + */ +static size_t computeSampleSizeFromFormatPow2( PaSampleFormat format ) +{ + switch( format & (~paNonInterleaved) ) { + case paFloat32: return 4; + case paInt32: return 4; + case paInt24: return 4; + case paInt16: return 2; + case paInt8: case paUInt8: return 1; + default: return 0; + } +} + + + +/* + * Functions for initializing, resetting, and destroying BLIO structures. + * + */ + +/** + * This should be called with the relevant info when initializing a stream for callback. + * + * @param ringBufferSizeInFrames must be a power of 2 + */ +PaError initializeBlioRingBuffers( + PaMacBlio *blio, + PaSampleFormat inputSampleFormat, + PaSampleFormat outputSampleFormat, + long ringBufferSizeInFrames, + int inChan, + int outChan ) +{ + void *data; + int result; + OSStatus err; + + /* zeroify things */ + bzero( blio, sizeof( PaMacBlio ) ); + /* this is redundant, but the buffers are used to check + if the buffers have been initialized, so we do it explicitly. */ + blio->inputRingBuffer.buffer = NULL; + blio->outputRingBuffer.buffer = NULL; + + /* initialize simple data */ + blio->ringBufferFrames = ringBufferSizeInFrames; + blio->inputSampleFormat = inputSampleFormat; + blio->inputSampleSizeActual = computeSampleSizeFromFormat(inputSampleFormat); + blio->inputSampleSizePow2 = computeSampleSizeFromFormatPow2(inputSampleFormat); // FIXME: WHY? + blio->outputSampleFormat = outputSampleFormat; + blio->outputSampleSizeActual = computeSampleSizeFromFormat(outputSampleFormat); + blio->outputSampleSizePow2 = computeSampleSizeFromFormatPow2(outputSampleFormat); + + blio->inChan = inChan; + blio->outChan = outChan; + blio->statusFlags = 0; + blio->errors = paNoError; +#ifdef PA_MAC_BLIO_MUTEX + blio->isInputEmpty = false; + blio->isOutputFull = false; +#endif + + /* setup ring buffers */ +#ifdef PA_MAC_BLIO_MUTEX + result = PaMacCore_SetUnixError( pthread_mutex_init(&(blio->inputMutex),NULL), 0 ); + if( result ) + goto error; + result = UNIX_ERR( pthread_cond_init( &(blio->inputCond), NULL ) ); + if( result ) + goto error; + result = UNIX_ERR( pthread_mutex_init(&(blio->outputMutex),NULL) ); + if( result ) + goto error; + result = UNIX_ERR( pthread_cond_init( &(blio->outputCond), NULL ) ); +#endif + if( inChan ) { + data = calloc( ringBufferSizeInFrames, blio->inputSampleSizePow2 * inChan ); + if( !data ) + { + result = paInsufficientMemory; + goto error; + } + + err = PaUtil_InitializeRingBuffer( + &blio->inputRingBuffer, + blio->inputSampleSizePow2 * inChan, + ringBufferSizeInFrames, + data ); + assert( !err ); + } + if( outChan ) { + data = calloc( ringBufferSizeInFrames, blio->outputSampleSizePow2 * outChan ); + if( !data ) + { + result = paInsufficientMemory; + goto error; + } + + err = PaUtil_InitializeRingBuffer( + &blio->outputRingBuffer, + blio->outputSampleSizePow2 * outChan, + ringBufferSizeInFrames, + data ); + assert( !err ); + } + + result = resetBlioRingBuffers( blio ); + if( result ) + goto error; + + return 0; + + error: + destroyBlioRingBuffers( blio ); + return result; +} + +#ifdef PA_MAC_BLIO_MUTEX +PaError blioSetIsInputEmpty( PaMacBlio *blio, bool isEmpty ) +{ + PaError result = paNoError; + if( isEmpty == blio->isInputEmpty ) + goto done; + + /* we need to update the value. Here's what we do: + * - Lock the mutex, so noone else can write. + * - update the value. + * - unlock. + * - broadcast to all listeners. + */ + result = UNIX_ERR( pthread_mutex_lock( &blio->inputMutex ) ); + if( result ) + goto done; + blio->isInputEmpty = isEmpty; + result = UNIX_ERR( pthread_mutex_unlock( &blio->inputMutex ) ); + if( result ) + goto done; + result = UNIX_ERR( pthread_cond_broadcast( &blio->inputCond ) ); + if( result ) + goto done; + + done: + return result; +} +PaError blioSetIsOutputFull( PaMacBlio *blio, bool isFull ) +{ + PaError result = paNoError; + if( isFull == blio->isOutputFull ) + goto done; + + /* we need to update the value. Here's what we do: + * - Lock the mutex, so noone else can write. + * - update the value. + * - unlock. + * - broadcast to all listeners. + */ + result = UNIX_ERR( pthread_mutex_lock( &blio->outputMutex ) ); + if( result ) + goto done; + blio->isOutputFull = isFull; + result = UNIX_ERR( pthread_mutex_unlock( &blio->outputMutex ) ); + if( result ) + goto done; + result = UNIX_ERR( pthread_cond_broadcast( &blio->outputCond ) ); + if( result ) + goto done; + + done: + return result; +} +#endif + +/* This should be called after stopping or aborting the stream, so that on next + start, the buffers will be ready. */ +PaError resetBlioRingBuffers( PaMacBlio *blio ) +{ +#ifdef PA_MAC__BLIO_MUTEX + int result; +#endif + blio->statusFlags = 0; + if( blio->outputRingBuffer.buffer ) { + PaUtil_FlushRingBuffer( &blio->outputRingBuffer ); + /* Fill the buffer with zeros. */ + bzero( blio->outputRingBuffer.buffer, + blio->outputRingBuffer.bufferSize * blio->outputRingBuffer.elementSizeBytes ); + PaUtil_AdvanceRingBufferWriteIndex( &blio->outputRingBuffer, blio->ringBufferFrames ); + + /* Update isOutputFull. */ +#ifdef PA_MAC__BLIO_MUTEX + result = blioSetIsOutputFull( blio, toAdvance == blio->outputRingBuffer.bufferSize ); + if( result ) + goto error; +#endif +/* + printf( "------%d\n" , blio->outChan ); + printf( "------%d\n" , blio->outputSampleSize ); +*/ + } + if( blio->inputRingBuffer.buffer ) { + PaUtil_FlushRingBuffer( &blio->inputRingBuffer ); + bzero( blio->inputRingBuffer.buffer, + blio->inputRingBuffer.bufferSize * blio->inputRingBuffer.elementSizeBytes ); + /* Update isInputEmpty. */ +#ifdef PA_MAC__BLIO_MUTEX + result = blioSetIsInputEmpty( blio, true ); + if( result ) + goto error; +#endif + } + return paNoError; +#ifdef PA_MAC__BLIO_MUTEX + error: + return result; +#endif +} + +/*This should be called when you are done with the blio. It can safely be called + multiple times if there are no exceptions. */ +PaError destroyBlioRingBuffers( PaMacBlio *blio ) +{ + PaError result = paNoError; + if( blio->inputRingBuffer.buffer ) { + free( blio->inputRingBuffer.buffer ); +#ifdef PA_MAC__BLIO_MUTEX + result = UNIX_ERR( pthread_mutex_destroy( & blio->inputMutex ) ); + if( result ) return result; + result = UNIX_ERR( pthread_cond_destroy( & blio->inputCond ) ); + if( result ) return result; +#endif + } + blio->inputRingBuffer.buffer = NULL; + if( blio->outputRingBuffer.buffer ) { + free( blio->outputRingBuffer.buffer ); +#ifdef PA_MAC__BLIO_MUTEX + result = UNIX_ERR( pthread_mutex_destroy( & blio->outputMutex ) ); + if( result ) return result; + result = UNIX_ERR( pthread_cond_destroy( & blio->outputCond ) ); + if( result ) return result; +#endif + } + blio->outputRingBuffer.buffer = NULL; + + return result; +} + +/* + * this is the BlioCallback function. It expects to recieve a PaMacBlio Object + * pointer as userData. + * + */ +int BlioCallback( const void *input, void *output, unsigned long frameCount, + const PaStreamCallbackTimeInfo* timeInfo, + PaStreamCallbackFlags statusFlags, + void *userData ) +{ + PaMacBlio *blio = (PaMacBlio*)userData; + ring_buffer_size_t framesAvailable; + ring_buffer_size_t framesToTransfer; + ring_buffer_size_t framesTransferred; + + /* set flags returned by OS: */ + OSAtomicOr32( statusFlags, &blio->statusFlags ) ; + + /* --- Handle Input Buffer --- */ + if( blio->inChan ) { + framesAvailable = PaUtil_GetRingBufferWriteAvailable( &blio->inputRingBuffer ); + + /* check for underflow */ + if( framesAvailable < frameCount ) + { + OSAtomicOr32( paInputOverflow, &blio->statusFlags ); + framesToTransfer = framesAvailable; + } + else + { + framesToTransfer = (ring_buffer_size_t)frameCount; + } + + /* Copy the data from the audio input to the application ring buffer. */ + /*printf( "reading %d\n", toRead );*/ + framesTransferred = PaUtil_WriteRingBuffer( &blio->inputRingBuffer, input, framesToTransfer ); + assert( framesToTransfer == framesTransferred ); +#ifdef PA_MAC__BLIO_MUTEX + /* Priority inversion. See notes below. */ + blioSetIsInputEmpty( blio, false ); +#endif + } + + + /* --- Handle Output Buffer --- */ + if( blio->outChan ) { + framesAvailable = PaUtil_GetRingBufferReadAvailable( &blio->outputRingBuffer ); + + /* check for underflow */ + if( framesAvailable < frameCount ) + { + /* zero out the end of the output buffer that we do not have data for */ + framesToTransfer = framesAvailable; + + size_t bytesPerFrame = blio->outputSampleSizeActual * blio->outChan; + size_t offsetInBytes = framesToTransfer * bytesPerFrame; + size_t countInBytes = (frameCount - framesToTransfer) * bytesPerFrame; + bzero( ((char *)output) + offsetInBytes, countInBytes ); + + OSAtomicOr32( paOutputUnderflow, &blio->statusFlags ); + framesToTransfer = framesAvailable; + } + else + { + framesToTransfer = (ring_buffer_size_t)frameCount; + } + + /* copy the data */ + /*printf( "writing %d\n", toWrite );*/ + framesTransferred = PaUtil_ReadRingBuffer( &blio->outputRingBuffer, output, framesToTransfer ); + assert( framesToTransfer == framesTransferred ); +#ifdef PA_MAC__BLIO_MUTEX + /* We have a priority inversion here. However, we will only have to + wait if this was true and is now false, which means we've got + some room in the buffer. + Hopefully problems will be minimized. */ + blioSetIsOutputFull( blio, false ); +#endif + } + + return paContinue; +} + +PaError ReadStream( PaStream* stream, + void *buffer, + unsigned long framesRequested ) +{ + PaMacBlio *blio = & ((PaMacCoreStream*)stream) -> blio; + char *cbuf = (char *) buffer; + PaError ret = paNoError; + VVDBUG(("ReadStream()\n")); + + while( framesRequested > 0 ) { + ring_buffer_size_t framesAvailable; + ring_buffer_size_t framesToTransfer; + ring_buffer_size_t framesTransferred; + do { + framesAvailable = PaUtil_GetRingBufferReadAvailable( &blio->inputRingBuffer ); +/* + printf( "Read Buffer is %%%g full: %ld of %ld.\n", + 100 * (float)avail / (float) blio->inputRingBuffer.bufferSize, + framesAvailable, blio->inputRingBuffer.bufferSize ); +*/ + if( framesAvailable == 0 ) { +#ifdef PA_MAC_BLIO_MUTEX + /**block when empty*/ + ret = UNIX_ERR( pthread_mutex_lock( &blio->inputMutex ) ); + if( ret ) + return ret; + while( blio->isInputEmpty ) { + ret = UNIX_ERR( pthread_cond_wait( &blio->inputCond, &blio->inputMutex ) ); + if( ret ) + return ret; + } + ret = UNIX_ERR( pthread_mutex_unlock( &blio->inputMutex ) ); + if( ret ) + return ret; +#else + Pa_Sleep( PA_MAC_BLIO_BUSY_WAIT_SLEEP_INTERVAL ); +#endif + } + } while( framesAvailable == 0 ); + framesToTransfer = (ring_buffer_size_t) MIN( framesAvailable, framesRequested ); + framesTransferred = PaUtil_ReadRingBuffer( &blio->inputRingBuffer, (void *)cbuf, framesToTransfer ); + cbuf += framesTransferred * blio->inputSampleSizeActual * blio->inChan; + framesRequested -= framesTransferred; + + if( framesToTransfer == framesAvailable ) { +#ifdef PA_MAC_BLIO_MUTEX + /* we just emptied the buffer, so we need to mark it as empty. */ + ret = blioSetIsInputEmpty( blio, true ); + if( ret ) + return ret; + /* of course, in the meantime, the callback may have put some sats + in, so + so check for that, too, to avoid a race condition. */ + /* FIXME - this does not seem to fix any race condition. */ + if( PaUtil_GetRingBufferReadAvailable( &blio->inputRingBuffer ) ) { + blioSetIsInputEmpty( blio, false ); + /* FIXME - why check? ret has not been set? */ + if( ret ) + return ret; + } +#endif + } + } + + /* Report either paNoError or paInputOverflowed. */ + /* may also want to report other errors, but this is non-standard. */ + /* FIXME should not clobber ret, use if(blio->statusFlags & paInputOverflow) */ + ret = blio->statusFlags & paInputOverflow; + + /* report underflow only once: */ + if( ret ) { + OSAtomicAnd32( (uint32_t)(~paInputOverflow), &blio->statusFlags ); + ret = paInputOverflowed; + } + + return ret; +} + + +PaError WriteStream( PaStream* stream, + const void *buffer, + unsigned long framesRequested ) +{ + PaMacCoreStream *macStream = (PaMacCoreStream*)stream; + PaMacBlio *blio = &macStream->blio; + char *cbuf = (char *) buffer; + PaError ret = paNoError; + VVDBUG(("WriteStream()\n")); + + while( framesRequested > 0 && macStream->state != STOPPING ) { + ring_buffer_size_t framesAvailable; + ring_buffer_size_t framesToTransfer; + ring_buffer_size_t framesTransferred; + + do { + framesAvailable = PaUtil_GetRingBufferWriteAvailable( &blio->outputRingBuffer ); +/* + printf( "Write Buffer is %%%g full: %ld of %ld.\n", + 100 - 100 * (float)avail / (float) blio->outputRingBuffer.bufferSize, + framesAvailable, blio->outputRingBuffer.bufferSize ); +*/ + if( framesAvailable == 0 ) { +#ifdef PA_MAC_BLIO_MUTEX + /*block while full*/ + ret = UNIX_ERR( pthread_mutex_lock( &blio->outputMutex ) ); + if( ret ) + return ret; + while( blio->isOutputFull ) { + ret = UNIX_ERR( pthread_cond_wait( &blio->outputCond, &blio->outputMutex ) ); + if( ret ) + return ret; + } + ret = UNIX_ERR( pthread_mutex_unlock( &blio->outputMutex ) ); + if( ret ) + return ret; +#else + Pa_Sleep( PA_MAC_BLIO_BUSY_WAIT_SLEEP_INTERVAL ); +#endif + } + } while( framesAvailable == 0 && macStream->state != STOPPING ); + + if( macStream->state == STOPPING ) + { + break; + } + + framesToTransfer = MIN( framesAvailable, framesRequested ); + framesTransferred = PaUtil_WriteRingBuffer( &blio->outputRingBuffer, (void *)cbuf, framesToTransfer ); + cbuf += framesTransferred * blio->outputSampleSizeActual * blio->outChan; + framesRequested -= framesTransferred; + +#ifdef PA_MAC_BLIO_MUTEX + if( framesToTransfer == framesAvailable ) { + /* we just filled up the buffer, so we need to mark it as filled. */ + ret = blioSetIsOutputFull( blio, true ); + if( ret ) + return ret; + /* of course, in the meantime, we may have emptied the buffer, so + so check for that, too, to avoid a race condition. */ + if( PaUtil_GetRingBufferWriteAvailable( &blio->outputRingBuffer ) ) { + blioSetIsOutputFull( blio, false ); + /* FIXME remove or review this code, does not fix race, ret not set! */ + if( ret ) + return ret; + } + } +#endif + } + + if ( macStream->state == STOPPING ) + { + ret = paInternalError; + } + else if (ret == paNoError ) + { + /* Test for underflow. */ + ret = blio->statusFlags & paOutputUnderflow; + + /* report underflow only once: */ + if( ret ) + { + OSAtomicAnd32( (uint32_t)(~paOutputUnderflow), &blio->statusFlags ); + ret = paOutputUnderflowed; + } + } + + return ret; +} + +/* + * Wait until the data in the buffer has finished playing. + */ +PaError waitUntilBlioWriteBufferIsEmpty( PaMacBlio *blio, double sampleRate, + size_t framesPerBuffer ) +{ + PaError result = paNoError; + if( blio->outputRingBuffer.buffer ) { + ring_buffer_size_t framesLeft = PaUtil_GetRingBufferReadAvailable( &blio->outputRingBuffer ); + + /* Calculate when we should give up waiting. To be safe wait for two extra periods. */ + PaTime now = PaUtil_GetTime(); + PaTime startTime = now; + PaTime timeoutTime = startTime + (framesLeft + (2 * framesPerBuffer)) / sampleRate; + + long msecPerBuffer = 1 + (long)( 1000.0 * framesPerBuffer / sampleRate); + while( framesLeft > 0 && now < timeoutTime ) { + VDBUG(( "waitUntilBlioWriteBufferIsFlushed: framesLeft = %d, framesPerBuffer = %ld\n", + framesLeft, framesPerBuffer )); + Pa_Sleep( msecPerBuffer ); + framesLeft = PaUtil_GetRingBufferReadAvailable( &blio->outputRingBuffer ); + now = PaUtil_GetTime(); + } + + if( framesLeft > 0 ) + { + VDBUG(( "waitUntilBlioWriteBufferIsFlushed: TIMED OUT - framesLeft = %d\n", framesLeft )); + result = paTimedOut; + } + } + return result; +} + +signed long GetStreamReadAvailable( PaStream* stream ) +{ + PaMacBlio *blio = & ((PaMacCoreStream*)stream) -> blio; + VVDBUG(("GetStreamReadAvailable()\n")); + + return PaUtil_GetRingBufferReadAvailable( &blio->inputRingBuffer ); +} + + +signed long GetStreamWriteAvailable( PaStream* stream ) +{ + PaMacBlio *blio = & ((PaMacCoreStream*)stream) -> blio; + VVDBUG(("GetStreamWriteAvailable()\n")); + + return PaUtil_GetRingBufferWriteAvailable( &blio->outputRingBuffer ); +} + diff --git a/external/portaudio/pa_mac_core_blocking.h b/external/portaudio/pa_mac_core_blocking.h index 971223b3..c994f090 100644 --- a/external/portaudio/pa_mac_core_blocking.h +++ b/external/portaudio/pa_mac_core_blocking.h @@ -1,136 +1,134 @@ -/* - * Internal blocking interfaces for PortAudio Apple AUHAL implementation - * - * PortAudio Portable Real-Time Audio Library - * Latest Version at: http://www.portaudio.com - * - * Written by Bjorn Roche of XO Audio LLC, from PA skeleton code. - * Portions copied from code by Dominic Mazzoni (who wrote a HAL implementation) - * - * Dominic's code was based on code by Phil Burk, Darren Gibbs, - * Gord Peters, Stephane Letz, and Greg Pfiel. - * - * The following people also deserve acknowledgements: - * - * Olivier Tristan for feedback and testing - * Glenn Zelniker and Z-Systems engineering for sponsoring the Blocking I/O - * interface. - * - * - * Based on the Open Source API proposed by Ross Bencina - * Copyright (c) 1999-2002 Ross Bencina, Phil Burk - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files - * (the "Software"), to deal in the Software without restriction, - * including without limitation the rights to use, copy, modify, merge, - * publish, distribute, sublicense, and/or sell copies of the Software, - * and to permit persons to whom the Software is furnished to do so, - * subject to the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR - * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/* - * The text above constitutes the entire PortAudio license; however, - * the PortAudio community also makes the following non-binding requests: - * - * Any person wishing to distribute modifications to the Software is - * requested to send the modifications to the original developer so that - * they can be incorporated into the canonical version. It is also - * requested that these non-binding requests be included along with the - * license above. - */ - -/** - @file - @ingroup hostapi_src -*/ - -#ifndef PA_MAC_CORE_BLOCKING_H_ -#define PA_MAC_CORE_BLOCKING_H_ - -#include "pa_ringbuffer.h" -#include "portaudio.h" -#include "pa_mac_core_utilities.h" - -/* - * Number of miliseconds to busy wait whil waiting for data in blocking calls. - */ -#define PA_MAC_BLIO_BUSY_WAIT_SLEEP_INTERVAL (5) -/* - * Define exactly one of these blocking methods - * PA_MAC_BLIO_MUTEX is not actively maintained. - */ -#define PA_MAC_BLIO_BUSY_WAIT -/* -#define PA_MAC_BLIO_MUTEX -*/ - -typedef struct { - PaUtilRingBuffer inputRingBuffer; - PaUtilRingBuffer outputRingBuffer; - size_t ringBufferFrames; - PaSampleFormat inputSampleFormat; - size_t inputSampleSizeActual; - size_t inputSampleSizePow2; - PaSampleFormat outputSampleFormat; - size_t outputSampleSizeActual; - size_t outputSampleSizePow2; - - size_t framesPerBuffer; - - int inChan; - int outChan; - - //PaStreamCallbackFlags statusFlags; - uint32_t statusFlags; - PaError errors; - - /* Here we handle blocking, using condition variables. */ -#ifdef PA_MAC_BLIO_MUTEX - volatile bool isInputEmpty; - pthread_mutex_t inputMutex; - pthread_cond_t inputCond; - - volatile bool isOutputFull; - pthread_mutex_t outputMutex; - pthread_cond_t outputCond; -#endif -} -PaMacBlio; - -/* - * These functions operate on condition and related variables. - */ - -PaError initializeBlioRingBuffers( - PaMacBlio *blio, - PaSampleFormat inputSampleFormat, - PaSampleFormat outputSampleFormat, - size_t framesPerBuffer, - long ringBufferSize, - int inChan, - int outChan ); -PaError destroyBlioRingBuffers( PaMacBlio *blio ); -PaError resetBlioRingBuffers( PaMacBlio *blio ); - -int BlioCallback( - const void *input, void *output, - unsigned long frameCount, - const PaStreamCallbackTimeInfo* timeInfo, - PaStreamCallbackFlags statusFlags, - void *userData ); - -void waitUntilBlioWriteBufferIsFlushed( PaMacBlio *blio ); - -#endif /*PA_MAC_CORE_BLOCKING_H_*/ +/* + * Internal blocking interfaces for PortAudio Apple AUHAL implementation + * + * PortAudio Portable Real-Time Audio Library + * Latest Version at: http://www.portaudio.com + * + * Written by Bjorn Roche of XO Audio LLC, from PA skeleton code. + * Portions copied from code by Dominic Mazzoni (who wrote a HAL implementation) + * + * Dominic's code was based on code by Phil Burk, Darren Gibbs, + * Gord Peters, Stephane Letz, and Greg Pfiel. + * + * The following people also deserve acknowledgements: + * + * Olivier Tristan for feedback and testing + * Glenn Zelniker and Z-Systems engineering for sponsoring the Blocking I/O + * interface. + * + * + * Based on the Open Source API proposed by Ross Bencina + * Copyright (c) 1999-2002 Ross Bencina, Phil Burk + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files + * (the "Software"), to deal in the Software without restriction, + * including without limitation the rights to use, copy, modify, merge, + * publish, distribute, sublicense, and/or sell copies of the Software, + * and to permit persons to whom the Software is furnished to do so, + * subject to the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR + * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF + * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + */ + +/* + * The text above constitutes the entire PortAudio license; however, + * the PortAudio community also makes the following non-binding requests: + * + * Any person wishing to distribute modifications to the Software is + * requested to send the modifications to the original developer so that + * they can be incorporated into the canonical version. It is also + * requested that these non-binding requests be included along with the + * license above. + */ + +/** + @file + @ingroup hostapi_src +*/ + +#ifndef PA_MAC_CORE_BLOCKING_H_ +#define PA_MAC_CORE_BLOCKING_H_ + +#include "pa_ringbuffer.h" +#include "portaudio.h" +#include "pa_mac_core_utilities.h" + +/* + * Number of milliseconds to busy wait while waiting for data in blocking calls. + */ +#define PA_MAC_BLIO_BUSY_WAIT_SLEEP_INTERVAL (5) +/* + * Define exactly one of these blocking methods + * PA_MAC_BLIO_MUTEX is not actively maintained. + */ +#define PA_MAC_BLIO_BUSY_WAIT +/* +#define PA_MAC_BLIO_MUTEX +*/ + +typedef struct { + PaUtilRingBuffer inputRingBuffer; + PaUtilRingBuffer outputRingBuffer; + ring_buffer_size_t ringBufferFrames; + PaSampleFormat inputSampleFormat; + size_t inputSampleSizeActual; + size_t inputSampleSizePow2; + PaSampleFormat outputSampleFormat; + size_t outputSampleSizeActual; + size_t outputSampleSizePow2; + + int inChan; + int outChan; + + //PaStreamCallbackFlags statusFlags; + uint32_t statusFlags; + PaError errors; + + /* Here we handle blocking, using condition variables. */ +#ifdef PA_MAC_BLIO_MUTEX + volatile bool isInputEmpty; + pthread_mutex_t inputMutex; + pthread_cond_t inputCond; + + volatile bool isOutputFull; + pthread_mutex_t outputMutex; + pthread_cond_t outputCond; +#endif +} +PaMacBlio; + +/* + * These functions operate on condition and related variables. + */ + +PaError initializeBlioRingBuffers( + PaMacBlio *blio, + PaSampleFormat inputSampleFormat, + PaSampleFormat outputSampleFormat, + long ringBufferSizeInFrames, + int inChan, + int outChan ); +PaError destroyBlioRingBuffers( PaMacBlio *blio ); +PaError resetBlioRingBuffers( PaMacBlio *blio ); + +int BlioCallback( + const void *input, void *output, + unsigned long frameCount, + const PaStreamCallbackTimeInfo* timeInfo, + PaStreamCallbackFlags statusFlags, + void *userData ); + +PaError waitUntilBlioWriteBufferIsEmpty( PaMacBlio *blio, double sampleRate, + size_t framesPerBuffer ); + +#endif /*PA_MAC_CORE_BLOCKING_H_*/ diff --git a/external/portaudio/pa_mac_core_utilities.h b/external/portaudio/pa_mac_core_utilities.h index 7c4afe52..ffa23de7 100644 --- a/external/portaudio/pa_mac_core_utilities.h +++ b/external/portaudio/pa_mac_core_utilities.h @@ -206,9 +206,9 @@ OSStatus xrunCallback( void* inClientData ) ; /** returns zero on success or a unix style error code. */ -int initializeXRunListenerList(); +int initializeXRunListenerList( void ); // ppgb 20200814 /** returns zero on success or a unix style error code. */ -int destroyXRunListenerList(); +int destroyXRunListenerList( void ); // ppgb 20200814 /**Returns the list, so that it can be passed to CorAudio.*/ void *addToXRunListenerList( void *stream ); diff --git a/external/portaudio/pa_process.c b/external/portaudio/pa_process.c index f6052d14..0faf8414 100644 --- a/external/portaudio/pa_process.c +++ b/external/portaudio/pa_process.c @@ -1,5 +1,5 @@ /* - * $Id: pa_process.c 1913 2013-11-18 11:42:27Z gineera $ + * $Id$ * Portable Audio I/O Library * streamCallback <-> host buffer processing adapter * @@ -744,7 +744,7 @@ static unsigned long NonAdaptingProcess( PaUtilBufferProcessor *bp, destChannelStrideBytes = bp->bytesPerUserInputSample; /* process host buffer directly, or use temp buffer if formats differ or host buffer non-interleaved, - * or if the number of channels differs between the host (set in stride) and the user */ + * or if num channels differs between the host (set in stride) and the user (eg with some Alsa hw:) */ if( bp->userInputSampleFormatIsEqualToHost && bp->hostInputIsInterleaved && bp->hostInputChannels[0][0].data && bp->inputChannelCount == hostInputChannels[0].stride ) { @@ -834,8 +834,10 @@ static unsigned long NonAdaptingProcess( PaUtilBufferProcessor *bp, { if( bp->userOutputIsInterleaved ) { - /* process host buffer directly, or use temp buffer if formats differ or host buffer non-interleaved */ - if( bp->userOutputSampleFormatIsEqualToHost && bp->hostOutputIsInterleaved ) + /* process host buffer directly, or use temp buffer if formats differ or host buffer non-interleaved, + * or if num channels differs between the host (set in stride) and the user (eg with some Alsa hw:) */ + if( bp->userOutputSampleFormatIsEqualToHost && bp->hostOutputIsInterleaved + && bp->outputChannelCount == hostOutputChannels[0].stride ) { userOutput = hostOutputChannels[0].data; skipOutputConvert = 1; diff --git a/external/portaudio/pa_process.h b/external/portaudio/pa_process.h index 4d5f56ad..37b91d72 100644 --- a/external/portaudio/pa_process.h +++ b/external/portaudio/pa_process.h @@ -1,7 +1,7 @@ #ifndef PA_PROCESS_H #define PA_PROCESS_H /* - * $Id: pa_process.h 1668 2011-05-02 17:07:11Z rossb $ + * $Id$ * Portable Audio I/O Library callback buffer processing adapters * * Based on the Open Source API proposed by Ross Bencina diff --git a/external/portaudio/pa_ringbuffer.c b/external/portaudio/pa_ringbuffer.c index 19c91497..93b3e430 100644 --- a/external/portaudio/pa_ringbuffer.c +++ b/external/portaudio/pa_ringbuffer.c @@ -1,5 +1,5 @@ /* - * $Id: pa_ringbuffer.c 1738 2011-08-18 11:47:28Z rossb $ + * $Id$ * Portable Audio I/O Library * Ring Buffer utility. * diff --git a/external/portaudio/pa_ringbuffer.h b/external/portaudio/pa_ringbuffer.h index 0cab3a58..9edba0dd 100644 --- a/external/portaudio/pa_ringbuffer.h +++ b/external/portaudio/pa_ringbuffer.h @@ -1,7 +1,7 @@ #ifndef PA_RINGBUFFER_H #define PA_RINGBUFFER_H /* - * $Id: pa_ringbuffer.h 1873 2012-10-07 19:00:11Z philburk $ + * $Id$ * Portable Audio I/O Library * Ring Buffer utility. * diff --git a/external/portaudio/pa_stream.c b/external/portaudio/pa_stream.c index ea91821f..03a0ee6e 100644 --- a/external/portaudio/pa_stream.c +++ b/external/portaudio/pa_stream.c @@ -1,5 +1,5 @@ /* - * $Id: pa_stream.c 1339 2008-02-15 07:50:33Z rossb $ + * $Id$ * Portable Audio I/O Library * stream interface * diff --git a/external/portaudio/pa_stream.h b/external/portaudio/pa_stream.h index 8d707b79..678e2ad5 100644 --- a/external/portaudio/pa_stream.h +++ b/external/portaudio/pa_stream.h @@ -1,7 +1,7 @@ #ifndef PA_STREAM_H #define PA_STREAM_H /* - * $Id: pa_stream.h 1339 2008-02-15 07:50:33Z rossb $ + * $Id$ * Portable Audio I/O Library * stream interface * diff --git a/external/portaudio/pa_trace.c b/external/portaudio/pa_trace.c index 6a41cbb3..818abffb 100644 --- a/external/portaudio/pa_trace.c +++ b/external/portaudio/pa_trace.c @@ -1,5 +1,5 @@ /* - * $Id: pa_trace.c 1916 2014-01-17 03:45:15Z philburk $ + * $Id$ * Portable Audio I/O Library Trace Facility * Store trace information in real-time for later printing. * diff --git a/external/portaudio/pa_trace.h b/external/portaudio/pa_trace.h index 612dbf32..6dfaeb79 100644 --- a/external/portaudio/pa_trace.h +++ b/external/portaudio/pa_trace.h @@ -1,7 +1,7 @@ #ifndef PA_TRACE_H #define PA_TRACE_H /* - * $Id: pa_trace.h 1812 2012-02-14 09:32:57Z robiwan $ + * $Id$ * Portable Audio I/O Library Trace Facility * Store trace information in real-time for later printing. * diff --git a/external/portaudio/pa_types.h b/external/portaudio/pa_types.h index fd9bfe30..5b647d64 100644 --- a/external/portaudio/pa_types.h +++ b/external/portaudio/pa_types.h @@ -51,18 +51,43 @@ A PA_VALIDATE_SIZES macro is provided to assert that the values set in this file are correct. - - Paul Boersma 2013: the sizes should not be handcoded if this header file is to be included in both 32-bit and 64-bit applications; - instead, we use int32_t and the like from . */ -#include +#ifndef SIZEOF_SHORT +#define SIZEOF_SHORT 2 +#endif + +#ifndef SIZEOF_INT +#define SIZEOF_INT 4 +#endif + +#ifndef SIZEOF_LONG +#define SIZEOF_LONG 4 +#endif + -typedef int16_t PaInt16; -typedef uint16_t PaUint16; +#if SIZEOF_SHORT == 2 +typedef signed short PaInt16; +typedef unsigned short PaUint16; +#elif SIZEOF_INT == 2 +typedef signed int PaInt16; +typedef unsigned int PaUint16; +#else +#error pa_types.h was unable to determine which type to use for 16bit integers on the target platform +#endif -typedef int32_t PaInt32; -typedef uint32_t PaUint32; +#if SIZEOF_SHORT == 4 +typedef signed short PaInt32; +typedef unsigned short PaUint32; +#elif SIZEOF_INT == 4 +typedef signed int PaInt32; +typedef unsigned int PaUint32; +#elif SIZEOF_LONG == 4 +typedef signed long PaInt32; +typedef unsigned long PaUint32; +#else +#error pa_types.h was unable to determine which type to use for 32bit integers on the target platform +#endif /* PA_VALIDATE_TYPE_SIZES compares the size of the integer types at runtime to diff --git a/external/portaudio/pa_util.h b/external/portaudio/pa_util.h index c454ea77..ad5dac52 100644 --- a/external/portaudio/pa_util.h +++ b/external/portaudio/pa_util.h @@ -1,7 +1,7 @@ #ifndef PA_UTIL_H #define PA_UTIL_H /* - * $Id: pa_util.h 1584 2011-02-02 18:58:17Z rossb $ + * $Id$ * Portable Audio I/O Library implementation utilities header * common implementation utilities and interfaces * diff --git a/external/portaudio/patest_record.c b/external/portaudio/patest_record.c new file mode 100644 index 00000000..5e3f6fdc --- /dev/null +++ b/external/portaudio/patest_record.c @@ -0,0 +1,349 @@ +/* + * $Id$ + * + * This program uses the PortAudio Portable Audio Library. + * For more information see: http://www.portaudio.com + * Copyright (c) 1999-2000 Ross Bencina and Phil Burk + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files + * (the "Software"), to deal in the Software without restriction, + * including without limitation the rights to use, copy, modify, merge, + * publish, distribute, sublicense, and/or sell copies of the Software, + * and to permit persons to whom the Software is furnished to do so, + * subject to the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR + * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF + * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + */ + +/* + * The text above constitutes the entire PortAudio license; however, + * the PortAudio community also makes the following non-binding requests: + * + * Any person wishing to distribute modifications to the Software is + * requested to send the modifications to the original developer so that + * they can be incorporated into the canonical version. It is also + * requested that these non-binding requests be included along with the + * license above. + */ + +#include +#include +#include "portaudio.h" + +/* #define SAMPLE_RATE (17932) // Test failure to open with this value. */ +#define SAMPLE_RATE (44100) +#define FRAMES_PER_BUFFER (512) +#define NUM_SECONDS (5) +#define NUM_CHANNELS (1) /*(2)*/ +/* #define DITHER_FLAG (paDitherOff) */ +#define DITHER_FLAG (0) + +#define WRITE_TO_FILE (0) + +/* Select sample format. */ +#if 1 +#define PA_SAMPLE_TYPE paFloat32 +typedef float SAMPLE; +#define SAMPLE_SILENCE (0.0f) +#define PRINTF_S_FORMAT "%.8f" +#elif 1 +#define PA_SAMPLE_TYPE paInt16 +typedef short SAMPLE; +#define SAMPLE_SILENCE (0) +#define PRINTF_S_FORMAT "%d" +#elif 0 +#define PA_SAMPLE_TYPE paInt8 +typedef char SAMPLE; +#define SAMPLE_SILENCE (0) +#define PRINTF_S_FORMAT "%d" +#else +#define PA_SAMPLE_TYPE paUInt8 +typedef unsigned char SAMPLE; +#define SAMPLE_SILENCE (128) +#define PRINTF_S_FORMAT "%d" +#endif + +typedef struct +{ + int frameIndex; /* Index into sample array. */ + int maxFrameIndex; + SAMPLE *recordedSamples; +} +paTestData; + +/* This routine will be called by the PortAudio engine when audio is needed. +** It may be called at interrupt level on some machines so don't do anything +** that could mess up the system like calling malloc() or free(). +*/ +static int recordCallback( const void *inputBuffer, void *outputBuffer, + unsigned long framesPerBuffer, + const PaStreamCallbackTimeInfo* timeInfo, + PaStreamCallbackFlags statusFlags, + void *userData ) +{ + paTestData *data = (paTestData*)userData; + const SAMPLE *rptr = (const SAMPLE*)inputBuffer; + SAMPLE *wptr = &data->recordedSamples[data->frameIndex * NUM_CHANNELS]; + long framesToCalc; + long i; + int finished; + unsigned long framesLeft = data->maxFrameIndex - data->frameIndex; + + (void) outputBuffer; /* Prevent unused variable warnings. */ + (void) timeInfo; + (void) statusFlags; + (void) userData; +fprintf (stderr, "samples " PRINTF_S_FORMAT " " PRINTF_S_FORMAT " " PRINTF_S_FORMAT " " PRINTF_S_FORMAT "\n", rptr [0], rptr [1], rptr [2], rptr [3]); + if( framesLeft < framesPerBuffer ) + { + framesToCalc = framesLeft; + finished = paComplete; + } + else + { + framesToCalc = framesPerBuffer; + finished = paContinue; + } + + if( inputBuffer == NULL ) + { + for( i=0; iframeIndex += framesToCalc; + return finished; +} + +/* This routine will be called by the PortAudio engine when audio is needed. +** It may be called at interrupt level on some machines so don't do anything +** that could mess up the system like calling malloc() or free(). +*/ +static int playCallback( const void *inputBuffer, void *outputBuffer, + unsigned long framesPerBuffer, + const PaStreamCallbackTimeInfo* timeInfo, + PaStreamCallbackFlags statusFlags, + void *userData ) +{ + paTestData *data = (paTestData*)userData; + SAMPLE *rptr = &data->recordedSamples[data->frameIndex * NUM_CHANNELS]; + SAMPLE *wptr = (SAMPLE*)outputBuffer; + unsigned int i; + int finished; + unsigned int framesLeft = data->maxFrameIndex - data->frameIndex; + + (void) inputBuffer; /* Prevent unused variable warnings. */ + (void) timeInfo; + (void) statusFlags; + (void) userData; + + if( framesLeft < framesPerBuffer ) + { + /* final buffer... */ + for( i=0; iframeIndex += framesLeft; + finished = paComplete; + } + else + { + for( i=0; iframeIndex += framesPerBuffer; + finished = paContinue; + } + return finished; +} + +/*******************************************************************/ +int patest_record (void); +int patest_record (void) +{ + PaStreamParameters inputParameters, + outputParameters; + PaStream* stream; + PaError err = paNoError; + paTestData data; + int i; + int totalFrames; + int numSamples; + int numBytes; + SAMPLE max, val; + double average; + + printf("patest_record.c\n"); fflush(stdout); + + data.maxFrameIndex = totalFrames = NUM_SECONDS * SAMPLE_RATE; /* Record for a few seconds. */ + data.frameIndex = 0; + numSamples = totalFrames * NUM_CHANNELS; + numBytes = numSamples * sizeof(SAMPLE); + data.recordedSamples = (SAMPLE *) malloc( numBytes ); /* From now on, recordedSamples is initialised. */ + if( data.recordedSamples == NULL ) + { + printf("Could not allocate record array.\n"); + goto done; + } + for( i=0; idefaultLowInputLatency; + inputParameters.hostApiSpecificStreamInfo = NULL; + + /* Record some audio. -------------------------------------------- */ + err = Pa_OpenStream( + &stream, + &inputParameters, + NULL, /* &outputParameters, */ + SAMPLE_RATE, + FRAMES_PER_BUFFER, + paClipOff, /* we won't output out of range samples so don't bother clipping them */ + recordCallback, + &data ); + if( err != paNoError ) goto done; + + err = Pa_StartStream( stream ); + if( err != paNoError ) goto done; + printf("\n=== Now recording!! Please speak into the microphone. ===\n"); fflush(stdout); + + while( ( err = Pa_IsStreamActive( stream ) ) == 1 ) + { + Pa_Sleep(1000); + printf("index = %d\n", data.frameIndex ); fflush(stdout); + } + if( err < 0 ) goto done; + + err = Pa_CloseStream( stream ); + if( err != paNoError ) goto done; + + /* Measure maximum peak amplitude. */ + max = 0; + average = 0.0; + for( i=0; i max ) + { + max = val; + } + average += val; + } + + average = average / (double)numSamples; + + printf("sample max amplitude = "PRINTF_S_FORMAT"\n", max ); + printf("sample average = %lf\n", average ); + + /* Write recorded data to a file. */ +#if WRITE_TO_FILE + { + FILE *fid; + fid = fopen("recorded.raw", "wb"); + if( fid == NULL ) + { + printf("Could not open file."); + } + else + { + fwrite( data.recordedSamples, NUM_CHANNELS * sizeof(SAMPLE), totalFrames, fid ); + fclose( fid ); + printf("Wrote data to 'recorded.raw'\n"); + } + } +#endif + + /* Playback recorded data. -------------------------------------------- */ + data.frameIndex = 0; + + outputParameters.device = Pa_GetDefaultOutputDevice(); /* default output device */ + if (outputParameters.device == paNoDevice) { + fprintf(stderr,"Error: No default output device.\n"); + goto done; + } + outputParameters.channelCount = 2; /* stereo output */ + outputParameters.sampleFormat = PA_SAMPLE_TYPE; + outputParameters.suggestedLatency = Pa_GetDeviceInfo( outputParameters.device )->defaultLowOutputLatency; + outputParameters.hostApiSpecificStreamInfo = NULL; + + printf("\n=== Now playing back. ===\n"); fflush(stdout); + err = Pa_OpenStream( + &stream, + NULL, /* no input */ + &outputParameters, + SAMPLE_RATE, + FRAMES_PER_BUFFER, + paClipOff, /* we won't output out of range samples so don't bother clipping them */ + playCallback, + &data ); + if( err != paNoError ) goto done; + + if( stream ) + { + err = Pa_StartStream( stream ); + if( err != paNoError ) goto done; + + printf("Waiting for playback to finish.\n"); fflush(stdout); + + while( ( err = Pa_IsStreamActive( stream ) ) == 1 ) Pa_Sleep(100); + if( err < 0 ) goto done; + + err = Pa_CloseStream( stream ); + if( err != paNoError ) goto done; + + printf("Done.\n"); fflush(stdout); + } + +done: + Pa_Terminate(); + if( data.recordedSamples ) /* Sure it is NULL or valid. */ + free( data.recordedSamples ); + if( err != paNoError ) + { + fprintf( stderr, "An error occured while using the portaudio stream\n" ); + fprintf( stderr, "Error number: %d\n", err ); + fprintf( stderr, "Error message: %s\n", Pa_GetErrorText( err ) ); + err = 1; /* Always return 0 or 1, but no other return codes. */ + } + return err; +} + diff --git a/external/portaudio/portaudio.h b/external/portaudio/portaudio.h index 5e11dad0..738080d4 100644 --- a/external/portaudio/portaudio.h +++ b/external/portaudio/portaudio.h @@ -1,7 +1,7 @@ #ifndef PORTAUDIO_H #define PORTAUDIO_H /* - * $Id: portaudio.h 1859 2012-09-01 00:10:13Z philburk $ + * $Id$ * PortAudio Portable Real-Time Audio Library * PortAudio API Header File * Latest version available at: http://www.portaudio.com/ @@ -50,18 +50,69 @@ extern "C" { #endif /* __cplusplus */ - -/** Retrieve the release number of the currently running PortAudio build, - eg 1900. +/** Retrieve the release number of the currently running PortAudio build. + For example, for version "19.5.1" this will return 0x00130501. + + @see paMakeVersionNumber */ int Pa_GetVersion( void ); - /** Retrieve a textual description of the current PortAudio build, - eg "PortAudio V19-devel 13 October 2002". + e.g. "PortAudio V19.5.0-devel, revision 1952M". + The format of the text may change in the future. Do not try to parse the + returned string. + + @deprecated As of 19.5.0, use Pa_GetVersionInfo()->versionText instead. */ const char* Pa_GetVersionText( void ); +/** + Generate a packed integer version number in the same format used + by Pa_GetVersion(). Use this to compare a specified version number with + the currently running version. For example: + + @code + if( Pa_GetVersion() < paMakeVersionNumber(19,5,1) ) {} + @endcode + + @see Pa_GetVersion, Pa_GetVersionInfo + @version Available as of 19.5.0. +*/ +#define paMakeVersionNumber(major, minor, subminor) \ + (((major)&0xFF)<<16 | ((minor)&0xFF)<<8 | ((subminor)&0xFF)) + + +/** + A structure containing PortAudio API version information. + @see Pa_GetVersionInfo, paMakeVersionNumber + @version Available as of 19.5.0. +*/ +typedef struct PaVersionInfo { + int versionMajor; + int versionMinor; + int versionSubMinor; + /** + This is currently the Git revision hash but may change in the future. + The versionControlRevision is updated by running a script before compiling the library. + If the update does not occur, this value may refer to an earlier revision. + */ + const char *versionControlRevision; + /** Version as a string, for example "PortAudio V19.5.0-devel, revision 1952M" */ + const char *versionText; +} PaVersionInfo; + +/** Retrieve version information for the currently running PortAudio build. + @return A pointer to an immutable PaVersionInfo structure. + + @note This function can be called at any time. It does not require PortAudio + to be initialized. The structure pointed to is statically allocated. Do not + attempt to free it or modify it. + + @see PaVersionInfo, paMakeVersionNumber + @version Available as of 19.5.0. +*/ +const PaVersionInfo* Pa_GetVersionInfo( void ); + /** Error codes returned by PortAudio functions. Note that with the exception of paNoError, all PaErrorCodes are negative. @@ -900,7 +951,7 @@ PaError Pa_CloseStream( PaStream *stream ); (ie once a call to Pa_StopStream() will not block). A stream will become inactive after the stream callback returns non-zero, or when Pa_StopStream or Pa_AbortStream is called. For a stream providing audio - output, if the stream callback returns paComplete, or Pa_StopStream is called, + output, if the stream callback returns paComplete, or Pa_StopStream() is called, the stream finished callback will not be called until all generated sample data has been played. @@ -1098,7 +1149,7 @@ PaError Pa_ReadStream( PaStream* stream, /** Write samples to an output stream. This function doesn't return until the - entire buffer has been consumed - this may involve waiting for the operating + entire buffer has been written - this may involve waiting for the operating system to consume the data. @param stream A pointer to an open stream previously created with Pa_OpenStream. diff --git a/fon/AmplitudeTier.cpp b/fon/AmplitudeTier.cpp index 4babb536..6c44d6de 100644 --- a/fon/AmplitudeTier.cpp +++ b/fon/AmplitudeTier.cpp @@ -103,12 +103,14 @@ autoSound Sound_AmplitudeTier_multiply (Sound me, AmplitudeTier amplitude) { autoAmplitudeTier PointProcess_Sound_to_AmplitudeTier_point (PointProcess me, Sound you) { try { - integer imin, imax, numberOfPeaks = PointProcess_getWindowPoints (me, my xmin, my xmax, & imin, & imax); - if (numberOfPeaks < 3) return autoAmplitudeTier(); + const MelderIntegerRange peaks = PointProcess_getWindowPoints (me, my xmin, my xmax); + if (peaks.size() < 3) + return autoAmplitudeTier(); autoAmplitudeTier him = AmplitudeTier_create (my xmin, my xmax); - for (integer i = imin; i <= imax; i ++) { - double value = Vector_getValueAtX (you, my t [i], Vector_CHANNEL_AVERAGE, Vector_VALUE_INTERPOLATION_SINC700); - if (isdefined (value)) RealTier_addPoint (him.get(), my t [i], value); + for (integer i = peaks.first; i <= peaks.last; i ++) { + const double value = Vector_getValueAtX (you, my t [i], Vector_CHANNEL_AVERAGE, kVector_valueInterpolation :: SINC700); + if (isdefined (value)) + RealTier_addPoint (him.get(), my t [i], value); } return him; } catch (MelderError) { @@ -137,7 +139,8 @@ static double Sound_getPeak (Sound me, double tmin, double tmax, integer channel */ static double Sound_getHannWindowedRms (Sound me, double tmid, double widthLeft, double widthRight) { integer imin, imax; - if (Sampled_getWindowSamples (me, tmid - widthLeft, tmid + widthRight, & imin, & imax) < 3) return undefined; + if (Sampled_getWindowSamples (me, tmid - widthLeft, tmid + widthRight, & imin, & imax) < 3) + return undefined; longdouble sumOfSquares = 0.0, windowSumOfSquares = 0.0; for (integer i = imin; i <= imax; i ++) { double t = my x1 + (i - 1) * my dx; @@ -155,11 +158,11 @@ autoAmplitudeTier PointProcess_Sound_to_AmplitudeTier_period (PointProcess me, S { try { Function_unidirectionalAutowindow (me, & tmin, & tmax); - integer imin, imax; - integer numberOfPeaks = PointProcess_getWindowPoints (me, tmin, tmax, & imin, & imax); - if (numberOfPeaks < 3) Melder_throw (U"Too few pulses between ", tmin, U" and ", tmax, U" seconds."); + const MelderIntegerRange peaks = PointProcess_getWindowPoints (me, tmin, tmax); + if (peaks.size() < 3) + Melder_throw (U"Too few pulses between ", tmin, U" and ", tmax, U" seconds."); autoAmplitudeTier him = AmplitudeTier_create (tmin, tmax); - for (integer i = imin + 1; i < imax; i ++) { + for (integer i = peaks.first + 1; i < peaks.last; i ++) { double p1 = my t [i] - my t [i - 1], p2 = my t [i + 1] - my t [i]; double intervalFactor = p1 > p2 ? p1 / p2 : p2 / p1; if (pmin == pmax || (p1 >= pmin && p1 <= pmax && p2 >= pmin && p2 <= pmax && intervalFactor <= maximumPeriodFactor)) { diff --git a/fon/AmplitudeTierEditor.cpp b/fon/AmplitudeTierEditor.cpp index d08a8b0e..63a6b9b3 100644 --- a/fon/AmplitudeTierEditor.cpp +++ b/fon/AmplitudeTierEditor.cpp @@ -1,6 +1,6 @@ /* AmplitudeTierEditor.cpp * - * Copyright (C) 2003-2011,2012,2014,2015,2016 Paul Boersma + * Copyright (C) 2003-2012,2014-2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,6 +19,8 @@ #include "AmplitudeTierEditor.h" #include "EditorM.h" +Thing_implement (AmplitudeTierArea, RealTierArea, 0); + Thing_implement (AmplitudeTierEditor, RealTierEditor, 0); static void menu_cb_AmplitudeTierHelp (AmplitudeTierEditor /* me */, EDITOR_ARGS_DIRECT) { @@ -30,18 +32,18 @@ void structAmplitudeTierEditor :: v_createHelpMenuItems (EditorMenu menu) { EditorMenu_addCommand (menu, U"AmplitudeTier help", 0, menu_cb_AmplitudeTierHelp); } -void structAmplitudeTierEditor :: v_play (double fromTime, double toTime) { +void structAmplitudeTierEditor :: v_play (double startTime, double endTime) { if (our d_sound.data) { - Sound_playPart (our d_sound.data, fromTime, toTime, theFunctionEditor_playCallback, this); + Sound_playPart (our d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); } else { - //AmplitudeTier_playPart (data, fromTime, toTime, false); + //AmplitudeTier_playPart (data, startTime, endTime, false); } } autoAmplitudeTierEditor AmplitudeTierEditor_create (conststring32 title, AmplitudeTier amplitude, Sound sound, bool ownSound) { try { autoAmplitudeTierEditor me = Thing_new (AmplitudeTierEditor); - RealTierEditor_init (me.get(), title, (RealTier) amplitude, sound, ownSound); + RealTierEditor_init (me.get(), classAmplitudeTierArea, title, amplitude, sound, ownSound); return me; } catch (MelderError) { Melder_throw (U"AmplitudeTier window not created."); diff --git a/fon/AmplitudeTierEditor.h b/fon/AmplitudeTierEditor.h index 950e7e35..1d87e896 100644 --- a/fon/AmplitudeTierEditor.h +++ b/fon/AmplitudeTierEditor.h @@ -2,7 +2,7 @@ #define _AmplitudeTierEditor_h_ /* AmplitudeTierEditor.h * - * Copyright (C) 2003-2011,2012,2014,2015,2017 Paul Boersma + * Copyright (C) 2003-2005,2007,2009-2012,2014-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -22,6 +22,15 @@ #include "AmplitudeTier.h" #include "Sound.h" +Thing_define (AmplitudeTierArea, RealTierArea) { + conststring32 v_rightTickUnits () + override { return U" Pa"; } + double v_defaultYmin () + override { return -1.0; } + double v_defaultYmax () + override { return +1.0; } +}; + Thing_define (AmplitudeTierEditor, RealTierEditor) { void v_createHelpMenuItems (EditorMenu menu) override; @@ -29,12 +38,6 @@ Thing_define (AmplitudeTierEditor, RealTierEditor) { override; conststring32 v_quantityText () override { return U"Sound pressure (Pa)"; } - conststring32 v_rightTickUnits () - override { return U" Pa"; } - double v_defaultYmin () - override { return -1.0; } - double v_defaultYmax () - override { return +1.0; } conststring32 v_setRangeTitle () override { return U"Set amplitude range..."; } conststring32 v_defaultYminText () diff --git a/fon/AnyTier.cpp b/fon/AnyTier.cpp index 201bf27b..df120ac6 100644 --- a/fon/AnyTier.cpp +++ b/fon/AnyTier.cpp @@ -1,6 +1,6 @@ /* AnyTier.cpp * - * Copyright (C) 1992-2005,2007,2008,2011,2015-2018 Paul Boersma + * Copyright (C) 1992-2005,2007,2008,2011,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -60,17 +60,20 @@ void structAnyTier :: v_scaleX (double xminfrom, double xmaxfrom, double xminto, } integer AnyTier_timeToLowIndex (AnyTier me, double time) { - if (my points.size == 0) return 0; // undefined + if (my points.size == 0) + return 0; // undefined integer ileft = 1, iright = my points.size; double tleft = my points.at [ileft] -> number; - if (time < tleft) return 0; // offleft + if (time < tleft) + return 0; // offleft double tright = my points.at [iright] -> number; - if (time >= tright) return iright; + if (time >= tright) + return iright; Melder_assert (time >= tleft && time < tright); Melder_assert (iright > ileft); while (iright > ileft + 1) { - integer imid = (ileft + iright) / 2; - double tmid = my points.at [imid] -> number; + const integer imid = (ileft + iright) / 2; + const double tmid = my points.at [imid] -> number; if (time < tmid) { iright = imid; tright = tmid; @@ -88,17 +91,20 @@ integer AnyTier_timeToLowIndex (AnyTier me, double time) { } integer AnyTier_timeToHighIndex (AnyTier me, double time) { - if (my points.size == 0) return 0; // undefined; is this right? + if (my points.size == 0) + return 0; // undefined; is this right? integer ileft = 1, iright = my points.size; double tleft = my points.at [ileft] -> number; - if (time <= tleft) return 1; + if (time <= tleft) + return 1; double tright = my points.at [iright] -> number; - if (time > tright) return iright + 1; // offright + if (time > tright) + return iright + 1; // offright Melder_assert (time > tleft && time <= tright); Melder_assert (iright > ileft); while (iright > ileft + 1) { - integer imid = (ileft + iright) / 2; - double tmid = my points.at [imid] -> number; + const integer imid = (ileft + iright) / 2; + const double tmid = my points.at [imid] -> number; if (time <= tmid) { iright = imid; tright = tmid; @@ -116,25 +122,32 @@ integer AnyTier_timeToHighIndex (AnyTier me, double time) { } integer AnyTier_getWindowPoints (AnyTier me, double tmin, double tmax, integer *imin, integer *imax) { - if (my points.size == 0) return 0; + if (my points.size == 0) + return 0; *imin = AnyTier_timeToHighIndex (me, tmin); *imax = AnyTier_timeToLowIndex (me, tmax); - if (*imax < *imin) return 0; + if (*imax < *imin) + return 0; return *imax - *imin + 1; } -integer AnyTier_timeToNearestIndex (AnyTier me, double time) { - if (my points.size == 0) return 0; // undefined - integer ileft = 1, iright = my points.size; +integer AnyTier_timeToNearestIndexInIndexWindow (AnyTier me, double time, integer imin, integer imax) { + Melder_assert (imin >= 1); + Melder_assert (imax <= my points.size); + if (imax < imin) + return 0; // undefined + integer ileft = imin, iright = imax; double tleft = my points.at [ileft] -> number; - if (time <= tleft) return 1; + if (time <= tleft) + return ileft; double tright = my points.at [iright] -> number; - if (time >= tright) return iright; + if (time >= tright) + return iright; Melder_assert (time > tleft && time < tright); Melder_assert (iright > ileft); while (iright > ileft + 1) { - integer imid = (ileft + iright) / 2; - double tmid = my points.at [imid] -> number; + const integer imid = (ileft + iright) / 2; + const double tmid = my points.at [imid] -> number; if (time < tmid) { iright = imid; tright = tmid; @@ -144,27 +157,41 @@ integer AnyTier_timeToNearestIndex (AnyTier me, double time) { } } Melder_assert (iright == ileft + 1); - Melder_assert (ileft >= 1); - Melder_assert (iright <= my points.size); + Melder_assert (ileft >= imin); + Melder_assert (iright <= imax); Melder_assert (time >= my points.at [ileft] -> number); Melder_assert (time <= my points.at [iright] -> number); return time - tleft <= tright - time ? ileft : iright; } +integer AnyTier_timeToNearestIndex (AnyTier me, double time) { + return AnyTier_timeToNearestIndexInIndexWindow (me, time, 1, my points.size); +} + +integer AnyTier_timeToNearestIndexInTimeWindow (AnyTier me, double time, double tmin, double tmax) { + integer imin, imax, n = AnyTier_getWindowPoints (me, tmin, tmax, & imin, & imax); + return n == 0 ? 0 : AnyTier_timeToNearestIndexInIndexWindow (me, time, imin, imax); +} + integer AnyTier_hasPoint (AnyTier me, double t) { - if (my points.size == 0) return 0; // point not found + if (my points.size == 0) + return 0; // point not found integer ileft = 1, iright = my points.size; double tleft = my points.at [ileft] -> number; - if (t < tleft) return 0; // offleft + if (t < tleft) + return 0; // offleft double tright = my points.at [iright] -> number; - if (t > tright) return 0; // offright - if (t == tleft) return 1; - if (t == tright) return iright; + if (t > tright) + return 0; // offright + if (t == tleft) + return 1; + if (t == tright) + return iright; Melder_assert (t > tleft && t < tright); Melder_assert (iright > ileft); while (iright > ileft + 1) { - integer imid = (ileft + iright) / 2; - double tmid = my points.at [imid] -> number; + const integer imid = (ileft + iright) / 2; + const double tmid = my points.at [imid] -> number; if (t < tmid) { iright = imid; tright = tmid; @@ -192,16 +219,19 @@ void AnyTier_addPoint_move (AnyTier me, autoAnyPoint point) { } void AnyTier_removePoint (AnyTier me, integer i) { - if (i >= 1 && i <= my points.size) my points. removeItem (i); + if (i >= 1 && i <= my points.size) + my points. removeItem (i); } void AnyTier_removePointNear (AnyTier me, double time) { integer ipoint = AnyTier_timeToNearestIndex (me, time); - if (ipoint) my points.removeItem (ipoint); + if (ipoint > 0) + my points.removeItem (ipoint); } void AnyTier_removePointsBetween (AnyTier me, double tmin, double tmax) { - if (my points.size == 0) return; + if (my points.size == 0) + return; integer ileft = AnyTier_timeToHighIndex (me, tmin); integer iright = AnyTier_timeToLowIndex (me, tmax); for (integer i = iright; i >= ileft; i --) @@ -210,7 +240,7 @@ void AnyTier_removePointsBetween (AnyTier me, double tmin, double tmax) { autoPointProcess AnyTier_downto_PointProcess (AnyTier me) { try { - integer numberOfPoints = my points.size; + const integer numberOfPoints = my points.size; autoPointProcess thee = PointProcess_create (my xmin, my xmax, numberOfPoints); for (integer i = 1; i <= numberOfPoints; i ++) PointProcess_addPoint (thee.get(), my points.at [i] -> number); diff --git a/fon/AnyTier.h b/fon/AnyTier.h index e2b5ec60..83dbd2c4 100644 --- a/fon/AnyTier.h +++ b/fon/AnyTier.h @@ -2,7 +2,7 @@ #define _AnyTier_h_ /* AnyTier.h * - * Copyright (C) 1992-2011,2015,2017 Paul Boersma + * Copyright (C) 1992-2005,2007,2011,2015-2017,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -40,6 +40,8 @@ integer AnyTier_timeToHighIndex (AnyTier me, double time); integer AnyTier_getWindowPoints (AnyTier me, double tmin, double tmax, integer *imin, integer *imax); integer AnyTier_timeToNearestIndex (AnyTier me, double time); +integer AnyTier_timeToNearestIndexInIndexWindow (AnyTier me, double time, integer imin, integer imax); +integer AnyTier_timeToNearestIndexInTimeWindow (AnyTier me, double time, double tmin, double tmax); integer AnyTier_hasPoint (AnyTier me, double t); diff --git a/fon/DurationTier.cpp b/fon/DurationTier.cpp index 332fd95f..7bd2aee8 100644 --- a/fon/DurationTier.cpp +++ b/fon/DurationTier.cpp @@ -1,6 +1,6 @@ /* DurationTier.cpp * - * Copyright (C) 1992-2012,2015,2016,2017 Paul Boersma + * Copyright (C) 1992-2008,2010-2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -42,7 +42,7 @@ autoDurationTier DurationTier_create (double tmin, double tmax) { } void DurationTier_draw (DurationTier me, Graphics g, double tmin, double tmax, - double ymin, double ymax, conststring32 method, int garnish) + double ymin, double ymax, conststring32 method, bool garnish) { RealTier_draw (me, g, tmin, tmax, ymin, ymax, garnish, method, U"Relative duration"); } @@ -50,9 +50,8 @@ void DurationTier_draw (DurationTier me, Graphics g, double tmin, double tmax, autoDurationTier PointProcess_upto_DurationTier (PointProcess me) { try { autoDurationTier thee = DurationTier_create (my xmin, my xmax); - for (integer i = 1; i <= my nt; i ++) { + for (integer i = 1; i <= my nt; i ++) RealTier_addPoint (thee.get(), my t [i], 1.0); - } return thee; } catch (MelderError) { Melder_throw (me, U": not converted to DurationTier."); diff --git a/fon/DurationTier.h b/fon/DurationTier.h index 6eb7f52c..057bf3f5 100644 --- a/fon/DurationTier.h +++ b/fon/DurationTier.h @@ -2,7 +2,7 @@ #define _DurationTier_h_ /* DurationTier.h * - * Copyright (C) 1992-2011,2015 Paul Boersma + * Copyright (C) 1992-2005,2007,2010-2012,2015,2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -33,7 +33,7 @@ Thing_define (DurationTier, RealTier) { autoDurationTier DurationTier_create (double tmin, double tmax); void DurationTier_draw (DurationTier me, Graphics g, double tmin, double tmax, - double ymin, double ymax, conststring32 method, int garnish); + double ymin, double ymax, conststring32 method, bool garnish); autoDurationTier PointProcess_upto_DurationTier (PointProcess me); diff --git a/fon/DurationTierArea.cpp b/fon/DurationTierArea.cpp new file mode 100644 index 00000000..0f71525b --- /dev/null +++ b/fon/DurationTierArea.cpp @@ -0,0 +1,30 @@ +/* DurationTierArea.cpp + * + * Copyright (C) 1992-2012,2014-2016,2018,2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "DurationTierArea.h" + +Thing_implement (DurationTierArea, RealTierArea, 0); + +#include "prefs_define.h" +#include "DurationTierArea_prefs.h" +#include "prefs_install.h" +#include "DurationTierArea_prefs.h" +#include "prefs_copyToInstance.h" +#include "DurationTierArea_prefs.h" + +/* End of file DurationTierArea.cpp */ diff --git a/fon/DurationTierArea.h b/fon/DurationTierArea.h new file mode 100644 index 00000000..cc065a27 --- /dev/null +++ b/fon/DurationTierArea.h @@ -0,0 +1,44 @@ +#ifndef _DurationTierArea_h_ +#define _DurationTierArea_h_ +/* DurationTierArea.h + * + * Copyright (C) 1992-2005,2007,2009-2012,2014-2018,2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "RealTierArea.h" +#include "DurationTier.h" + +Thing_define (DurationTierArea, RealTierArea) { + double v_minimumLegalY () + override { return 0.0; } + conststring32 v_rightTickUnits () + override { return U""; } + double v_defaultYmin () + override { return 0.25; } + double v_defaultYmax () + override { return 3.0; } + + #include "DurationTierArea_prefs.h" +}; + +inline static autoDurationTierArea DurationTierArea_create (FunctionEditor editor, double ymin_fraction, double ymax_fraction) { + autoDurationTierArea me = Thing_new (DurationTierArea); + FunctionArea_init (me.get(), editor, ymin_fraction, ymax_fraction); + return me; +} + +/* End of file DurationTierArea.h */ +#endif diff --git a/fon/DurationTierArea_prefs.h b/fon/DurationTierArea_prefs.h new file mode 100644 index 00000000..b35f7ee6 --- /dev/null +++ b/fon/DurationTierArea_prefs.h @@ -0,0 +1,26 @@ +/* DurationTierArea_prefs.h + * + * Copyright (C) 2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +prefs_begin (DurationTierArea) + + prefs_add_double_with_data (DurationTierArea, minimum, 1, U"0.25") + prefs_add_double_with_data (DurationTierArea, maximum, 1, U"3.0") + +prefs_end (DurationTierArea) + +/* End of file DurationTierArea_prefs.h */ diff --git a/fon/DurationTierEditor.cpp b/fon/DurationTierEditor.cpp index cb956191..75bf1c87 100644 --- a/fon/DurationTierEditor.cpp +++ b/fon/DurationTierEditor.cpp @@ -1,6 +1,6 @@ /* DurationTierEditor.cpp * - * Copyright (C) 1992-2011,2012,2014,2015,2016 Paul Boersma + * Copyright (C) 1992-2012,2014-2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -39,7 +39,7 @@ void structDurationTierEditor :: v_play (double fromTime, double toTime) { autoDurationTierEditor DurationTierEditor_create (conststring32 title, DurationTier duration, Sound sound, bool ownSound) { try { autoDurationTierEditor me = Thing_new (DurationTierEditor); - RealTierEditor_init (me.get(), title, (RealTier) duration, sound, ownSound); + RealTierEditor_init (me.get(), classDurationTierArea, title, duration, sound, ownSound); return me; } catch (MelderError) { Melder_throw (U"DurationTier window not created."); diff --git a/fon/DurationTierEditor.h b/fon/DurationTierEditor.h index 4d025694..709a7180 100644 --- a/fon/DurationTierEditor.h +++ b/fon/DurationTierEditor.h @@ -2,7 +2,7 @@ #define _DurationTierEditor_h_ /* DurationTierEditor.h * - * Copyright (C) 1992-2011,2012,2014,2015,2017 Paul Boersma + * Copyright (C) 1992-2005,2007,2009-2012,2014-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,7 +19,7 @@ */ #include "RealTierEditor.h" -#include "DurationTier.h" +#include "DurationTierArea.h" #include "Sound.h" Thing_define (DurationTierEditor, RealTierEditor) { @@ -27,16 +27,8 @@ Thing_define (DurationTierEditor, RealTierEditor) { override; void v_play (double fromTime, double toTime) override; - double v_minimumLegalValue () - override { return 0.0; } conststring32 v_quantityText () override { return U"Relative duration"; } - conststring32 v_rightTickUnits () - override { return U""; } - double v_defaultYmin () - override { return 0.25; } - double v_defaultYmax () - override { return 3.0; } conststring32 v_setRangeTitle () override { return U"Set duration range..."; } conststring32 v_defaultYminText () diff --git a/fon/Excitation.cpp b/fon/Excitation.cpp index 04d6f77a..5871f313 100644 --- a/fon/Excitation.cpp +++ b/fon/Excitation.cpp @@ -64,7 +64,8 @@ void structExcitation :: v_info () { structDaata :: v_info (); MelderInfo_writeLine (U"Loudness: ", Melder_half (Excitation_getLoudness (this)), U" sones"); for (integer i = 2; i < nx; i ++) if (y [i] > y [i - 1] && y [i] >= y [i + 1]) { - if (++ numberOfMaxima > 15) break; + if (++ numberOfMaxima > 15) + break; double i_real; double strength = NUMimproveMaximum (y, i, NUM_PEAK_INTERPOLATE_SINC70, & i_real); double formant_bark = x1 + (i_real - 1.0) * dx; diff --git a/fon/ExperimentMFC.cpp b/fon/ExperimentMFC.cpp index f1b80634..b3ce4fe7 100644 --- a/fon/ExperimentMFC.cpp +++ b/fon/ExperimentMFC.cpp @@ -98,7 +98,8 @@ static void readSound (ExperimentMFC me, conststring32 fileNameHead, conststring Determine partial file name. */ char32 *comma = str32chr (fileNames, U','); - if (comma) *comma = U'\0'; + if (comma) + *comma = U'\0'; /* Determine complete (relative) file name. */ @@ -157,7 +158,8 @@ static void readSound (ExperimentMFC me, conststring32 fileNameHead, conststring /* Cycle. */ - if (! comma) break; + if (! comma) + break; fileNames = & comma [1]; } } diff --git a/fon/Formant.cpp b/fon/Formant.cpp index 0f43be45..bf77e73c 100644 --- a/fon/Formant.cpp +++ b/fon/Formant.cpp @@ -136,7 +136,7 @@ void Formant_drawTracks (Formant me, Graphics g, double tmin, double tmax, doubl } void Formant_drawSpeckles_inside (Formant me, Graphics g, double tmin, double tmax, double fmin, double fmax, - double suppress_dB) + double suppress_dB, MelderColour oddColour, MelderColour evenColour, bool drawWithContrast) { double maximumIntensity = 0.0, minimumIntensity; Function_unidirectionalAutowindow (me, & tmin, & tmax); @@ -162,12 +162,31 @@ void Formant_drawSpeckles_inside (Formant me, Graphics g, double tmin, double tm continue; for (integer iformant = 1; iformant <= frame -> numberOfFormants; iformant ++) { const double frequency = frame -> formant [iformant]. frequency; - if (frequency >= fmin && frequency <= fmax) - Graphics_speckle (g, x, frequency); + if (frequency >= fmin && frequency <= fmax) { + if (drawWithContrast) { + const double original_speckleSize = Graphics_inqSpeckleSize (g); + Graphics_setSpeckleSize (g, 1.111 * original_speckleSize); + Graphics_setColour (g, iformant % 2 == 1 ? evenColour : oddColour); + Graphics_speckle (g, x, frequency); + Graphics_setSpeckleSize (g, 0.900 * original_speckleSize); + Graphics_setColour (g, iformant % 2 == 1 ? oddColour : evenColour); + Graphics_speckle (g, x, frequency); + Graphics_setSpeckleSize (g, original_speckleSize); + } else { + Graphics_setColour (g, iformant % 2 == 1 ? oddColour : evenColour); + Graphics_speckle (g, x, frequency); + } + } } } } +void Formant_drawSpeckles_inside (Formant me, Graphics g, double tmin, double tmax, double fmin, double fmax, + double suppress_dB) +{ + Formant_drawSpeckles_inside (me, g, tmin, tmax, fmin, fmax, suppress_dB, Graphics_inqColour (g), Graphics_inqColour (g), false); +} + void Formant_drawSpeckles (Formant me, Graphics g, double tmin, double tmax, double fmax, double suppress_dB, bool garnish) { diff --git a/fon/Formant.h b/fon/Formant.h index 57f9dc59..59edf8b5 100644 --- a/fon/Formant.h +++ b/fon/Formant.h @@ -69,6 +69,8 @@ double Formant_getStandardDeviation (Formant me, integer formantNumber, double t void Formant_sort (Formant me); void Formant_drawTracks (Formant me, Graphics graphics, double tmin, double tmax, double fmax, bool garnish); +void Formant_drawSpeckles_inside (Formant me, Graphics graphics, double tmin, double tmax, double fmin, double fmax, + double suppress_dB, MelderColour oddColour, MelderColour evenColour, bool drawWithContrast); void Formant_drawSpeckles_inside (Formant me, Graphics graphics, double tmin, double tmax, double fmin, double fmax, double suppress_dB); void Formant_drawSpeckles (Formant me, Graphics graphics, double tmin, double tmax, double fmax, diff --git a/fon/FormantGridEditor.cpp b/fon/FormantGridEditor.cpp index b5047fa4..36308a1f 100644 --- a/fon/FormantGridEditor.cpp +++ b/fon/FormantGridEditor.cpp @@ -1,6 +1,6 @@ /* FormantGridEditor.cpp * - * Copyright (C) 2008-2011,2012,2013,2014,2015,2016,2017 Paul Boersma & David Weenink + * Copyright (C) 2008-2020 Paul Boersma & David Weenink * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -20,6 +20,8 @@ #include "EditorM.h" #include "PointProcess_and_Sound.h" +Thing_implement (FormantGridArea, RealTierArea, 0); + Thing_implement (FormantGridEditor, FunctionEditor, 0); #include "prefs_define.h" @@ -36,10 +38,7 @@ static void menu_cb_removePoints (FormantGridEditor me, EDITOR_ARGS_DIRECT) { FormantGrid grid = (FormantGrid) my data; OrderedOf* tiers = ( my editingBandwidths ? & grid -> bandwidths : & grid -> formants ); RealTier tier = tiers->at [my selectedFormant]; - if (my startSelection == my endSelection) - AnyTier_removePointNear (tier->asAnyTier(), my startSelection); - else - AnyTier_removePointsBetween (tier->asAnyTier(), my startSelection, my endSelection); + RealTierArea_removePoints (my formantGridArea.get(), tier); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } @@ -49,7 +48,7 @@ static void menu_cb_addPointAtCursor (FormantGridEditor me, EDITOR_ARGS_DIRECT) FormantGrid grid = (FormantGrid) my data; OrderedOf* tiers = ( my editingBandwidths ? & grid -> bandwidths : & grid -> formants ); RealTier tier = tiers->at [my selectedFormant]; - RealTier_addPoint (tier, 0.5 * (my startSelection + my endSelection), my ycursor); + RealTierArea_addPointAtCursor (my formantGridArea.get(), tier); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } @@ -60,13 +59,13 @@ static void menu_cb_addPointAt (FormantGridEditor me, EDITOR_ARGS_FORM) { POSITIVE (frequency, U"Frequency (Hz)", U"200.0") EDITOR_OK SET_REAL (time, 0.5 * (my startSelection + my endSelection)) - SET_REAL (frequency, my ycursor) + SET_REAL (frequency, my formantGridArea -> ycursor) EDITOR_DO Editor_save (me, U"Add point"); FormantGrid grid = (FormantGrid) my data; OrderedOf* tiers = ( my editingBandwidths ? & grid -> bandwidths : & grid -> formants ); RealTier tier = tiers->at [my selectedFormant]; - RealTier_addPoint (tier, time, frequency); + RealTierArea_addPointAt (my formantGridArea.get(), tier, time, frequency); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); EDITOR_END @@ -197,21 +196,20 @@ void structFormantGridEditor :: v_draw () { FormantGrid grid = (FormantGrid) our data; OrderedOf* tiers = ( our editingBandwidths ? & grid -> bandwidths : & grid -> formants ); RealTier selectedTier = tiers->at [our selectedFormant]; - double ymin = our editingBandwidths ? our p_bandwidthFloor : our p_formantFloor; - double ymax = our editingBandwidths ? our p_bandwidthCeiling : our p_formantCeiling; + our formantGridArea -> ymin = ( our editingBandwidths ? our p_bandwidthFloor : our p_formantFloor ); + our formantGridArea -> ymax = ( our editingBandwidths ? our p_bandwidthCeiling : our p_formantCeiling ); + + our formantGridArea -> setViewport(); + Graphics_setColour (our graphics.get(), Melder_WHITE); Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, ymin, ymax); + Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, our formantGridArea -> ymin, our formantGridArea -> ymax); Graphics_setColour (our graphics.get(), Melder_RED); - Graphics_line (our graphics.get(), our startWindow, our ycursor, our endWindow, our ycursor); + //Graphics_line (our graphics.get(), our startWindow, our formantGridArea -> ycursor, our endWindow, our formantGridArea -> ycursor); Graphics_setTextAlignment (our graphics.get(), Graphics_RIGHT, Graphics_HALF); - Graphics_text (our graphics.get(), our startWindow, our ycursor, Melder_float (Melder_half (our ycursor))); - Graphics_setColour (our graphics.get(), Melder_BLUE); - Graphics_setTextAlignment (our graphics.get(), Graphics_LEFT, Graphics_TOP); - Graphics_text (our graphics.get(), our endWindow, ymax, Melder_float (Melder_half (ymax)), U" Hz"); - Graphics_setTextAlignment (our graphics.get(), Graphics_LEFT, Graphics_HALF); - Graphics_text (our graphics.get(), our endWindow, ymin, Melder_float (Melder_half (ymin)), U" Hz"); + //Graphics_text (our graphics.get(), our startWindow, our formantGridArea -> ycursor, + // Melder_float (Melder_half (our formantGridArea -> ycursor))); Graphics_setLineWidth (our graphics.get(), 1.0); Graphics_setColour (our graphics.get(), Melder_GREY); for (integer iformant = 1; iformant <= grid -> formants.size; iformant ++) if (iformant != our selectedFormant) { @@ -224,209 +222,55 @@ void structFormantGridEditor :: v_draw () { double yleft = RealTier_getValueAtTime (tier, our startWindow); double yright = RealTier_getValueAtTime (tier, our endWindow); Graphics_line (our graphics.get(), our startWindow, yleft, our endWindow, yright); - } else for (integer i = imin; i <= imax; i ++) { - RealPoint point = tier -> points.at [i]; - double t = point -> number, y = point -> value; - Graphics_fillCircle_mm (our graphics.get(), t, y, 2.0); - if (i == 1) - Graphics_line (our graphics.get(), our startWindow, y, t, y); - else if (i == imin) - Graphics_line (our graphics.get(), t, y, our startWindow, RealTier_getValueAtTime (tier, our startWindow)); - if (i == n) - Graphics_line (our graphics.get(), t, y, our endWindow, y); - else if (i == imax) - Graphics_line (our graphics.get(), t, y, our endWindow, RealTier_getValueAtTime (tier, our endWindow)); - else { - RealPoint pointRight = tier -> points.at [i + 1]; - Graphics_line (our graphics.get(), t, y, pointRight -> number, pointRight -> value); + } else { + for (integer i = imin; i <= imax; i ++) { + RealPoint point = tier -> points.at [i]; + double t = point -> number, y = point -> value; + Graphics_fillCircle_mm (our graphics.get(), t, y, 2.0); + if (i == 1) + Graphics_line (our graphics.get(), our startWindow, y, t, y); + else if (i == imin) + Graphics_line (our graphics.get(), t, y, our startWindow, RealTier_getValueAtTime (tier, our startWindow)); + if (i == n) + Graphics_line (our graphics.get(), t, y, our endWindow, y); + else if (i == imax) + Graphics_line (our graphics.get(), t, y, our endWindow, RealTier_getValueAtTime (tier, our endWindow)); + else { + RealPoint pointRight = tier -> points.at [i + 1]; + Graphics_line (our graphics.get(), t, y, pointRight -> number, pointRight -> value); + } } } } - Graphics_setColour (our graphics.get(), Melder_BLUE); - integer ifirstSelected = AnyTier_timeToHighIndex (selectedTier->asAnyTier(), our startSelection); - integer ilastSelected = AnyTier_timeToLowIndex (selectedTier->asAnyTier(), our endSelection); - integer n = selectedTier -> points.size; - integer imin = AnyTier_timeToHighIndex (selectedTier->asAnyTier(), our startWindow); - integer imax = AnyTier_timeToLowIndex (selectedTier->asAnyTier(), our endWindow); - Graphics_setLineWidth (our graphics.get(), 2.0); - if (n == 0) { - Graphics_setTextAlignment (our graphics.get(), Graphics_CENTRE, Graphics_HALF); - Graphics_text (our graphics.get(), 0.5 * (our startWindow + our endWindow), - 0.5 * (ymin + ymax), U"(no points in selected formant tier)"); - } else if (imax < imin) { - double yleft = RealTier_getValueAtTime (selectedTier, our startWindow); - double yright = RealTier_getValueAtTime (selectedTier, our endWindow); - Graphics_line (our graphics.get(), our startWindow, yleft, our endWindow, yright); - } else for (integer i = imin; i <= imax; i ++) { - RealPoint point = selectedTier -> points.at [i]; - double t = point -> number, y = point -> value; - if (i >= ifirstSelected && i <= ilastSelected) - Graphics_setColour (our graphics.get(), Melder_RED); - Graphics_fillCircle_mm (our graphics.get(), t, y, 3); - Graphics_setColour (our graphics.get(), Melder_BLUE); - if (i == 1) - Graphics_line (our graphics.get(), our startWindow, y, t, y); - else if (i == imin) - Graphics_line (our graphics.get(), t, y, our startWindow, RealTier_getValueAtTime (selectedTier, our startWindow)); - if (i == n) - Graphics_line (our graphics.get(), t, y, our endWindow, y); - else if (i == imax) - Graphics_line (our graphics.get(), t, y, our endWindow, RealTier_getValueAtTime (selectedTier, our endWindow)); - else { - RealPoint pointRight = selectedTier -> points.at [i + 1]; - Graphics_line (our graphics.get(), t, y, pointRight -> number, pointRight -> value); - } - } - Graphics_setLineWidth (our graphics.get(), 1.0); - Graphics_setColour (our graphics.get(), Melder_BLACK); -} - -static void drawWhileDragging (FormantGridEditor me, double /* xWC */, double /* yWC */, integer first, integer last, double dt, double dy) { - FormantGrid grid = (FormantGrid) my data; - OrderedOf* tiers = my editingBandwidths ? & grid -> bandwidths : & grid -> formants; - RealTier tier = tiers->at [my selectedFormant]; - double ymin = my editingBandwidths ? my p_bandwidthFloor : my p_formantFloor; - double ymax = my editingBandwidths ? my p_bandwidthCeiling : my p_formantCeiling; - - /* - * Draw all selected points as magenta empty circles, if inside the window. - */ - for (integer i = first; i <= last; i ++) { - RealPoint point = tier -> points.at [i]; - double t = point -> number + dt, y = point -> value + dy; - if (t >= my startWindow && t <= my endWindow) - Graphics_circle_mm (my graphics.get(), t, y, 3.0); - } - - if (last == first) { - /* - * Draw a crosshair with time and y. - */ - RealPoint point = tier -> points.at [first]; - double t = point -> number + dt, y = point -> value + dy; - Graphics_line (my graphics.get(), t, ymin, t, ymax - Graphics_dyMMtoWC (my graphics.get(), 4.0)); - Graphics_setTextAlignment (my graphics.get(), kGraphics_horizontalAlignment::CENTRE, Graphics_TOP); - Graphics_text (my graphics.get(), t, ymax, Melder_fixed (t, 6)); - Graphics_line (my graphics.get(), my startWindow, y, my endWindow, y); - Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_BOTTOM); - Graphics_text (my graphics.get(), my startWindow, y, Melder_fixed (y, 6)); - } + RealTierArea_draw (our formantGridArea.get(), selectedTier); + if (isdefined (our formantGridArea -> anchorTime)) + RealTierArea_drawWhileDragging (our formantGridArea.get(), selectedTier); } -bool structFormantGridEditor :: v_click (double xWC, double yWC, bool shiftKeyPressed) { +bool structFormantGridEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double globalY_fraction) { FormantGrid grid = (FormantGrid) our data; OrderedOf* tiers = our editingBandwidths ? & grid -> bandwidths : & grid -> formants; RealTier tier = tiers->at [selectedFormant]; - double ymin = our editingBandwidths ? our p_bandwidthFloor : our p_formantFloor; - double ymax = our editingBandwidths ? our p_bandwidthCeiling : our p_formantCeiling; - integer inearestPoint, ifirstSelected, ilastSelected; - RealPoint nearestPoint; - double dt = 0, df = 0; - bool draggingSelection; - - /* - * Perform the default action: move cursor. - */ - //our startSelection = our endSelection = xWC; - our ycursor = (1.0 - yWC) * ymin + yWC * ymax; - Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, ymin, ymax); - yWC = our ycursor; - - /* - * Clicked on a point? - */ - inearestPoint = AnyTier_timeToNearestIndex (tier->asAnyTier(), xWC); - if (inearestPoint == 0) { - return FormantGridEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - nearestPoint = tier -> points.at [inearestPoint]; - if (Graphics_distanceWCtoMM (our graphics.get(), xWC, yWC, nearestPoint -> number, nearestPoint -> value) > 1.5) { - return our FormantGridEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - - /* - * Clicked on a selected point? - */ - draggingSelection = shiftKeyPressed && - nearestPoint -> number > our startSelection && nearestPoint -> number < our endSelection; - if (draggingSelection) { - ifirstSelected = AnyTier_timeToHighIndex (tier->asAnyTier(), our startSelection); - ilastSelected = AnyTier_timeToLowIndex (tier->asAnyTier(), our endSelection); - Editor_save (this, U"Drag points"); + our formantGridArea -> ymin = ( our editingBandwidths ? our p_bandwidthFloor : our p_formantFloor ); + our formantGridArea -> ymax = ( our editingBandwidths ? our p_bandwidthCeiling : our p_formantCeiling ); + + static bool clickedInWideRealTierArea = false; + if (event -> isClick ()) + clickedInWideRealTierArea = our formantGridArea -> y_fraction_globalIsInside (globalY_fraction); + bool result = false; + if (clickedInWideRealTierArea) { + our formantGridArea -> setViewport (); + result = RealTierArea_mouse (our formantGridArea.get(), tier, event, x_world, globalY_fraction); } else { - ifirstSelected = ilastSelected = inearestPoint; - Editor_save (this, U"Drag point"); - } - - /* - * Drag. - */ - Graphics_xorOn (our graphics.get(), Melder_MAROON); - drawWhileDragging (this, xWC, yWC, ifirstSelected, ilastSelected, dt, df); - while (Graphics_mouseStillDown (our graphics.get())) { - double xWC_new, yWC_new; - Graphics_getMouseLocation (our graphics.get(), & xWC_new, & yWC_new); - if (xWC_new != xWC || yWC_new != yWC) { - drawWhileDragging (this, xWC, yWC, ifirstSelected, ilastSelected, dt, df); - dt += xWC_new - xWC, df += yWC_new - yWC; - xWC = xWC_new, yWC = yWC_new; - drawWhileDragging (this, xWC, yWC, ifirstSelected, ilastSelected, dt, df); - } + result = our FormantGridEditor_Parent :: v_mouseInWideDataView (event, x_world, globalY_fraction); } - Graphics_xorOff (our graphics.get()); - - /* - * Dragged inside window? - */ - if (xWC < our startWindow || xWC > our endWindow) return 1; - - /* - * Points not dragged past neighbours? - */ - double newTime = tier -> points.at [ifirstSelected] -> number + dt; - if (newTime < our tmin) return 1; // outside domain - if (ifirstSelected > 1 && newTime <= tier -> points.at [ifirstSelected - 1] -> number) - return 1; // past left neighbour - newTime = tier -> points.at [ilastSelected] -> number + dt; - if (newTime > our tmax) return 1; // outside domain - if (ilastSelected < tier -> points.size && newTime >= tier -> points.at [ilastSelected + 1] -> number) - return FunctionEditor_UPDATE_NEEDED; // past right neighbour - - /* - * Drop. - */ - for (integer i = ifirstSelected; i <= ilastSelected; i ++) { - RealPoint point = tier -> points.at [i]; - point -> number += dt; - point -> value += df; - } - - /* - * Make sure that the same points are still selected (a problem with Undo...). - */ - - if (draggingSelection) our startSelection += dt, our endSelection += dt; - if (ifirstSelected == ilastSelected) { - /* - * Move crosshair to only selected formant point. - */ - RealPoint point = tier -> points.at [ifirstSelected]; - our startSelection = our endSelection = point -> number; - our ycursor = point -> value; - } else { - /* - * Move crosshair to mouse location. - */ - /*our cursor += dt;*/ - our ycursor += df; - } - - Editor_broadcastDataChanged (this); - return FunctionEditor_UPDATE_NEEDED; + if (event -> isDrop()) + clickedInWideRealTierArea = false; + return result; } -void structFormantGridEditor :: v_play (double tmin, double tmax) { - FormantGrid_playPart ((FormantGrid) our data, tmin, tmax, our p_play_samplingFrequency, +void structFormantGridEditor :: v_play (double startTime, double endTime) { + FormantGrid_playPart ((FormantGrid) our data, startTime, endTime, our p_play_samplingFrequency, our p_source_pitch_tStart, our p_source_pitch_f0Start, our p_source_pitch_tMid, our p_source_pitch_f0Mid, our p_source_pitch_tEnd, our p_source_pitch_f0End, @@ -440,8 +284,10 @@ void FormantGridEditor_init (FormantGridEditor me, conststring32 title, FormantG Melder_assert (data); Melder_assert (Thing_isa (data, classFormantGrid)); FunctionEditor_init (me, title, data); - my ycursor = 0.382 * my p_formantFloor + 0.618 * my p_formantCeiling; my selectedFormant = 1; + my formantGridArea = Thing_new (FormantGridArea); + FunctionArea_init (my formantGridArea.get(), me, 0.0, 1.0); + my formantGridArea -> ycursor = 0.382 * my p_formantFloor + 0.618 * my p_formantCeiling; } autoFormantGridEditor FormantGridEditor_create (conststring32 title, FormantGrid data) { diff --git a/fon/FormantGridEditor.h b/fon/FormantGridEditor.h index 3770173f..df777db8 100644 --- a/fon/FormantGridEditor.h +++ b/fon/FormantGridEditor.h @@ -2,7 +2,7 @@ #define _FormantGridEditor_h_ /* FormantGridEditor.h * - * Copyright (C) 2008-2011,2012,2013,2015,2017 Paul Boersma & David Weenink + * Copyright (C) 2008-2018,2020 Paul Boersma & David Weenink * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -20,20 +20,25 @@ #include "FunctionEditor.h" #include "FormantGrid.h" +#include "RealTierArea.h" + +Thing_define (FormantGridArea, RealTierArea) { +}; Thing_define (FormantGridEditor, FunctionEditor) { + autoFormantGridArea formantGridArea; + bool editingBandwidths; GuiMenuItem d_bandwidthsToggle; integer selectedFormant; - double ycursor; void v_createMenus () override; void v_draw () override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double globalY_fraction) override; - void v_play (double tmin, double tmax) + void v_play (double startTime, double endTime) override; virtual bool v_hasSourceMenu () { return true; } diff --git a/fon/FunctionArea.cpp b/fon/FunctionArea.cpp new file mode 100644 index 00000000..72a1ebec --- /dev/null +++ b/fon/FunctionArea.cpp @@ -0,0 +1,23 @@ +/* FunctionArea.cpp + * + * Copyright (C) 1992-2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "FunctionArea.h" + +Thing_implement (FunctionArea, Thing, 0); + +/* End of file FunctionArea.cpp */ diff --git a/fon/FunctionArea.h b/fon/FunctionArea.h new file mode 100644 index 00000000..a1f2b9a3 --- /dev/null +++ b/fon/FunctionArea.h @@ -0,0 +1,66 @@ +#ifndef _FunctionArea_h_ +#define _FunctionArea_h_ +/* FunctionArea.h + * + * Copyright (C) 1992-2005,2007-2012,2015-2018,2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "FunctionEditor.h" + +Thing_define (FunctionArea, Thing) { + FunctionEditor editor; + double ymin_fraction, ymax_fraction; + Graphics graphics() const { return our editor -> graphics.get(); } + double startWindow() const { return our editor -> startWindow; } + double endWindow() const { return our editor -> endWindow; } + double startSelection() const { return our editor -> startSelection; } + double endSelection() const { return our editor -> endSelection; } + bool y_fraction_globalIsInside (double globalY_fraction) const { + const double y_pxlt = globalY_fraction_to_pxlt (globalY_fraction); + return y_pxlt >= our bottom_pxlt() && y_pxlt <= our top_pxlt(); + } + void setViewport() const { + Graphics_setViewport (our graphics(), our left_pxlt(), our right_pxlt(), our bottom_pxlt(), our top_pxlt()); + } + double y_fraction_globalToLocal (double globalY_fraction) const { + const double y_pxlt = globalY_fraction_to_pxlt (globalY_fraction); + return (y_pxlt - our bottom_pxlt()) / (our top_pxlt() - our bottom_pxlt()); + } +private: + double globalY_fraction_to_pxlt (double globalY_fraction) const { + return our editor -> dataBottom_pxlt() + + globalY_fraction * (our editor -> dataTop_pxlt() - our editor -> dataBottom_pxlt()); + } + double left_pxlt() const { return our editor -> dataLeft_pxlt(); } + double right_pxlt() const { return our editor -> dataRight_pxlt(); } + double verticalSpacing_pxlt() const { return 11; } + double bottom_pxlt() const { + const double bottomSpacing_pxlt = ( our ymin_fraction == 0.0 ? 0.0 : our verticalSpacing_pxlt() ); + return globalY_fraction_to_pxlt (our ymin_fraction) + bottomSpacing_pxlt; + } + double top_pxlt() const { + return globalY_fraction_to_pxlt (our ymax_fraction) - our verticalSpacing_pxlt(); + } +}; + +inline static void FunctionArea_init (FunctionArea me, FunctionEditor editor, double ymin_fraction, double ymax_fraction) { + my editor = editor; + my ymin_fraction = ymin_fraction; + my ymax_fraction = ymax_fraction; +} + +/* End of file FunctionArea.h */ +#endif diff --git a/fon/FunctionEditor.cpp b/fon/FunctionEditor.cpp index d5577947..35d5fd44 100644 --- a/fon/FunctionEditor.cpp +++ b/fon/FunctionEditor.cpp @@ -23,18 +23,6 @@ Thing_implement (FunctionEditor, Editor, 0); -#define maximumScrollBarValue 2000000000 -#define RELATIVE_PAGE_INCREMENT 0.8 -#define SCROLL_INCREMENT_FRACTION 20 -#define space 30 -#define MARGIN 107 -#define BOTTOM_MARGIN 2 -#define TOP_MARGIN 3 -#define TEXT_HEIGHT 50 -#define BUTTON_X 3 -#define BUTTON_WIDTH 40 -#define BUTTON_SPACING 8 - #include "prefs_define.h" #include "FunctionEditor_prefs.h" #include "prefs_install.h" @@ -42,14 +30,21 @@ Thing_implement (FunctionEditor, Editor, 0); #include "prefs_copyToInstance.h" #include "FunctionEditor_prefs.h" + namespace { + constexpr double maximumScrollBarValue = 2000000000; + constexpr double RELATIVE_PAGE_INCREMENT = 0.8; + constexpr double SCROLL_INCREMENT_FRACTION = 20.0; + constexpr int TEXT_HEIGHT = 50; + constexpr int BUTTON_X = 3; + constexpr int BUTTON_WIDTH = 40; + constexpr int BUTTON_SPACING = 8; + constexpr integer THE_MAXIMUM_GROUP_SIZE = 100; integer theGroupSize = 0; FunctionEditor theGroupMembers [1 + THE_MAXIMUM_GROUP_SIZE]; } -static void drawWhileDragging (FunctionEditor me, double x1, double x2); - static bool group_equalDomain (double tmin, double tmax) { if (theGroupSize == 0) return true; @@ -61,8 +56,8 @@ static bool group_equalDomain (double tmin, double tmax) { static void updateScrollBar (FunctionEditor me) { /* We cannot call this immediately after creation. */ - const double slider_size = std::max (1.0, (my endWindow - my startWindow) / (my tmax - my tmin) * maximumScrollBarValue - 1.0); - const double value = std::min (std::max (1.0, (my startWindow - my tmin) / (my tmax - my tmin) * maximumScrollBarValue + 1.0), maximumScrollBarValue - slider_size); + const double slider_size = Melder_clippedLeft (1.0, (my endWindow - my startWindow) / (my tmax - my tmin) * maximumScrollBarValue - 1.0); + const double value = Melder_clipped (1.0, (my startWindow - my tmin) / (my tmax - my tmin) * maximumScrollBarValue + 1.0, maximumScrollBarValue - slider_size); const double increment = slider_size / SCROLL_INCREMENT_FRACTION + 1.0; const double page_increment = RELATIVE_PAGE_INCREMENT * slider_size + 1.0; GuiScrollBar_set (my scrollBar, undefined, maximumScrollBarValue, value, slider_size, increment, page_increment); @@ -74,7 +69,7 @@ static void updateGroup (FunctionEditor me) { for (integer i = 1; i <= THE_MAXIMUM_GROUP_SIZE; i ++) { if (theGroupMembers [i] && theGroupMembers [i] != me) { FunctionEditor thee = theGroupMembers [i]; - if (my pref_synchronizedZoomAndScroll ()) { + if (my pref_synchronizedZoomAndScroll()) { thy startWindow = my startWindow; thy endWindow = my endWindow; } @@ -87,286 +82,276 @@ static void updateGroup (FunctionEditor me) { } } -static void drawNow (FunctionEditor me) { - const bool leftFromWindow = ( my startWindow > my tmin ); - const bool rightFromWindow = ( my endWindow < my tmax ); - const bool cursorIsVisible = ( my startSelection == my endSelection && my startSelection >= my startWindow && my startSelection <= my endWindow ); - const bool selectionIsNonempty = ( my endSelection > my startSelection ); +void structFunctionEditor :: draw () { + const bool leftFromWindow = ( our startWindow > our tmin ); + const bool rightFromWindow = ( our endWindow < our tmax ); + const bool cursorIsVisible = ( our startSelection == our endSelection && our startSelection >= our startWindow && our startSelection <= our endWindow ); + const bool selectionIsNonempty = ( our endSelection > our startSelection ); /* Update selection. */ - const bool startIsVisible = ( my startSelection > my startWindow && my startSelection < my endWindow ); - const bool endIsVisible = ( my endSelection > my startWindow && my endSelection < my endWindow ); + const bool startIsVisible = ( our startSelection > our startWindow && our startSelection < our endWindow ); + const bool endIsVisible = ( our endSelection > our startWindow && our endSelection < our endWindow ); /* Update markers. */ - my numberOfMarkers = 0; + our numberOfMarkers = 0; if (startIsVisible) - my marker [++ my numberOfMarkers] = my startSelection; - if (endIsVisible && my endSelection != my startSelection) - my marker [++ my numberOfMarkers] = my endSelection; - my marker [++ my numberOfMarkers] = my endWindow; - VECsort_inplace (VEC (& my marker [1], my numberOfMarkers)); + our marker [++ our numberOfMarkers] = our startSelection; + if (endIsVisible && our endSelection != our startSelection) + our marker [++ our numberOfMarkers] = our endSelection; + our marker [++ our numberOfMarkers] = our endWindow; + VECsort_inplace (VEC (& our marker [1], our numberOfMarkers)); /* Update rectangles. */ for (integer i = 0; i < 8; i++) - my rect [i]. left = my rect [i]. right = 0; + our rect [i]. left = our rect [i]. right = 0; /* 0: rectangle for total. */ - my rect [0]. left = my functionViewerLeft + ( leftFromWindow ? 0 : MARGIN ); - my rect [0]. right = my functionViewerRight - ( rightFromWindow ? 0 : MARGIN ); - my rect [0]. bottom = BOTTOM_MARGIN; - my rect [0]. top = BOTTOM_MARGIN + space; + our rect [0]. left = our functionViewerLeft + ( leftFromWindow ? 0 : MARGIN ); + our rect [0]. right = our functionViewerRight - ( rightFromWindow ? 0 : MARGIN ); + our rect [0]. bottom = BOTTOM_MARGIN; + our rect [0]. top = BOTTOM_MARGIN + space; /* 1: rectangle for visible part. */ - my rect [1]. left = my functionViewerLeft + MARGIN; - my rect [1]. right = my functionViewerRight - MARGIN; - my rect [1]. bottom = BOTTOM_MARGIN + space; - my rect [1]. top = BOTTOM_MARGIN + space * ( my numberOfMarkers > 1 ? 2 : 3 ); + our rect [1]. left = our functionViewerLeft + MARGIN; + our rect [1]. right = our functionViewerRight - MARGIN; + our rect [1]. bottom = BOTTOM_MARGIN + space; + our rect [1]. top = BOTTOM_MARGIN + space * ( our numberOfMarkers > 1 ? 2 : 3 ); /* 2: rectangle for left from visible part. */ if (leftFromWindow) { - my rect [2]. left = my functionViewerLeft; - my rect [2]. right = my functionViewerLeft + MARGIN; - my rect [2]. bottom = BOTTOM_MARGIN + space; - my rect [2]. top = BOTTOM_MARGIN + space * 2; + our rect [2]. left = our functionViewerLeft; + our rect [2]. right = our functionViewerLeft + MARGIN; + our rect [2]. bottom = BOTTOM_MARGIN + space; + our rect [2]. top = BOTTOM_MARGIN + space * 2; } /* 3: rectangle for right from visible part. */ if (rightFromWindow) { - my rect [3]. left = my functionViewerRight - MARGIN; - my rect [3]. right = my functionViewerRight; - my rect [3]. bottom = BOTTOM_MARGIN + space; - my rect [3]. top = BOTTOM_MARGIN + space * 2; + our rect [3]. left = our functionViewerRight - MARGIN; + our rect [3]. right = our functionViewerRight; + our rect [3]. bottom = BOTTOM_MARGIN + space; + our rect [3]. top = BOTTOM_MARGIN + space * 2; } /* 4, 5, 6: rectangles between markers visible in visible part. */ - if (my numberOfMarkers > 1) { - const double window = my endWindow - my startWindow; - for (integer i = 1; i <= my numberOfMarkers; i ++) { - my rect [3 + i]. left = i == 1 ? my functionViewerLeft + MARGIN : my functionViewerLeft + MARGIN + (my functionViewerRight - my functionViewerLeft - MARGIN * 2) * - (my marker [i - 1] - my startWindow) / window; - my rect [3 + i]. right = my functionViewerLeft + MARGIN + (my functionViewerRight - my functionViewerLeft - MARGIN * 2) * - (my marker [i] - my startWindow) / window; - my rect [3 + i]. bottom = BOTTOM_MARGIN + space * 2; - my rect [3 + i]. top = BOTTOM_MARGIN + space * 3; + if (our numberOfMarkers > 1) { + const double window = our endWindow - our startWindow; + for (integer i = 1; i <= our numberOfMarkers; i ++) { + our rect [3 + i]. left = i == 1 ? our functionViewerLeft + MARGIN : our functionViewerLeft + MARGIN + (our functionViewerRight - our functionViewerLeft - MARGIN * 2) * + (our marker [i - 1] - our startWindow) / window; + our rect [3 + i]. right = our functionViewerLeft + MARGIN + (our functionViewerRight - our functionViewerLeft - MARGIN * 2) * + (our marker [i] - our startWindow) / window; + our rect [3 + i]. bottom = BOTTOM_MARGIN + space * 2; + our rect [3 + i]. top = BOTTOM_MARGIN + space * 3; } } if (selectionIsNonempty) { - const double window = my endWindow - my startWindow; + const double window = our endWindow - our startWindow; const double left = - my startSelection == my startWindow ? my functionViewerLeft + MARGIN : - my startSelection == my tmin ? my functionViewerLeft : - my startSelection < my startWindow ? my functionViewerLeft + MARGIN * 0.3 : - my startSelection < my endWindow ? my functionViewerLeft + MARGIN + (my functionViewerRight - my functionViewerLeft - MARGIN * 2) * (my startSelection - my startWindow) / window : - my startSelection == my endWindow ? my functionViewerRight - MARGIN : my functionViewerRight - MARGIN * 0.7; + our startSelection == our startWindow ? our functionViewerLeft + MARGIN : + our startSelection == our tmin ? our functionViewerLeft : + our startSelection < our startWindow ? our functionViewerLeft + MARGIN * 0.3 : + our startSelection < our endWindow ? our functionViewerLeft + MARGIN + (our functionViewerRight - our functionViewerLeft - MARGIN * 2) * (our startSelection - our startWindow) / window : + our startSelection == our endWindow ? our functionViewerRight - MARGIN : our functionViewerRight - MARGIN * 0.7; const double right = - my endSelection < my startWindow ? my functionViewerLeft + MARGIN * 0.7 : - my endSelection == my startWindow ? my functionViewerLeft + MARGIN : - my endSelection < my endWindow ? my functionViewerLeft + MARGIN + (my functionViewerRight - my functionViewerLeft - MARGIN * 2) * (my endSelection - my startWindow) / window : - my endSelection == my endWindow ? my functionViewerRight - MARGIN : - my endSelection < my tmax ? my functionViewerRight - MARGIN * 0.3 : my functionViewerRight; - my rect [7]. left = left; - my rect [7]. right = right; - my rect [7]. bottom = my height - space - TOP_MARGIN; - my rect [7]. top = my height - TOP_MARGIN; + our endSelection < our startWindow ? our functionViewerLeft + MARGIN * 0.7 : + our endSelection == our startWindow ? our functionViewerLeft + MARGIN : + our endSelection < our endWindow ? our functionViewerLeft + MARGIN + (our functionViewerRight - our functionViewerLeft - MARGIN * 2) * (our endSelection - our startWindow) / window : + our endSelection == our endWindow ? our functionViewerRight - MARGIN : + our endSelection < our tmax ? our functionViewerRight - MARGIN * 0.3 : our functionViewerRight; + our rect [7]. left = left; + our rect [7]. right = right; + our rect [7]. bottom = our height_pxlt - space - TOP_MARGIN; + our rect [7]. top = our height_pxlt - TOP_MARGIN; } /* - Be responsive: update the markers now. + Window background. */ - Graphics_setViewport (my graphics.get(), my functionViewerLeft, my functionViewerRight, 0.0, my height); - Graphics_setWindow (my graphics.get(), my functionViewerLeft, my functionViewerRight, 0.0, my height); - Graphics_setColour (my graphics.get(), Melder_WINDOW_BACKGROUND_COLOUR); - Graphics_fillRectangle (my graphics.get(), my functionViewerLeft + MARGIN, my selectionViewerRight - MARGIN, my height - (TOP_MARGIN + space), my height); - Graphics_fillRectangle (my graphics.get(), my functionViewerLeft, my functionViewerLeft + MARGIN, BOTTOM_MARGIN + ( leftFromWindow ? space * 2 : 0 ), my height); - Graphics_fillRectangle (my graphics.get(), my functionViewerRight - MARGIN, my functionViewerRight, BOTTOM_MARGIN + ( rightFromWindow ? space * 2 : 0 ), my height); - if (my p_showSelectionViewer) { - Graphics_setViewport (my graphics.get(), my selectionViewerLeft, my selectionViewerRight, 0.0, my height); - Graphics_setWindow (my graphics.get(), my selectionViewerLeft, my selectionViewerRight, 0.0, my height); - Graphics_fillRectangle (my graphics.get(), my selectionViewerLeft, my selectionViewerLeft + MARGIN, BOTTOM_MARGIN, my height); - Graphics_fillRectangle (my graphics.get(), my selectionViewerRight - MARGIN, my selectionViewerRight, BOTTOM_MARGIN, my height); - Graphics_fillRectangle (my graphics.get(), my selectionViewerLeft + MARGIN, my selectionViewerRight - MARGIN, 0, BOTTOM_MARGIN + space * 3); - } - Graphics_setGrey (my graphics.get(), 0.0); - #if defined (macintosh) - Graphics_line (my graphics.get(), my functionViewerLeft, 2.0, my selectionViewerRight, 2.0); - Graphics_line (my graphics.get(), my functionViewerLeft, my height - 2.0, my selectionViewerRight, my height - 2.0); - #endif + our viewAllAsPixelettes (); + Graphics_setColour (our graphics.get(), Melder_WINDOW_BACKGROUND_COLOUR); + Graphics_fillRectangle (our graphics.get(), our functionViewerLeft, our selectionViewerRight, BOTTOM_MARGIN, our height_pxlt); + Graphics_setColour (our graphics.get(), Melder_BLACK); - Graphics_setViewport (my graphics.get(), my functionViewerLeft, my functionViewerRight, 0.0, my height); - Graphics_setWindow (my graphics.get(), my functionViewerLeft, my functionViewerRight, 0.0, my height); - Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_HALF); + our viewFunctionViewerAsPixelettes (); + Graphics_setTextAlignment (our graphics.get(), Graphics_CENTRE, Graphics_HALF); for (integer i = 0; i < 8; i ++) { - const double left = my rect [i]. left, right = my rect [i]. right; + const double left = our rect [i]. left, right = our rect [i]. right; if (left < right) - Graphics_button (my graphics.get(), left, right, my rect [i]. bottom, my rect [i]. top); + Graphics_button (our graphics.get(), left, right, our rect [i]. bottom, our rect [i]. top); } - double verticalCorrection = my height / (my height - 111.0 + 11.0); - #ifdef _WIN32 - verticalCorrection *= 1.5; - #endif + const double verticalCorrection = our height_pxlt / (our height_pxlt - 111.0 + 11.0) + #ifdef _WIN32 + * 1.5 + #endif + ; for (integer i = 0; i < 8; i ++) { - const double left = my rect [i]. left, right = my rect [i]. right; - const double bottom = my rect [i]. bottom, top = my rect [i]. top; + const double left = our rect [i]. left, right = our rect [i]. right; + const double bottom = our rect [i]. bottom, top = our rect [i]. top; if (left < right) { - const char *format = my v_format_long (); + conststring8 format = our v_format_long (); double value = undefined, inverseValue = 0.0; switch (i) { case 0: { - format = my v_format_totalDuration (); - value = my tmax - my tmin; + format = our v_format_totalDuration (); + value = our tmax - our tmin; } break; case 1: { - format = my v_format_window (); - value = my endWindow - my startWindow; + format = our v_format_window (); + value = our endWindow - our startWindow; /* Window domain text. */ - Graphics_setColour (my graphics.get(), Melder_BLUE); - Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_HALF); - Graphics_text (my graphics.get(), left, 0.5 * (bottom + top) - verticalCorrection, - Melder_fixed (my startWindow, my v_fixedPrecision_long ())); - Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_HALF); - Graphics_text (my graphics.get(), right, 0.5 * (bottom + top) - verticalCorrection, - Melder_fixed (my endWindow, my v_fixedPrecision_long ())); - Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_HALF); + Graphics_setColour (our graphics.get(), Melder_BLUE); + Graphics_setTextAlignment (our graphics.get(), Graphics_LEFT, Graphics_HALF); + Graphics_text (our graphics.get(), left, 0.5 * (bottom + top) - verticalCorrection, + Melder_fixed (our startWindow, our v_fixedPrecision_long ())); + Graphics_setTextAlignment (our graphics.get(), Graphics_RIGHT, Graphics_HALF); + Graphics_text (our graphics.get(), right, 0.5 * (bottom + top) - verticalCorrection, + Melder_fixed (our endWindow, our v_fixedPrecision_long ())); + Graphics_setColour (our graphics.get(), Melder_BLACK); + Graphics_setTextAlignment (our graphics.get(), Graphics_CENTRE, Graphics_HALF); } break; case 2: { - value = my startWindow - my tmin; + value = our startWindow - our tmin; } break; case 3: { - value = my tmax - my endWindow; + value = our tmax - our endWindow; } break; case 4: { - value = my marker [1] - my startWindow; + value = our marker [1] - our startWindow; } break; case 5: { - value = my marker [2] - my marker [1]; + value = our marker [2] - our marker [1]; } break; case 6: { - value = my marker [3] - my marker [2]; + value = our marker [3] - our marker [2]; } break; case 7: { - format = my v_format_selection (); - value = my endSelection - my startSelection; + format = our v_format_selection (); + value = our endSelection - our startSelection; inverseValue = 1.0 / value; } } char text8 [100]; snprintf (text8, 100, format, value, inverseValue); autostring32 text = Melder_8to32 (text8); - if (Graphics_textWidth (my graphics.get(), text.get()) < right - left) { - Graphics_text (my graphics.get(), 0.5 * (left + right), 0.5 * (bottom + top) - verticalCorrection, text.get()); - } else if (format == my v_format_long ()) { - snprintf (text8, 100, my v_format_short (), value); + if (Graphics_textWidth (our graphics.get(), text.get()) < right - left) { + Graphics_text (our graphics.get(), 0.5 * (left + right), 0.5 * (bottom + top) - verticalCorrection, text.get()); + } else if (format == our v_format_long()) { + snprintf (text8, 100, our v_format_short(), value); text = Melder_8to32 (text8); - if (Graphics_textWidth (my graphics.get(), text.get()) < right - left) - Graphics_text (my graphics.get(), 0.5 * (left + right), 0.5 * (bottom + top) - verticalCorrection, text.get()); + if (Graphics_textWidth (our graphics.get(), text.get()) < right - left) + Graphics_text (our graphics.get(), 0.5 * (left + right), 0.5 * (bottom + top) - verticalCorrection, text.get()); } else { - snprintf (text8, 100, my v_format_long (), value); + snprintf (text8, 100, our v_format_long(), value); text = Melder_8to32 (text8); - if (Graphics_textWidth (my graphics.get(), text.get()) < right - left) { - Graphics_text (my graphics.get(), 0.5 * (left + right), 0.5 * (bottom + top) - verticalCorrection, text.get()); + if (Graphics_textWidth (our graphics.get(), text.get()) < right - left) { + Graphics_text (our graphics.get(), 0.5 * (left + right), 0.5 * (bottom + top) - verticalCorrection, text.get()); } else { - snprintf (text8, 100, my v_format_short (), my endSelection - my startSelection); + snprintf (text8, 100, our v_format_short(), our endSelection - our startSelection); text = Melder_8to32 (text8); - if (Graphics_textWidth (my graphics.get(), text.get()) < right - left) - Graphics_text (my graphics.get(), 0.5 * (left + right), 0.5 * (bottom + top) - verticalCorrection, text.get()); + if (Graphics_textWidth (our graphics.get(), text.get()) < right - left) + Graphics_text (our graphics.get(), 0.5 * (left + right), 0.5 * (bottom + top) - verticalCorrection, text.get()); } } } } - Graphics_setViewport (my graphics.get(), my functionViewerLeft + MARGIN, my functionViewerRight - MARGIN, 0.0, my height); - Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, 0.0, my height); - /*Graphics_setColour (my graphics.get(), Melder_WHITE); - Graphics_fillRectangle (my graphics.get(), my startWindow, my endWindow, BOTTOM_MARGIN + space * 3, my height - (TOP_MARGIN + space));*/ - Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_rectangle (my graphics.get(), my startWindow, my endWindow, BOTTOM_MARGIN + space * 3, my height - (TOP_MARGIN + space)); + our viewTallDataAsWorldByFraction (); /* Red marker text. */ - Graphics_setColour (my graphics.get(), Melder_RED); + Graphics_setColour (our graphics.get(), Melder_RED); if (cursorIsVisible) { - Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_BOTTOM); - Graphics_text (my graphics.get(), my startSelection, my height - (TOP_MARGIN + space) - verticalCorrection, - Melder_fixed (my startSelection, my v_fixedPrecision_long ())); + Graphics_setTextAlignment (our graphics.get(), Graphics_CENTRE, Graphics_BOTTOM); + Graphics_text (our graphics.get(), our startSelection, our height_pxlt - (TOP_MARGIN + space*0.9) - verticalCorrection * 7, + Melder_fixed (our startSelection, our v_fixedPrecision_long())); } if (startIsVisible && selectionIsNonempty) { - Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_HALF); - Graphics_text (my graphics.get(), my startSelection, my height - (TOP_MARGIN + space/2) - verticalCorrection, - Melder_fixed (my startSelection, my v_fixedPrecision_long ())); + Graphics_setTextAlignment (our graphics.get(), Graphics_RIGHT, Graphics_HALF); + Graphics_text (our graphics.get(), our startSelection, our height_pxlt - (TOP_MARGIN + space/2) - verticalCorrection, + Melder_fixed (our startSelection, our v_fixedPrecision_long())); } if (endIsVisible && selectionIsNonempty) { - Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_HALF); - Graphics_text (my graphics.get(), my endSelection, my height - (TOP_MARGIN + space/2) - verticalCorrection, - Melder_fixed (my endSelection, my v_fixedPrecision_long ())); + Graphics_setTextAlignment (our graphics.get(), Graphics_LEFT, Graphics_HALF); + Graphics_text (our graphics.get(), our endSelection, our height_pxlt - (TOP_MARGIN + space/2) - verticalCorrection, + Melder_fixed (our endSelection, our v_fixedPrecision_long())); } - Graphics_setColour (my graphics.get(), Melder_BLACK); + Graphics_setColour (our graphics.get(), Melder_BLACK); /* To reduce flashing, give our descendants the opportunity to prepare their data. */ - my v_prepareDraw (); + our v_prepareDraw (); /* Start of inner drawing. */ - Graphics_setViewport (my graphics.get(), my functionViewerLeft + MARGIN, my functionViewerRight - MARGIN, BOTTOM_MARGIN + space * 3, my height - (TOP_MARGIN + space)); - - my v_draw (); - Graphics_setViewport (my graphics.get(), my functionViewerLeft + MARGIN, my functionViewerRight - MARGIN, BOTTOM_MARGIN + space * 3, my height - (TOP_MARGIN + space)); + our viewDataAsWorldByFraction (); + our v_draw (); /* Red dotted marker lines. */ - Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, 0.0, 1.0); - Graphics_setColour (my graphics.get(), Melder_RED); - Graphics_setLineType (my graphics.get(), Graphics_DOTTED); - double bottom = my v_getBottomOfSoundAndAnalysisArea (); + our viewDataAsWorldByFraction (); + Graphics_setColour (our graphics.get(), Melder_RED); + Graphics_setLineType (our graphics.get(), Graphics_DOTTED); + const double bottom = our v_getBottomOfSoundAndAnalysisArea (); if (cursorIsVisible) - Graphics_line (my graphics.get(), my startSelection, bottom, my startSelection, 1.0); + Graphics_line (our graphics.get(), our startSelection, bottom, our startSelection, 1.0); if (startIsVisible) - Graphics_line (my graphics.get(), my startSelection, bottom, my startSelection, 1.0); + Graphics_line (our graphics.get(), our startSelection, bottom, our startSelection, 1.0); if (endIsVisible) - Graphics_line (my graphics.get(), my endSelection, bottom, my endSelection, 1.0); - Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_setLineType (my graphics.get(), Graphics_DRAWN); + Graphics_line (our graphics.get(), our endSelection, bottom, our endSelection, 1.0); + Graphics_setColour (our graphics.get(), Melder_BLACK); + Graphics_setLineType (our graphics.get(), Graphics_DRAWN); /* Highlight selection. */ - if (selectionIsNonempty && my startSelection < my endWindow && my endSelection > my startWindow) { - const double left = std::max (my startSelection, my startWindow); - const double right = std::min (my endSelection, my endWindow); - my v_highlightSelection (left, right, 0.0, 1.0); + if (selectionIsNonempty && our startSelection < our endWindow && our endSelection > our startWindow) { + const double left = Melder_clippedLeft (our startWindow, our startSelection); + const double right = Melder_clippedRight (our endSelection, our endWindow); + our v_highlightSelection (left, right, 0.0, 1.0); } /* - Draw the selection part. + Draw the running cursor. */ - if (my p_showSelectionViewer) { - Graphics_setViewport (my graphics.get(), my selectionViewerLeft + MARGIN, my selectionViewerRight - MARGIN, BOTTOM_MARGIN + space * 3, my height - (TOP_MARGIN + space)); - my v_drawSelectionViewer (); + if (our duringPlay) { + if (Melder_debug == 53) + Melder_casual (U"playing cursor"); + Graphics_setColour (our graphics.get(), Melder_BLACK); + Graphics_setLineWidth (our graphics.get(), 3.0); + Graphics_xorOn (our graphics.get(), Melder_BLACK); + Graphics_line (our graphics.get(), our playCursor, 0.0, our playCursor, 1.0); + Graphics_xorOff (our graphics.get()); + Graphics_setLineWidth (our graphics.get(), 1.0); } /* - End of inner drawing. + Draw the selection part. */ - Graphics_flushWs (my graphics.get()); - Graphics_setViewport (my graphics.get(), my functionViewerLeft, my selectionViewerRight, 0.0, my height); + if (our p_showSelectionViewer) { + our viewInnerSelectionViewerAsFractionByFraction (); + if (our duringPlay) + our v_drawRealTimeSelectionViewer (our playCursor); + else + our v_drawSelectionViewer (); + } } /********** METHODS **********/ @@ -387,13 +372,13 @@ void structFunctionEditor :: v_destroy () noexcept { void structFunctionEditor :: v_info () { FunctionEditor_Parent :: v_info (); - MelderInfo_writeLine (U"Editor start: ", our tmin, U" ", v_format_units_long ()); - MelderInfo_writeLine (U"Editor end: ", our tmax, U" ", v_format_units_long ()); - MelderInfo_writeLine (U"Window start: ", our startWindow, U" ", v_format_units_long ()); - MelderInfo_writeLine (U"Window end: ", our endWindow, U" ", v_format_units_long ()); - MelderInfo_writeLine (U"Selection start: ", our startSelection, U" ", v_format_units_long ()); - MelderInfo_writeLine (U"Selection end: ", our endSelection, U" ", v_format_units_long ()); - MelderInfo_writeLine (U"Arrow scroll step: ", our p_arrowScrollStep, U" ", v_format_units_long ()); + MelderInfo_writeLine (U"Editor start: ", our tmin, U" ", v_format_units_long()); + MelderInfo_writeLine (U"Editor end: ", our tmax, U" ", v_format_units_long()); + MelderInfo_writeLine (U"Window start: ", our startWindow, U" ", v_format_units_long()); + MelderInfo_writeLine (U"Window end: ", our endWindow, U" ", v_format_units_long()); + MelderInfo_writeLine (U"Selection start: ", our startSelection, U" ", v_format_units_long()); + MelderInfo_writeLine (U"Selection end: ", our endSelection, U" ", v_format_units_long()); + MelderInfo_writeLine (U"Arrow scroll step: ", our p_arrowScrollStep, U" ", v_format_units_long()); MelderInfo_writeLine (U"Group: ", group ? U"yes" : U"no"); } @@ -402,50 +387,35 @@ void structFunctionEditor :: v_info () { static void gui_drawingarea_cb_resize (FunctionEditor me, GuiDrawingArea_ResizeEvent event) { if (! my graphics) return; // could be the case in the very beginning - Graphics_setWsViewport (my graphics.get(), 0, event -> width, 0, event -> height); - int width = event -> width + 21; - /* - Put the function viewer at the left and the selection viewer at the right. - */ - my functionViewerLeft = 0; - my functionViewerRight = ( my p_showSelectionViewer ? Melder_ifloor (width * (2.0/3.0)) : width ); - my selectionViewerLeft = my functionViewerRight; - my selectionViewerRight = width; - my height = event -> height + 111; - Graphics_setWsWindow (my graphics.get(), 0.0, width, 0.0, my height); - Graphics_setViewport (my graphics.get(), 0.0, width, 0.0, my height); + my updateGeometry (event -> width, event -> height); Graphics_updateWs (my graphics.get()); /* Save the current shell size as the user's preference for a new FunctionEditor. */ - my pref_shellWidth () = GuiShell_getShellWidth (my windowForm); - my pref_shellHeight () = GuiShell_getShellHeight (my windowForm); + my pref_shellWidth() = GuiShell_getShellWidth (my windowForm); + my pref_shellHeight() = GuiShell_getShellHeight (my windowForm); } static void menu_cb_preferences (FunctionEditor me, EDITOR_ARGS_FORM) { EDITOR_FORM (U"Preferences", nullptr) - BOOLEAN (synchronizeZoomAndScroll, U"Synchronize zoom and scroll", my default_synchronizedZoomAndScroll ()) - BOOLEAN (showSelectionViewer, Melder_cat (U"Show ", my v_selectionViewerName ()), my default_showSelectionViewer ()) - POSITIVE (arrowScrollStep, Melder_cat (U"Arrow scroll step (", my v_format_units_short (), U")"), my default_arrowScrollStep ()) + BOOLEAN (synchronizeZoomAndScroll, U"Synchronize zoom and scroll", my default_synchronizedZoomAndScroll()) + BOOLEAN (showSelectionViewer, Melder_cat (U"Show ", my v_selectionViewerName()), my default_showSelectionViewer()) + POSITIVE (arrowScrollStep, Melder_cat (U"Arrow scroll step (", my v_format_units_short(), U")"), my default_arrowScrollStep()) my v_prefs_addFields (cmd); EDITOR_OK - SET_BOOLEAN (synchronizeZoomAndScroll, my pref_synchronizedZoomAndScroll ()) + SET_BOOLEAN (synchronizeZoomAndScroll, my pref_synchronizedZoomAndScroll()) SET_BOOLEAN (showSelectionViewer, my pref_showSelectionViewer ()) SET_REAL (arrowScrollStep, my p_arrowScrollStep) my v_prefs_setValues (cmd); EDITOR_DO - bool oldSynchronizedZoomAndScroll = my pref_synchronizedZoomAndScroll (); - bool oldShowSelectionViewer = my p_showSelectionViewer; - my pref_synchronizedZoomAndScroll () = synchronizeZoomAndScroll; - my pref_showSelectionViewer () = my p_showSelectionViewer = showSelectionViewer; - my pref_arrowScrollStep () = my p_arrowScrollStep = arrowScrollStep; - if (my p_showSelectionViewer != oldShowSelectionViewer) { - struct structGuiDrawingArea_ResizeEvent event { my drawingArea, 0, 0 }; - event. width = GuiControl_getWidth (my drawingArea); - event. height = GuiControl_getHeight (my drawingArea); - gui_drawingarea_cb_resize (me, & event); - } - if (! oldSynchronizedZoomAndScroll && my pref_synchronizedZoomAndScroll ()) + const bool oldSynchronizedZoomAndScroll = my pref_synchronizedZoomAndScroll(); + const bool oldShowSelectionViewer = my p_showSelectionViewer; + my pref_synchronizedZoomAndScroll() = synchronizeZoomAndScroll; + my pref_showSelectionViewer() = my p_showSelectionViewer = showSelectionViewer; + my pref_arrowScrollStep() = my p_arrowScrollStep = arrowScrollStep; + if (my p_showSelectionViewer != oldShowSelectionViewer) + my updateGeometry (GuiControl_getWidth (my drawingArea), GuiControl_getHeight (my drawingArea)); + if (! oldSynchronizedZoomAndScroll && my pref_synchronizedZoomAndScroll()) updateGroup (me); my v_prefs_getValues (cmd); EDITOR_END @@ -459,28 +429,28 @@ void structFunctionEditor :: v_form_pictureSelection (EditorCommand cmd) { } void structFunctionEditor :: v_ok_pictureSelection (EditorCommand cmd) { FunctionEditor me = (FunctionEditor) cmd -> d_editor; - SET_BOOLEAN (v_form_pictureSelection_drawSelectionTimes, my pref_picture_drawSelectionTimes ()) - SET_BOOLEAN (v_form_pictureSelection_drawSelectionHairs, my pref_picture_drawSelectionHairs ()) + SET_BOOLEAN (v_form_pictureSelection_drawSelectionTimes, my pref_picture_drawSelectionTimes()) + SET_BOOLEAN (v_form_pictureSelection_drawSelectionHairs, my pref_picture_drawSelectionHairs()) } void structFunctionEditor :: v_do_pictureSelection (EditorCommand cmd) { FunctionEditor me = (FunctionEditor) cmd -> d_editor; - my pref_picture_drawSelectionTimes () = v_form_pictureSelection_drawSelectionTimes; - my pref_picture_drawSelectionHairs () = v_form_pictureSelection_drawSelectionHairs; + my pref_picture_drawSelectionTimes() = v_form_pictureSelection_drawSelectionTimes; + my pref_picture_drawSelectionHairs() = v_form_pictureSelection_drawSelectionHairs; } /********** QUERY MENU **********/ static void menu_cb_getB (FunctionEditor me, EDITOR_ARGS_DIRECT) { - Melder_informationReal (my startSelection, my v_format_units_long ()); + Melder_informationReal (my startSelection, my v_format_units_long()); } static void menu_cb_getCursor (FunctionEditor me, EDITOR_ARGS_DIRECT) { - Melder_informationReal (0.5 * (my startSelection + my endSelection), my v_format_units_long ()); + Melder_informationReal (0.5 * (my startSelection + my endSelection), my v_format_units_long()); } static void menu_cb_getE (FunctionEditor me, EDITOR_ARGS_DIRECT) { - Melder_informationReal (my endSelection, my v_format_units_long ()); + Melder_informationReal (my endSelection, my v_format_units_long()); } static void menu_cb_getSelectionDuration (FunctionEditor me, EDITOR_ARGS_DIRECT) { - Melder_informationReal (my endSelection - my startSelection, my v_format_units_long ()); + Melder_informationReal (my endSelection - my startSelection, my v_format_units_long()); } /********** VIEW MENU **********/ @@ -505,11 +475,7 @@ static void menu_cb_zoom (FunctionEditor me, EDITOR_ARGS_FORM) { my endWindow = to; my v_updateText (); updateScrollBar (me); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); EDITOR_END } @@ -519,12 +485,8 @@ static void do_showAll (FunctionEditor me) { my endWindow = my tmax; my v_updateText (); updateScrollBar (me); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif - if (my pref_synchronizedZoomAndScroll ()) + Graphics_updateWs (my graphics.get()); + if (my pref_synchronizedZoomAndScroll()) updateGroup (me); } @@ -538,12 +500,8 @@ static void do_zoomIn (FunctionEditor me) { my endWindow -= shift; my v_updateText (); updateScrollBar (me); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif - if (my pref_synchronizedZoomAndScroll ()) + Graphics_updateWs (my graphics.get()); + if (my pref_synchronizedZoomAndScroll()) updateGroup (me); } @@ -562,12 +520,8 @@ static void do_zoomOut (FunctionEditor me) { my endWindow = my tmax; my v_updateText (); updateScrollBar (me); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif - if (my pref_synchronizedZoomAndScroll ()) + Graphics_updateWs (my graphics.get()); + if (my pref_synchronizedZoomAndScroll()) updateGroup (me); } @@ -579,22 +533,13 @@ static void do_zoomToSelection (FunctionEditor me) { if (my endSelection > my startSelection) { my startZoomHistory = my startWindow; // remember for Zoom Back my endZoomHistory = my endWindow; // remember for Zoom Back - trace (U"Zooming in to ", my startSelection, U" ~ ", my endSelection, U" seconds."); my startWindow = my startSelection; my endWindow = my endSelection; - trace (U"Zoomed in to ", my startWindow, U" ~ ", my endWindow, U" seconds (1)."); my v_updateText (); - trace (U"Zoomed in to ", my startWindow, U" ~ ", my endWindow, U" seconds (2)."); updateScrollBar (me); - trace (U"Zoomed in to ", my startWindow, U" ~ ", my endWindow, U" seconds (3)."); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif - if (my pref_synchronizedZoomAndScroll ()) + Graphics_updateWs (my graphics.get()); + if (my pref_synchronizedZoomAndScroll()) updateGroup (me); - trace (U"Zoomed in to ", my startWindow, U" ~ ", my endWindow, U" seconds (4)."); } } @@ -608,12 +553,8 @@ static void do_zoomBack (FunctionEditor me) { my endWindow = my endZoomHistory; my v_updateText (); updateScrollBar (me); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif - if (my pref_synchronizedZoomAndScroll ()) + Graphics_updateWs (my graphics.get()); + if (my pref_synchronizedZoomAndScroll()) updateGroup (me); } } @@ -655,14 +596,12 @@ static void menu_cb_play (FunctionEditor me, EDITOR_ARGS_FORM) { EDITOR_END } -static void menu_cb_playOrStop (FunctionEditor me, EDITOR_ARGS_FORM) { +static void menu_cb_playOrStop (FunctionEditor me, EDITOR_ARGS_DIRECT) { if (MelderAudio_isPlaying) { MelderAudio_stopPlaying (MelderAudio_EXPLICIT); } else if (my startSelection < my endSelection) { - my playingSelection = true; my v_play (my startSelection, my endSelection); } else { - my playingCursor = true; if (my startSelection == my endSelection && my startSelection > my startWindow && my startSelection < my endWindow) my v_play (my startSelection, my endWindow); else @@ -672,7 +611,6 @@ static void menu_cb_playOrStop (FunctionEditor me, EDITOR_ARGS_FORM) { static void menu_cb_playWindow (FunctionEditor me, EDITOR_ARGS_DIRECT) { MelderAudio_stopPlaying (MelderAudio_IMPLICIT); - my playingCursor = true; my v_play (my startWindow, my endWindow); } @@ -699,11 +637,7 @@ static void menu_cb_select (FunctionEditor me, EDITOR_ARGS_FORM) { if (my startSelection > my endSelection) std::swap (my startSelection, my endSelection); my v_updateText (); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); EDITOR_END } @@ -744,11 +678,7 @@ static void menu_cb_widenOrShrinkSelection (FunctionEditor me, EDITOR_ARGS_FORM) my startSelection = newStartOfSelection; my endSelection = newEndOfSelection; my v_updateText (); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); EDITOR_END } @@ -756,22 +686,14 @@ static void menu_cb_widenOrShrinkSelection (FunctionEditor me, EDITOR_ARGS_FORM) static void menu_cb_moveCursorToStartOfSelection (FunctionEditor me, EDITOR_ARGS_DIRECT) { my endSelection = my startSelection; my v_updateText (); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); } static void menu_cb_moveCursorToEndOfSelection (FunctionEditor me, EDITOR_ARGS_DIRECT) { my startSelection = my endSelection; my v_updateText (); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); } @@ -787,11 +709,7 @@ static void menu_cb_moveCursorTo (FunctionEditor me, EDITOR_ARGS_FORM) { position = my tmax; my startSelection = my endSelection = position; my v_updateText (); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); EDITOR_END } @@ -801,18 +719,10 @@ static void menu_cb_moveCursorBy (FunctionEditor me, EDITOR_ARGS_FORM) { REAL (distance, Melder_cat (U"Distance (", my v_format_units_short(), U")"), U"0.05") EDITOR_OK EDITOR_DO - double position = 0.5 * (my startSelection + my endSelection) + distance; - if (position < my tmin) - position = my tmin; - if (position > my tmax) - position = my tmax; + const double position = Melder_clipped (my tmin, 0.5 * (my startSelection + my endSelection) + distance, my tmax); my startSelection = my endSelection = position; my v_updateText (); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); EDITOR_END } @@ -822,20 +732,10 @@ static void menu_cb_moveStartOfSelectionBy (FunctionEditor me, EDITOR_ARGS_FORM) REAL (distance, Melder_cat (U"Distance (", my v_format_units_short(), U")"), U"0.05") EDITOR_OK EDITOR_DO - double position = my startSelection + distance; - if (position < my tmin) - position = my tmin; - if (position > my tmax) - position = my tmax; - my startSelection = position; - if (my startSelection > my endSelection) - std::swap (my startSelection, my endSelection); + my startSelection = Melder_clipped (my tmin, my startSelection + distance, my tmax); + Melder_sort (& my startSelection, & my endSelection); my v_updateText (); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); EDITOR_END } @@ -845,20 +745,10 @@ static void menu_cb_moveEndOfSelectionBy (FunctionEditor me, EDITOR_ARGS_FORM) { REAL (distance, Melder_cat (U"Distance (", my v_format_units_short(), U")"), U"0.05") EDITOR_OK EDITOR_DO - double position = my endSelection + distance; - if (position < my tmin) - position = my tmin; - if (position > my tmax) - position = my tmax; - my endSelection = position; - if (my startSelection > my endSelection) - std::swap (my startSelection, my endSelection); + my endSelection = Melder_clipped (my tmin, my endSelection + distance, my tmax); + Melder_sort (& my startSelection, & my endSelection); my v_updateText (); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); updateGroup (me); EDITOR_END } @@ -992,13 +882,8 @@ static void gui_cb_scroll (FunctionEditor me, GuiScrollBarEvent event) { if (shifted || zoomed) { my v_updateText (); updateScrollBar (me); - #if cocoa - Graphics_updateWs (my graphics.get()); - #else - /*Graphics_clearWs (my graphics.get());*/ - drawNow (me); // do not wait for expose event - #endif - if (! my group || ! my pref_synchronizedZoomAndScroll ()) + Graphics_updateWs (my graphics.get()); + if (! my group || ! my pref_synchronizedZoomAndScroll()) return; for (integer i = 1; i <= THE_MAXIMUM_GROUP_SIZE; i ++) { if (theGroupMembers [i] && theGroupMembers [i] != me) { @@ -1006,12 +891,7 @@ static void gui_cb_scroll (FunctionEditor me, GuiScrollBarEvent event) { theGroupMembers [i] -> endWindow = my endWindow; FunctionEditor_updateText (theGroupMembers [i]); updateScrollBar (theGroupMembers [i]); - #if cocoa - Graphics_updateWs (theGroupMembers [i] -> graphics.get()); - #else - Graphics_clearWs (theGroupMembers [i] -> graphics.get()); - drawNow (theGroupMembers [i]); - #endif + Graphics_updateWs (theGroupMembers [i] -> graphics.get()); } } } @@ -1049,17 +929,15 @@ static void gui_checkbutton_cb_group (FunctionEditor me, GuiCheckButtonEvent /* } const integer otherGroupMember = findOtherGroupMember (me); const FunctionEditor thee = theGroupMembers [otherGroupMember]; - if (my pref_synchronizedZoomAndScroll ()) { + if (my pref_synchronizedZoomAndScroll()) { my startWindow = thy startWindow; my endWindow = thy endWindow; } my startSelection = thy startSelection; my endSelection = thy endSelection; if (my tmin > thy tmin || my tmax < thy tmax) { - if (my tmin > thy tmin) - my tmin = thy tmin; - if (my tmax < thy tmax) - my tmax = thy tmax; + Melder_clipRight (& my tmin, thy tmin); + Melder_clipLeft (thy tmax, & my tmax); my v_updateText (); updateScrollBar (me); Graphics_updateWs (my graphics.get()); @@ -1176,91 +1054,108 @@ static void gui_drawingarea_cb_expose (FunctionEditor me, GuiDrawingArea_ExposeE if (! my graphics) return; // could be the case in the very beginning if (my enableUpdates) - drawNow (me); + my draw (); +} + +bool structFunctionEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double mouseTime, double /* mouseY_fraction */) { + Melder_assert (our startSelection <= our endSelection); + Melder_clip (our startWindow, & mouseTime, our endWindow); // WYSIWYG + static double anchorTime = undefined; + static bool hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = false; + if (event -> isClick()) { + Melder_assert (isundef (anchorTime)); // sanity check for the fixed order click-drag-drop + Melder_assert (! hasBeenDraggedBeyondVicinityRadiusAtLeastOnce); // sanity check for the fixed order click-drag-drop + const double selectedMiddleTime = 0.5 * (our startSelection + our endSelection); + const bool theyWantToExtendTheCurrentSelectionAtTheLeft = + (event -> shiftKeyPressed && mouseTime < selectedMiddleTime) || event -> isLeftBottomFunctionKeyPressed(); + const bool theyWantToExtendTheCurrentSelectionAtTheRight = + (event -> shiftKeyPressed && mouseTime >= selectedMiddleTime) || event -> isRightBottomFunctionKeyPressed(); + if (theyWantToExtendTheCurrentSelectionAtTheLeft) { + our startSelection = mouseTime; + anchorTime = our endSelection; + } else if (theyWantToExtendTheCurrentSelectionAtTheRight) { + our endSelection = mouseTime; + anchorTime = our startSelection; + } else { + our startSelection = mouseTime; + our endSelection = mouseTime; + anchorTime = mouseTime; + } + Melder_sort (& our startSelection, & our endSelection); + Melder_assert (isdefined (anchorTime)); + } else if (event -> isDrag() || event -> isDrop()) { + if (isdefined (anchorTime)) { // `false` if a descendant preempted the above click handling + if (! hasBeenDraggedBeyondVicinityRadiusAtLeastOnce) { + const double distanceToAnchor_mm = fabs (Graphics_dxWCtoMM (our graphics.get(), mouseTime - anchorTime)); + constexpr double vicinityRadius_mm = 1.0; + if (distanceToAnchor_mm > vicinityRadius_mm) + hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = true; + } + if (hasBeenDraggedBeyondVicinityRadiusAtLeastOnce) { + our startSelection = std::min (anchorTime, mouseTime); + our endSelection = std::max (anchorTime, mouseTime); + } + if (event -> isDrop()) { + anchorTime = undefined; + hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = false; + } + } + } + return true; +} + +void structFunctionEditor :: v_clickSelectionViewer (double /* x_fraction */, double /* y_fraction */) { } -static void gui_drawingarea_cb_click (FunctionEditor me, GuiDrawingArea_ClickEvent event) { +static void gui_drawingarea_cb_mouse (FunctionEditor me, GuiDrawingArea_MouseEvent event) { if (! my graphics) return; // could be the case in the very beginning - my shiftKeyPressed = event -> shiftKeyPressed; - Graphics_setViewport (my graphics.get(), my functionViewerLeft, my selectionViewerRight, 0.0, my height); - Graphics_setWindow (my graphics.get(), my functionViewerLeft, my selectionViewerRight, 0.0, my height); - double xWC, yWC; - Graphics_DCtoWC (my graphics.get(), event -> x, event -> y, & xWC, & yWC); - - if (xWC > my selectionViewerLeft) - { - Graphics_setViewport (my graphics.get(), my selectionViewerLeft + MARGIN, my selectionViewerRight - MARGIN, - BOTTOM_MARGIN + space * 3, my height - (TOP_MARGIN + space)); - Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_DCtoWC (my graphics.get(), event -> x, event -> y, & xWC, & yWC); - my v_clickSelectionViewer (xWC, yWC); - //my v_updateText (); - drawNow (me); - updateGroup (me); + my viewAllAsPixelettes (); + double x_pxlt, y_pxlt; + Graphics_DCtoWC (my graphics.get(), event -> x, event -> y, & x_pxlt, & y_pxlt); + static bool anchorIsInSelectionViewer = false; + static bool anchorIsInWideDataView = false; + if (event -> isClick()) { + my clickWasModifiedByShiftKey = event -> shiftKeyPressed; + anchorIsInSelectionViewer = my isInSelectionViewer (x_pxlt); + anchorIsInWideDataView = ( y_pxlt > my dataBottom_pxlt() && y_pxlt < my dataTop_pxlt() ); } - else if (yWC > BOTTOM_MARGIN + space * 3 && yWC < my height - (TOP_MARGIN + space)) { // in signal region? - bool needsUpdate; - Graphics_setViewport (my graphics.get(), my functionViewerLeft + MARGIN, my functionViewerRight - MARGIN, - BOTTOM_MARGIN + space * 3, my height - (TOP_MARGIN + space)); - Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, 0.0, 1.0); - Graphics_DCtoWC (my graphics.get(), event -> x, event -> y, & xWC, & yWC); - if (xWC < my startWindow) - xWC = my startWindow; - if (xWC > my endWindow) - xWC = my endWindow; - if (Melder_debug == 24) { - Melder_casual (U"FunctionEditor::gui_drawingarea_cb_click:" - U" button ", event -> button, - U" shift ", my shiftKeyPressed, - U" option ", event -> optionKeyPressed, - U" command ", event -> commandKeyPressed, - U" control ", event -> extraControlKeyPressed); - } -#if defined (macintosh) - needsUpdate = - event -> optionKeyPressed || event -> extraControlKeyPressed ? my v_clickB (xWC, yWC) : - event -> commandKeyPressed ? my v_clickE (xWC, yWC) : - my v_click (xWC, yWC, my shiftKeyPressed); -#elif defined (_WIN32) - needsUpdate = - event -> commandKeyPressed ? my v_clickB (xWC, yWC) : - event -> optionKeyPressed ? my v_clickE (xWC, yWC) : - my v_click (xWC, yWC, my shiftKeyPressed); -#else - needsUpdate = - event -> commandKeyPressed ? my v_clickB (xWC, yWC) : - event -> optionKeyPressed ? my v_clickE (xWC, yWC) : - event -> button == 1 ? my v_click (xWC, yWC, my shiftKeyPressed) : - event -> button == 2 ? my v_clickB (xWC, yWC) : my v_clickE (xWC, yWC); -#endif - if (needsUpdate) - my v_updateText (); - Graphics_setViewport (my graphics.get(), my functionViewerLeft, my functionViewerRight, 0.0, my height); - if (needsUpdate) - drawNow (me); - if (needsUpdate) + if (anchorIsInSelectionViewer) { + my viewInnerSelectionViewerAsFractionByFraction (); + double x_fraction, y_fraction; + Graphics_DCtoWC (my graphics.get(), event -> x, event -> y, & x_fraction, & y_fraction); + if (event -> isClick()) { + my v_clickSelectionViewer (x_fraction, y_fraction); + //my v_updateText (); + Graphics_updateWs (my graphics.get()); updateGroup (me); - } - else // clicked outside signal region? Let us hear it - { + } else; // no dragging (yet?) in any selection viewer + } else if (anchorIsInWideDataView) { + my viewDataAsWorldByFraction (); + double x_world, y_fraction; + Graphics_DCtoWC (my graphics.get(), event -> x, event -> y, & x_world, & y_fraction); + my v_mouseInWideDataView (event, x_world, y_fraction); + my v_updateText (); + Graphics_updateWs (my graphics.get()); + updateGroup (me); + } else { // clicked outside signal region? Let us hear it try { - for (integer i = 0; i < 8; i ++) { - if (xWC > my rect [i]. left && xWC < my rect [i]. right && - yWC > my rect [i]. bottom && yWC < my rect [i]. top) - { - switch (i) { - case 0: my v_play (my tmin, my tmax); break; - case 1: my v_play (my startWindow, my endWindow); break; - case 2: my v_play (my tmin, my startWindow); break; - case 3: my v_play (my endWindow, my tmax); break; - case 4: my v_play (my startWindow, my marker [1]); break; - case 5: my v_play (my marker [1], my marker [2]); break; - case 6: my v_play (my marker [2], my marker [3]); break; - case 7: my v_play (my startSelection, my endSelection); break; + if (event -> isClick()) { + for (integer i = 0; i < 8; i ++) { + if (x_pxlt > my rect [i]. left && x_pxlt < my rect [i]. right && y_pxlt > my rect [i]. bottom && y_pxlt < my rect [i]. top) { + switch (i) { + case 0: my v_play (my tmin, my tmax); break; + case 1: my v_play (my startWindow, my endWindow); break; + case 2: my v_play (my tmin, my startWindow); break; + case 3: my v_play (my endWindow, my tmax); break; + case 4: my v_play (my startWindow, my marker [1]); break; + case 5: my v_play (my marker [1], my marker [2]); break; + case 6: my v_play (my marker [2], my marker [3]); break; + case 7: my v_play (my startSelection, my endSelection); break; + } } } - } + } else; // no dragging in the play rectangles } catch (MelderError) { Melder_flushError (); } @@ -1325,15 +1220,16 @@ void structFunctionEditor :: v_createChildren () { our drawingArea = GuiDrawingArea_createShown (our windowForm, 0, 0, Machine_getMenuBarHeight () + ( our v_hasText () ? TEXT_HEIGHT + marginBetweenTextAndDrawingAreaToEnsureCorrectUnhighlighting : 0), -8 - Gui_PUSHBUTTON_HEIGHT, - gui_drawingarea_cb_expose, gui_drawingarea_cb_click, nullptr, gui_drawingarea_cb_resize, this, 0); + gui_drawingarea_cb_expose, gui_drawingarea_cb_mouse, + nullptr, gui_drawingarea_cb_resize, this, 0 + ); GuiDrawingArea_setSwipable (our drawingArea, our scrollBar, nullptr); } void structFunctionEditor :: v_dataChanged () { - const Function function = (Function) our data; - Melder_assert (Thing_isa (function, classFunction)); - our tmin = function -> xmin; - our tmax = function -> xmax; + Melder_assert (Thing_isa (our function(), classFunction)); + our tmin = our function() -> xmin; + our tmax = our function() -> xmax; if (our startWindow < our tmin || our startWindow > our tmax) our startWindow = our tmin; if (our endWindow < our tmin || our endWindow > our tmax) @@ -1342,358 +1238,47 @@ void structFunctionEditor :: v_dataChanged () { our startWindow = our tmin; our endWindow = our tmax; } - if (our startSelection < our tmin) - our startSelection = our tmin; - if (our startSelection > our tmax) - our startSelection = our tmax; - if (our endSelection < our tmin) - our endSelection = our tmin; - if (our endSelection > our tmax) - our endSelection = our tmax; + Melder_clip (our tmin, & our startSelection, our tmax); + Melder_clip (our tmin, & our endSelection, our tmax); FunctionEditor_marksChanged (this, false); } -static void drawWhileDragging (FunctionEditor me, double x1, double x2) { - /* - We must draw this within the window, because the window tends to have a white background. - We cannot draw this in the margins, because these tend to be grey, so that Graphics_xorOn does not work properly. - We draw the text twice, because we expect that not ALL of the window is white... - */ - const double xleft = std::min (x1, x2); - const double xright = std::max (x1, x2); - Graphics_xorOn (my graphics.get(), Melder_MAROON); - Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_TOP); - Graphics_text (my graphics.get(), xleft, 1.0, Melder_fixed (xleft, 6)); - Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_TOP); - Graphics_text (my graphics.get(), xright, 1.0, Melder_fixed (xright, 6)); - Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_BOTTOM); - Graphics_text (my graphics.get(), xleft, 0.0, Melder_fixed (xleft, 6)); - Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_BOTTOM); - Graphics_text (my graphics.get(), xright, 0.0, Melder_fixed (xright, 6)); - Graphics_setLineType (my graphics.get(), Graphics_DOTTED); - Graphics_line (my graphics.get(), xleft, 0.0, xleft, 1.0); - Graphics_line (my graphics.get(), xright, 0.0, xright, 1.0); - Graphics_setLineType (my graphics.get(), Graphics_DRAWN); - Graphics_xorOff (my graphics.get()); -} - -bool structFunctionEditor :: v_click (double xbegin, double ybegin, bool a_shiftKeyPressed) { - bool drag = false; - double x = xbegin, y = ybegin; - - /* - The 'anchor' is the point that will stay fixed during dragging. - For instance, if the user clicks and drags to the right, - the location at which she originally clicked will be the anchor, - even if she later chooses to drag the mouse to the left of it. - Another example: if she shift-clicks near E, B will become (and stay) the anchor. - */ - - Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, 1.0); - - double anchorForDragging = xbegin; // the default (for if the shift key isn't pressed) - if (a_shiftKeyPressed) { - /* - Extend the selection. - We should always end up with a real selection (B < E), - even if we start with the reversed temporal order (E < B). - */ - const bool reversed = ( our startSelection > our endSelection ); - const double firstMark = ( reversed ? our endSelection : our startSelection ); - const double secondMark = ( reversed ? our startSelection : our endSelection ); - /* - Undraw the old selection. - */ - if (our endSelection > our startSelection) { - /* - Determine the visible part of the old selection. - */ - const double startVisible = std::max (our startSelection, our startWindow); - const double endVisible = std::min (our endSelection, our endWindow); - /* - Undraw the visible part of the old selection. - */ - if (endVisible > startVisible) { - v_unhighlightSelection (startVisible, endVisible, 0.0, 1.0); - //Graphics_flushWs (our graphics.get()); - } - } - if (xbegin >= secondMark) { - /* - She clicked right from the second mark (usually E). We move E. - */ - our endSelection = xbegin; - anchorForDragging = our startSelection; - } else if (xbegin <= firstMark) { - /* - She clicked left from the first mark (usually B). We move B. - */ - our startSelection = xbegin; - anchorForDragging = our endSelection; - } else { - /* - She clicked in between the two marks. We move the nearest mark. - */ - const double distanceOfClickToFirstMark = fabs (xbegin - firstMark); - const double distanceOfClickToSecondMark = fabs (xbegin - secondMark); - /* - We make sure that the marks are in the unmarked B - E order. - */ - if (reversed) { - /* - Swap B and E. - */ - our startSelection = firstMark; - our endSelection = secondMark; - } - /* - Move the nearest mark. - */ - if (distanceOfClickToFirstMark < distanceOfClickToSecondMark) { - our startSelection = xbegin; - anchorForDragging = our endSelection; - } else { - our endSelection = xbegin; - anchorForDragging = our startSelection; - } - } - /* - Draw the new selection. - */ - if (our endSelection > our startSelection) { - /* - Determine the visible part of the new selection. - */ - const double startVisible = std::max (our startSelection, our startWindow); - const double endVisible = std::min (our endSelection, our endWindow); - /* - Draw the visible part of the new selection. - */ - if (endVisible > startVisible) - v_highlightSelection (startVisible, endVisible, 0.0, 1.0); - } - } - /* - Find out whether this is a click or a drag. - */ - while (Graphics_mouseStillDown (our graphics.get())) { - Graphics_getMouseLocation (our graphics.get(), & x, & y); - if (x < our startWindow) - x = our startWindow; - if (x > our endWindow) - x = our endWindow; - if (fabs (Graphics_dxWCtoMM (our graphics.get(), x - xbegin)) > 1.5) { - drag = true; - break; - } +int structFunctionEditor :: v_playCallback (int phase, double /* startTime */, double endTime, double currentTime) { + our playCursor = currentTime; + if (phase == 1) { + our duringPlay = true; + return 1; } - - if (drag) { - /* - First undraw the old selection. - */ - if (our endSelection > our startSelection) { - /* - Determine the visible part of the old selection. - */ - const double startVisible = std::max (our startSelection, our startWindow); - const double endVisible = std::min (our endSelection, our endWindow); - /* - Undraw the visible part of the old selection. - */ - if (endVisible > startVisible) - v_unhighlightSelection (startVisible, endVisible, 0.0, 1.0); - } - /* - Draw the text at least once. - */ - /*if (x < our startWindow) x = our startWindow; else if (x > our endWindow) x = our endWindow;*/ - drawWhileDragging (this, anchorForDragging, x); - /* - Draw the dragged selection at least once. - */ - { - double x1, x2; - if (x > anchorForDragging) { - x1 = anchorForDragging; - x2 = x; - } else { - x1 = x; - x2 = anchorForDragging; - } - v_highlightSelection (x1, x2, 0.0, 1.0); - } - /* - Drag for the new selection. - */ - - while (Graphics_mouseStillDown (our graphics.get())) - { - double xold = x, x1, x2; - Graphics_getMouseLocation (our graphics.get(), & x, & y); - /* - Clip to the visible window. Ideally, we should perform autoscrolling instead, though... - */ - if (x < our startWindow) - x = our startWindow; - else if (x > our endWindow) - x = our endWindow; - - if (x == xold) - continue; - - /* - Undraw previous dragged selection. - */ - if (xold > anchorForDragging) { - x1 = anchorForDragging; - x2 = xold; - } else { - x1 = xold; - x2 = anchorForDragging; - } - if (x1 != x2) - v_unhighlightSelection (x1, x2, 0.0, 1.0); - /* - Undraw the text. - */ - drawWhileDragging (this, anchorForDragging, xold); - /* - Redraw the text at the new location. - */ - drawWhileDragging (this, anchorForDragging, x); - /* - Draw new dragged selection. - */ - if (x > anchorForDragging) { - x1 = anchorForDragging; - x2 = x; - } else { - x1 = x; - x2 = anchorForDragging; - } - if (x1 != x2) - v_highlightSelection (x1, x2, 0.0, 1.0); - } ; - /* - Set the new selection. - */ - if (x > anchorForDragging) { - our startSelection = anchorForDragging; - our endSelection = x; - } else { - our startSelection = x; - our endSelection = anchorForDragging; - } - } else if (! a_shiftKeyPressed) { - /* - Move the cursor to the clicked position. - */ - our startSelection = our endSelection = xbegin; - } - return FunctionEditor_UPDATE_NEEDED; -} - -bool structFunctionEditor :: v_clickB (double xWC, double /* yWC */) { - our startSelection = xWC; - if (our startSelection > our endSelection) - std::swap (our startSelection, our endSelection); - return FunctionEditor_UPDATE_NEEDED; -} - -bool structFunctionEditor :: v_clickE (double xWC, double /* yWC */) { - our endSelection = xWC; - if (our startSelection > our endSelection) - std::swap (our startSelection, our endSelection); - return FunctionEditor_UPDATE_NEEDED; -} - -void structFunctionEditor :: v_clickSelectionViewer (double /* xWC */, double /* yWC */) { -} - -int structFunctionEditor :: v_playCallback (int phase, double /* a_tmin */, double a_tmax, double t) { - /* - * This callback will often be called by the Melder workproc during playback. - * However, it will sometimes be called by Melder_stopPlaying with phase=3. - * This will occur at unpredictable times, perhaps when the LongSound is updated. - * So we had better make no assumptions about the current viewport. - */ - double x1NDC, x2NDC, y1NDC, y2NDC; - Graphics_inqViewport (our graphics.get(), & x1NDC, & x2NDC, & y1NDC, & y2NDC); - Graphics_setViewport (our graphics.get(), - our functionViewerLeft + MARGIN, our functionViewerRight - MARGIN, - BOTTOM_MARGIN + space * 3, our height - (TOP_MARGIN + space)); - Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, 1.0); - Graphics_xorOn (our graphics.get(), Melder_MAROON); - /* - * Undraw the play cursor at its old location. - * BUG: during scrolling, zooming, and exposure, an ugly line may remain. - */ - if (phase != 1 && playCursor >= our startWindow && playCursor <= our endWindow) { - Graphics_setLineWidth (our graphics.get(), 3.0); - Graphics_line (our graphics.get(), playCursor, 0.0, playCursor, 1.0); - Graphics_setLineWidth (our graphics.get(), 1.0); - } - /* - * Draw the play cursor at its new location. - */ - if (phase != 3 && t >= our startWindow && t <= our endWindow) { - Graphics_setLineWidth (our graphics.get(), 3.0); - Graphics_line (our graphics.get(), t, 0.0, t, 1.0); - Graphics_setLineWidth (our graphics.get(), 1.0); - } - Graphics_xorOff (our graphics.get()); - if (our p_showSelectionViewer) { - Graphics_setViewport (our graphics.get(), - our selectionViewerLeft + MARGIN, our selectionViewerRight - MARGIN, - BOTTOM_MARGIN + space * 3, our height - (TOP_MARGIN + space)); - our v_drawRealTimeSelectionViewer (phase, t); - } - /* - * Usually, there will be an event test after each invocation of this callback, - * because the asynchronicity is kMelder_asynchronicityLevel_INTERRUPTABLE or kMelder_asynchronicityLevel_ASYNCHRONOUS. - * However, if the asynchronicity is just kMelder_asynchronicityLevel_CALLING_BACK, - * there is no event test. Which means: no server round trip. - * Which means: no automatic flushing of graphics output. - * So: we force the flushing ourselves, lest we see too few moving cursors. - * - * At the moment, Cocoa seems to require this flushing even if the asynchronicity is kMelder_asynchronicityLevel_ASYNCHRONOUS. - */ - Graphics_flushWs (our graphics.get()); - Graphics_setViewport (our graphics.get(), x1NDC, x2NDC, y1NDC, y2NDC); - playCursor = t; if (phase == 3) { - if (t < a_tmax && MelderAudio_stopWasExplicit ()) { - if (t > our startSelection && t < our endSelection) - our startSelection = t; + our duringPlay = false; + if (currentTime < endTime && MelderAudio_stopWasExplicit ()) { + if (currentTime > our startSelection && currentTime < our endSelection) + our startSelection = currentTime; else - our startSelection = our endSelection = t; + our startSelection = our endSelection = currentTime; v_updateText (); - /*Graphics_updateWs (our graphics);*/ drawNow (this); updateGroup (this); } - playingCursor = false; - playingSelection = false; } + if (Melder_debug == 53) + Melder_casual (U"draining"); + Graphics_updateWs (our graphics.get()); + GuiShell_drain (our windowForm); // this may not be needed on all platforms (but on Windows it is, at least on 2020-09-21) return 1; } -int theFunctionEditor_playCallback (FunctionEditor me, int phase, double a_tmin, double a_tmax, double t) { - return my v_playCallback (phase, a_tmin, a_tmax, t); +int theFunctionEditor_playCallback (FunctionEditor me, int phase, double startTime, double endTime, double currentTime) { + return my v_playCallback (phase, startTime, endTime, currentTime); } void structFunctionEditor :: v_highlightSelection (double left, double right, double bottom, double top) { Graphics_highlight (our graphics.get(), left, right, bottom, top); } -void structFunctionEditor :: v_unhighlightSelection (double left, double right, double bottom, double top) { - Graphics_unhighlight (our graphics.get(), left, right, bottom, top); -} - -void FunctionEditor_init (FunctionEditor me, conststring32 title, Function data) { - my tmin = data -> xmin; // set before adding children (see group button) - my tmax = data -> xmax; - Editor_init (me, 0, 0, my pref_shellWidth (), my pref_shellHeight (), title, data); +void FunctionEditor_init (FunctionEditor me, conststring32 title, Function function) { + my tmin = function -> xmin; // set before adding children (see group button) + my tmax = function -> xmax; + Editor_init (me, 0, 0, my pref_shellWidth(), my pref_shellHeight(), title, function); my startWindow = my tmin; my endWindow = my tmax; @@ -1704,11 +1289,7 @@ void FunctionEditor_init (FunctionEditor me, conststring32 title, Function data) my graphics = Graphics_create_xmdrawingarea (my drawingArea); Graphics_setFontSize (my graphics.get(), 12); -// This exdents because it's a hack: -struct structGuiDrawingArea_ResizeEvent event { my drawingArea, 0, 0 }; -event. width = GuiControl_getWidth (my drawingArea); -event. height = GuiControl_getHeight (my drawingArea); -gui_drawingarea_cb_resize (me, & event); + my updateGeometry (GuiControl_getWidth (my drawingArea), GuiControl_getHeight (my drawingArea)); my v_updateText (); if (group_equalDomain (my tmin, my tmax)) @@ -1719,11 +1300,7 @@ gui_drawingarea_cb_resize (me, & event); void FunctionEditor_marksChanged (FunctionEditor me, bool needsUpdateGroup) { my v_updateText (); updateScrollBar (me); - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); if (needsUpdateGroup) updateGroup (me); } @@ -1733,11 +1310,7 @@ void FunctionEditor_updateText (FunctionEditor me) { } void FunctionEditor_redraw (FunctionEditor me) { - #if SUPPORT_DIRECT_DRAWING - drawNow (me); - #else - Graphics_updateWs (my graphics.get()); - #endif + Graphics_updateWs (my graphics.get()); } void FunctionEditor_enableUpdates (FunctionEditor me, bool enable) { @@ -1781,15 +1354,18 @@ void FunctionEditor_drawCursorFunctionValue (FunctionEditor me, double yWC, cons void FunctionEditor_insertCursorFunctionValue (FunctionEditor me, double yWC, conststring32 yWC_string, conststring32 units, double minimum, double maximum) { double textX = my endWindow, textY = yWC; - int tooHigh = Graphics_dyWCtoMM (my graphics.get(), maximum - textY) < 5.0; - int tooLow = Graphics_dyWCtoMM (my graphics.get(), textY - minimum) < 5.0; - if (yWC < minimum || yWC > maximum) return; + const bool tooHigh = ( Graphics_dyWCtoMM (my graphics.get(), maximum - textY) < 5.0 ); + const bool tooLow = ( Graphics_dyWCtoMM (my graphics.get(), textY - minimum) < 5.0 ); + if (yWC < minimum || yWC > maximum) + return; Graphics_setColour (my graphics.get(), Melder_CYAN); Graphics_line (my graphics.get(), 0.99 * my endWindow + 0.01 * my startWindow, yWC, my endWindow, yWC); Graphics_fillCircle_mm (my graphics.get(), 0.5 * (my startSelection + my endSelection), yWC, 1.5); if (tooHigh) { - if (tooLow) textY = 0.5 * (minimum + maximum); - else textY = maximum - Graphics_dyMMtoWC (my graphics.get(), 5.0); + if (tooLow) + textY = 0.5 * (minimum + maximum); + else + textY = maximum - Graphics_dyMMtoWC (my graphics.get(), 5.0); } else if (tooLow) { textY = minimum + Graphics_dyMMtoWC (my graphics.get(), 5.0); } diff --git a/fon/FunctionEditor.h b/fon/FunctionEditor.h index 09baec30..147a9395 100644 --- a/fon/FunctionEditor.h +++ b/fon/FunctionEditor.h @@ -2,7 +2,7 @@ #define _FunctionEditor_h_ /* FunctionEditor.h * - * Copyright (C) 1992-2019 Paul Boersma + * Copyright (C) 1992-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -28,23 +28,97 @@ struct FunctionEditor_picture { }; Thing_define (FunctionEditor, Editor) { - /* Subclass may change the following attributes, */ - /* but has to respect the invariants, */ - /* and has to call FunctionEditor_marksChanged () */ - /* immediately after making the changes. */ + /* + Inherited attributes: + data: must be a Function. + */ + Function & function() { return * reinterpret_cast (& our data); } + + /* + Subclasses may change the following attributes, + but have to respect the invariants, + and have to call FunctionEditor_marksChanged () + immediately after making those changes. + Invariants: + tmin <= startWindow < endWindow <= tmax; + tmin <= startSelection <= endSelection <= tmax; + */ double tmin, tmax, startWindow, endWindow; double startSelection, endSelection; // markers - /* These attributes are all expressed in seconds. Invariants: */ - /* tmin <= startWindow < endWindow <= tmax; */ - /* tmin <= (startSelection, endSelection) <= tmax; */ autoGraphics graphics; // used in the 'draw' method - int functionViewerLeft, functionViewerRight; // size of drawing areas in pixels - int selectionViewerLeft, selectionViewerRight; // size of drawing areas in pixels - int height; // size of drawing areas in pixels + void draw (); + /* + The Normalized Device cordinates are in "pixelettes", which are a bit smaller than pixels. + The purpose of this is optimal look and feel. + The extent to which a pixelette is smaller than a pixel depends on the size of the drawing area: + for smaller drawing areas, texts are a bit more cramped in their rectangles + than for larger drawing areas. + */ + double width_pxlt, height_pxlt; // size of drawing area in pixelettes +private: + double functionViewerLeft, functionViewerRight; // location of function viewer in pixelettes + double selectionViewerLeft, selectionViewerRight; // location of selection viewer in pixelettes +public: + void updateGeometry (int width_pixels, int height_pixels) { + Graphics_setWsViewport (our graphics.get(), 0.0, width_pixels, 0.0, height_pixels); + our width_pxlt = width_pixels + 21; // the +21 means that the horizontal margin becomes a tiny bit larger when the window grows + our height_pxlt = height_pixels + 111; // the +111 means that the vertical margins become a bit larger when the window grows + Graphics_setWsWindow (our graphics.get(), 0.0, our width_pxlt, 0.0, our height_pxlt); + //my viewAllAsPixelettes (); + /* + Put the function viewer at the left and the selection viewer at the right. + */ + our functionViewerLeft = 0; + our functionViewerRight = ( our p_showSelectionViewer ? our width_pxlt * (2.0/3.0) : our width_pxlt ); + our selectionViewerLeft = our functionViewerRight; + our selectionViewerRight = our width_pxlt; + } + bool isInSelectionViewer (double x_pxlt) const { + return x_pxlt > our selectionViewerLeft; + } + void viewAllAsPixelettes () const { + Graphics_setViewport (our graphics.get(), 0.0, our width_pxlt, 0.0, our height_pxlt); + Graphics_setWindow (our graphics.get(), 0.0, our width_pxlt, 0.0, our height_pxlt); + } + void viewFunctionViewerAsPixelettes () const { + Graphics_setViewport (our graphics.get(), our functionViewerLeft, our functionViewerRight, 0.0, our height_pxlt); + Graphics_setWindow (our graphics.get(), our functionViewerLeft, our functionViewerRight, 0.0, our height_pxlt); + } + void viewSelectionViewerAsPixelettes () const { + Graphics_setViewport (our graphics.get(), our selectionViewerLeft, our selectionViewerRight, 0.0, our height_pxlt); + Graphics_setWindow (our graphics.get(), our selectionViewerLeft, our selectionViewerRight, 0.0, our height_pxlt); + } + constexpr static double space = 30.0; + constexpr static double MARGIN = 107.0; + constexpr static double BOTTOM_MARGIN = 2.0; + constexpr static double TOP_MARGIN = 3.0; + double dataLeft_pxlt () const { return our functionViewerLeft + our MARGIN; } + double dataRight_pxlt () const { return our functionViewerRight - our MARGIN; } + double dataBottom_pxlt () const { return our BOTTOM_MARGIN + our space * 3; } + double dataTop_pxlt () const { return our height_pxlt - (TOP_MARGIN + space); } + void viewDataAsWorldByFraction () const { + Graphics_setViewport (our graphics.get(), dataLeft_pxlt(), dataRight_pxlt(), dataBottom_pxlt(), dataTop_pxlt()); + Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, 1.0); + } + void viewTallDataAsWorldByFraction () const { + Graphics_setViewport (our graphics.get(), our dataLeft_pxlt(), our dataRight_pxlt(), 0.0, our height_pxlt); + Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, our height_pxlt); + } + constexpr static double SELECTION_VIEWER_MARGIN = 0.0; + void viewInnerSelectionViewerAsFractionByFraction () const { + Graphics_setViewport (our graphics.get(), our selectionViewerLeft + our MARGIN, our selectionViewerRight - our MARGIN, + our BOTTOM_MARGIN + our space * 3, our height_pxlt - (our TOP_MARGIN + our space)); + Graphics_setViewport (our graphics.get(), + our selectionViewerLeft + our SELECTION_VIEWER_MARGIN, our selectionViewerRight - our SELECTION_VIEWER_MARGIN, + our SELECTION_VIEWER_MARGIN, our height_pxlt - SELECTION_VIEWER_MARGIN + ); + Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); + } + GuiText text; // optional text at top - int shiftKeyPressed; // information for the 'play' method - bool playingCursor, playingSelection; // information for end of play + bool clickWasModifiedByShiftKey; // information for drag-and-drop and for start of play + bool duringPlay; struct FunctionEditor_picture picture; /* Private: */ @@ -76,11 +150,8 @@ Thing_define (FunctionEditor, Editor) { override; virtual void v_draw () { } - /* - * Message: "draw your part of the data between startWindow and endWindow." - */ virtual void v_drawSelectionViewer () { } - virtual void v_drawRealTimeSelectionViewer (int /* phase */, double /* time */) { } + virtual void v_drawRealTimeSelectionViewer (double /* time */) { } virtual void v_prepareDraw () { } // for less flashing virtual conststring32 v_domainName () { return U"time"; } virtual conststring32 v_selectionViewerName () { return U"selection viewer"; } @@ -94,30 +165,18 @@ Thing_define (FunctionEditor, Editor) { virtual const char *v_format_selection () { return u8"%f (%.3f / s)"; } virtual int v_fixedPrecision_long () { return 6; } virtual bool v_hasText () { return false; } - virtual void v_play (double /* timeFrom */, double /* timeTo */) { } + virtual void v_play (double /* startTime */, double /* endTime */) { } + virtual bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction); /* - * Message: "the user clicked in one of the rectangles above or below the data window." - */ - virtual bool v_click (double xWC, double yWC, bool shiftKeyPressed); - /* - * Message: "the user clicked in data window with the left mouse button." - * 'xWC' is the time; - * 'yWC' is a value between 0.0 (bottom) and 1.0 (top); - * 'shiftKeyPressed' flags if the Shift key was held down during the click. - * Constraints: - * Return FunctionEditor_UPDATE_NEEDED if you want a window update, i.e., - * if your 'click' moves the cursor or otherwise changes the appearance of the data. - * Return FunctionEditor_NO_UPDATE_NEEDED if you do not want a window update, e.g., - * if your 'click' method just 'plays' something or puts a dialog on the screen. - * In the latter case, the 'ok' callback of the dialog should - * call FunctionEditor_marksChanged if necessary. - * Behaviour of FunctionEditor::click (): - * moves the cursor to 'xWC', drags to create a selection, or extends the selection. - */ - virtual void v_clickSelectionViewer (double xWC, double yWC); - virtual bool v_clickB (double xWC, double yWC); - virtual bool v_clickE (double xWC, double yWC); - virtual int v_playCallback (int phase, double tmin, double tmax, double t); + Message: "they clicked in the data part of the window, or in the left or right margin." + 'event' is the mouse event, with still relevant info on phase and modifier keys; + 'x_world' is the time (or another world unit); + 'y_fraction' is a value between 0.0 (bottom) and 1.0 (top); + Behaviour of structFunctionEditor::v_mouseInWideDataView (): + moves the cursor to 'x_world', drags to create a selection, or extends the selection. + */ + virtual void v_clickSelectionViewer (double x_fraction, double y_fraction); + virtual int v_playCallback (int phase, double startTime, double endTime, double currentTime); virtual void v_updateText () { } virtual void v_prefs_addFields (EditorCommand) { } virtual void v_prefs_setValues (EditorCommand) { } @@ -129,7 +188,6 @@ Thing_define (FunctionEditor, Editor) { virtual void v_createMenuItems_view_timeDomain (EditorMenu); virtual void v_createMenuItems_view_audio (EditorMenu); virtual void v_highlightSelection (double left, double right, double bottom, double top); - virtual void v_unhighlightSelection (double left, double right, double bottom, double top); virtual double v_getBottomOfSoundArea () { return 0.0; } virtual double v_getBottomOfSoundAndAnalysisArea () { return 0.0; } virtual void v_form_pictureSelection (EditorCommand); @@ -139,31 +197,7 @@ Thing_define (FunctionEditor, Editor) { #include "FunctionEditor_prefs.h" }; -int theFunctionEditor_playCallback (FunctionEditor me, int phase, double tmin, double tmax, double t); - -/* - Attributes: - data: must be a Function. - - int clickB (double xWC, double yWC); - "user clicked in data window with the middle mouse button (Mac: control- or option-click)." - 'xWC' is the time; 'yWC' is a value between 0.0 (bottom) and 1.0 (top). - For the return value, see the 'click' method. - FunctionEditor::clickB simply moves the start of the selection (B) to 'xWC', - with the sole statement 'my startSelection = xWC'. - - int clickE (double xWC, double yWC); - "user clicked in data window with the right mouse button (Mac: command-click)." - 'xWC' is the time; 'yWC' is a value between 0.0 (bottom) and 1.0 (top). - For the return value, see the 'click' method. - FunctionEditor::clickB simply moves the end of the selection (E) to 'xWC', - with the sole statement 'my endSelection = xWC'. - - void key (unsigned char key); - "user typed a key to the data window." - FunctionEditor::key ignores this message. -*/ - +int theFunctionEditor_playCallback (FunctionEditor me, int phase, double startTime, double endTime, double currentTime); #define FunctionEditor_UPDATE_NEEDED true #define FunctionEditor_NO_UPDATE_NEEDED false @@ -213,7 +247,7 @@ void FunctionEditor_redraw (FunctionEditor me); Function: update the drawing area of a single editor. Usage: - calls this after she changes a view option (font, scaling, hide/show xx) + call this after she changes a view option (font, scaling, hide/show xx) or after any of the data have changed. In the latter case, also call Editor_broadcastChange. Behaviour: we just call Graphics_updateWs (my graphics). @@ -224,7 +258,7 @@ void FunctionEditor_enableUpdates (FunctionEditor me, bool enable); Function: temporarily disable update event to cause 'draw' messages. Usage: - If you call from your 'draw' method routines that may trigger expose events, + If you call from your 'draw' method functions that may trigger expose events, you should bracket those routines between FunctionEditor_enableUpdates (me, false); and @@ -237,23 +271,27 @@ void FunctionEditor_ungroup (FunctionEditor me); Function: force me out of the group. Usage: - Start cut or paste methods by calling this routine, + Start cut or paste methods by calling this function, as the grouped editors will not be synchronized after either of those actions. Worse, the selection may get outside the common interval of the editors. */ -/* Some routines to enforce common look to all function editors. */ -/* The x axis of the window is supposed to have been set to [my startWindow, my endWindow]. */ -/* Preconditions: default line type, default line width. */ -/* Postconditions: default line type, default line width, undefined colour, undefined text alignment. */ +/* + Some functions to enforce a common look to all function editors. + The x axis of the window is supposed to have been set to [my startWindow, my endWindow]. + Preconditions: + default line type, default line width. + Postconditions: + default line type, default line width, undefined colour, undefined text alignment. +*/ void FunctionEditor_drawRangeMark (FunctionEditor me, double yWC, conststring32 yWC_string, conststring32 units, int verticalAlignment); void FunctionEditor_drawCursorFunctionValue (FunctionEditor me, double yWC, conststring32 yWC_string, conststring32 units); void FunctionEditor_insertCursorFunctionValue (FunctionEditor me, double yWC, conststring32 yWC_string, conststring32 units, double minimum, double maximum); void FunctionEditor_drawHorizontalHair (FunctionEditor me, double yWC, conststring32 yWC_string, conststring32 units); void FunctionEditor_drawGridLine (FunctionEditor me, double yWC); -void FunctionEditor_garnish (FunctionEditor me); // Optionally selection times and selection hairs. +void FunctionEditor_garnish (FunctionEditor me); // optionally selection times and selection hairs /* End of file FunctionEditor.h */ #endif diff --git a/fon/Harmonics.h b/fon/Harmonics.h index 3c6c846c..f8a17bc5 100644 --- a/fon/Harmonics.h +++ b/fon/Harmonics.h @@ -2,7 +2,7 @@ #define _Harmonics_h_ /* Harmonics.h * - * Copyright (C) 2011,2015,2017 Paul Boersma + * Copyright (C) 2011,2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -26,7 +26,7 @@ autoHarmonics Harmonics_create (integer numberOfHarmonics); void Harmonics_draw (Harmonics me, Graphics g, double fmin, double fmax, - double minimum, double maximum, int garnish, conststring32 method); + double minimum, double maximum, bool garnish, conststring32 method); autoMatrix Harmonics_to_Matrix (Harmonics me); autoHarmonics Matrix_to_Harmonics (Matrix me); diff --git a/fon/IntensityTier.cpp b/fon/IntensityTier.cpp index 4a8919b1..a237dfcc 100644 --- a/fon/IntensityTier.cpp +++ b/fon/IntensityTier.cpp @@ -1,6 +1,6 @@ /* IntensityTier.cpp * - * Copyright (C) 1992-2011,2015,2016,2017 Paul Boersma + * Copyright (C) 1992-2005,2007,2008,2010-2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -31,7 +31,7 @@ autoIntensityTier IntensityTier_create (double tmin, double tmax) { } void IntensityTier_draw (IntensityTier me, Graphics g, double tmin, double tmax, - double ymin, double ymax, conststring32 method, int garnish) + double ymin, double ymax, conststring32 method, bool garnish) { RealTier_draw (me, g, tmin, tmax, ymin, ymax, garnish, method, U"Intensity (dB)"); } diff --git a/fon/IntensityTier.h b/fon/IntensityTier.h index 3c54d5a8..0cd56d45 100644 --- a/fon/IntensityTier.h +++ b/fon/IntensityTier.h @@ -2,7 +2,7 @@ #define _IntensityTier_h_ /* IntensityTier.h * - * Copyright (C) 1992-2011,2015 Paul Boersma + * Copyright (C) 1992-2005,2007,2010-2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -31,7 +31,7 @@ Thing_define (IntensityTier, RealTier) { autoIntensityTier IntensityTier_create (double tmin, double tmax); void IntensityTier_draw (IntensityTier me, Graphics g, double tmin, double tmax, - double ymin, double ymax, conststring32 method, int garnish); + double ymin, double ymax, conststring32 method, bool garnish); autoIntensityTier PointProcess_upto_IntensityTier (PointProcess me, double intensity); autoIntensityTier Intensity_downto_IntensityTier (Intensity me); diff --git a/fon/IntensityTierEditor.cpp b/fon/IntensityTierEditor.cpp index b0817464..47e7c9ab 100644 --- a/fon/IntensityTierEditor.cpp +++ b/fon/IntensityTierEditor.cpp @@ -1,6 +1,6 @@ /* IntensityTierEditor.cpp * - * Copyright (C) 1992-2011,2012,2014,2015,2016 Paul Boersma + * Copyright (C) 1992-2012,2014-2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,6 +19,8 @@ #include "IntensityTierEditor.h" #include "EditorM.h" +Thing_implement (IntensityTierArea, RealTierArea, 0); + Thing_implement (IntensityTierEditor, RealTierEditor, 0); static void menu_cb_IntensityTierHelp (IntensityTierEditor, EDITOR_ARGS_DIRECT) { Melder_help (U"IntensityTier"); } @@ -28,18 +30,18 @@ void structIntensityTierEditor :: v_createHelpMenuItems (EditorMenu menu) { EditorMenu_addCommand (menu, U"IntensityTier help", 0, menu_cb_IntensityTierHelp); } -void structIntensityTierEditor :: v_play (double a_tmin, double a_tmax) { +void structIntensityTierEditor :: v_play (double startTime, double endTime) { if (our d_sound.data) { - Sound_playPart (our d_sound.data, a_tmin, a_tmax, theFunctionEditor_playCallback, this); + Sound_playPart (our d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); } else { - //IntensityTier_playPart (our data, a_tmin, a_tmax, false); + //IntensityTier_playPart (our data, startTime, endTime, false); } } autoIntensityTierEditor IntensityTierEditor_create (conststring32 title, IntensityTier intensity, Sound sound, bool ownSound) { try { autoIntensityTierEditor me = Thing_new (IntensityTierEditor); - RealTierEditor_init (me.get(), title, (RealTier) intensity, sound, ownSound); + RealTierEditor_init (me.get(), classIntensityTierArea, title, intensity, sound, ownSound); return me; } catch (MelderError) { Melder_throw (U"IntensityTier window not created."); diff --git a/fon/IntensityTierEditor.h b/fon/IntensityTierEditor.h index 77f63bdb..7c942d56 100644 --- a/fon/IntensityTierEditor.h +++ b/fon/IntensityTierEditor.h @@ -22,6 +22,21 @@ #include "IntensityTier.h" #include "Sound.h" +Thing_define (IntensityTierArea, RealTierArea) { + conststring32 v_rightTickUnits () + override { return U" dB"; } + double v_defaultYmin () + override { return 50.0; } + double v_defaultYmax () + override { return 100.0; } +}; + +inline static autoIntensityTierArea IntensityTierArea_create (FunctionEditor editor, double ymin_fraction, double ymax_fraction) { + autoIntensityTierArea me = Thing_new (IntensityTierArea); + FunctionArea_init (me.get(), editor, ymin_fraction, ymax_fraction); + return me; +} + Thing_define (IntensityTierEditor, RealTierEditor) { void v_createHelpMenuItems (EditorMenu menu) override; @@ -29,12 +44,6 @@ Thing_define (IntensityTierEditor, RealTierEditor) { override; conststring32 v_quantityText () override { return U"Intensity (dB)"; } - conststring32 v_rightTickUnits () - override { return U" dB"; } - double v_defaultYmin () - override { return 50.0; } - double v_defaultYmax () - override { return 100.0; } conststring32 v_setRangeTitle () override { return U"Set intensity range..."; } conststring32 v_defaultYminText () diff --git a/fon/Makefile b/fon/Makefile index 5f7f4426..6b1f6d54 100644 --- a/fon/Makefile +++ b/fon/Makefile @@ -1,5 +1,5 @@ # Makefile of the library "fon" -# Paul Boersma, 28 February 2019 +# Paul Boersma, 31 August 2020 include ../makefile.defs @@ -22,10 +22,10 @@ OBJECTS = Transition.o Distributions_and_Transition.o \ Sound_to_Cochleagram.o Spectrum_to_Excitation.o \ VocalTract.o VocalTract_to_Spectrum.o \ SoundRecorder.o Sound_enhance.o VoiceAnalysis.o \ - FunctionEditor.o TimeSoundEditor.o TimeSoundAnalysisEditor.o \ + FunctionArea.o FunctionEditor.o TimeSoundEditor.o TimeSoundAnalysisEditor.o \ PitchEditor.o SoundEditor.o SpectrumEditor.o SpectrogramEditor.o PointEditor.o \ - RealTierEditor.o PitchTierEditor.o IntensityTierEditor.o \ - DurationTierEditor.o AmplitudeTierEditor.o \ + RealTierArea.o RealTierEditor.o PitchTierArea.o PitchTierEditor.o IntensityTierEditor.o \ + DurationTierArea.o DurationTierEditor.o AmplitudeTierEditor.o \ ManipulationEditor.o TextGridEditor.o FormantGridEditor.o \ WordList.o SpellingChecker.o \ FujisakiPitch.o \ diff --git a/fon/ManipulationEditor.cpp b/fon/ManipulationEditor.cpp index cd1427c0..42ec4b62 100644 --- a/fon/ManipulationEditor.cpp +++ b/fon/ManipulationEditor.cpp @@ -1,6 +1,6 @@ /* ManipulationEditor.cpp * - * Copyright (C) 1992-2018 Paul Boersma + * Copyright (C) 1992-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -51,10 +51,6 @@ static const conststring32 units_strings [] = { 0, U"Hz", U"st" }; static int prefs_synthesisMethod = Manipulation_OVERLAPADD; /* Remembered across editor creations, not across Praat sessions. */ -/* BUG: 25 should be fmin */ -#define YLIN(freq) (my p_pitch_units == kManipulationEditor_pitchUnits::HERTZ ? ((freq) < 25 ? 25 : (freq)) : NUMhertzToSemitones ((freq) < 25 ? 25 : (freq))) -#define YLININV(freq) (my p_pitch_units == kManipulationEditor_pitchUnits::HERTZ ? (freq) : NUMsemitonesToHertz (freq)) - static void updateMenus (ManipulationEditor me) { Melder_assert (my synthPulsesButton); GuiMenuItem_check (my synthPulsesButton, my synthesisMethod == Manipulation_PULSES); @@ -77,29 +73,12 @@ static void updateMenus (ManipulationEditor me) { } /* - * The "sound area" contains the original sound and the pulses. + The "sound area" contains the original sound and the pulses. */ static bool getSoundArea (ManipulationEditor me, double *ymin, double *ymax) { - Manipulation ana = (Manipulation) my data; - *ymin = 0.66; + *ymin = 0.67; *ymax = 1.00; - return ana -> sound || ana -> pulses; -} -/* - * The "pitch area" contains the grey pitch analysis based on the pulses, and the blue pitch tier. - */ -static bool getPitchArea (ManipulationEditor me, double *ymin, double *ymax) { - Manipulation ana = (Manipulation) my data; - *ymin = ana -> duration ? 0.16 : 0.00; - *ymax = 0.65; - return ana -> pulses || ana -> pitch; -} -static bool getDurationArea (ManipulationEditor me, double *ymin, double *ymax) { - Manipulation ana = (Manipulation) my data; - if (! ana -> duration) return false; - *ymin = 0.00; - *ymax = 0.15; - return true; + return my sound() || my pulses(); } /********** MENU COMMANDS **********/ @@ -107,74 +86,70 @@ static bool getDurationArea (ManipulationEditor me, double *ymin, double *ymax) /***** FILE MENU *****/ static void menu_cb_extractOriginalSound (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> sound) return; - autoSound publish = Data_copy (ana -> sound.get()); + if (! my sound()) + return; + autoSound publish = Data_copy (my sound().get()); Editor_broadcastPublication (me, publish.move()); } static void menu_cb_extractPulses (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> pulses) return; - autoPointProcess publish = Data_copy (ana -> pulses.get()); + if (! my pulses()) + return; + autoPointProcess publish = Data_copy (my pulses().get()); Editor_broadcastPublication (me, publish.move()); } static void menu_cb_extractPitchTier (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; - autoPitchTier publish = Data_copy (ana -> pitch.get()); + if (! my pitch()) + return; + autoPitchTier publish = Data_copy (my pitch().get()); Editor_broadcastPublication (me, publish.move()); } static void menu_cb_extractDurationTier (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> duration) return; - autoDurationTier publish = Data_copy (ana -> duration.get()); + if (! my duration()) + return; + autoDurationTier publish = Data_copy (my duration().get()); Editor_broadcastPublication (me, publish.move()); } static void menu_cb_extractManipulatedSound (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - autoSound publish = Manipulation_to_Sound (ana, my synthesisMethod); + autoSound publish = Manipulation_to_Sound (my manipulation(), my synthesisMethod); Editor_broadcastPublication (me, publish.move()); } /***** EDIT MENU *****/ void structManipulationEditor :: v_saveData () { - Manipulation ana = (Manipulation) our data; - if (ana -> pulses) our previousPulses = Data_copy (ana -> pulses.get()); - if (ana -> pitch) our previousPitch = Data_copy (ana -> pitch.get()); - if (ana -> duration) our previousDuration = Data_copy (ana -> duration.get()); + our previousPulses = Data_copy (our pulses().get()); // could be null + our previousPitch = Data_copy (our pitch().get()); // could be null + our previousDuration = Data_copy (our duration().get()); // could be null } void structManipulationEditor :: v_restoreData () { - Manipulation ana = (Manipulation) our data; - autoPointProcess dummy1 = ana -> pulses.move(); ana -> pulses = our previousPulses.move(); our previousPulses = dummy1.move(); - autoPitchTier dummy2 = ana -> pitch.move(); ana -> pitch = our previousPitch.move(); our previousPitch = dummy2.move(); - autoDurationTier dummy3 = ana -> duration.move(); ana -> duration = our previousDuration.move(); our previousDuration = dummy3.move(); + std::swap (our pulses(), our previousPulses); // could be null + std::swap (our pitch(), our previousPitch); // could be null + std::swap (our duration(), our previousDuration); // could be null } /***** PULSES MENU *****/ static void menu_cb_removePulses (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> pulses) return; + if (! my pulses()) + return; Editor_save (me, U"Remove pulse(s)"); if (my startSelection == my endSelection) - PointProcess_removePointNear (ana -> pulses.get(), my startSelection); + PointProcess_removePointNear (my pulses().get(), my startSelection); else - PointProcess_removePointsBetween (ana -> pulses.get(), my startSelection, my endSelection); + PointProcess_removePointsBetween (my pulses().get(), my startSelection, my endSelection); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } static void menu_cb_addPulseAtCursor (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> pulses) return; + if (! my pulses()) return; Editor_save (me, U"Add pulse"); - PointProcess_addPoint (ana -> pulses.get(), 0.5 * (my startSelection + my endSelection)); + PointProcess_addPoint (my pulses().get(), 0.5 * (my startSelection + my endSelection)); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } @@ -185,10 +160,10 @@ static void menu_cb_addPulseAt (ManipulationEditor me, EDITOR_ARGS_FORM) { EDITOR_OK SET_REAL (position, 0.5 * (my startSelection + my endSelection)) EDITOR_DO - Manipulation ana = (Manipulation) my data; - if (! ana -> pulses) return; + if (! my pulses()) + return; Editor_save (me, U"Add pulse"); - PointProcess_addPoint (ana -> pulses.get(), position); + PointProcess_addPoint (my pulses().get(), position); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); EDITOR_END @@ -197,47 +172,47 @@ static void menu_cb_addPulseAt (ManipulationEditor me, EDITOR_ARGS_FORM) { /***** PITCH MENU *****/ static void menu_cb_removePitchPoints (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Remove pitch point(s)"); if (my startSelection == my endSelection) - AnyTier_removePointNear (ana -> pitch.get()->asAnyTier(), my startSelection); + AnyTier_removePointNear (my pitch()->asAnyTier(), my startSelection); else - AnyTier_removePointsBetween (ana -> pitch.get()->asAnyTier(), my startSelection, my endSelection); + AnyTier_removePointsBetween (my pitch()->asAnyTier(), my startSelection, my endSelection); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } static void menu_cb_addPitchPointAtCursor (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Add pitch point"); - RealTier_addPoint (ana -> pitch.get(), 0.5 * (my startSelection + my endSelection), YLININV (my pitchTier.cursor)); + RealTier_addPoint (my pitch().get(), 0.5 * (my startSelection + my endSelection), + my pitchTierArea -> v_yToValue (my pitchTierArea -> ycursor)); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } static void menu_cb_addPitchPointAtSlice (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - PointProcess pulses = ana -> pulses.get(); - if (! pulses) + if (! my pulses()) Melder_throw (U"There are no pulses."); - if (! ana -> pitch) + if (! my pitch()) return; - integer ileft = PointProcess_getLowIndex (pulses, 0.5 * (my startSelection + my endSelection)), iright = ileft + 1, nt = pulses -> nt; - constVEC t = pulses -> t.get(); - double f = my pitchTier.cursor; // default + const integer ileft = PointProcess_getLowIndex (my pulses().get(), 0.5 * (my startSelection + my endSelection)); + const integer iright = ileft + 1, nt = my pulses() -> nt; + constVEC t = my pulses() -> t.get(); + double desiredY = my pitchTierArea -> ycursor; // default Editor_save (me, U"Add pitch point"); if (nt <= 1) { /* Ignore. */ } else if (ileft <= 0) { double tright = t [2] - t [1]; if (tright > 0.0 && tright <= 0.02) - f = YLIN (1.0 / tright); + desiredY = my pitchTierArea -> v_valueToY (1.0 / tright); } else if (iright > nt) { double tleft = t [nt] - t [nt - 1]; if (tleft > 0.0 && tleft <= 0.02) - f = YLIN (1.0 / tleft); + desiredY = my pitchTierArea -> v_valueToY (1.0 / tleft); } else { /* Three-period median. */ double tmid = t [iright] - t [ileft], tleft = 0.0, tright = 0.0; if (ileft > 1) @@ -258,13 +233,13 @@ static void menu_cb_addPitchPointAtSlice (ManipulationEditor me, EDITOR_ARGS_DIR if (tright < tmid) std::swap (tright, tmid); if (tleft != 0.0) - f = YLIN (1 / tmid); // median of 3 + desiredY = my pitchTierArea -> v_valueToY (1 / tmid); // median of 3 else if (tmid != 0.0) - f = YLIN (2 / (tmid + tright)); // median of 2 + desiredY = my pitchTierArea -> v_valueToY (2 / (tmid + tright)); // median of 2 else if (tright != 0.0) - f = YLIN (1 / tright); // median of 1 + desiredY = my pitchTierArea -> v_valueToY (1 / tright); // median of 1 } - RealTier_addPoint (ana -> pitch.get(), 0.5 * (my startSelection + my endSelection), YLININV (f)); + RealTierArea_addPointAt (my pitchTierArea.get(), my pitch().get(), 0.5 * (my startSelection + my endSelection), desiredY); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } @@ -275,12 +250,12 @@ static void menu_cb_addPitchPointAt (ManipulationEditor me, EDITOR_ARGS_FORM) { REAL (frequency, U"Frequency (Hz or st)", U"100.0") EDITOR_OK SET_REAL (time, 0.5 * (my startSelection + my endSelection)) - SET_REAL (frequency, my pitchTier.cursor) + SET_REAL (frequency, my pitchTierArea -> ycursor) EDITOR_DO - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Add pitch point"); - RealTier_addPoint (ana -> pitch.get(), time, YLININV (frequency)); + RealTierArea_addPointAt (my pitchTierArea.get(), my pitch().get(), time, frequency); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); EDITOR_END @@ -296,10 +271,10 @@ static void menu_cb_stylizePitch (ManipulationEditor me, EDITOR_ARGS_FORM) { SET_REAL (frequencyResolution, my p_pitch_stylize_frequencyResolution) SET_OPTION (units, my p_pitch_stylize_useSemitones + 1) EDITOR_DO - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Stylize pitch"); - PitchTier_stylize (ana -> pitch.get(), + PitchTier_stylize (my pitch().get(), my pref_pitch_stylize_frequencyResolution () = my p_pitch_stylize_frequencyResolution = frequencyResolution, my pref_pitch_stylize_useSemitones () = my p_pitch_stylize_useSemitones = units - 1); FunctionEditor_redraw (me); @@ -308,10 +283,10 @@ static void menu_cb_stylizePitch (ManipulationEditor me, EDITOR_ARGS_FORM) { } static void menu_cb_stylizePitch_2st (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Stylize pitch"); - PitchTier_stylize (ana -> pitch.get(), 2.0, true); + PitchTier_stylize (my pitch().get(), 2.0, true); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } @@ -322,22 +297,22 @@ static void menu_cb_interpolateQuadratically (ManipulationEditor me, EDITOR_ARGS EDITOR_OK SET_INTEGER (numberOfPointsPerParabola, my p_pitch_interpolateQuadratically_numberOfPointsPerParabola) EDITOR_DO - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Interpolate quadratically"); - RealTier_interpolateQuadratically (ana -> pitch.get(), + RealTier_interpolateQuadratically (my pitch().get(), my pref_pitch_interpolateQuadratically_numberOfPointsPerParabola () = my p_pitch_interpolateQuadratically_numberOfPointsPerParabola = numberOfPointsPerParabola, - my p_pitch_units == kManipulationEditor_pitchUnits::SEMITONES); + my pitchTierArea -> p_units == kPitchTierArea_units::SEMITONES); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); EDITOR_END } static void menu_cb_interpolateQuadratically_4pts (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Interpolate quadratically"); - RealTier_interpolateQuadratically (ana -> pitch.get(), 4, my p_pitch_units == kManipulationEditor_pitchUnits::SEMITONES); + RealTier_interpolateQuadratically (my pitch().get(), 4, my pitchTierArea -> p_units == kPitchTierArea_units::SEMITONES); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } @@ -353,17 +328,17 @@ static void menu_cb_shiftPitchFrequencies (ManipulationEditor me, EDITOR_ARGS_FO OPTION (U"ERB") EDITOR_OK EDITOR_DO - Manipulation ana = (Manipulation) my data; kPitch_unit unit = unit_i == 1 ? kPitch_unit::HERTZ : unit_i == 2 ? kPitch_unit::MEL : unit_i == 3 ? kPitch_unit::LOG_HERTZ : unit_i == 4 ? kPitch_unit::SEMITONES_1 : kPitch_unit::ERB; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Shift pitch frequencies"); try { - PitchTier_shiftFrequencies (ana -> pitch.get(), my startSelection, my endSelection, frequencyShift, unit); + PitchTier_shiftFrequencies (my pitch().get(), my startSelection, my endSelection, frequencyShift, unit); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } catch (MelderError) { @@ -381,10 +356,10 @@ static void menu_cb_multiplyPitchFrequencies (ManipulationEditor me, EDITOR_ARGS LABEL (U"The multiplication is always done in hertz.") EDITOR_OK EDITOR_DO - Manipulation ana = (Manipulation) my data; - if (! ana -> pitch) return; + if (! my pitch()) + return; Editor_save (me, U"Multiply pitch frequencies"); - PitchTier_multiplyFrequencies (ana -> pitch.get(), my startSelection, my endSelection, factor); + PitchTier_multiplyFrequencies (my pitch().get(), my startSelection, my endSelection, factor); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); EDITOR_END @@ -393,38 +368,38 @@ static void menu_cb_multiplyPitchFrequencies (ManipulationEditor me, EDITOR_ARGS static void menu_cb_setPitchRange (ManipulationEditor me, EDITOR_ARGS_FORM) { EDITOR_FORM (U"Set pitch range", nullptr) /* BUG: should include Minimum */ - REAL (maximum, U"Maximum (Hz or st)", my default_pitch_maximum ()) + REAL (maximum, U"Maximum (Hz or st)", my pitchTierArea -> default_maximum ()) EDITOR_OK - SET_REAL (maximum, my p_pitch_maximum) + SET_REAL (maximum, my pitchTierArea -> p_maximum) EDITOR_DO if (maximum <= my pitchTier.minPeriodic) - Melder_throw (U"Maximum pitch must be greater than ", - Melder_half (my pitchTier.minPeriodic), U" ", units_strings [(int) my p_pitch_units], U"."); - my pref_pitch_maximum () = my p_pitch_maximum = maximum; + Melder_throw (U"Maximum pitch should be greater than ", + Melder_half (my pitchTier.minPeriodic), U" ", units_strings [(int) my pitchTierArea -> p_units], U"."); + my pitchTierArea -> ymax = my pitchTierArea -> pref_maximum () = my pitchTierArea -> p_maximum = maximum; FunctionEditor_redraw (me); EDITOR_END } static void menu_cb_setPitchUnits (ManipulationEditor me, EDITOR_ARGS_FORM) { EDITOR_FORM (U"Set pitch units", nullptr) - RADIO_ENUM (kManipulationEditor_pitchUnits, pitchUnits, - U"Pitch units", my default_pitch_units ()) + RADIO_ENUM (kPitchTierArea_units, pitchUnits, + U"Pitch units", my pitchTierArea -> default_units ()) EDITOR_OK - SET_ENUM (pitchUnits, kManipulationEditor_pitchUnits, my p_pitch_units) + SET_ENUM (pitchUnits, kPitchTierArea_units, my pitchTierArea -> p_units) EDITOR_DO - enum kManipulationEditor_pitchUnits oldPitchUnits = my p_pitch_units; - my pref_pitch_units () = my p_pitch_units = pitchUnits; - if (my p_pitch_units == oldPitchUnits) return; - if (my p_pitch_units == kManipulationEditor_pitchUnits::HERTZ) { - my p_pitch_minimum = 25.0; + enum kPitchTierArea_units oldPitchUnits = my pitchTierArea -> p_units; + my pitchTierArea -> pref_units () = my pitchTierArea -> p_units = pitchUnits; + if (my pitchTierArea -> p_units == oldPitchUnits) return; + if (my pitchTierArea -> p_units == kPitchTierArea_units::HERTZ) { + my pitchTierArea -> p_minimum = 25.0; my pitchTier.minPeriodic = 50.0; - my pref_pitch_maximum () = my p_pitch_maximum = NUMsemitonesToHertz (my p_pitch_maximum); - my pitchTier.cursor = NUMsemitonesToHertz (my pitchTier.cursor); + my pitchTierArea -> ymax = my pitchTierArea -> pref_maximum () = my pitchTierArea -> p_maximum = NUMsemitonesToHertz (my pitchTierArea -> p_maximum); + my pitchTierArea -> ycursor = NUMsemitonesToHertz (my pitchTierArea -> ycursor); } else { - my p_pitch_minimum = -24.0; + my pitchTierArea -> p_minimum = -24.0; my pitchTier.minPeriodic = -12.0; - my pref_pitch_maximum () = my p_pitch_maximum = NUMhertzToSemitones (my p_pitch_maximum); - my pitchTier.cursor = NUMhertzToSemitones (my pitchTier.cursor); + my pitchTierArea -> ymax = my pitchTierArea -> pref_maximum () = my pitchTierArea -> p_maximum = NUMhertzToSemitones (my pitchTierArea -> p_maximum); + my pitchTierArea -> ycursor = NUMhertzToSemitones (my pitchTierArea -> ycursor); } FunctionEditor_redraw (me); EDITOR_END @@ -434,26 +409,28 @@ static void menu_cb_setPitchUnits (ManipulationEditor me, EDITOR_ARGS_FORM) { static void menu_cb_setDurationRange (ManipulationEditor me, EDITOR_ARGS_FORM) { EDITOR_FORM (U"Set duration range", nullptr) - REAL (minimum, U"Minimum", my default_duration_minimum ()) - REAL (maximum, U"Maximum", my default_duration_maximum ()) + REAL (minimum, U"Minimum", my durationTierArea -> default_minimum ()) + REAL (maximum, U"Maximum", my durationTierArea -> default_maximum ()) EDITOR_OK - SET_REAL (minimum, my p_duration_minimum) - SET_REAL (maximum, my p_duration_maximum) + SET_REAL (minimum, my durationTierArea -> p_minimum) + SET_REAL (maximum, my durationTierArea -> p_maximum) EDITOR_DO - Manipulation ana = (Manipulation) my data; - double minimumValue = ana -> duration ? RealTier_getMinimumValue (ana -> duration.get()) : undefined; - double maximumValue = ana -> duration ? RealTier_getMaximumValue (ana -> duration.get()) : undefined; - if (minimum > 1) Melder_throw (U"Minimum relative duration must not be greater than 1."); - if (maximum < 1) Melder_throw (U"Maximum relative duration must not be less than 1."); - if (minimum >= maximum) Melder_throw (U"Maximum relative duration must be greater than minimum."); + double minimumValue = ( my duration() ? RealTier_getMinimumValue (my duration().get()) : undefined ); + double maximumValue = ( my duration() ? RealTier_getMaximumValue (my duration().get()) : undefined ); + if (minimum > 1.0) + Melder_throw (U"Minimum relative duration should not be greater than 1."); + if (maximum < 1.0) + Melder_throw (U"Maximum relative duration should not be less than 1."); + if (minimum >= maximum) + Melder_throw (U"Maximum relative duration should be greater than minimum."); if (isdefined (minimumValue) && minimum > minimumValue) - Melder_throw (U"Minimum relative duration must not be greater than the minimum value present, " + Melder_throw (U"Minimum relative duration should not be greater than the minimum value present, " U"which is ", Melder_half (minimumValue), U"."); if (isdefined (maximumValue) && maximum < maximumValue) - Melder_throw (U"Maximum relative duration must not be less than the maximum value present, " + Melder_throw (U"Maximum relative duration should not be less than the maximum value present, " U"which is ", Melder_half (maximumValue), U"."); - my pref_duration_minimum () = my p_duration_minimum = minimum; - my pref_duration_maximum () = my p_duration_maximum = maximum; + my durationTierArea -> ymin = my durationTierArea -> pref_minimum () = my durationTierArea -> p_minimum = minimum; + my durationTierArea -> ymax = my durationTierArea -> pref_maximum () = my durationTierArea -> p_maximum = maximum; FunctionEditor_redraw (me); EDITOR_END } @@ -470,22 +447,22 @@ static void menu_cb_setDraggingStrategy (ManipulationEditor me, EDITOR_ARGS_FORM } static void menu_cb_removeDurationPoints (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> duration) return; + if (! my duration()) + return; Editor_save (me, U"Remove duration point(s)"); if (my startSelection == my endSelection) - AnyTier_removePointNear (ana -> duration.get()->asAnyTier(), 0.5 * (my startSelection + my endSelection)); + AnyTier_removePointNear (my duration()->asAnyTier(), 0.5 * (my startSelection + my endSelection)); else - AnyTier_removePointsBetween (ana -> duration.get()->asAnyTier(), my startSelection, my endSelection); + AnyTier_removePointsBetween (my duration()->asAnyTier(), my startSelection, my endSelection); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } static void menu_cb_addDurationPointAtCursor (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - if (! ana -> duration) return; + if (! my duration()) + return; Editor_save (me, U"Add duration point"); - RealTier_addPoint (ana -> duration.get(), 0.5 * (my startSelection + my endSelection), my duration.cursor); + RealTier_addPoint (my duration().get(), 0.5 * (my startSelection + my endSelection), my durationTierArea -> ycursor); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } @@ -497,26 +474,25 @@ static void menu_cb_addDurationPointAt (ManipulationEditor me, EDITOR_ARGS_FORM) EDITOR_OK SET_REAL (time, 0.5 * (my startSelection + my endSelection)) EDITOR_DO - Manipulation ana = (Manipulation) my data; - if (! ana -> duration) return; + if (! my duration()) + return; Editor_save (me, U"Add duration point"); - RealTier_addPoint (ana -> duration.get(), time, relativeDuration); + RealTier_addPoint (my duration().get(), time, relativeDuration); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); EDITOR_END } static void menu_cb_newDuration (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; Editor_save (me, U"New duration"); - ana -> duration = DurationTier_create (ana -> xmin, ana -> xmax); + my duration() = DurationTier_create (my manipulation() -> xmin, my manipulation() -> xmax); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } static void menu_cb_forgetDuration (ManipulationEditor me, EDITOR_ARGS_DIRECT) { - Manipulation ana = (Manipulation) my data; - ana -> duration = autoDurationTier(); + Editor_save (me, U"Forget duration"); + my duration() = autoDurationTier(); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } @@ -610,9 +586,6 @@ void structManipulationEditor :: v_createHelpMenuItems (EditorMenu menu) { /********** DRAWING AREA **********/ static void drawSoundArea (ManipulationEditor me, double ymin, double ymax) { - Manipulation ana = (Manipulation) my data; - Sound sound = ana -> sound.get(); - PointProcess pulses = ana -> pulses.get(); Graphics_Viewport viewport = Graphics_insetViewport (my graphics.get(), 0.0, 1.0, ymin, ymax); Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setColour (my graphics.get(), Melder_WHITE); @@ -627,77 +600,73 @@ static void drawSoundArea (ManipulationEditor me, double ymin, double ymax) { Graphics_setFont (my graphics.get(), kGraphics_font::HELVETICA); /* - * Draw blue pulses. - */ - if (pulses) { + Draw blue pulses. + */ + if (my pulses()) { Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, 0.0, 1.0); Graphics_setColour (my graphics.get(), Melder_BLUE); - for (integer i = 1; i <= pulses -> nt; i ++) { - double t = pulses -> t [i]; + for (integer i = 1; i <= my pulses() -> nt; i ++) { + double t = my pulses() -> t [i]; if (t >= my startWindow && t <= my endWindow) Graphics_line (my graphics.get(), t, 0.05, t, 0.95); } } /* - * Draw sound. - */ + Draw sound. + */ integer first, last; - if (sound && Sampled_getWindowSamples (sound, my startWindow, my endWindow, & first, & last) > 1) { + if (my sound() && Sampled_getWindowSamples (my sound().get(), my startWindow, my endWindow, & first, & last) > 1) { double minimum, maximum, scaleMin, scaleMax; - Matrix_getWindowExtrema (sound, first, last, 1, 1, & minimum, & maximum); - if (minimum == maximum) minimum = -0.5, maximum = +0.5; - + Matrix_getWindowExtrema (my sound().get(), first, last, 1, 1, & minimum, & maximum); + if (minimum == maximum) { + minimum = -0.5; + maximum = +0.5; + } /* - * Scaling. - */ + Scaling. + */ scaleMin = 0.83 * minimum + 0.17 * my soundmin; scaleMax = 0.83 * maximum + 0.17 * my soundmax; Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, scaleMin, scaleMax); FunctionEditor_drawRangeMark (me, scaleMin, Melder_float (Melder_half (scaleMin)), U"", Graphics_BOTTOM); FunctionEditor_drawRangeMark (me, scaleMax, Melder_float (Melder_half (scaleMax)), U"", Graphics_TOP); - /* - * Draw dotted zero line. - */ + Draw dotted zero line. + */ if (minimum < 0.0 && maximum > 0.0) { Graphics_setColour (my graphics.get(), Melder_CYAN); Graphics_setLineType (my graphics.get(), Graphics_DOTTED); Graphics_line (my graphics.get(), my startWindow, 0.0, my endWindow, 0.0); Graphics_setLineType (my graphics.get(), Graphics_DRAWN); - } - + } /* - * Draw samples. - */ + Draw samples. + */ Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_function (my graphics.get(), & sound -> z [1] [0], first, last, - Sampled_indexToX (sound, first), Sampled_indexToX (sound, last)); + Graphics_function (my graphics.get(), & my sound() -> z [1] [0], first, last, + Sampled_indexToX (my sound().get(), first), Sampled_indexToX (my sound().get(), last)); } Graphics_resetViewport (my graphics.get(), viewport); } -static void drawPitchArea (ManipulationEditor me, double ymin, double ymax) { - Manipulation ana = (Manipulation) my data; - PointProcess pulses = ana -> pulses.get(); - PitchTier pitch = ana -> pitch.get(); - integer ifirstSelected, ilastSelected, n = pitch ? pitch -> points.size : 0, imin, imax, i; - int cursorVisible = my startSelection == my endSelection && my startSelection >= my startWindow && my startSelection <= my endWindow; - double minimumFrequency = YLIN (50); - int rangePrecisions [] = { 0, 1, 2 }; +static void drawPitchArea (ManipulationEditor me) { + const integer n = ( my pitch() ? my pitch() -> points.size : 0 ); + const bool cursorVisible = ( my startSelection == my endSelection && my startSelection >= my startWindow && my startSelection <= my endWindow ); + const double minimumFrequency = my pitchTierArea -> v_valueToY (50.0); + const int rangePrecisions [] = { 0, 1, 2 }; static const conststring32 rangeUnits [] = { U"", U" Hz", U" st" }; - /* - * Pitch contours. - */ - Graphics_Viewport viewport = Graphics_insetViewport (my graphics.get(), 0, 1, ymin, ymax); + my pitchTierArea -> setViewport(); + Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setColour (my graphics.get(), Melder_WHITE); Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setColour (my graphics.get(), Melder_BLACK); Graphics_rectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setColour (my graphics.get(), Melder_GREEN); + + Graphics_setColour (my graphics.get(), Melder_BLUE); Graphics_setFont (my graphics.get(), kGraphics_font::TIMES); Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_TOP); Graphics_text (my graphics.get(), 1.0, 1.0, U"%%Pitch manip"); @@ -705,577 +674,190 @@ static void drawPitchArea (ManipulationEditor me, double ymin, double ymax) { Graphics_text (my graphics.get(), 1.0, 1.0 - Graphics_dyMMtoWC (my graphics.get(), 3), U"%%Pitch from pulses"); Graphics_setFont (my graphics.get(), kGraphics_font::HELVETICA); - Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my p_pitch_minimum, my p_pitch_maximum); + Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my pitchTierArea -> p_minimum, my pitchTierArea -> p_maximum); /* - * Draw pitch contour based on pulses. - */ + Draw pitch contour based on pulses. + */ Graphics_setGrey (my graphics.get(), 0.7); - if (pulses) for (i = 1; i < pulses -> nt; i ++) { - double tleft = pulses -> t [i], tright = pulses -> t [i + 1], t = 0.5 * (tleft + tright); + if (my pulses()) for (integer i = 1; i < my pulses() -> nt; i ++) { + const double tleft = my pulses() -> t [i], tright = my pulses() -> t [i + 1], t = 0.5 * (tleft + tright); if (t >= my startWindow && t <= my endWindow) { if (tleft != tright) { - double f = YLIN (1 / (tright - tleft)); - if (f >= my pitchTier.minPeriodic && f <= my p_pitch_maximum) { + const double f = my pitchTierArea -> v_valueToY (1 / (tright - tleft)); + if (f >= my pitchTier.minPeriodic && f <= my pitchTierArea -> p_maximum) Graphics_fillCircle_mm (my graphics.get(), t, f, 1); - } } } } Graphics_setGrey (my graphics.get(), 0.0); FunctionEditor_drawGridLine (me, minimumFrequency); - FunctionEditor_drawRangeMark (me, my p_pitch_maximum, - Melder_fixed (my p_pitch_maximum, rangePrecisions [(int) my p_pitch_units]), rangeUnits [(int) my p_pitch_units], Graphics_TOP); - FunctionEditor_drawRangeMark (me, my p_pitch_minimum, - Melder_fixed (my p_pitch_minimum, rangePrecisions [(int) my p_pitch_units]), rangeUnits [(int) my p_pitch_units], Graphics_BOTTOM); - if (my startSelection == my endSelection && my pitchTier.cursor >= my p_pitch_minimum && my pitchTier.cursor <= my p_pitch_maximum) - FunctionEditor_drawHorizontalHair (me, my pitchTier.cursor, - Melder_fixed (my pitchTier.cursor, rangePrecisions [(int) my p_pitch_units]), rangeUnits [(int) my p_pitch_units]); if (cursorVisible && n > 0) { - double y = YLIN (RealTier_getValueAtTime (pitch, my startSelection)); + const double y = my pitchTierArea -> v_valueToY (RealTier_getValueAtTime (my pitch().get(), my startSelection)); FunctionEditor_insertCursorFunctionValue (me, y, - Melder_fixed (y, rangePrecisions [(int) my p_pitch_units]), rangeUnits [(int) my p_pitch_units], - my p_pitch_minimum, my p_pitch_maximum); - } - if (pitch) { - ifirstSelected = AnyTier_timeToHighIndex (pitch->asAnyTier(), my startSelection); - ilastSelected = AnyTier_timeToLowIndex (pitch->asAnyTier(), my endSelection); - imin = AnyTier_timeToHighIndex (pitch->asAnyTier(), my startWindow); - imax = AnyTier_timeToLowIndex (pitch->asAnyTier(), my endWindow); - } - Graphics_setLineWidth (my graphics.get(), 2.0); - if (n == 0) { - Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_HALF); - Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_text (my graphics.get(), 0.5 * (my startWindow + my endWindow), 0.5 * (my p_pitch_minimum + my p_pitch_maximum), U"(no pitch points)"); - } else if (imax < imin) { - double fleft = YLIN (RealTier_getValueAtTime (pitch, my startWindow)); - double fright = YLIN (RealTier_getValueAtTime (pitch, my endWindow)); - Graphics_setColour (my graphics.get(), Melder_GREEN); - Graphics_line (my graphics.get(), my startWindow, fleft, my endWindow, fright); - } else { - for (i = imin; i <= imax; i ++) { - RealPoint point = pitch -> points.at [i]; - double t = point -> number, f = YLIN (point -> value); - Graphics_setColour (my graphics.get(), Melder_GREEN); - if (i == 1) - Graphics_line (my graphics.get(), my startWindow, f, t, f); - else if (i == imin) - Graphics_line (my graphics.get(), t, f, my startWindow, YLIN (RealTier_getValueAtTime (pitch, my startWindow))); - if (i == n) - Graphics_line (my graphics.get(), t, f, my endWindow, f); - else if (i == imax) - Graphics_line (my graphics.get(), t, f, my endWindow, YLIN (RealTier_getValueAtTime (pitch, my endWindow))); - else { - RealPoint pointRight = pitch -> points.at [i + 1]; - Graphics_line (my graphics.get(), t, f, pointRight -> number, YLIN (pointRight -> value)); - } - } - for (i = imin; i <= imax; i ++) { - RealPoint point = pitch -> points.at [i]; - double t = point -> number, f = YLIN (point -> value); - if (i >= ifirstSelected && i <= ilastSelected) - Graphics_setColour (my graphics.get(), Melder_RED); - else - Graphics_setColour (my graphics.get(), Melder_GREEN); - Graphics_fillCircle_mm (my graphics.get(), t, f, 3.0); - } + Melder_fixed (y, rangePrecisions [(int) my pitchTierArea -> p_units]), rangeUnits [(int) my pitchTierArea -> p_units], + my pitchTierArea -> p_minimum, my pitchTierArea -> p_maximum); } - Graphics_setLineWidth (my graphics.get(), 1.0); + RealTierArea_draw (my pitchTierArea.get(), my pitch().get()); + if (isdefined (my pitchTierArea -> anchorTime)) + RealTierArea_drawWhileDragging (my pitchTierArea.get(), my pitch().get()); Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_resetViewport (my graphics.get(), viewport); } -static void drawDurationArea (ManipulationEditor me, double ymin, double ymax) { - Manipulation ana = (Manipulation) my data; - DurationTier duration = ana -> duration.get(); - integer ifirstSelected, ilastSelected, n = duration ? duration -> points.size : 0, imin, imax, i; - int cursorVisible = my startSelection == my endSelection && my startSelection >= my startWindow && my startSelection <= my endWindow; +static void drawDurationArea (ManipulationEditor me) { + DurationTier duration = my manipulation() -> duration.get(); + const bool cursorVisible = ( my startSelection == my endSelection && my startSelection >= my startWindow && my startSelection <= my endWindow ); + + my durationTierArea -> setViewport(); - /* - * Duration contours. - */ - Graphics_Viewport viewport = Graphics_insetViewport (my graphics.get(), 0.0, 1.0, ymin, ymax); Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setColour (my graphics.get(), Melder_WHITE); Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setColour (my graphics.get(), Melder_BLACK); Graphics_rectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setColour (my graphics.get(), Melder_GREEN); + + Graphics_setColour (my graphics.get(), Melder_BLUE); Graphics_setFont (my graphics.get(), kGraphics_font::TIMES); Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_TOP); Graphics_text (my graphics.get(), 1.0, 1.0, U"%%Duration manip"); Graphics_setFont (my graphics.get(), kGraphics_font::HELVETICA); - Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my p_duration_minimum, my p_duration_maximum); + Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my durationTierArea -> p_minimum, my durationTierArea -> p_maximum); FunctionEditor_drawGridLine (me, 1.0); - FunctionEditor_drawRangeMark (me, my p_duration_maximum, Melder_fixed (my p_duration_maximum, 3), U"", Graphics_TOP); - FunctionEditor_drawRangeMark (me, my p_duration_minimum, Melder_fixed (my p_duration_minimum, 3), U"", Graphics_BOTTOM); - if (my startSelection == my endSelection && my duration.cursor >= my p_duration_minimum && my duration.cursor <= my p_duration_maximum) - FunctionEditor_drawHorizontalHair (me, my duration.cursor, Melder_fixed (my duration.cursor, 3), U""); - if (cursorVisible && n > 0) { - double y = RealTier_getValueAtTime (duration, my startSelection); - FunctionEditor_insertCursorFunctionValue (me, y, Melder_fixed (y, 3), U"", my p_duration_minimum, my p_duration_maximum); + //FunctionEditor_drawRangeMark (me, my durationTierArea -> p_maximum, Melder_fixed (my durationTierArea -> p_maximum, 3), U"", Graphics_HALF); + //FunctionEditor_drawRangeMark (me, my durationTierArea -> p_minimum, Melder_fixed (my durationTierArea -> p_minimum, 3), U"", Graphics_HALF); + //if (my startSelection == my endSelection && my durationTierArea -> ycursor >= my durationTierArea -> p_minimum && my durationTierArea -> ycursor <= my durationTierArea -> p_maximum) + // FunctionEditor_drawHorizontalHair (me, my durationTierArea -> ycursor, Melder_fixed (my durationTierArea -> ycursor, 3), U""); + if (cursorVisible && duration -> points.size > 0) { + const double y = RealTier_getValueAtTime (duration, my startSelection); + FunctionEditor_insertCursorFunctionValue (me, y, Melder_fixed (y, 3), U"", my durationTierArea -> p_minimum, my durationTierArea -> p_maximum); } - /* - * Draw duration tier. - */ - if (duration) { - ifirstSelected = AnyTier_timeToHighIndex (duration->asAnyTier(), my startSelection); - ilastSelected = AnyTier_timeToLowIndex (duration->asAnyTier(), my endSelection); - imin = AnyTier_timeToHighIndex (duration->asAnyTier(), my startWindow); - imax = AnyTier_timeToLowIndex (duration->asAnyTier(), my endWindow); - } - Graphics_setLineWidth (my graphics.get(), 2.0); - if (n == 0) { - Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_HALF); - Graphics_text (my graphics.get(), 0.5 * (my startWindow + my endWindow), - 0.5 * (my p_duration_minimum + my p_duration_maximum), U"(no duration points)"); - } else if (imax < imin) { - double fleft = RealTier_getValueAtTime (duration, my startWindow); - double fright = RealTier_getValueAtTime (duration, my endWindow); - Graphics_setColour (my graphics.get(), Melder_GREEN); - Graphics_line (my graphics.get(), my startWindow, fleft, my endWindow, fright); - } else { - for (i = imin; i <= imax; i ++) { - RealPoint point = duration -> points.at [i]; - double t = point -> number, dur = point -> value; - Graphics_setColour (my graphics.get(), Melder_GREEN); - if (i == 1) - Graphics_line (my graphics.get(), my startWindow, dur, t, dur); - else if (i == imin) - Graphics_line (my graphics.get(), t, dur, my startWindow, RealTier_getValueAtTime (duration, my startWindow)); - if (i == n) - Graphics_line (my graphics.get(), t, dur, my endWindow, dur); - else if (i == imax) - Graphics_line (my graphics.get(), t, dur, my endWindow, RealTier_getValueAtTime (duration, my endWindow)); - else { - RealPoint pointRight = duration -> points.at [i + 1]; - Graphics_line (my graphics.get(), t, dur, pointRight -> number, pointRight -> value); - } - } - for (i = imin; i <= imax; i ++) { - RealPoint point = duration -> points.at [i]; - double t = point -> number, dur = point -> value; - if (i >= ifirstSelected && i <= ilastSelected) - Graphics_setColour (my graphics.get(), Melder_RED); - else - Graphics_setColour (my graphics.get(), Melder_GREEN); - Graphics_fillCircle_mm (my graphics.get(), t, dur, 3.0); - } - } + Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my durationTierArea -> p_minimum, my durationTierArea -> p_maximum); + RealTierArea_draw (my durationTierArea.get(), duration); + if (isdefined (my durationTierArea -> anchorTime)) + RealTierArea_drawWhileDragging (my durationTierArea.get(), duration); Graphics_setLineWidth (my graphics.get(), 1.0); Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_resetViewport (my graphics.get(), viewport); } void structManipulationEditor :: v_draw () { double ysoundmin, ysoundmax; - double ypitchmin, ypitchmax, ydurationmin, ydurationmax; - int hasSoundArea = getSoundArea (this, & ysoundmin, & ysoundmax); - int hasPitchArea = getPitchArea (this, & ypitchmin, & ypitchmax); - int hasDurationArea = getDurationArea (this, & ydurationmin, & ydurationmax); - - if (hasSoundArea) drawSoundArea (this, ysoundmin, ysoundmax); - if (hasPitchArea) drawPitchArea (this, ypitchmin, ypitchmax); - if (hasDurationArea) drawDurationArea (this, ydurationmin, ydurationmax); - - Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setGrey (our graphics.get(), 0.85); - Graphics_fillRectangle (our graphics.get(), -0.001, 1.001, ypitchmax, ysoundmin); - Graphics_setGrey (our graphics.get(), 0.00); - Graphics_line (our graphics.get(), 0.0, ysoundmin, 1.0, ysoundmin); - Graphics_line (our graphics.get(), 0.0, ypitchmax, 1.0, ypitchmax); - if (hasDurationArea) { - Graphics_setGrey (our graphics.get(), 0.85); - Graphics_fillRectangle (our graphics.get(), -0.001, 1.001, ydurationmax, ypitchmin); - Graphics_setGrey (our graphics.get(), 0.00); - Graphics_line (our graphics.get(), 0, ypitchmin, 1, ypitchmin); - Graphics_line (our graphics.get(), 0, ydurationmax, 1, ydurationmax); - } + (void) getSoundArea (this, & ysoundmin, & ysoundmax); + if (our sound()) + drawSoundArea (this, ysoundmin, ysoundmax); + if (our pitch()) + drawPitchArea (this); + if (our duration()) + drawDurationArea (this); updateMenus (this); } -static void drawWhileDragging (ManipulationEditor me, double xWC, double yWC, integer first, integer last, double dt, double df) { - Manipulation ana = (Manipulation) my data; - PitchTier pitch = ana -> pitch.get(); - (void) xWC; - (void) yWC; - - /* - * Draw all selected pitch points as magenta empty circles, if inside the window. - */ - for (integer i = first; i <= last; i ++) { - RealPoint point = pitch -> points.at [i]; - double t = point -> number + dt, f = YLIN (point -> value) + df; - if (t >= my startWindow && t <= my endWindow) - Graphics_circle_mm (my graphics.get(), t, - f < my pitchTier.minPeriodic ? my pitchTier.minPeriodic : f > my p_pitch_maximum ? my p_pitch_maximum : f, 3.0); - } - - if (last == first) { - /* - * Draw a crosshair with time and frequency. - */ - RealPoint point = pitch -> points.at [first]; - double t = point -> number + dt, fWC = YLIN (point -> value) + df; - Graphics_line (my graphics.get(), t, my p_pitch_minimum, t, my p_pitch_maximum - Graphics_dyMMtoWC (my graphics.get(), 4.0)); - Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_TOP); - Graphics_text (my graphics.get(), t, my p_pitch_maximum, Melder_fixed (t, 6)); - Graphics_line (my graphics.get(), my startWindow, fWC, my endWindow, fWC); - Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_BOTTOM); - Graphics_text (my graphics.get(), my startWindow, fWC, Melder_fixed (fWC, 5)); - } -} - -static bool clickPitch (ManipulationEditor me, double xWC, double yWC, bool shiftKeyPressed) { - Manipulation ana = (Manipulation) my data; - PitchTier pitch = ana -> pitch.get(); - integer inearestPoint, ifirstSelected, ilastSelected, i; - RealPoint nearestPoint; - double dt = 0, df = 0; - int draggingSelection, dragHorizontal, dragVertical; - - my pitchTier.cursor = my p_pitch_minimum + yWC * (my p_pitch_maximum - my p_pitch_minimum); - if (! pitch) { - Graphics_resetViewport (my graphics.get(), my inset); - return my ManipulationEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my p_pitch_minimum, my p_pitch_maximum); - yWC = my pitchTier.cursor; - - /* - * Clicked on a pitch point? - */ - inearestPoint = AnyTier_timeToNearestIndex (pitch->asAnyTier(), xWC); - if (inearestPoint == 0) { - Graphics_resetViewport (my graphics.get(), my inset); - return my ManipulationEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - nearestPoint = pitch -> points.at [inearestPoint]; - if (Graphics_distanceWCtoMM (my graphics.get(), xWC, yWC, nearestPoint -> number, YLIN (nearestPoint -> value)) > 1.5) { - Graphics_resetViewport (my graphics.get(), my inset); - return my ManipulationEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - - /* - * Clicked on a selected pitch point? - */ - draggingSelection = shiftKeyPressed && - nearestPoint -> number > my startSelection && nearestPoint -> number < my endSelection; - if (draggingSelection) { - ifirstSelected = AnyTier_timeToHighIndex (pitch->asAnyTier(), my startSelection); - ilastSelected = AnyTier_timeToLowIndex (pitch->asAnyTier(), my endSelection); - Editor_save (me, U"Drag pitch points"); +bool structManipulationEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double globalY_fraction) { + static bool clickedInWidePitchArea = false; + static bool clickedInWideDurationArea = false; + if (event -> isClick()) { + clickedInWidePitchArea = our pitchTierArea -> y_fraction_globalIsInside (globalY_fraction); + clickedInWideDurationArea = our durationTierArea -> y_fraction_globalIsInside (globalY_fraction); + } + bool result = false; + if (clickedInWidePitchArea) { + our pitchTierArea -> setViewport (); + result = RealTierArea_mouse (our pitchTierArea.get(), our manipulation() -> pitch.get(), event, x_world, globalY_fraction); + our pitchTierArea -> p_minimum = our pitchTierArea -> ymin; + our pitchTierArea -> p_maximum = our pitchTierArea -> ymax; + } else if (clickedInWideDurationArea) { + our durationTierArea -> setViewport (); + result = RealTierArea_mouse (our durationTierArea.get(), our manipulation() -> duration.get(), event, x_world, globalY_fraction); + our durationTierArea -> p_minimum = our durationTierArea -> ymin; + our durationTierArea -> p_maximum = our durationTierArea -> ymax; } else { - ifirstSelected = ilastSelected = inearestPoint; - Editor_save (me, U"Drag pitch point"); + result = our ManipulationEditor_Parent :: v_mouseInWideDataView (event, x_world, globalY_fraction); } - - /* - * Drag. - */ - /* - * Draw at the old location once. - * Since some systems do double buffering, - * the undrawing at the old position and redrawing at the new have to be bracketed by Graphics_mouseStillDown (). - */ - Graphics_xorOn (my graphics.get(), Melder_MAROON); - drawWhileDragging (me, xWC, yWC, ifirstSelected, ilastSelected, dt, df); - dragHorizontal = my p_pitch_draggingStrategy != kManipulationEditor_draggingStrategy::VERTICAL && - (! shiftKeyPressed || my p_pitch_draggingStrategy != kManipulationEditor_draggingStrategy::HYBRID); - dragVertical = my p_pitch_draggingStrategy != kManipulationEditor_draggingStrategy::HORIZONTAL; - while (Graphics_mouseStillDown (my graphics.get())) { - double xWC_new, yWC_new; - Graphics_getMouseLocation (my graphics.get(), & xWC_new, & yWC_new); - if (xWC_new != xWC || yWC_new != yWC) { - drawWhileDragging (me, xWC, yWC, ifirstSelected, ilastSelected, dt, df); - if (dragHorizontal) - dt += xWC_new - xWC; - if (dragVertical) - df += yWC_new - yWC; - xWC = xWC_new; - yWC = yWC_new; - drawWhileDragging (me, xWC, yWC, ifirstSelected, ilastSelected, dt, df); - } + if (event -> isDrop()) { + clickedInWidePitchArea = false; + clickedInWideDurationArea = false; } - Graphics_xorOff (my graphics.get()); - - /* - * Dragged inside window? - */ - if (xWC < my startWindow || xWC > my endWindow) - return 1; - - /* - * Points not dragged past neighbours? - */ - { - double newTime = pitch -> points.at [ifirstSelected] -> number + dt; - if (newTime < my tmin) return 1; // outside domain - if (ifirstSelected > 1 && newTime <= pitch -> points.at [ifirstSelected - 1] -> number) - return 1; /* Past left neighbour. */ - newTime = pitch -> points.at [ilastSelected] -> number + dt; - if (newTime > my tmax) return 1; // outside domain - if (ilastSelected < pitch -> points.size && newTime >= pitch -> points.at [ilastSelected + 1] -> number) - return FunctionEditor_UPDATE_NEEDED; // past right neighbour - } - - /* - * Drop. - */ - for (i = ifirstSelected; i <= ilastSelected; i ++) { - RealPoint point = pitch -> points.at [i]; - point -> number += dt; - point -> value = YLININV (YLIN (point -> value) + df); - if (point -> value < 50.0) - point -> value = 50.0; - if (point -> value > YLININV (my p_pitch_maximum)) - point -> value = YLININV (my p_pitch_maximum); - } - - /* - * Make sure that the same pitch points are still selected (a problem with Undo...). - */ - - if (draggingSelection) { - my startSelection += dt; - my endSelection += dt; - } - if (my startSelection == my endSelection) { - RealPoint point = pitch -> points.at [ifirstSelected]; - my startSelection = my endSelection = point -> number; - my pitchTier.cursor = YLIN (point -> value); - } - - Editor_broadcastDataChanged (me); - return FunctionEditor_UPDATE_NEEDED; -} - -static void drawDurationWhileDragging (ManipulationEditor me, double /* xWC */, double /* yWC */, integer first, integer last, double dt, double df) { - Manipulation ana = (Manipulation) my data; - DurationTier duration = ana -> duration.get(); - - /* - * Draw all selected duration points as magenta empty circles, if inside the window. - */ - for (integer i = first; i <= last; i ++) { - RealPoint point = duration -> points.at [i]; - double t = point -> number + dt, dur = point -> value + df; - if (t >= my startWindow && t <= my endWindow) - Graphics_circle_mm (my graphics.get(), t, dur < my p_duration_minimum ? my p_duration_minimum : - dur > my p_duration_maximum ? my p_duration_maximum : dur, 3.0); - } - - if (last == first) { - /* - * Draw a crosshair with time and duration. - */ - RealPoint point = duration -> points.at [first]; - double t = point -> number + dt, durWC = point -> value + df; - Graphics_line (my graphics.get(), t, my p_duration_minimum, t, my p_duration_maximum - Graphics_dyMMtoWC (my graphics.get(), 4.0)); - Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_TOP); - Graphics_text (my graphics.get(), t, my p_duration_maximum, Melder_fixed (t, 6)); - Graphics_line (my graphics.get(), my startWindow, durWC, my endWindow, durWC); - Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_BOTTOM); - Graphics_text (my graphics.get(), my startWindow, durWC, Melder_fixed (durWC, 2)); - } -} - -static bool clickDuration (ManipulationEditor me, double xWC, double yWC, int shiftKeyPressed) { - Manipulation ana = (Manipulation) my data; - DurationTier duration = ana -> duration.get(); - integer inearestPoint, ifirstSelected, ilastSelected; - RealPoint nearestPoint; - double dt = 0, df = 0; - int draggingSelection; - - /* - * Convert from FunctionEditor's [0, 1] coordinates to world coordinates. - */ - yWC = my p_duration_minimum + yWC * (my p_duration_maximum - my p_duration_minimum); - - /* - * Move horizontal hair to clicked position. - */ - my duration.cursor = yWC; - - if (! duration) { - Graphics_resetViewport (my graphics.get(), my inset); - return my ManipulationEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my p_duration_minimum, my p_duration_maximum); - - /* - * Clicked on a duration point? - */ - inearestPoint = AnyTier_timeToNearestIndex (duration->asAnyTier(), xWC); - if (inearestPoint == 0) { - Graphics_resetViewport (my graphics.get(), my inset); - return my ManipulationEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - nearestPoint = duration -> points.at [inearestPoint]; - if (Graphics_distanceWCtoMM (my graphics.get(), xWC, yWC, nearestPoint -> number, nearestPoint -> value) > 1.5) { - Graphics_resetViewport (my graphics.get(), my inset); - return my ManipulationEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - - /* - * Clicked on a selected duration point? - */ - draggingSelection = shiftKeyPressed && - nearestPoint -> number > my startSelection && nearestPoint -> number < my endSelection; - if (draggingSelection) { - ifirstSelected = AnyTier_timeToHighIndex (duration->asAnyTier(), my startSelection); - ilastSelected = AnyTier_timeToLowIndex (duration->asAnyTier(), my endSelection); - Editor_save (me, U"Drag duration points"); - } else { - ifirstSelected = ilastSelected = inearestPoint; - Editor_save (me, U"Drag duration point"); - } - - /* - * Drag. - */ - Graphics_xorOn (my graphics.get(), Melder_MAROON); - drawDurationWhileDragging (me, xWC, yWC, ifirstSelected, ilastSelected, dt, df); - while (Graphics_mouseStillDown (my graphics.get())) { - double xWC_new, yWC_new; - Graphics_getMouseLocation (my graphics.get(), & xWC_new, & yWC_new); - if (xWC_new != xWC || yWC_new != yWC) { - drawDurationWhileDragging (me, xWC, yWC, ifirstSelected, ilastSelected, dt, df); - dt += xWC_new - xWC, xWC = xWC_new; - df += yWC_new - yWC, yWC = yWC_new; - drawDurationWhileDragging (me, xWC_new, yWC_new, ifirstSelected, ilastSelected, dt, df); - } - } - Graphics_xorOff (my graphics.get()); - - /* - * Dragged inside window? - */ - if (xWC < my startWindow || xWC > my endWindow) return 1; - - /* - * Points not dragged past neighbours? - */ - { - double newTime = duration -> points.at [ifirstSelected] -> number + dt; - if (newTime < my tmin) return 1; // outside domain - if (ifirstSelected > 1 && newTime <= duration -> points.at [ifirstSelected - 1] -> number) - return 1; /* Past left neighbour. */ - newTime = duration -> points.at [ilastSelected] -> number + dt; - if (newTime > my tmax) return 1; // outside domain - if (ilastSelected < duration -> points.size && newTime >= duration -> points.at [ilastSelected + 1] -> number) - return 1; // past right neighbour - } - - /* - * Drop. - */ - for (integer i = ifirstSelected; i <= ilastSelected; i ++) { - RealPoint point = duration -> points.at [i]; - point -> number += dt; - point -> value += df; - if (point -> value < my p_duration_minimum) point -> value = my p_duration_minimum; - if (point -> value > my p_duration_maximum) point -> value = my p_duration_maximum; - } - - /* - * Make sure that the same duration points are still selected (a problem with Undo...). - */ - - if (draggingSelection) my startSelection += dt, my endSelection += dt; - if (my startSelection == my endSelection) { - RealPoint point = duration -> points.at [ifirstSelected]; - my startSelection = my endSelection = point -> number; - my duration.cursor = point -> value; - } - - Editor_broadcastDataChanged (me); - return FunctionEditor_UPDATE_NEEDED; + return result; } -bool structManipulationEditor :: v_click (double xWC, double yWC, bool shiftKeyPressed) { - double ypitchmin, ypitchmax, ydurationmin, ydurationmax; - int hasPitchArea = getPitchArea (this, & ypitchmin, & ypitchmax); - int hasDurationArea = getDurationArea (this, & ydurationmin, & ydurationmax); - - /* - * Dispatch click to clicked area. - */ - if (hasPitchArea && yWC > ypitchmin && yWC < ypitchmax) { // clicked in pitch area? - inset = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, ypitchmin, ypitchmax); - return clickPitch (this, xWC, (yWC - ypitchmin) / (ypitchmax - ypitchmin), shiftKeyPressed); - } else if (hasDurationArea && yWC > ydurationmin && yWC < ydurationmax) { // clicked in duration area? - inset = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, ydurationmin, ydurationmax); - return clickDuration (this, xWC, (yWC - ydurationmin) / (ydurationmax - ydurationmin), shiftKeyPressed); - } - /* - * Perform the default action: move cursor or drag selection. - */ - return our ManipulationEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); -} - -void structManipulationEditor :: v_play (double a_tmin, double a_tmax) { - Manipulation ana = (Manipulation) our data; - if (our shiftKeyPressed) { - if (ana -> sound) - Sound_playPart (ana -> sound.get(), a_tmin, a_tmax, theFunctionEditor_playCallback, this); +void structManipulationEditor :: v_play (double startTime, double endTime) { + if (our clickWasModifiedByShiftKey) { + if (our manipulation() -> sound) + Sound_playPart (our manipulation() -> sound.get(), startTime, endTime, theFunctionEditor_playCallback, this); } else { - Manipulation_playPart (ana, a_tmin, a_tmax, our synthesisMethod); + Manipulation_playPart (our manipulation(), startTime, endTime, our synthesisMethod); } } -autoManipulationEditor ManipulationEditor_create (conststring32 title, Manipulation ana) { +autoManipulationEditor ManipulationEditor_create (conststring32 title, Manipulation manipulation) { try { autoManipulationEditor me = Thing_new (ManipulationEditor); - FunctionEditor_init (me.get(), title, ana); + FunctionEditor_init (me.get(), title, manipulation); + my pitchTierArea = PitchTierArea_create (me.get(), ( manipulation -> duration ? 0.17 : 0.0 ), 0.67); + if (manipulation -> duration) { + my durationTierArea = DurationTierArea_create (me.get(), 0.0, 0.17); + } - double maximumPitchValue = RealTier_getMaximumValue (ana -> pitch.get()); - if (my p_pitch_units == kManipulationEditor_pitchUnits::HERTZ) { - my p_pitch_minimum = 25.0; + const double maximumPitchValue = RealTier_getMaximumValue (manipulation -> pitch.get()); + if (my pitchTierArea -> p_units == kPitchTierArea_units::HERTZ) { + my pitchTierArea -> ymin = my pitchTierArea -> p_minimum = 25.0; my pitchTier.minPeriodic = 50.0; - my p_pitch_maximum = maximumPitchValue; - my pitchTier.cursor = my p_pitch_maximum * 0.8; - my p_pitch_maximum *= 1.2; - } else { - my p_pitch_minimum = -24.0; + my pitchTierArea -> p_maximum = maximumPitchValue; + my pitchTierArea -> ycursor = my pitchTierArea -> p_maximum * 0.8; + my pitchTierArea -> ymax = my pitchTierArea -> p_maximum *= 1.2; + } else if (my pitchTierArea -> p_units == kPitchTierArea_units::SEMITONES) { + my pitchTierArea -> ymin = my pitchTierArea -> p_minimum = -24.0; my pitchTier.minPeriodic = -12.0; - my p_pitch_maximum = ( isdefined (maximumPitchValue) ? NUMhertzToSemitones (maximumPitchValue) : undefined ); - my pitchTier.cursor = my p_pitch_maximum - 4.0; - my p_pitch_maximum += 3.0; - } - if (isundef (my p_pitch_maximum) || my p_pitch_maximum < my pref_pitch_maximum ()) - my p_pitch_maximum = my pref_pitch_maximum (); - - double minimumDurationValue = ( ana -> duration ? RealTier_getMinimumValue (ana -> duration.get()) : undefined ); - my p_duration_minimum = ( isdefined (minimumDurationValue) ? minimumDurationValue : 1.0 ); - if (my pref_duration_minimum () > 1) - my pref_duration_minimum () = Melder_atof (my default_duration_minimum ()); - if (my p_duration_minimum > my pref_duration_minimum ()) - my p_duration_minimum = my pref_duration_minimum (); - double maximumDurationValue = ( ana -> duration ? RealTier_getMaximumValue (ana -> duration.get()) : undefined ); - my p_duration_maximum = ( isdefined (maximumDurationValue) ? maximumDurationValue : 1.0 ); - if (my pref_duration_maximum () < 1) - my pref_duration_maximum () = Melder_atof (my default_duration_maximum ()); - if (my pref_duration_maximum () <= my pref_duration_minimum ()) { - my pref_duration_minimum () = Melder_atof (my default_duration_minimum ()); - my pref_duration_maximum () = Melder_atof (my default_duration_maximum ()); - } - if (my p_duration_maximum < my pref_duration_maximum ()) - my p_duration_maximum = my pref_duration_maximum (); - my duration.cursor = 1.0; + my pitchTierArea -> p_maximum = ( isdefined (maximumPitchValue) ? NUMhertzToSemitones (maximumPitchValue) : undefined ); + my pitchTierArea -> ycursor = my pitchTierArea -> p_maximum - 4.0; + my pitchTierArea -> ymax = my pitchTierArea -> p_maximum *= 3.0; + } else + Melder_fatal (U"ManipulationEditor_create: Unknown pitch units: ", (int) my pitchTierArea -> p_units); + if (isundef (my pitchTierArea -> p_maximum) || my pitchTierArea -> p_maximum < my pitchTierArea -> pref_maximum()) + my pitchTierArea -> ymax = my pitchTierArea -> p_maximum = my pitchTierArea -> pref_maximum(); + + /* + If needed, fix preferences to sane values. + */ + if (my durationTierArea -> pref_minimum() > 1.0) + my durationTierArea -> pref_minimum() = Melder_atof (my durationTierArea -> default_minimum()); // sanity + if (my durationTierArea -> pref_maximum() < 1.0) + my durationTierArea -> pref_maximum() = Melder_atof (my durationTierArea -> default_maximum()); + Melder_assert (my durationTierArea -> pref_minimum() < my durationTierArea -> pref_maximum()); + /* + Honour preferences. + */ + my durationTierArea -> ymin = my durationTierArea -> p_minimum = my durationTierArea -> pref_minimum(); + my durationTierArea -> ymax = my durationTierArea -> p_maximum = my durationTierArea -> pref_maximum(); + /* + If needed, widen on the basis of the data. + */ + const double minimumDurationValue = ( manipulation -> duration ? RealTier_getMinimumValue (manipulation -> duration.get()) : undefined ); + const double maximumDurationValue = ( manipulation -> duration ? RealTier_getMaximumValue (manipulation -> duration.get()) : undefined ); + if (minimumDurationValue < my durationTierArea -> p_minimum) // NaN-safe + my durationTierArea -> ymin = my durationTierArea -> p_minimum = minimumDurationValue / 1.25; + if (maximumDurationValue > my durationTierArea -> p_maximum) // NaN-safe + my durationTierArea -> ymax = my durationTierArea -> p_maximum = minimumDurationValue * 1.25; + + my durationTierArea -> ycursor = 1.0; my synthesisMethod = prefs_synthesisMethod; - if (ana -> sound) - Matrix_getWindowExtrema (ana -> sound.get(), 0, 0, 0, 0, & my soundmin, & my soundmax); - if (my soundmin == my soundmax) my soundmin = -1.0, my soundmax = +1.0; + if (manipulation -> sound) + Matrix_getWindowExtrema (manipulation -> sound.get(), 0, 0, 0, 0, & my soundmin, & my soundmax); + if (my soundmin == my soundmax) { + my soundmin = -1.0; + my soundmax = +1.0; + } + RealTierArea_updateScaling (my pitchTierArea.get(), manipulation -> pitch.get()); + if (manipulation -> duration) { + RealTierArea_updateScaling (my durationTierArea.get(), manipulation -> duration.get()); + my durationTierArea -> p_minimum = my durationTierArea -> ymin; + my durationTierArea -> p_maximum = my durationTierArea -> ymax; + } updateMenus (me.get()); return me; } catch (MelderError) { diff --git a/fon/ManipulationEditor.h b/fon/ManipulationEditor.h index c4525f56..5f67fe89 100644 --- a/fon/ManipulationEditor.h +++ b/fon/ManipulationEditor.h @@ -2,7 +2,7 @@ #define _ManipulationEditor_h_ /* ManipulationEditor.h * - * Copyright (C) 1992-2011,2012,2013,2015 Paul Boersma + * Copyright (C) 1992-2005,2007,2009-2013,2015,2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,11 +19,25 @@ */ #include "FunctionEditor.h" +#include "PitchTierEditor.h" +#include "DurationTierEditor.h" #include "Manipulation.h" #include "ManipulationEditor_enums.h" Thing_define (ManipulationEditor, FunctionEditor) { + /* + Access inherited attributes by their derived types. + */ + Manipulation & manipulation() { return * reinterpret_cast (& our data); } + /* + Quick access to internal objects. + */ + autoSound & sound() { return our manipulation() -> sound; } + autoPointProcess & pulses() { return our manipulation() -> pulses; } + autoPitchTier & pitch() { return our manipulation() -> pitch; } + autoDurationTier & duration() { return our manipulation() -> duration; } + autoPointProcess previousPulses; autoPitchTier previousPitch; autoDurationTier previousDuration; @@ -35,8 +49,10 @@ Thing_define (ManipulationEditor, FunctionEditor) { GuiMenuItem synthPulsesPitchButton, synthPulsesPitchHumButton; GuiMenuItem synthOverlapAddNodurButton, synthOverlapAddButton; GuiMenuItem synthPitchLpcButton; - struct { double minPeriodic, cursor; } pitchTier; - struct { double cursor; } duration; + autoPitchTierArea pitchTierArea; + autoDurationTierArea durationTierArea; + + struct { double minPeriodic; } pitchTier; Graphics_Viewport inset; void v_createMenus () @@ -49,7 +65,7 @@ Thing_define (ManipulationEditor, FunctionEditor) { override; void v_draw () override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) override; void v_play (double tmin, double tmax) override; diff --git a/fon/ManipulationEditor_enums.h b/fon/ManipulationEditor_enums.h index 414b086e..c2e6ab2e 100644 --- a/fon/ManipulationEditor_enums.h +++ b/fon/ManipulationEditor_enums.h @@ -1,6 +1,6 @@ /* ManipulationEditor_enums.h * - * Copyright (C) 1992-2007,2013,2015 Paul Boersma + * Copyright (C) 1992-2005,2007,2013,2015,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -28,4 +28,4 @@ enums_begin (kManipulationEditor_pitchUnits, 1) enums_add (kManipulationEditor_pitchUnits, 2, SEMITONES, U"semitones re 100 Hz") enums_end (kManipulationEditor_pitchUnits, 2, HERTZ) -/* End of file ManipulationEditor.h */ +/* End of file ManipulationEditor_enums.h */ diff --git a/fon/ManipulationEditor_prefs.h b/fon/ManipulationEditor_prefs.h index 5d1e2f27..e6316d00 100644 --- a/fon/ManipulationEditor_prefs.h +++ b/fon/ManipulationEditor_prefs.h @@ -1,6 +1,6 @@ /* ManipulationEditor_prefs.h * - * Copyright (C) 2013,2015,2017 Paul Boersma + * Copyright (C) 2013,2015-2017,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -18,15 +18,10 @@ prefs_begin (ManipulationEditor) - prefs_add_double_with_data (ManipulationEditor, pitch_minimum, 1, U"50.0") // Hz - prefs_add_double_with_data (ManipulationEditor, pitch_maximum, 1, U"300.0") // Hz - prefs_add_enum_with_data (ManipulationEditor, pitch_units, 1, kManipulationEditor_pitchUnits, DEFAULT) prefs_add_enum_with_data (ManipulationEditor, pitch_draggingStrategy, 1, kManipulationEditor_draggingStrategy, DEFAULT) prefs_add_double_with_data (ManipulationEditor, pitch_stylize_frequencyResolution, 1, U"2.0") prefs_add_bool_with_data (ManipulationEditor, pitch_stylize_useSemitones, 1, true) prefs_add_integer_with_data (ManipulationEditor, pitch_interpolateQuadratically_numberOfPointsPerParabola, 1, U"4") - prefs_add_double_with_data (ManipulationEditor, duration_minimum, 1, U"0.25") - prefs_add_double_with_data (ManipulationEditor, duration_maximum, 1, U"3.0") prefs_end (ManipulationEditor) diff --git a/fon/Matrix.cpp b/fon/Matrix.cpp index e2effdb0..79e924a8 100644 --- a/fon/Matrix.cpp +++ b/fon/Matrix.cpp @@ -438,7 +438,7 @@ void Matrix_playMovie (Matrix me, Graphics g) { maximum += 0.5; } for (integer icol = 1; icol <= my nx; icol ++) { - column.all() <<= my z.column (icol); + column.all() <<= my z.column (icol); Graphics_beginMovieFrame (g, & Melder_WHITE); Graphics_setWindow (g, my ymin, my ymax, minimum, maximum); Graphics_function (g, column.asArgumentToFunctionThatExpectsOneBasedArray(), 1, my ny, my ymin, my ymax); diff --git a/fon/MovieWindow.cpp b/fon/MovieWindow.cpp index e8066273..e1fa8dd7 100644 --- a/fon/MovieWindow.cpp +++ b/fon/MovieWindow.cpp @@ -1,6 +1,6 @@ /* MovieWindow.cpp * - * Copyright (C) 2011-2012,2013,2014,2016,2017 Paul Boersma + * Copyright (C) 2011-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -105,20 +105,13 @@ void structMovieWindow :: v_highlightSelection (double left, double right, doubl Graphics_highlight (our graphics.get(), left, right, 0.7 * bottom + 0.3 * top, top); } -void structMovieWindow :: v_unhighlightSelection (double left, double right, double bottom, double top) { - if (our p_spectrogram_show) - Graphics_highlight (our graphics.get(), left, right, 0.3 * bottom + 0.7 * top, top); - else - Graphics_highlight (our graphics.get(), left, right, 0.7 * bottom + 0.3 * top, top); -} - -bool structMovieWindow :: v_click (double xWC, double yWC, bool shiftKeyPressed) { - return our MovieWindow_Parent :: v_click (xWC, yWC, shiftKeyPressed); +bool structMovieWindow :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) { + return our MovieWindow_Parent :: v_mouseInWideDataView(event, x_world, y_fraction); } -void structMovieWindow :: v_play (double tmin, double tmax) { +void structMovieWindow :: v_play (double startTime, double endTime) { Movie movie = (Movie) data; - Movie_play (movie, our graphics.get(), tmin, tmax, theFunctionEditor_playCallback, this); + Movie_play (movie, our graphics.get(), startTime, endTime, theFunctionEditor_playCallback, this); } void MovieWindow_init (MovieWindow me, conststring32 title, Movie movie) { diff --git a/fon/MovieWindow.h b/fon/MovieWindow.h index 3480d4b6..a407525c 100644 --- a/fon/MovieWindow.h +++ b/fon/MovieWindow.h @@ -2,7 +2,7 @@ #define _MovieWindow_h_ /* MovieWindow.h * - * Copyright (C) 2011,2012,2014,2015 Paul Boersma + * Copyright (C) 2011,2012,2014-2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -26,7 +26,7 @@ Thing_define (MovieWindow, TimeSoundAnalysisEditor) { override; void v_draw () override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) override; void v_play (double tmin, double tmax) override; @@ -34,8 +34,6 @@ Thing_define (MovieWindow, TimeSoundAnalysisEditor) { override; void v_highlightSelection (double left, double right, double bottom, double top) override; - void v_unhighlightSelection (double left, double right, double bottom, double top) - override; }; void MovieWindow_init (MovieWindow me, conststring32 title, Movie movie); diff --git a/fon/Pitch.cpp b/fon/Pitch.cpp index 2198480d..eda59673 100644 --- a/fon/Pitch.cpp +++ b/fon/Pitch.cpp @@ -315,6 +315,35 @@ integer Pitch_getMeanAbsSlope_noOctave (Pitch me, double *slope) { return Pitch_getMeanAbsoluteSlope (me, nullptr, nullptr, nullptr, nullptr, slope); } +MelderFraction Pitch_getFractionOfLocallyVoicedFrames ( + Pitch me, double tmin, double tmax, double ceiling, double silenceThreshold, double voicingThreshold) +{ + MelderFraction result; + integer imin, imax; + result.denominator = Sampled_getWindowSamples (me, tmin, tmax, & imin, & imax); + for (integer i = imin; i <= imax; i ++) { + const Pitch_Frame frame = & my frames [i]; + if (frame -> intensity >= silenceThreshold) { + for (integer icand = 1; icand <= frame -> nCandidates; icand ++) { + const Pitch_Candidate cand = & frame -> candidates [icand]; + if (cand -> frequency > 0.0 && cand -> frequency < ceiling && cand -> strength >= voicingThreshold) { + result.numerator += 1.0; + break; // next frame + } + } + } + } + return result; +} + +MelderFraction Pitch_getFractionOfLocallyUnvoicedFrames ( + Pitch me, double tmin, double tmax, double ceiling, double silenceThreshold, double voicingThreshold) +{ + MelderFraction fraction = Pitch_getFractionOfLocallyVoicedFrames (me, tmin, tmax, ceiling, silenceThreshold, voicingThreshold); + fraction.numerator = fraction.denominator - fraction.numerator; + return fraction; +} + void structPitch :: v_info () { autoVEC frequencies = Sampled_getSortedValues (this, 0.0, 0.0, Pitch_LEVEL_FREQUENCY, (int) kPitch_unit::HERTZ); structDaata :: v_info (); diff --git a/fon/Pitch.h b/fon/Pitch.h index a21a2053..9817dce4 100644 --- a/fon/Pitch.h +++ b/fon/Pitch.h @@ -2,7 +2,7 @@ #define _Pitch_h_ /* Pitch.h * - * Copyright (C) 1992-2007,2009,2011,2012,2014-2019 Paul Boersma + * Copyright (C) 1992-2007,2009,2011,2012,2014-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -159,6 +159,11 @@ integer Pitch_getMeanAbsSlope_noOctave (Pitch me, double *slope); 'minimum', 'maximum', 'mean', and 'variance' may be null. */ +MelderFraction Pitch_getFractionOfLocallyVoicedFrames (Pitch me, double tmin, double tmax, + double ceiling, double silenceThreshold, double voicingThreshold); +MelderFraction Pitch_getFractionOfLocallyUnvoicedFrames (Pitch me, double tmin, double tmax, + double ceiling, double silenceThreshold, double voicingThreshold); + autoPitch Pitch_killOctaveJumps (Pitch me); /* Add octave jumps so that every pitch step, including those across unvoiced frames, diff --git a/fon/PitchEditor.cpp b/fon/PitchEditor.cpp index 977779e4..ea75ee1a 100644 --- a/fon/PitchEditor.cpp +++ b/fon/PitchEditor.cpp @@ -1,6 +1,6 @@ /* PitchEditor.cpp * - * Copyright (C) 1992-2012,2014-2018 Paul Boersma + * Copyright (C) 1992-2012,2014-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -288,15 +288,17 @@ void structPitchEditor :: v_play (double a_tmin, double a_tmax) { Pitch_hum ((Pitch) our data, a_tmin, a_tmax); } -bool structPitchEditor :: v_click (double xWC, double yWC, bool dummy) { +bool structPitchEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) { + if (! event -> isClick()) + return PitchEditor_Parent :: v_mouseInWideDataView (event, x_world, y_fraction); // move cursor or drag selection const Pitch pitch = (Pitch) our data; const double dyUnv = Graphics_dyMMtoWC (our graphics.get(), HEIGHT_UNV); const double dyIntens = Graphics_dyMMtoWC (our graphics.get(), HEIGHT_INTENS); - const double clickedFrequency = (yWC - dyUnv) / (1.0 - dyIntens - dyUnv) * pitch -> ceiling; + const double clickedFrequency = (y_fraction - dyUnv) / (1.0 - dyIntens - dyUnv) * pitch -> ceiling; double minimumDf = 1e30; integer bestCandidate = -1; - integer ibestFrame = Sampled_xToNearestIndex (pitch, xWC); + integer ibestFrame = Sampled_xToNearestIndex (pitch, x_world); Melder_clip (1_integer, & ibestFrame, pitch -> nx); const Pitch_Frame bestFrame = & pitch -> frames [ibestFrame]; @@ -312,9 +314,9 @@ bool structPitchEditor :: v_click (double xWC, double yWC, bool dummy) { if (bestCandidate != -1) { const double bestFrequency = bestFrame -> candidates [bestCandidate]. frequency; const double distanceWC = (clickedFrequency - bestFrequency) / pitch -> ceiling * (1.0 - dyIntens - dyUnv); - const double dx_mm = Graphics_dxWCtoMM (our graphics.get(), xWC - tmid), dy_mm = Graphics_dyWCtoMM (our graphics.get(), distanceWC); + const double dx_mm = Graphics_dxWCtoMM (our graphics.get(), x_world - tmid), dy_mm = Graphics_dyWCtoMM (our graphics.get(), distanceWC); if (bestFrequency < pitch -> ceiling && // above ceiling: ignore - ((bestFrequency <= 0.0 && fabs (xWC - tmid) <= 0.5 * pitch -> dx && clickedFrequency <= 0.0) || // voiceless: click within frame + ((bestFrequency <= 0.0 && fabs (x_world - tmid) <= 0.5 * pitch -> dx && clickedFrequency <= 0.0) || // voiceless: click within frame (bestFrequency > 0.0 && dx_mm * dx_mm + dy_mm * dy_mm <= RADIUS * RADIUS))) // voiced: click within circle { Editor_save (this, U"Change path"); @@ -324,10 +326,10 @@ bool structPitchEditor :: v_click (double xWC, double yWC, bool dummy) { our startSelection = our endSelection = tmid; // cursor will snap to candidate return FunctionEditor_UPDATE_NEEDED; } else { - return PitchEditor_Parent :: v_click (xWC, yWC, dummy); // move cursor or drag selection + return PitchEditor_Parent :: v_mouseInWideDataView (event, x_world, y_fraction); // move cursor or drag selection } } - return PitchEditor_Parent :: v_click (xWC, yWC, dummy); // move cursor or drag selection + return PitchEditor_Parent :: v_mouseInWideDataView (event, x_world, y_fraction); // move cursor or drag selection } autoPitchEditor PitchEditor_create (conststring32 title, Pitch pitch) { diff --git a/fon/PitchEditor.h b/fon/PitchEditor.h index 5e7ef5a7..911da242 100644 --- a/fon/PitchEditor.h +++ b/fon/PitchEditor.h @@ -2,7 +2,7 @@ #define _PitchEditor_h_ /* PitchEditor.h * - * Copyright (C) 1992-2011,2012,2015 Paul Boersma + * Copyright (C) 1992-2005,2007,2009-2012,2015,2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -30,7 +30,7 @@ Thing_define (PitchEditor, FunctionEditor) { override; void v_play (double tmin, double tmax) override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) override; }; diff --git a/fon/PitchTierArea.cpp b/fon/PitchTierArea.cpp new file mode 100644 index 00000000..a3a73948 --- /dev/null +++ b/fon/PitchTierArea.cpp @@ -0,0 +1,35 @@ +/* PitchTierArea.cpp + * + * Copyright (C) 1992-2012,2015,2016,2018,2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "PitchTierArea.h" + +#include "enums_getText.h" +#include "PitchTierArea_enums.h" +#include "enums_getValue.h" +#include "PitchTierArea_enums.h" + +Thing_implement (PitchTierArea, RealTierArea, 0); + +#include "prefs_define.h" +#include "PitchTierArea_prefs.h" +#include "prefs_install.h" +#include "PitchTierArea_prefs.h" +#include "prefs_copyToInstance.h" +#include "PitchTierArea_prefs.h" + +/* End of file PitchTierArea.cpp */ diff --git a/fon/PitchTierArea.h b/fon/PitchTierArea.h new file mode 100644 index 00000000..2c092d80 --- /dev/null +++ b/fon/PitchTierArea.h @@ -0,0 +1,74 @@ +#ifndef _PitchTierArea_h_ +#define _PitchTierArea_h_ +/* PitchTierArea.h + * + * Copyright (C) 1992-2005,2007,2009-2012,2015-2018,2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "RealTierArea.h" +#include "PitchTier.h" + +#include "PitchTierArea_enums.h" + +Thing_define (PitchTierArea, RealTierArea) { + double v_minimumLegalY () + override { return 0.0; } + conststring32 v_rightTickUnits () override { + if (our p_units == kPitchTierArea_units::HERTZ) + return U" Hz"; + else if (our p_units == kPitchTierArea_units::SEMITONES) + return U" st"; + else + Melder_fatal (U"PitchTierArea::v_rightTickUnits: Unknown pitch units: ", (int) our p_units); + } + double v_defaultYmin () + override { return 50.0; } + double v_defaultYmax () + override { return 600.0; } + double v_valueToY (double value) override { + const double clippedValue = Melder_clippedLeft (25.0, value); + if (our p_units == kPitchTierArea_units::HERTZ) + return clippedValue; + else if (our p_units == kPitchTierArea_units::SEMITONES) + return NUMhertzToSemitones (clippedValue); + else + Melder_fatal (U"PitchTierArea::v_valueToY: Unknown pitch units: ", (int) our p_units); + return undefined; + } + double v_yToValue (double y) override { + if (our p_units == kPitchTierArea_units::HERTZ) + return y; + else if (our p_units == kPitchTierArea_units::SEMITONES) + return NUMsemitonesToHertz (y); + else + Melder_fatal (U"PitchTierArea::v_yToValue: Unknown pitch units: ", (int) our p_units); + return undefined; + } + + #include "PitchTierArea_prefs.h" +}; + +Thing_declare (PitchTierEditor); + +inline static autoPitchTierArea PitchTierArea_create (FunctionEditor editor, double bottom_fraction, double top_fraction) { + autoPitchTierArea me = Thing_new (PitchTierArea); + FunctionArea_init (me.get(), editor, bottom_fraction, top_fraction); + my p_units = my pref_units(); + return me; +} + +/* End of file PitchTierArea.h */ +#endif diff --git a/fon/PitchTierArea_enums.h b/fon/PitchTierArea_enums.h new file mode 100644 index 00000000..12753789 --- /dev/null +++ b/fon/PitchTierArea_enums.h @@ -0,0 +1,24 @@ +/* PitchTierArea_enums.h + * + * Copyright (C) 2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +enums_begin (kPitchTierArea_units, 1) + enums_add (kPitchTierArea_units, 1, HERTZ, U"Hertz") + enums_add (kPitchTierArea_units, 2, SEMITONES, U"semitones re 100 Hz") +enums_end (kPitchTierArea_units, 2, HERTZ) + +/* End of file PitchTierArea_enums.h */ diff --git a/fon/PitchTierArea_prefs.h b/fon/PitchTierArea_prefs.h new file mode 100644 index 00000000..77a60f44 --- /dev/null +++ b/fon/PitchTierArea_prefs.h @@ -0,0 +1,27 @@ +/* PitchTierArea_prefs.h + * + * Copyright (C) 2013,2015-2017,2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +prefs_begin (PitchTierArea) + + prefs_add_enum_with_data (PitchTierArea, units, 1, kPitchTierArea_units, DEFAULT) + prefs_add_double_with_data (PitchTierArea, minimum, 1, U"50.0") // Hz + prefs_add_double_with_data (PitchTierArea, maximum, 1, U"300.0") // Hz + +prefs_end (PitchTierArea) + +/* End of file PitchTierArea_prefs.h */ diff --git a/fon/PitchTierEditor.cpp b/fon/PitchTierEditor.cpp index 3edf0616..42b6f951 100644 --- a/fon/PitchTierEditor.cpp +++ b/fon/PitchTierEditor.cpp @@ -1,6 +1,6 @@ /* PitchTierEditor.cpp * - * Copyright (C) 1992-2011,2012,20152016 Paul Boersma + * Copyright (C) 1992-2012,2015,2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -31,18 +31,20 @@ void structPitchTierEditor :: v_createHelpMenuItems (EditorMenu menu) { EditorMenu_addCommand (menu, U"PitchTier help", 0, menu_cb_PitchTierHelp); } -void structPitchTierEditor :: v_play (double a_tmin, double a_tmax) { - if (d_sound.data) { - Sound_playPart (d_sound.data, a_tmin, a_tmax, theFunctionEditor_playCallback, this); +void structPitchTierEditor :: v_play (double startTime, double endTime) { + if (our d_sound.data) { + Sound_playPart (our d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); } else { - PitchTier_playPart ((PitchTier) data, a_tmin, a_tmax, false); + PitchTier_playPart (our pitchTier(), startTime, endTime, false); } } autoPitchTierEditor PitchTierEditor_create (conststring32 title, PitchTier pitch, Sound sound, bool ownSound) { try { autoPitchTierEditor me = Thing_new (PitchTierEditor); - RealTierEditor_init (me.get(), title, pitch, sound, ownSound); + autoPitchTierArea area = PitchTierArea_create (me.get(), 0.0, ( sound ? 1.0 - structRealTierEditor::SOUND_HEIGHT : 1.0 )); + RealTierEditor_init (me.get(), area.move(), title, pitch, sound, ownSound); + my pitchTierArea() -> p_units = kPitchTierArea_units::HERTZ; // override preferences return me; } catch (MelderError) { Melder_throw (U"PitchTier window not created."); diff --git a/fon/PitchTierEditor.h b/fon/PitchTierEditor.h index bcf6d414..e02f8c8a 100644 --- a/fon/PitchTierEditor.h +++ b/fon/PitchTierEditor.h @@ -2,7 +2,7 @@ #define _PitchTierEditor_h_ /* PitchTierEditor.h * - * Copyright (C) 1992-2011,2012,2015,2017 Paul Boersma + * Copyright (C) 1992-2005,2007,2009-2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,24 +19,22 @@ */ #include "RealTierEditor.h" -#include "PitchTier.h" +#include "PitchTierArea.h" #include "Sound.h" Thing_define (PitchTierEditor, RealTierEditor) { + /* + Access inherited attributes by their derived type. + */ + PitchTier & pitchTier() { return * reinterpret_cast (& our data); } + autoPitchTierArea & pitchTierArea() { return * reinterpret_cast (& our realTierArea); } + void v_createHelpMenuItems (EditorMenu menu) override; void v_play (double tmin, double tmax) override; - double v_minimumLegalValue () - override { return 0.0; } conststring32 v_quantityText () override { return U"Frequency (Hz)"; } - conststring32 v_rightTickUnits () - override { return U" Hz"; } - double v_defaultYmin () - override { return 50.0; } - double v_defaultYmax () - override { return 600.0; } conststring32 v_setRangeTitle () override { return U"Set frequency range..."; } conststring32 v_defaultYminText () diff --git a/fon/Pitch_to_PitchTier.cpp b/fon/Pitch_to_PitchTier.cpp index bbb58c15..c87e04ec 100644 --- a/fon/Pitch_to_PitchTier.cpp +++ b/fon/Pitch_to_PitchTier.cpp @@ -22,13 +22,12 @@ autoPitchTier Pitch_to_PitchTier (Pitch me) { try { autoPitchTier you = PitchTier_create (my xmin, my xmax); for (integer i = 1; i <= my nx; i ++) { - double frequency = my frames [i]. candidates [1]. frequency; - + const double frequency = my frames [i]. candidates [1]. frequency; /* Count only voiced frames. */ if (Pitch_util_frequencyIsVoiced (frequency, my ceiling)) { - double time = Sampled_indexToX (me, i); + const double time = Sampled_indexToX (me, i); RealTier_addPoint (you.get(), time, frequency); } } @@ -38,80 +37,80 @@ autoPitchTier Pitch_to_PitchTier (Pitch me) { } } -static void Pitch_line (Pitch me, Graphics g, double tmin, double fleft, double tmax, double fright, +static void Pitch_line (Pitch me, Graphics graphics, double tmin, double fleft, double tmax, double fright, int nonPeriodicLineType) { /* f = fleft + (t - tmin) * (fright - fleft) / (tmax - tmin); */ - int lineType = Graphics_inqLineType (g); - double lineWidth = Graphics_inqLineWidth (g); - double slope = (fright - fleft) / (tmax - tmin); - integer imin = Sampled_xToNearestIndex (me, tmin); - if (imin < 1) imin = 1; - integer imax = Sampled_xToNearestIndex (me, tmax); - if (imax > my nx) imax = my nx; + const int lineType = Graphics_inqLineType (graphics); + const double lineWidth = Graphics_inqLineWidth (graphics); + const double slope = (fright - fleft) / (tmax - tmin); + const integer imin = Melder_clippedLeft (1_integer, Sampled_xToNearestIndex (me, tmin)); + const integer imax = Melder_clippedRight (Sampled_xToNearestIndex (me, tmax), my nx); for (integer i = imin; i <= imax; i ++) { - double tleft, tright; if (! Pitch_isVoiced_i (me, i)) { - if (nonPeriodicLineType == 2) continue; - Graphics_setLineType (g, Graphics_DOTTED); - Graphics_setLineWidth (g, 0.67 * lineWidth); + if (nonPeriodicLineType == 2) + continue; + Graphics_setLineType (graphics, Graphics_DOTTED); + Graphics_setLineWidth (graphics, 0.67 * lineWidth); } else if (nonPeriodicLineType != 2) { - Graphics_setLineWidth (g, 2 * lineWidth); + Graphics_setLineWidth (graphics, 2 * lineWidth); } - tleft = Sampled_indexToX (me, i) - 0.5 * my dx, tright = tleft + my dx; - if (tleft < tmin) tleft = tmin; - if (tright > tmax) tright = tmax; - Graphics_line (g, tleft, fleft + (tleft - tmin) * slope, - tright, fleft + (tright - tmin) * slope); - Graphics_setLineType (g, lineType); - Graphics_setLineWidth (g, lineWidth); + double tleft = Sampled_indexToX (me, i) - 0.5 * my dx; + double tright = tleft + my dx; + Melder_clipLeft (tmin, & tleft); // has to be ordered after the previous line! + Melder_clipRight (& tright, tmax); + Graphics_line (graphics, + tleft, fleft + (tleft - tmin) * slope, + tright, fleft + (tright - tmin) * slope + ); + Graphics_setLineType (graphics, lineType); + Graphics_setLineWidth (graphics, lineWidth); } } -void PitchTier_Pitch_draw (PitchTier me, Pitch uv, Graphics g, - double tmin, double tmax, double fmin, double fmax, int nonPeriodicLineType, int garnish, conststring32 method) +void PitchTier_Pitch_draw (PitchTier me, Pitch uv, Graphics graphics, + double tmin, double tmax, double fmin, double fmax, int nonPeriodicLineType, bool garnish, conststring32 method) { - integer n = my points.size, imin, imax, i; if (nonPeriodicLineType == 0) { - PitchTier_draw (me, g, tmin, tmax, fmin, fmax, garnish, method); + PitchTier_draw (me, graphics, tmin, tmax, fmin, fmax, garnish, method); return; } Function_unidirectionalAutowindow (me, & tmin, & tmax); - Graphics_setWindow (g, tmin, tmax, fmin, fmax); - Graphics_setInner (g); - imin = AnyTier_timeToHighIndex (me->asAnyTier(), tmin); - imax = AnyTier_timeToLowIndex (me->asAnyTier(), tmax); - if (n == 0) { + Graphics_setWindow (graphics, tmin, tmax, fmin, fmax); + Graphics_setInner (graphics); + const integer imin = AnyTier_timeToHighIndex (me->asAnyTier(), tmin); + const integer imax = AnyTier_timeToLowIndex (me->asAnyTier(), tmax); + if (my points.size == 0) { } else if (imax < imin) { - double fleft = RealTier_getValueAtTime (me, tmin); - double fright = RealTier_getValueAtTime (me, tmax); - Pitch_line (uv, g, tmin, fleft, tmax, fright, nonPeriodicLineType); - } else for (i = imin; i <= imax; i ++) { - RealPoint point = my points.at [i]; - double t = point -> number, f = point -> value; - Graphics_speckle (g, t, f); + const double fleft = RealTier_getValueAtTime (me, tmin); + const double fright = RealTier_getValueAtTime (me, tmax); + Pitch_line (uv, graphics, tmin, fleft, tmax, fright, nonPeriodicLineType); + } else for (integer i = imin; i <= imax; i ++) { + const RealPoint point = my points.at [i]; + const double time = point -> number, frequency = point -> value; + Graphics_speckle (graphics, time, frequency); if (i == 1) - Pitch_line (uv, g, tmin, f, t, f, nonPeriodicLineType); + Pitch_line (uv, graphics, tmin, frequency, time, frequency, nonPeriodicLineType); else if (i == imin) - Pitch_line (uv, g, t, f, tmin, RealTier_getValueAtTime (me, tmin), nonPeriodicLineType); - if (i == n) - Pitch_line (uv, g, t, f, tmax, f, nonPeriodicLineType); + Pitch_line (uv, graphics, time, frequency, tmin, RealTier_getValueAtTime (me, tmin), nonPeriodicLineType); + if (i == my points.size) + Pitch_line (uv, graphics, time, frequency, tmax, frequency, nonPeriodicLineType); else if (i == imax) - Pitch_line (uv, g, t, f, tmax, RealTier_getValueAtTime (me, tmax), nonPeriodicLineType); + Pitch_line (uv, graphics, time, frequency, tmax, RealTier_getValueAtTime (me, tmax), nonPeriodicLineType); else { RealPoint pointRight = my points.at [i + 1]; - Pitch_line (uv, g, t, f, pointRight -> number, pointRight -> value, nonPeriodicLineType); + Pitch_line (uv, graphics, time, frequency, pointRight -> number, pointRight -> value, nonPeriodicLineType); } } - Graphics_unsetInner (g); + Graphics_unsetInner (graphics); if (garnish) { - Graphics_drawInnerBox (g); - Graphics_textBottom (g, true, U"Time (s)"); - Graphics_marksBottom (g, 2, true, true, false); - Graphics_marksLeft (g, 2, true, true, false); - Graphics_textLeft (g, true, U"Frequency (Hz)"); + Graphics_drawInnerBox (graphics); + Graphics_textBottom (graphics, true, U"Time (s)"); + Graphics_marksBottom (graphics, 2, true, true, false); + Graphics_marksLeft (graphics, 2, true, true, false); + Graphics_textLeft (graphics, true, U"Frequency (Hz)"); } } @@ -122,10 +121,10 @@ autoPitch Pitch_PitchTier_to_Pitch (Pitch me, PitchTier tier) { autoPitch you = Data_copy (me); for (integer iframe = 1; iframe <= my nx; iframe ++) { const Pitch_Frame frame = & your frames [iframe]; - const Pitch_Candidate cand = & frame -> candidates [1]; - if (Pitch_util_frequencyIsVoiced (cand -> frequency, my ceiling)) - cand -> frequency = RealTier_getValueAtTime (tier, Sampled_indexToX (me, iframe)); - cand -> strength = 0.9; + const Pitch_Candidate candidate = & frame -> candidates [1]; + if (Pitch_util_frequencyIsVoiced (candidate -> frequency, my ceiling)) + candidate -> frequency = RealTier_getValueAtTime (tier, Sampled_indexToX (me, iframe)); + candidate -> strength = 0.9; frame -> candidates. resize (frame -> nCandidates = 1); } return you; diff --git a/fon/Pitch_to_PitchTier.h b/fon/Pitch_to_PitchTier.h index 6c9abdca..476d7332 100644 --- a/fon/Pitch_to_PitchTier.h +++ b/fon/Pitch_to_PitchTier.h @@ -1,6 +1,6 @@ /* Pitch_to_PitchTier.h * - * Copyright (C) 1992-2011,2015 Paul Boersma + * Copyright (C) 1992-2005,2010-2012,2015,2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -28,7 +28,7 @@ autoPitchTier Pitch_to_PitchTier (Pitch me); void PitchTier_Pitch_draw (PitchTier me, Pitch uv, Graphics g, double tmin, double tmax, double fmin, double fmax, - int nonPeriodicLineType, int garnish, conststring32 method); + int nonPeriodicLineType, bool garnish, conststring32 method); autoPitch Pitch_PitchTier_to_Pitch (Pitch me, PitchTier tier); diff --git a/fon/Pitch_to_PointProcess.cpp b/fon/Pitch_to_PointProcess.cpp index 180bf371..0c5aa6f9 100644 --- a/fon/Pitch_to_PointProcess.cpp +++ b/fon/Pitch_to_PointProcess.cpp @@ -178,27 +178,28 @@ autoPointProcess Sound_Pitch_to_PointProcess_cc (Sound sound, Pitch pitch) { autoPointProcess point = PointProcess_create (sound -> xmin, sound -> xmax, 10); double t = pitch -> xmin; double addedRight = -1e308; - double globalPeak = Vector_getAbsoluteExtremum (sound, sound -> xmin, sound -> xmax, 0), peak; + const double globalPeak = Vector_getAbsoluteExtremum (sound, sound -> xmin, sound -> xmax, kVector_peakInterpolation :: NONE); /* - * Cycle over all voiced intervals. - */ + Cycle over all voiced intervals. + */ autoMelderProgress progress (U"Sound & Pitch: To PointProcess..."); for (;;) { double tleft, tright; - if (! Pitch_getVoicedIntervalAfter (pitch, t, & tleft, & tright)) break; + if (! Pitch_getVoicedIntervalAfter (pitch, t, & tleft, & tright)) + break; Melder_assert (tright > t); /* * Go to the middle of the voice stretch. */ - double tmiddle = (tleft + tright) / 2; + const double tmiddle = (tleft + tright) / 2.0; Melder_progress ((tmiddle - sound -> xmin) / (sound -> xmax - sound -> xmin), U"Sound & Pitch to PointProcess"); - double f0middle = Pitch_getValueAtTime (pitch, tmiddle, kPitch_unit::HERTZ, Pitch_LINEAR); + const double f0middle = Pitch_getValueAtTime (pitch, tmiddle, kPitch_unit::HERTZ, Pitch_LINEAR); /* - * Our first point is near this middle. - */ + Our first point is near this middle. + */ if (isundef (f0middle)) { Melder_fatal (U"Sound_Pitch_to_PointProcess_cc:" U" tleft ", tleft, @@ -212,14 +213,16 @@ autoPointProcess Sound_Pitch_to_PointProcess_cc (Sound sound, Pitch pitch) { double tsave = tmax; for (;;) { - double f0 = Pitch_getValueAtTime (pitch, tmax, kPitch_unit::HERTZ, Pitch_LINEAR), correlation; - if (isundef (f0)) break; - correlation = Sound_findMaximumCorrelation (sound, tmax, 1.0 / f0, tmax - 1.25 / f0, tmax - 0.8 / f0, & tmax, & peak); - if (correlation == -1) /*break*/ tmax -= 1.0 / f0; // this one period will drop out + const double f0 = Pitch_getValueAtTime (pitch, tmax, kPitch_unit::HERTZ, Pitch_LINEAR); + if (isundef (f0)) + break; + double peak; + const double correlation = Sound_findMaximumCorrelation (sound, tmax, 1.0 / f0, tmax - 1.25 / f0, tmax - 0.8 / f0, & tmax, & peak); + if (correlation == -1.0) + /*break*/ tmax -= 1.0 / f0; // this one period will drop out if (tmax < tleft) { - if (correlation > 0.7 && peak > 0.023333 * globalPeak && tmax - addedRight > 0.8 / f0) { + if (correlation > 0.7 && peak > 0.023333 * globalPeak && tmax - addedRight > 0.8 / f0) PointProcess_addPoint (point.get(), tmax); - } break; } if (correlation > 0.3 && (peak == 0.0 || peak > 0.01 * globalPeak)) { @@ -230,10 +233,13 @@ autoPointProcess Sound_Pitch_to_PointProcess_cc (Sound sound, Pitch pitch) { } tmax = tsave; for (;;) { - double f0 = Pitch_getValueAtTime (pitch, tmax, kPitch_unit::HERTZ, Pitch_LINEAR), correlation; - if (isundef (f0)) break; - correlation = Sound_findMaximumCorrelation (sound, tmax, 1.0 / f0, tmax + 0.8 / f0, tmax + 1.25 / f0, & tmax, & peak); - if (correlation == -1) /*break*/ tmax += 1.0 / f0; + const double f0 = Pitch_getValueAtTime (pitch, tmax, kPitch_unit::HERTZ, Pitch_LINEAR); + if (isundef (f0)) + break; + double peak; + const double correlation = Sound_findMaximumCorrelation (sound, tmax, 1.0 / f0, tmax + 0.8 / f0, tmax + 1.25 / f0, & tmax, & peak); + if (correlation == -1.0) + /*break*/ tmax += 1.0 / f0; if (tmax > tright) { if (correlation > 0.7 && peak > 0.023333 * globalPeak) { PointProcess_addPoint (point.get(), tmax); @@ -253,7 +259,6 @@ autoPointProcess Sound_Pitch_to_PointProcess_cc (Sound sound, Pitch pitch) { Melder_throw (sound, U" & ", pitch, U": not converted to PointProcess (cc)."); } } - autoPointProcess Sound_Pitch_to_PointProcess_peaks (Sound sound, Pitch pitch, int includeMaxima, int includeMinima) { try { @@ -261,23 +266,24 @@ autoPointProcess Sound_Pitch_to_PointProcess_peaks (Sound sound, Pitch pitch, in double t = pitch -> xmin; double addedRight = -1e308; /* - * Cycle over all voiced intervals. - */ + Cycle over all voiced intervals. + */ autoMelderProgress progress (U"Sound & Pitch: To PointProcess"); for (;;) { double tleft, tright; - if (! Pitch_getVoicedIntervalAfter (pitch, t, & tleft, & tright)) break; + if (! Pitch_getVoicedIntervalAfter (pitch, t, & tleft, & tright)) + break; /* - * Go to the middle of the voiced interval. - */ - double tmiddle = (tleft + tright) / 2; + Go to the middle of the voiced interval. + */ + const double tmiddle = (tleft + tright) / 2.0; Melder_progress ((tmiddle - sound -> xmin) / (sound -> xmax - sound -> xmin), U"Sound & Pitch: To PointProcess"); - double f0middle = Pitch_getValueAtTime (pitch, tmiddle, kPitch_unit::HERTZ, Pitch_LINEAR); + const double f0middle = Pitch_getValueAtTime (pitch, tmiddle, kPitch_unit::HERTZ, Pitch_LINEAR); /* - * Our first point is near this middle. - */ + Our first point is near this middle. + */ Melder_assert (isdefined (f0middle)); double tmax = Sound_findExtremum (sound, tmiddle - 0.5 / f0middle, tmiddle + 0.5 / f0middle, includeMaxima, includeMinima); Melder_assert (isdefined (tmax)); @@ -285,23 +291,23 @@ autoPointProcess Sound_Pitch_to_PointProcess_peaks (Sound sound, Pitch pitch, in double tsave = tmax; for (;;) { - double f0 = Pitch_getValueAtTime (pitch, tmax, kPitch_unit::HERTZ, Pitch_LINEAR); - if (isundef (f0)) break; + const double f0 = Pitch_getValueAtTime (pitch, tmax, kPitch_unit::HERTZ, Pitch_LINEAR); + if (isundef (f0)) + break; tmax = Sound_findExtremum (sound, tmax - 1.25 / f0, tmax - 0.8 / f0, includeMaxima, includeMinima); if (tmax < tleft) { - if (tmax - addedRight > 0.8 / f0) { + if (tmax - addedRight > 0.8 / f0) PointProcess_addPoint (point.get(), tmax); - } break; } - if (tmax - addedRight > 0.8 / f0) { // do not fill in a short originally unvoiced interval twice + if (tmax - addedRight > 0.8 / f0) // do not fill in a short originally unvoiced interval twice PointProcess_addPoint (point.get(), tmax); - } } tmax = tsave; for (;;) { - double f0 = Pitch_getValueAtTime (pitch, tmax, kPitch_unit::HERTZ, Pitch_LINEAR); - if (isundef (f0)) break; + const double f0 = Pitch_getValueAtTime (pitch, tmax, kPitch_unit::HERTZ, Pitch_LINEAR); + if (isundef (f0)) + break; tmax = Sound_findExtremum (sound, tmax + 0.8 / f0, tmax + 1.25 / f0, includeMaxima, includeMinima); if (tmax > tright) { PointProcess_addPoint (point.get(), tmax); diff --git a/fon/PointEditor.cpp b/fon/PointEditor.cpp index 37d8060a..9fc49226 100644 --- a/fon/PointEditor.cpp +++ b/fon/PointEditor.cpp @@ -191,11 +191,11 @@ void structPointEditor :: v_draw () { v_updateMenuItems_file (); } -void structPointEditor :: v_play (double a_tmin, double a_tmax) { +void structPointEditor :: v_play (double startTime, double endTime) { if (d_sound.data) { - Sound_playPart (d_sound.data, a_tmin, a_tmax, theFunctionEditor_playCallback, this); + Sound_playPart (d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); } else { - PointProcess_playPart ((PointProcess) data, a_tmin, a_tmax); + PointProcess_playPart ((PointProcess) data, startTime, endTime); } } diff --git a/fon/PointProcess.cpp b/fon/PointProcess.cpp index b8cb62a6..a6a15bdd 100644 --- a/fon/PointProcess.cpp +++ b/fon/PointProcess.cpp @@ -41,14 +41,14 @@ Thing_implement (PointProcess, Function, 0); static void infoPeriods (PointProcess me, double shortestPeriod, double longestPeriod, double maximumPeriodFactor, int precision) { - integer numberOfPeriods = PointProcess_getNumberOfPeriods (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); - double meanPeriod = PointProcess_getMeanPeriod (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); - double stdevPeriod = PointProcess_getStdevPeriod (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); - double jitter_local = PointProcess_getJitter_local (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); - double jitter_local_absolute = PointProcess_getJitter_local_absolute (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); - double jitter_rap = PointProcess_getJitter_rap (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); - double jitter_ppq5 = PointProcess_getJitter_ppq5 (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); - double jitter_ddp = PointProcess_getJitter_ddp (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); + const integer numberOfPeriods = PointProcess_getNumberOfPeriods (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); + const double meanPeriod = PointProcess_getMeanPeriod (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); + const double stdevPeriod = PointProcess_getStdevPeriod (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); + const double jitter_local = PointProcess_getJitter_local (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); + const double jitter_local_absolute = PointProcess_getJitter_local_absolute (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); + const double jitter_rap = PointProcess_getJitter_rap (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); + const double jitter_ppq5 = PointProcess_getJitter_ppq5 (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); + const double jitter_ddp = PointProcess_getJitter_ddp (me, 0.0, 0.0, shortestPeriod, longestPeriod, maximumPeriodFactor); MelderInfo_writeLine (U" Number of periods: ", numberOfPeriods); MelderInfo_writeLine (U" Mean period: ", meanPeriod, U" seconds"); MelderInfo_writeLine (U" Stdev period: ", stdevPeriod, U" seconds"); @@ -108,7 +108,7 @@ autoPointProcess PointProcess_create (double tmin, double tmax, integer initialM autoPointProcess PointProcess_createPoissonProcess (double startingTime, double finishingTime, double density) { try { autoPointProcess me = PointProcess_create (startingTime, finishingTime, 0); - integer numberOfPoints = (integer) NUMrandomPoisson ((finishingTime - startingTime) * density); + const integer numberOfPoints = (integer) NUMrandomPoisson ((finishingTime - startingTime) * density); my t = newVECrandomUniform (numberOfPoints, startingTime, finishingTime); my nt = numberOfPoints; // maintain invariant VECsort_inplace (my t.get()); @@ -124,11 +124,16 @@ integer PointProcess_getLowIndex (PointProcess me, double t) { if (t >= my t [my nt]) // special case that often occurs in practice return my nt; Melder_assert (my nt != 1); // may fail if t or my t [1] is NaN - /* Start binary search. */ + /* + Start binary search. + */ integer left = 1, right = my nt; while (left < right - 1) { - integer mid = (left + right) / 2; - if (t >= my t [mid]) left = mid; else right = mid; + const integer mid = (left + right) / 2; + if (t >= my t [mid]) + left = mid; + else + right = mid; } Melder_assert (right == left + 1); return left; @@ -141,11 +146,16 @@ integer PointProcess_getHighIndex (PointProcess me, double t) { return 1; if (t > my t [my nt]) return my nt + 1; - /* Start binary search. */ + /* + Start binary search. + */ integer left = 1, right = my nt; while (left < right - 1) { - integer mid = (left + right) / 2; - if (t > my t [mid]) left = mid; else right = mid; + const integer mid = (left + right) / 2; + if (t > my t [mid]) + left = mid; + else + right = mid; } Melder_assert (right == left + 1); return right; @@ -158,11 +168,16 @@ integer PointProcess_getNearestIndex (PointProcess me, double t) { return 1; if (t >= my t [my nt]) return my nt; - /* Start binary search. */ + /* + Start binary search. + */ integer left = 1, right = my nt; while (left < right - 1) { - integer mid = (left + right) / 2; - if (t >= my t [mid]) left = mid; else right = mid; + const integer mid = (left + right) / 2; + if (t >= my t [mid]) + left = mid; + else + right = mid; } Melder_assert (right == left + 1); return t - my t [left] < my t [right] - t ? left : right; @@ -172,13 +187,13 @@ void PointProcess_addPoint (PointProcess me, double t) { try { Melder_require (isdefined (t), U"Cannot add a point at an undefined time."); - integer newNumberOfPoints = my nt + 1; + const integer newNumberOfPoints = my nt + 1; my t. resize (newNumberOfPoints); if (my nt == 0 || t >= my t [my nt]) { // special case that often occurs in practice my nt = newNumberOfPoints; // maintain invariant my t [newNumberOfPoints] = t; } else { - integer left = PointProcess_getLowIndex (me, t); + const integer left = PointProcess_getLowIndex (me, t); if (left == 0 || my t [left] != t) { for (integer i = my nt; i > left; i --) my t [i + 1] = my t [i]; @@ -193,7 +208,7 @@ void PointProcess_addPoint (PointProcess me, double t) { void PointProcess_addPoints (PointProcess me, constVECVU const& times) { try { - integer newNumberOfPoints = my nt + times.size; + const integer newNumberOfPoints = my nt + times.size; my t. resize (newNumberOfPoints); my t.part (my nt + 1, newNumberOfPoints) <<= times; my nt = newNumberOfPoints; // maintain invariant @@ -210,7 +225,7 @@ void PointProcess_removePoint (PointProcess me, integer pointNumber) { */ for (integer i = pointNumber; i < my nt; i ++) my t [i] = my t [i + 1]; - integer newNumberOfPoints = my nt - 1; + const integer newNumberOfPoints = my nt - 1; my t. resize (newNumberOfPoints); my nt = newNumberOfPoints; // maintain invariant } @@ -220,13 +235,14 @@ void PointProcess_removePointNear (PointProcess me, double time) { } void PointProcess_removePoints (PointProcess me, integer first, integer last) { - if (first < 1) first = 1; - if (last > my nt) last = my nt; - integer distance = last - first + 1; - if (distance <= 0) return; + Melder_clipLeft (1_integer, & first); + Melder_clipRight (& last, my nt); + const integer distance = last - first + 1; + if (distance <= 0) + return; for (integer i = first + distance; i <= my nt; i ++) my t [i - distance] = my t [i]; - integer newNumberOfPoints = my nt - distance; + const integer newNumberOfPoints = my nt - distance; my t. resize (newNumberOfPoints); my nt = newNumberOfPoints; // maintain invariant } @@ -239,9 +255,9 @@ void PointProcess_draw (PointProcess me, Graphics g, double tmin, double tmax, b Function_unidirectionalAutowindow (me, & tmin, & tmax); Graphics_setWindow (g, tmin, tmax, -1.0, 1.0); if (my nt) { - integer imin = PointProcess_getHighIndex (me, tmin); - integer imax = PointProcess_getLowIndex (me, tmax); - int lineType = Graphics_inqLineType (g); + const integer imin = PointProcess_getHighIndex (me, tmin); + const integer imax = PointProcess_getLowIndex (me, tmax); + const int lineType = Graphics_inqLineType (g); Graphics_setLineType (g, Graphics_DOTTED); Graphics_setInner (g); for (integer i = imin; i <= imax; i ++) @@ -257,16 +273,19 @@ void PointProcess_draw (PointProcess me, Graphics g, double tmin, double tmax, b } double PointProcess_getInterval (PointProcess me, double t) { - integer ileft = PointProcess_getLowIndex (me, t); - if (ileft <= 0 || ileft >= my nt) return undefined; + const integer ileft = PointProcess_getLowIndex (me, t); + if (ileft <= 0 || ileft >= my nt) + return undefined; return my t [ileft + 1] - my t [ileft]; } autoPointProcess PointProcesses_union (PointProcess me, PointProcess thee) { try { autoPointProcess him = Data_copy (me); - if (thy xmin < my xmin) his xmin = thy xmin; - if (thy xmax > my xmax) his xmax = thy xmax; + if (thy xmin < my xmin) + his xmin = thy xmin; + if (thy xmax > my xmax) + his xmax = thy xmax; for (integer i = 1; i <= thy nt; i ++) PointProcess_addPoint (him.get(), thy t [i]); return him; @@ -277,26 +296,33 @@ autoPointProcess PointProcesses_union (PointProcess me, PointProcess thee) { integer PointProcess_findPoint (PointProcess me, double t) { integer left = 1, right = my nt; - if (my nt == 0) return 0; - if (t < my t [left] || t > my t [right]) return 0; + if (my nt == 0) + return 0; + if (t < my t [left] || t > my t [right]) + return 0; while (left < right - 1) { integer mid = (left + right) / 2; // tleft <= t <= tright - if (t == my t [mid]) return mid; + if (t == my t [mid]) + return mid; if (t > my t [mid]) left = mid; else right = mid; } - if (t == my t [left]) return left; - if (t == my t [right]) return right; + if (t == my t [left]) + return left; + if (t == my t [right]) + return right; return 0; } autoPointProcess PointProcesses_intersection (PointProcess me, PointProcess thee) { try { autoPointProcess him = Data_copy (me); - if (thy xmin > my xmin) his xmin = thy xmin; - if (thy xmax < my xmax) his xmax = thy xmax; + if (thy xmin > my xmin) + his xmin = thy xmin; + if (thy xmax < my xmax) + his xmax = thy xmax; for (integer i = my nt; i >= 1; i --) if (! PointProcess_findPoint (thee, my t [i])) PointProcess_removePoint (him.get(), i); @@ -350,63 +376,48 @@ void PointProcess_voice (PointProcess me, double period, double maxT) { } } -integer PointProcess_getWindowPoints (PointProcess me, double tmin, double tmax, integer *p_imin, integer *p_imax) { - integer imin = PointProcess_getHighIndex (me, tmin); - integer imax = PointProcess_getLowIndex (me, tmax); - if (p_imin) *p_imin = imin; - if (p_imax) *p_imax = imax; - return imax - imin + 1; +MelderIntegerRange PointProcess_getWindowPoints (PointProcess me, double tmin, double tmax) { + return { PointProcess_getHighIndex (me, tmin), PointProcess_getLowIndex (me, tmax) }; } static bool PointProcess_isPeriod (PointProcess me, integer ileft, double minimumPeriod, double maximumPeriod, double maximumPeriodFactor) { /* - * This function answers the question: is the interval from point 'ileft' to point 'ileft+1' a period? - */ - integer iright = ileft + 1; + This function answers the question: is the interval from point 'ileft' to point 'ileft+1' a period? + */ + const integer iright = ileft + 1; /* - * Period condition 1: both 'ileft' and 'iright' have to be within the point process. - */ - if (ileft < 1 || iright > my nt) { + Period condition 1: both 'ileft' and 'iright' have to be within the point process. + */ + if (ileft < 1 || iright > my nt) + return false; + /* + Period condition 2: the interval has to be within the boundaries, if specified. + */ + if (minimumPeriod == maximumPeriod) // special input setting (typically both zero) + return true; // all intervals count as periods, irrespective of absolute size and relative size + const double interval = my t [iright] - my t [ileft]; + if (interval <= 0.0 || interval < minimumPeriod || interval > maximumPeriod) + return false; + if (isundef (maximumPeriodFactor) || maximumPeriodFactor < 1.0) + return true; + /* + Period condition 3: the interval cannot be too different from both of its neigbours, if any. + */ + const double previousInterval = ( ileft <= 1 ? undefined : my t [ileft] - my t [ileft - 1] ); + const double nextInterval = ( iright >= my nt ? undefined : my t [iright + 1] - my t [iright] ); + double previousIntervalFactor = + ( isdefined (previousInterval) && previousInterval > 0.0 ? interval / previousInterval : undefined ); + double nextIntervalFactor = + ( isdefined (nextInterval) && nextInterval > 0.0 ? interval / nextInterval : undefined ); + if (isundef (previousIntervalFactor) && isundef (nextIntervalFactor)) + return true; // no neighbours: this is a period + if (isdefined (previousIntervalFactor) && previousIntervalFactor > 0.0 && previousIntervalFactor < 1.0) + previousIntervalFactor = 1.0 / previousIntervalFactor; + if (isdefined (nextIntervalFactor) && nextIntervalFactor > 0.0 && nextIntervalFactor < 1.0) + nextIntervalFactor = 1.0 / nextIntervalFactor; + if (isdefined (previousIntervalFactor) && previousIntervalFactor > maximumPeriodFactor && + isdefined (nextIntervalFactor) && nextIntervalFactor > maximumPeriodFactor) return false; - } else { - /* - * Period condition 2: the interval has to be within the boundaries, if specified. - */ - if (minimumPeriod == maximumPeriod) { - return true; // all intervals count as periods, irrespective of absolute size and relative size - } else { - double interval = my t [iright] - my t [ileft]; - if (interval <= 0.0 || interval < minimumPeriod || interval > maximumPeriod) { - return false; - } else if (isundef (maximumPeriodFactor) || maximumPeriodFactor < 1.0) { - return true; - } else { - /* - * Period condition 3: the interval cannot be too different from both of its neigbours, if any. - */ - double previousInterval = ( ileft <= 1 ? undefined : my t [ileft] - my t [ileft - 1] ); - double nextInterval = ( iright >= my nt ? undefined : my t [iright + 1] - my t [iright] ); - double previousIntervalFactor = - ( isdefined (previousInterval) && previousInterval > 0.0 ? interval / previousInterval : undefined ); - double nextIntervalFactor = - ( isdefined (nextInterval) && nextInterval > 0.0 ? interval / nextInterval : undefined ); - if (isundef (previousIntervalFactor) && isundef (nextIntervalFactor)) { - return true; // no neighbours: this is a period - } - if (isdefined (previousIntervalFactor) && previousIntervalFactor > 0.0 && previousIntervalFactor < 1.0) { - previousIntervalFactor = 1.0 / previousIntervalFactor; - } - if (isdefined (nextIntervalFactor) && nextIntervalFactor > 0.0 && nextIntervalFactor < 1.0) { - nextIntervalFactor = 1.0 / nextIntervalFactor; - } - if (isdefined (previousIntervalFactor) && previousIntervalFactor > maximumPeriodFactor && - isdefined (nextIntervalFactor) && nextIntervalFactor > maximumPeriodFactor) - { - return false; - } - } - } - } return true; } @@ -414,16 +425,10 @@ integer PointProcess_getNumberOfPeriods (PointProcess me, double tmin, double tm double minimumPeriod, double maximumPeriod, double maximumPeriodFactor) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - integer imin, imax; - integer numberOfPeriods = PointProcess_getWindowPoints (me, tmin, tmax, & imin, & imax) - 1; - if (numberOfPeriods < 1) return 0; - for (integer i = imin; i < imax; i ++) { - if (PointProcess_isPeriod (me, i, minimumPeriod, maximumPeriod, maximumPeriodFactor)) { - (void) 0; // this interval counts as a period - } else { - numberOfPeriods --; // this interval does not count as a period - } - } + const MelderIntegerRange pointNumbers = PointProcess_getWindowPoints (me, tmin, tmax); + integer numberOfPeriods = 0; + for (integer ipoint = pointNumbers.first; ipoint < pointNumbers.last; ipoint ++) + numberOfPeriods += PointProcess_isPeriod (me, ipoint, minimumPeriod, maximumPeriod, maximumPeriodFactor); return numberOfPeriods; } @@ -431,15 +436,13 @@ double PointProcess_getMeanPeriod (PointProcess me, double tmin, double tmax, double minimumPeriod, double maximumPeriod, double maximumPeriodFactor) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - integer imin, imax; - integer numberOfPeriods = PointProcess_getWindowPoints (me, tmin, tmax, & imin, & imax) - 1; - if (numberOfPeriods < 1) return undefined; + const MelderIntegerRange pointNumbers = PointProcess_getWindowPoints (me, tmin, tmax); + integer numberOfPeriods = 0; longdouble sum = 0.0; - for (integer i = imin; i < imax; i ++) { - if (PointProcess_isPeriod (me, i, minimumPeriod, maximumPeriod, maximumPeriodFactor)) { - sum += my t [i + 1] - my t [i]; // this interval counts as a period - } else { - numberOfPeriods --; // this interval does not count as a period + for (integer ipoint = pointNumbers.first; ipoint < pointNumbers.last; ipoint ++) { + if (PointProcess_isPeriod (me, ipoint, minimumPeriod, maximumPeriod, maximumPeriodFactor)) { + numberOfPeriods ++; + sum += my t [ipoint + 1] - my t [ipoint]; } } return numberOfPeriods > 0 ? double (sum / numberOfPeriods) : undefined; @@ -449,36 +452,60 @@ double PointProcess_getStdevPeriod (PointProcess me, double tmin, double tmax, double minimumPeriod, double maximumPeriod, double maximumPeriodFactor) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - integer imin, imax; - integer numberOfPeriods = PointProcess_getWindowPoints (me, tmin, tmax, & imin, & imax) - 1; - if (numberOfPeriods < 2) return undefined; + const MelderIntegerRange pointNumbers = PointProcess_getWindowPoints (me, tmin, tmax); + integer numberOfPeriods = 0; /* - * Compute mean. - */ + Compute mean. + */ longdouble sum = 0.0; - for (integer i = imin; i < imax; i ++) { - if (PointProcess_isPeriod (me, i, minimumPeriod, maximumPeriod, maximumPeriodFactor)) { - sum += my t [i + 1] - my t [i]; // this interval counts as a period - } else { - numberOfPeriods --; // this interval does not count as a period + for (integer ipoint = pointNumbers.first; ipoint < pointNumbers.last; ipoint ++) { + if (PointProcess_isPeriod (me, ipoint, minimumPeriod, maximumPeriod, maximumPeriodFactor)) { + numberOfPeriods ++; + sum += my t [ipoint + 1] - my t [ipoint]; } } - if (numberOfPeriods < 2) return undefined; - double mean = double (sum / numberOfPeriods); + constexpr integer minimumNumberOfDatapointsToComputeAStandardDeviation = 2; + if (numberOfPeriods < minimumNumberOfDatapointsToComputeAStandardDeviation) + return undefined; + const double mean = double (sum / numberOfPeriods); /* - * Compute variance. - */ + Compute sum of squares. + */ longdouble sum2 = 0.0; - for (integer i = imin; i < imax; i ++) { - if (PointProcess_isPeriod (me, i, minimumPeriod, maximumPeriod, maximumPeriodFactor)) { - double dperiod = my t [i + 1] - my t [i] - mean; + for (integer ipoint = pointNumbers.first; ipoint < pointNumbers.last; ipoint ++) { + if (PointProcess_isPeriod (me, ipoint, minimumPeriod, maximumPeriod, maximumPeriodFactor)) { + const double dperiod = my t [ipoint + 1] - my t [ipoint] - mean; sum2 += dperiod * dperiod; } } /* - * Compute standard deviation. - */ + Compute standard deviation. + */ return sqrt (double (sum2 / (numberOfPeriods - 1))); } +MelderCountAndFraction PointProcess_getCountAndFractionOfVoiceBreaks (PointProcess me, + double tmin, double tmax, double maximumPeriod) +{ + MelderCountAndFraction result; + const MelderIntegerRange pointNumbers = PointProcess_getWindowPoints (me, tmin, tmax); + if (pointNumbers.size() > 1) { + result.denominator = tmax - tmin; + bool previousPeriodVoiced = true; + for (integer ipoint = pointNumbers.first + 1; ipoint < pointNumbers.last; ipoint ++) { + const double period = my t [ipoint] - my t [ipoint - 1]; + if (period > maximumPeriod) { + result.numerator += period; + if (previousPeriodVoiced) { + result.count ++; + previousPeriodVoiced = false; + } + } else { + previousPeriodVoiced = true; + } + } + } + return result; +} + /* End of file PointProcess.cpp */ diff --git a/fon/PointProcess.h b/fon/PointProcess.h index 3ec4404b..9a7365f2 100644 --- a/fon/PointProcess.h +++ b/fon/PointProcess.h @@ -2,7 +2,7 @@ #define _PointProcess_h_ /* PointProcess.h * - * Copyright (C) 1992-2005,2007,2011,2015-2018 Paul Boersma + * Copyright (C) 1992-2005,2007,2011,2015-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -29,7 +29,7 @@ void PointProcess_init (PointProcess me, double startingTime, double finishingTi integer PointProcess_getLowIndex (PointProcess me, double t); integer PointProcess_getHighIndex (PointProcess me, double t); integer PointProcess_getNearestIndex (PointProcess me, double t); -integer PointProcess_getWindowPoints (PointProcess me, double tmin, double tmax, integer *p_imin, integer *p_imax); +MelderIntegerRange PointProcess_getWindowPoints (PointProcess me, double tmin, double tmax); void PointProcess_addPoint (PointProcess me, double t); void PointProcess_addPoints (PointProcess me, constVECVU const& times); integer PointProcess_findPoint (PointProcess me, double t); @@ -51,6 +51,8 @@ double PointProcess_getMeanPeriod (PointProcess me, double tmin, double tmax, double minimumPeriod, double maximumPeriod, double maximumPeriodFactor); double PointProcess_getStdevPeriod (PointProcess me, double tmin, double tmax, double minimumPeriod, double maximumPeriod, double maximumPeriodFactor); +MelderCountAndFraction PointProcess_getCountAndFractionOfVoiceBreaks (PointProcess me, double tmin, double tmax, + double maximumPeriod); /* End of file PointProcess.h */ #endif diff --git a/fon/Praat_tests.cpp b/fon/Praat_tests.cpp index 2a3a0abf..d44fb970 100644 --- a/fon/Praat_tests.cpp +++ b/fon/Praat_tests.cpp @@ -36,6 +36,8 @@ #include "Praat_tests_enums.h" #include +extern "C" int patest_record (void); + static void testAutoData (autoDaata data) { fprintf (stderr, "testAutoData: %p %p\n", data.get(), data -> name.get()); } @@ -491,6 +493,9 @@ int Praat_tests (kPraatTests itest, conststring32 arg1, conststring32 arg2, cons MelderInfo_writeLine (sum, U" should be ", size1 * size2 * size3 * 30.0); //Melder_require (NUMequal (result.get(), constantHH (size, size, size * 30.0).get()), U"..."); } break; + case kPraatTests::PATEST_RECORD: { + (void) patest_record (); + } break; case kPraatTests::THING_AUTO: { integer numberOfThingsBefore = theTotalNumberOfThings; { @@ -614,16 +619,19 @@ int Praat_tests (kPraatTests itest, conststring32 arg1, conststring32 arg2, cons VEC h; autoVEC j; //VEC jh = j; - //VEC zero = newVECzero (10); // should be ruled out - //constVEC zero = newVECzero (10); // should be ruled out - //j = h; // up assignment standardly correctly ruled out - //h = j; // down assignment was explicitly ruled out as well - //h = VEC (j); + //VEC zero = newVECzero (10); // should be ruled out: "Call to deleted constructor of 'VEC' (aka 'vector')" + //constVEC zero = newVECzero (10); // ruled out: "Conversion function from 'autoVEC' (aka 'autovector') + // to 'constVEC' (aka 'constvector') invokes a deleted function" + //j = h; // up assignment standardly correctly ruled out: "No viable overloaded '='" + //h = j; // down assignment was explicitly ruled out as well: "Overload resolution selected deleted operator '='" + //h = VEC (j); // ruled out: "Functional-style cast from 'autoVEC' (aka 'autovector') + // to 'VEC' (aka 'vector') uses deleted function" VEC & jref = j; // (in)correctly? accepted VEC *ph = & h; autoVEC *pj = & j; ph = pj; // (in)correctly? accepted - //pj = ph; // correctly ruled out + //pj = ph; // correctly ruled out: "Assigning to 'autoVEC *' (aka 'autovector *') + // from incompatible type 'VEC *' (aka 'vector *') #endif autoSound sound = Sound_create (1, 0.0, 1.0, 10000, 0.0001, 0.0); sound = Sound_create (1, 0.0, 1.0, 10000, 0.0001, 0.00005); diff --git a/fon/Praat_tests_enums.h b/fon/Praat_tests_enums.h index b599fe25..cc24defe 100644 --- a/fon/Praat_tests_enums.h +++ b/fon/Praat_tests_enums.h @@ -1,6 +1,6 @@ /* Praat_tests_enums.h * - * Copyright (C) 2001-2012,2015,2016,2017 Paul Boersma + * Copyright (C) 2001-2005,2009,2013-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -62,6 +62,7 @@ enums_begin (kPraatTests, 0) enums_add (kPraatTests, 42, TIME_MATMUL, U"TimeMatMul") enums_add (kPraatTests, 43, THING_AUTO, U"ThingAuto") enums_add (kPraatTests, 44, FILEINMEMORYMANAGER_IO, U"FileInMemoryManager_io") -enums_end (kPraatTests, 44, CHECK_RANDOM_1009_2009) + enums_add (kPraatTests, 45, PATEST_RECORD, U"PaTestRecord") +enums_end (kPraatTests, 45, CHECK_RANDOM_1009_2009) /* End of file Praat_tests_enums.h */ diff --git a/fon/RealTier.cpp b/fon/RealTier.cpp index 59099b4c..e3401cf6 100644 --- a/fon/RealTier.cpp +++ b/fon/RealTier.cpp @@ -299,7 +299,7 @@ void RealTier_multiplyPart (RealTier me, double tmin, double tmax, double factor } void RealTier_draw (RealTier me, Graphics g, double tmin, double tmax, double fmin, double fmax, - int garnish, conststring32 method, conststring32 quantity) + bool garnish, conststring32 method, conststring32 quantity) { Function_unidirectionalAutowindow (me, & tmin, & tmax); const bool drawLines = str32str (method, U"lines") || str32str (method, U"Lines"); @@ -448,7 +448,7 @@ autoRealTier Vector_to_RealTier_peaks (Vector me, integer channel, ClassInfo kla if (left <= centre && right < centre) { double x, maximum; Vector_getMaximumAndX (me, my x1 + (i - 2.5) * my dx, my x1 + (i + 0.5) * my dx, - channel, NUM_PEAK_INTERPOLATE_PARABOLIC, & maximum, & x); + channel, kVector_peakInterpolation :: PARABOLIC, & maximum, & x); RealTier_addPoint (thee.get(), x, maximum); } } @@ -466,7 +466,7 @@ autoRealTier Vector_to_RealTier_valleys (Vector me, integer channel, ClassInfo k if (left >= centre && right > centre) { double x, minimum; Vector_getMinimumAndX (me, my x1 + (i - 2.5) * my dx, my x1 + (i + 0.5) * my dx, - channel, NUM_PEAK_INTERPOLATE_PARABOLIC, & minimum, & x); + channel, kVector_peakInterpolation :: PARABOLIC, & minimum, & x); RealTier_addPoint (thee.get(), x, minimum); } } diff --git a/fon/RealTier.h b/fon/RealTier.h index fb0d59e7..e9c10c60 100644 --- a/fon/RealTier.h +++ b/fon/RealTier.h @@ -2,7 +2,7 @@ #define _RealTier_h_ /* RealTier.h * - * Copyright (C) 1992-2011,2015,2016,2017 Paul Boersma + * Copyright (C) 1992-2005,2007-2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -65,7 +65,7 @@ double RealTier_getStandardDeviation_points (RealTier me, double tmin, double tm void RealTier_addPoint (RealTier me, double t, double value); void RealTier_draw (RealTier me, Graphics g, double tmin, double tmax, - double ymin, double ymax, int garnish, conststring32 method, conststring32 quantity); + double ymin, double ymax, bool garnish, conststring32 method, conststring32 quantity); autoTableOfReal RealTier_downto_TableOfReal (RealTier me, conststring32 timeLabel, conststring32 valueLabel); void RealTier_interpolateQuadratically (RealTier me, integer numberOfPointsPerParabola, int logarithmically); diff --git a/fon/RealTierArea.cpp b/fon/RealTierArea.cpp new file mode 100644 index 00000000..f5d47bff --- /dev/null +++ b/fon/RealTierArea.cpp @@ -0,0 +1,269 @@ +/* RealTierArea.cpp + * + * Copyright (C) 1992-2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "RealTierArea.h" +#include "RealTierEditor.h" + +Thing_implement (RealTierArea, FunctionArea, 0); + +void RealTierArea_addPointAt (RealTierArea me, RealTier tier, double time, double desiredY) { + if (isdefined (my v_minimumLegalY ()) && desiredY < my v_minimumLegalY ()) + Melder_throw (U"Cannot add a point below ", my v_minimumLegalY (), my v_rightTickUnits (), U"."); + if (isdefined (my v_maximumLegalY ()) && desiredY > my v_maximumLegalY ()) + Melder_throw (U"Cannot add a point above ", my v_maximumLegalY (), my v_rightTickUnits (), U"."); + RealTier_addPoint (tier, time, my v_yToValue (desiredY)); +} + +void RealTierArea_removePoints (RealTierArea me, RealTier tier) { + if (my startSelection() == my endSelection()) + AnyTier_removePointNear (tier->asAnyTier(), my startSelection()); + else + AnyTier_removePointsBetween (tier->asAnyTier(), my startSelection(), my endSelection()); +} + +void RealTierArea_addPointAtCursor (RealTierArea me, RealTier tier) { + const double cursorTime = 0.5 * (my startSelection() + my endSelection()); + RealTierArea_addPointAt (me, tier, cursorTime, my v_yToValue (my ycursor)); +} + +void RealTierArea_updateScaling (RealTierArea me, RealTier tier) { + if (tier -> points.size == 0) { + my ymin = my v_defaultYmin (); + my ymax = my v_defaultYmax (); + } else { + double ymin = my v_valueToY (RealTier_getMinimumValue (tier)); + double ymax = my v_valueToY (RealTier_getMaximumValue (tier)); + const double yrange = ymax - ymin; + if (yrange == 0.0) { + ymin -= 1.0; + ymax += 1.0; + } else { + ymin -= 0.2 * yrange; + ymax += 0.2 * yrange; + } + Melder_clip (my v_minimumLegalY(), & ymin, my v_maximumLegalY()); + Melder_clip (my v_minimumLegalY(), & ymax, my v_maximumLegalY()); + if (ymin >= ymax) { + if (isdefined (my v_minimumLegalY ()) && isdefined (my v_maximumLegalY ())) { + ymin = my v_minimumLegalY (); + ymax = my v_maximumLegalY (); + } else if (isdefined (my v_minimumLegalY ())) { + ymin = my v_minimumLegalY (); + ymax = ymin + 1.0; + } else { + Melder_assert (isdefined (my v_maximumLegalY ())); + ymax = my v_maximumLegalY (); + ymin = ymax - 1.0; + } + } + if (ymin < my ymin) + my ymin = ymin; + if (ymax > my ymax) + my ymax = ymax; + if (my ycursor <= my ymin || my ycursor >= my ymax) + my ycursor = 0.382 * my ymin + 0.618 * my ymax; + } +} + +void RealTierArea_draw (RealTierArea me, RealTier tier) { + Graphics_setColour (my graphics(), Melder_RED); + Graphics_line (my graphics(), my startWindow(), my ycursor, my endWindow(), my ycursor); + Graphics_setTextAlignment (my graphics(), Graphics_RIGHT, Graphics_HALF); + Graphics_text (my graphics(), my startWindow(), my ycursor, + Melder_float (Melder_half (my ycursor)), my v_rightTickUnits()); + Graphics_setColour (my graphics(), Melder_BLUE); + Graphics_setTextAlignment (my graphics(), Graphics_LEFT, Graphics_HALF); + Graphics_text (my graphics(), my endWindow(), my ymax, + Melder_float (Melder_half (my ymax)), my v_rightTickUnits()); + Graphics_setTextAlignment (my graphics(), Graphics_LEFT, Graphics_HALF); + Graphics_text (my graphics(), my endWindow(), my ymin, + Melder_float (Melder_half (my ymin)), my v_rightTickUnits()); + + const integer ifirstSelected = AnyTier_timeToHighIndex (tier->asAnyTier(), my startSelection()); + const integer ilastSelected = AnyTier_timeToLowIndex (tier->asAnyTier(), my endSelection()); + const integer imin = AnyTier_timeToHighIndex (tier->asAnyTier(), my startWindow()); + const integer imax = AnyTier_timeToLowIndex (tier->asAnyTier(), my endWindow()); + Graphics_setLineWidth (my graphics(), 2.0); + if (tier -> points.size == 0) { + Graphics_setTextAlignment (my graphics(), Graphics_CENTRE, Graphics_HALF); + Graphics_text (my graphics(), 0.5 * (my startWindow() + my endWindow()), 0.5 * (my ymin + my ymax), + U"(no points)"); + } else if (imax < imin) { + const double yleft = my v_valueToY (RealTier_getValueAtTime (tier, my startWindow())); + const double yright = my v_valueToY (RealTier_getValueAtTime (tier, my endWindow())); + Graphics_line (my graphics(), my startWindow(), yleft, my endWindow(), yright); + } else { + Graphics_setColour (my graphics(), Melder_BLUE); + for (integer ipoint = imin; ipoint <= imax; ipoint ++) { + RealPoint point = tier -> points.at [ipoint]; + const double t = point -> number, y = my v_valueToY (point -> value); + if (ipoint == 1) + Graphics_line (my graphics(), my startWindow(), y, t, y); + else if (ipoint == imin) + Graphics_line (my graphics(), t, y, my startWindow(), my v_valueToY (RealTier_getValueAtTime (tier, my startWindow()))); + if (ipoint == tier -> points.size) + Graphics_line (my graphics(), t, y, my endWindow(), y); + else if (ipoint == imax) + Graphics_line (my graphics(), t, y, my endWindow(), my v_valueToY (RealTier_getValueAtTime (tier, my endWindow()))); + else { + RealPoint pointRight = tier -> points.at [ipoint + 1]; + Graphics_line (my graphics(), t, y, pointRight -> number, my v_valueToY (pointRight -> value)); + } + } + for (integer ipoint = imin; ipoint <= imax; ipoint ++) { + RealPoint point = tier -> points.at [ipoint]; + const double t = point -> number, y = my v_valueToY (point -> value); + const bool pointIsSelected = ( ipoint >= ifirstSelected && ipoint <= ilastSelected ); + Graphics_setColour (my graphics(), pointIsSelected ? Melder_RED : Melder_BLUE); + Graphics_fillCircle_mm (my graphics(), t, y, 3.0); + } + } + Graphics_setLineWidth (my graphics(), 1.0); + Graphics_setColour (my graphics(), Melder_BLACK); +} + +void RealTierArea_drawWhileDragging (RealTierArea me, RealTier tier) { + Graphics_xorOn (my graphics(), Melder_MAROON); + /* + Draw all selected points as empty circles, if inside the window. + */ + for (integer ipoint = my firstSelected; ipoint <= my lastSelected; ipoint ++) { + const RealPoint point = tier -> points.at [ipoint]; + const double t = point -> number + my dt, y = my v_valueToY (point -> value) + my dy; + if (t >= my startWindow() && t <= my endWindow()) + Graphics_circle_mm (my graphics(), t, y, 3); + } + + if (my lastSelected == my firstSelected) { + /* + Draw a crosshair with time and y. + */ + const RealPoint point = tier -> points.at [my firstSelected]; + const double t = point -> number + my dt, y = my v_valueToY (point -> value) + my dy; + Graphics_line (my graphics(), t, my ymin, t, my ymax - Graphics_dyMMtoWC (my graphics(), 4.0)); + Graphics_setTextAlignment (my graphics(), kGraphics_horizontalAlignment::CENTRE, Graphics_TOP); + Graphics_text (my graphics(), t, my ymax, Melder_fixed (t, 6)); + Graphics_line (my graphics(), my startWindow(), y, my endWindow(), y); + Graphics_setTextAlignment (my graphics(), Graphics_LEFT, Graphics_BOTTOM); + Graphics_text (my graphics(), my startWindow(), y, Melder_fixed (y, 6)); + } + Graphics_xorOff (my graphics()); +} + +bool RealTierArea_mouse (RealTierArea me, RealTier tier, GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) { + static bool anchorIsInFreePart, anchorIsNearPoint; + if (event -> isClick()) { + anchorIsInFreePart = false; + anchorIsNearPoint = false; + } + const double y_fraction_withinRealTierArea = my y_fraction_globalToLocal (y_fraction); + const double y_world = (1.0 - y_fraction_withinRealTierArea) * my ymin + y_fraction_withinRealTierArea * my ymax; + my viewRealTierAsWorldByWorld (); + if (event -> isClick()) { + Melder_assert (isundef (my anchorTime)); + RealPoint clickedPoint = nullptr; + integer inearestPoint = AnyTier_timeToNearestIndexInTimeWindow (tier->asAnyTier(), x_world, my startWindow(), my endWindow()); + if (inearestPoint != 0) { + RealPoint nearestPoint = tier -> points.at [inearestPoint]; + if (Graphics_distanceWCtoMM (my graphics(), x_world, y_world, nearestPoint -> number, nearestPoint -> value) < 1.5) + clickedPoint = nearestPoint; + } + if (! clickedPoint) { + anchorIsInFreePart = true; + my ycursor = y_world; + my editor -> viewDataAsWorldByFraction (); + return my editor -> structFunctionEditor :: v_mouseInWideDataView (event, x_world, y_fraction); + } + anchorIsNearPoint = true; + my draggingSelection = event -> shiftKeyPressed && + clickedPoint -> number >= my startSelection() && clickedPoint -> number <= my endSelection(); + if (my draggingSelection) { + AnyTier_getWindowPoints (tier->asAnyTier(), my startSelection(), my endSelection(), & my firstSelected, & my lastSelected); + Editor_save (my editor, U"Drag points"); // TODO: title can be more specific + } else { + my firstSelected = my lastSelected = inearestPoint; + Editor_save (my editor, U"Drag point"); // TODO: title can be more specific + } + my anchorTime = x_world; + my anchorY = y_world; + my dt = 0.0; + my dy = 0.0; + return FunctionEditor_UPDATE_NEEDED; + } else if (event -> isDrag() || event -> isDrop()) { + if (anchorIsInFreePart) { + my ycursor = y_world; + my editor -> viewDataAsWorldByFraction (); + return my editor -> structFunctionEditor :: v_mouseInWideDataView (event, x_world, y_fraction); + } + Melder_assert (anchorIsNearPoint); + my dt = x_world - my anchorTime; + my dy = y_world - my anchorY; + + if (event -> isDrop()) { + my anchorTime = undefined; + const double leftNewTime = tier -> points.at [my firstSelected] -> number + my dt; + const double rightNewTime = tier -> points.at [my lastSelected] -> number + my dt; + const bool offLeft = ( leftNewTime < my editor -> tmin ); + const bool offRight = ( rightNewTime > my editor -> tmax ); + const bool draggedPastLeftNeighbour = ( my firstSelected > 1 && leftNewTime <= tier -> points.at [my firstSelected - 1] -> number ); + const bool draggedPastRightNeighbour = ( my lastSelected < tier -> points.size && rightNewTime >= tier -> points.at [my lastSelected + 1] -> number ); + if (offLeft || offRight || draggedPastLeftNeighbour || draggedPastRightNeighbour) { + Melder_beep (); + return FunctionEditor_UPDATE_NEEDED; + } + + for (integer i = my firstSelected; i <= my lastSelected; i ++) { + RealPoint point = tier -> points.at [i]; + point -> number += my dt; + double pointY = my v_valueToY (point -> value); + pointY += my dy; + Melder_clip (my v_minimumLegalY (), & pointY, my v_maximumLegalY ()); + point -> value = my v_yToValue (pointY); + } + + /* + Make sure that the same points are still selected (a problem with Undo...). + */ + + if (my draggingSelection) { + my editor -> startSelection += my dt; + my editor -> endSelection += my dt; + } + if (my firstSelected == my lastSelected) { + /* + Move crosshair to only selected point. + */ + RealPoint point = tier -> points.at [my firstSelected]; + my editor -> startSelection = my editor -> endSelection = point -> number; + my ycursor = point -> value; + } else { + /* + Move crosshair to mouse location. + */ + my ycursor += my dy; + Melder_clip (my v_minimumLegalY (), & my ycursor, my v_maximumLegalY ()); // NaN-safe + } + + Editor_broadcastDataChanged (my editor); + RealTierArea_updateScaling (me, tier); + } + } + return FunctionEditor_UPDATE_NEEDED; +} + +/* End of file RealTierArea.cpp */ diff --git a/fon/RealTierArea.h b/fon/RealTierArea.h new file mode 100644 index 00000000..46816649 --- /dev/null +++ b/fon/RealTierArea.h @@ -0,0 +1,60 @@ +#ifndef _RealTierArea_h_ +#define _RealTierArea_h_ +/* RealTierArea.h + * + * Copyright (C) 1992-2005,2007-2012,2015-2018,2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +#include "FunctionArea.h" +#include "RealTier.h" + +Thing_define (RealTierArea, FunctionArea) { + virtual double v_minimumLegalY () { return undefined; } + virtual double v_maximumLegalY () { return undefined; } + virtual conststring32 v_rightTickUnits () { return U""; } + virtual double v_defaultYmin () { return 0.0; } + virtual double v_defaultYmax () { return 1.0; } + virtual double v_valueToY (double value) { return value; } + virtual double v_yToValue (double y) { return y; } + + double ymin, ymax, ycursor; + double anchorTime = undefined, anchorY; + bool draggingSelection; + double dt = 0.0, dy = 0.0; + integer firstSelected, lastSelected; + + void viewRealTierAsWorldByWorld () const { + our setViewport (); + Graphics_setWindow (our graphics(), our startWindow(), our endWindow(), our ymin, our ymax); + } +}; + +void RealTierArea_addPointAt (RealTierArea me, RealTier tier, double time, double desiredY); + +void RealTierArea_removePoints (RealTierArea me, RealTier tier); + +void RealTierArea_addPointAtCursor (RealTierArea me, RealTier tier); + +void RealTierArea_updateScaling (RealTierArea me, RealTier tier); + +void RealTierArea_draw (RealTierArea me, RealTier tier); + +void RealTierArea_drawWhileDragging (RealTierArea me, RealTier tier); + +bool RealTierArea_mouse (RealTierArea me, RealTier tier, GuiDrawingArea_MouseEvent event, double x_world, double y_fraction); + +/* End of file RealTierArea.h */ +#endif diff --git a/fon/RealTierEditor.cpp b/fon/RealTierEditor.cpp index ac9fc248..fb67e3c0 100644 --- a/fon/RealTierEditor.cpp +++ b/fon/RealTierEditor.cpp @@ -1,6 +1,6 @@ /* RealTierEditor.cpp * - * Copyright (C) 1992-2011,2012,2013,2014,2015,2016,2017 Paul Boersma + * Copyright (C) 1992-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -21,29 +21,19 @@ Thing_implement (RealTierEditor, TimeSoundEditor, 0); -#define SOUND_HEIGHT 0.382 - -/********** MENU COMMANDS **********/ +/* MARK: - MENU COMMANDS */ static void menu_cb_removePoints (RealTierEditor me, EDITOR_ARGS_DIRECT) { + RealTierArea_removePoints (my realTierArea.get(), my realTier()); Editor_save (me, U"Remove point(s)"); - RealTier tier = (RealTier) my data; - if (my startSelection == my endSelection) - AnyTier_removePointNear (tier->asAnyTier(), my startSelection); - else - AnyTier_removePointsBetween (tier->asAnyTier(), my startSelection, my endSelection); RealTierEditor_updateScaling (me); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); } static void menu_cb_addPointAtCursor (RealTierEditor me, EDITOR_ARGS_DIRECT) { - if (isdefined (my v_minimumLegalValue ()) && my ycursor < my v_minimumLegalValue ()) - Melder_throw (U"Cannot add a point below ", my v_minimumLegalValue (), my v_rightTickUnits (), U"."); - if (isdefined (my v_maximumLegalValue ()) && my ycursor > my v_maximumLegalValue ()) - Melder_throw (U"Cannot add a point above ", my v_maximumLegalValue (), my v_rightTickUnits (), U"."); + RealTierArea_addPointAtCursor (my realTierArea.get(), my realTier()); Editor_save (me, U"Add point"); - RealTier_addPoint ((RealTier) my data, 0.5 * (my startSelection + my endSelection), my ycursor); RealTierEditor_updateScaling (me); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); @@ -52,17 +42,13 @@ static void menu_cb_addPointAtCursor (RealTierEditor me, EDITOR_ARGS_DIRECT) { static void menu_cb_addPointAt (RealTierEditor me, EDITOR_ARGS_FORM) { EDITOR_FORM (U"Add point", nullptr) REAL (time, U"Time (s)", U"0.0") - REAL (desiredValue, my v_quantityText (), U"0.0") + REAL (desiredY, my v_quantityText (), U"0.0") EDITOR_OK SET_REAL (time, 0.5 * (my startSelection + my endSelection)) - SET_REAL (desiredValue, my ycursor) + SET_REAL (desiredY, my realTierArea -> ycursor) EDITOR_DO - if (isdefined (my v_minimumLegalValue ()) && desiredValue < my v_minimumLegalValue ()) - Melder_throw (U"Cannot add a point below ", my v_minimumLegalValue (), my v_rightTickUnits (), U"."); - if (isdefined (my v_maximumLegalValue ()) && desiredValue > my v_maximumLegalValue ()) - Melder_throw (U"Cannot add a point above ", my v_maximumLegalValue (), my v_rightTickUnits (), U"."); + RealTierArea_addPointAt (my realTierArea.get(), my realTier(), time, desiredY); Editor_save (me, U"Add point"); - RealTier_addPoint ((RealTier) my data, time, desiredValue); RealTierEditor_updateScaling (me); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); @@ -74,12 +60,13 @@ static void menu_cb_setRange (RealTierEditor me, EDITOR_ARGS_FORM) { REAL (ymin, my v_yminText (), my v_defaultYminText ()) REAL (ymax, my v_ymaxText (), my v_defaultYmaxText ()) EDITOR_OK - SET_REAL (ymin, my ymin) - SET_REAL (ymax, my ymax) + SET_REAL (ymin, my realTierArea -> ymin) + SET_REAL (ymax, my realTierArea -> ymax) EDITOR_DO - my ymin = ymin; - my ymax = ymax; - if (my ymax <= my ymin) RealTierEditor_updateScaling (me); + my realTierArea -> ymin = ymin; + my realTierArea -> ymax = ymax; + if (my realTierArea -> ymax <= my realTierArea -> ymin) + RealTierEditor_updateScaling (me); FunctionEditor_redraw (me); EDITOR_END } @@ -100,47 +87,7 @@ void structRealTierEditor :: v_createMenus () { } void RealTierEditor_updateScaling (RealTierEditor me) { - RealTier data = (RealTier) my data; - if (data -> points.size == 0) { - my ymin = my v_defaultYmin (); - my ymax = my v_defaultYmax (); - } else { - double ymin = RealTier_getMinimumValue (data); - double ymax = RealTier_getMaximumValue (data); - double range = ymax - ymin; - if (range == 0.0) { - ymin -= 1.0; - ymax += 1.0; - } else { - ymin -= 0.2 * range; - ymax += 0.2 * range; - } - if (isdefined (my v_minimumLegalValue()) && ymin < my v_minimumLegalValue ()) - ymin = my v_minimumLegalValue (); - if (isdefined (my v_maximumLegalValue ()) && ymin > my v_maximumLegalValue ()) - ymin = my v_maximumLegalValue (); - if (isdefined (my v_minimumLegalValue ()) && ymax < my v_minimumLegalValue ()) - ymax = my v_minimumLegalValue (); - if (isdefined (my v_maximumLegalValue ()) && ymax > my v_maximumLegalValue ()) - ymax = my v_maximumLegalValue (); - if (ymin >= ymax) { - if (isdefined (my v_minimumLegalValue ()) && isdefined (my v_maximumLegalValue ())) { - ymin = my v_minimumLegalValue (); - ymax = my v_maximumLegalValue (); - } else if (isdefined (my v_minimumLegalValue ())) { - ymin = my v_minimumLegalValue (); - ymax = ymin + 1.0; - } else { - Melder_assert (isdefined (my v_maximumLegalValue ())); - ymax = my v_maximumLegalValue (); - ymin = ymax - 1.0; - } - } - if (ymin < my ymin || my ymin < 0.0) my ymin = ymin; - if (ymax > my ymax) my ymax = ymax; - if (my ycursor <= my ymin || my ycursor >= my ymax) - my ycursor = 0.382 * my ymin + 0.618 * my ymax; - } + RealTierArea_updateScaling (my realTierArea.get(), my realTier()); } void structRealTierEditor :: v_dataChanged () { @@ -148,242 +95,70 @@ void structRealTierEditor :: v_dataChanged () { RealTierEditor_Parent :: v_dataChanged (); } -/********** DRAWING AREA **********/ +/* MARK: - DRAWING AREA */ void structRealTierEditor :: v_draw () { - RealTier data = (RealTier) our data; - integer n = data -> points.size; - trace (U"structRealTierEditor :: v_draw ", n); - Graphics_Viewport viewport; if (our d_sound.data) { - viewport = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 1.0 - SOUND_HEIGHT, 1.0); - Graphics_setColour (our graphics.get(), Melder_WHITE); + Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 1.0 - SOUND_HEIGHT, 1.0); Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); + Graphics_setColour (our graphics.get(), Melder_WHITE); Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); TimeSoundEditor_drawSound (this, -1.0, 1.0); - Graphics_resetViewport (our graphics.get(), viewport); - Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 0.0, 1.0 - SOUND_HEIGHT); } - Graphics_setColour (our graphics.get(), Melder_WHITE); + our realTierArea -> setViewport(); + Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); + Graphics_setColour (our graphics.get(), Melder_WHITE); Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, our ymin, our ymax); - Graphics_setColour (our graphics.get(), Melder_RED); - Graphics_line (our graphics.get(), our startWindow, ycursor, our endWindow, our ycursor); - Graphics_setTextAlignment (our graphics.get(), Graphics_RIGHT, Graphics_HALF); - Graphics_text (our graphics.get(), our startWindow, our ycursor, Melder_float (Melder_half (our ycursor))); - Graphics_setColour (our graphics.get(), Melder_BLUE); - Graphics_setTextAlignment (our graphics.get(), Graphics_LEFT, Graphics_TOP); - Graphics_text (our graphics.get(), our endWindow, our ymax, Melder_float (Melder_half (ymax)), our v_rightTickUnits ()); - Graphics_setTextAlignment (our graphics.get(), Graphics_LEFT, Graphics_HALF); - Graphics_text (our graphics.get(), our endWindow, our ymin, Melder_float (Melder_half (our ymin)), our v_rightTickUnits ()); - integer ifirstSelected = AnyTier_timeToHighIndex (data->asAnyTier(), our startSelection); - integer ilastSelected = AnyTier_timeToLowIndex (data->asAnyTier(), our endSelection); - trace (U"structRealTierEditor :: v_draw: selected from ", our startSelection, U" ", - ifirstSelected, U" to ", our endSelection, U" ", ilastSelected); - integer imin = AnyTier_timeToHighIndex (data->asAnyTier(), our startWindow); - integer imax = AnyTier_timeToLowIndex (data->asAnyTier(), our endWindow); - Graphics_setLineWidth (our graphics.get(), 2.0); - if (n == 0) { - Graphics_setTextAlignment (our graphics.get(), Graphics_CENTRE, Graphics_HALF); - Graphics_text (our graphics.get(), 0.5 * (our startWindow + our endWindow), - 0.5 * (our ymin + our ymax), U"(no points)"); - } else if (imax < imin) { - double yleft = RealTier_getValueAtTime (data, our startWindow); - double yright = RealTier_getValueAtTime (data, our endWindow); - Graphics_line (our graphics.get(), our startWindow, yleft, our endWindow, yright); - } else for (integer i = imin; i <= imax; i ++) { - RealPoint point = data -> points.at [i]; - double t = point -> number, y = point -> value; - if (i >= ifirstSelected && i <= ilastSelected) - Graphics_setColour (our graphics.get(), Melder_RED); - Graphics_fillCircle_mm (our graphics.get(), t, y, 3.0); - Graphics_setColour (our graphics.get(), Melder_BLUE); - if (i == 1) - Graphics_line (our graphics.get(), our startWindow, y, t, y); - else if (i == imin) - Graphics_line (our graphics.get(), t, y, our startWindow, RealTier_getValueAtTime (data, our startWindow)); - if (i == n) - Graphics_line (our graphics.get(), t, y, our endWindow, y); - else if (i == imax) - Graphics_line (our graphics.get(), t, y, our endWindow, RealTier_getValueAtTime (data, our endWindow)); - else { - RealPoint pointRight = data -> points.at [i + 1]; - Graphics_line (our graphics.get(), t, y, pointRight -> number, pointRight -> value); - } - } - Graphics_setLineWidth (our graphics.get(), 1.0); Graphics_setColour (our graphics.get(), Melder_BLACK); - our v_updateMenuItems_file (); -} - -static void drawWhileDragging (RealTierEditor me, double /* xWC */, double /* yWC */, integer first, integer last, double dt, double dy) { - RealTier data = (RealTier) my data; + Graphics_rectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); - /* - * Draw all selected points as magenta empty circles, if inside the window. - */ - for (integer i = first; i <= last; i ++) { - RealPoint point = data -> points.at [i]; - double t = point -> number + dt, y = point -> value + dy; - if (t >= my startWindow && t <= my endWindow) - Graphics_circle_mm (my graphics.get(), t, y, 3); - } - - if (last == first) { - /* - * Draw a crosshair with time and y. - */ - RealPoint point = data -> points.at [first]; - double t = point -> number + dt, y = point -> value + dy; - Graphics_line (my graphics.get(), t, my ymin, t, my ymax - Graphics_dyMMtoWC (my graphics.get(), 4.0)); - Graphics_setTextAlignment (my graphics.get(), kGraphics_horizontalAlignment::CENTRE, Graphics_TOP); - Graphics_text (my graphics.get(), t, my ymax, Melder_fixed (t, 6)); - Graphics_line (my graphics.get(), my startWindow, y, my endWindow, y); - Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_BOTTOM); - Graphics_text (my graphics.get(), my startWindow, y, Melder_fixed (y, 6)); - } + Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, our realTierArea -> ymin, our realTierArea -> ymax); + RealTierArea_draw (our realTierArea.get(), our realTier()); + if (isdefined (our realTierArea -> anchorTime)) + RealTierArea_drawWhileDragging (our realTierArea.get(), our realTier()); + our v_updateMenuItems_file (); // TODO: this is not about drawing; improve logic? 2020-07-23 } -bool structRealTierEditor :: v_click (double xWC, double yWC, bool shiftKeyPressed) { - RealTier pitch = (RealTier) our data; - double dt = 0.0, df = 0.0; - Graphics_Viewport viewport; - - /* - * Perform the default action: move cursor. - */ - //our startSelection = our endSelection = xWC; - if (our d_sound.data) { - if (yWC < 1.0 - SOUND_HEIGHT) { // clicked in tier area? - yWC /= 1.0 - SOUND_HEIGHT; - our ycursor = (1.0 - yWC) * our ymin + yWC * our ymax; - viewport = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 0.0, 1.0 - SOUND_HEIGHT); - } else { - return our RealTierEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - } else { - our ycursor = (1.0 - yWC) * our ymin + yWC * our ymax; - } - Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, our ymin, our ymax); - yWC = our ycursor; - - /* - * Clicked on a point? - */ - integer inearestPoint = AnyTier_timeToNearestIndex (pitch->asAnyTier(), xWC); - if (inearestPoint == 0) return our RealTierEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - RealPoint nearestPoint = pitch -> points.at [inearestPoint]; - if (Graphics_distanceWCtoMM (our graphics.get(), xWC, yWC, nearestPoint -> number, nearestPoint -> value) > 1.5) { - if (our d_sound.data) Graphics_resetViewport (our graphics.get(), viewport); - return our RealTierEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); - } - - /* - * Clicked on a selected point? - */ - bool draggingSelection = shiftKeyPressed && - nearestPoint -> number > our startSelection && nearestPoint -> number < our endSelection; - integer ifirstSelected, ilastSelected; - if (draggingSelection) { - ifirstSelected = AnyTier_timeToHighIndex (pitch->asAnyTier(), our startSelection); - ilastSelected = AnyTier_timeToLowIndex (pitch->asAnyTier(), our endSelection); - Editor_save (this, U"Drag points"); +bool structRealTierEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double globalY_fraction) { + static bool clickedInWideRealTierArea = false; + if (event -> isClick ()) + clickedInWideRealTierArea = our realTierArea -> y_fraction_globalIsInside (globalY_fraction); + bool result = false; + if (clickedInWideRealTierArea) { + our realTierArea -> setViewport (); + result = RealTierArea_mouse (our realTierArea.get(), our realTier(), event, x_world, globalY_fraction); } else { - ifirstSelected = ilastSelected = inearestPoint; - Editor_save (this, U"Drag point"); + result = our RealTierEditor_Parent :: v_mouseInWideDataView (event, x_world, globalY_fraction); } - - /* - * Drag. - */ - Graphics_xorOn (our graphics.get(), Melder_MAROON); - drawWhileDragging (this, xWC, yWC, ifirstSelected, ilastSelected, dt, df); // draw at old position - while (Graphics_mouseStillDown (our graphics.get())) { - double xWC_new, yWC_new; - Graphics_getMouseLocation (our graphics.get(), & xWC_new, & yWC_new); - if (xWC_new != xWC || yWC_new != yWC) { - drawWhileDragging (this, xWC, yWC, ifirstSelected, ilastSelected, dt, df); // undraw at old position - dt += xWC_new - xWC, df += yWC_new - yWC; - xWC = xWC_new, yWC = yWC_new; - drawWhileDragging (this, xWC, yWC, ifirstSelected, ilastSelected, dt, df); // draw at new position - } - } - Graphics_xorOff (our graphics.get()); - - /* - * Dragged inside window? - */ - if (xWC < our startWindow || xWC > our endWindow) return 1; - - /* - * Points not dragged past neighbours? - */ - { - double newTime = pitch -> points.at [ifirstSelected] -> number + dt; - if (newTime < our tmin) return 1; // outside domain - if (ifirstSelected > 1 && newTime <= pitch -> points.at [ifirstSelected - 1] -> number) - return 1; // past left neighbour - newTime = pitch -> points.at [ilastSelected] -> number + dt; - if (newTime > our tmax) return 1; // outside domain - if (ilastSelected < pitch -> points.size && newTime >= pitch -> points.at [ilastSelected + 1] -> number) - return FunctionEditor_UPDATE_NEEDED; // past right neighbour - } - - /* - * Drop. - */ - for (int i = ifirstSelected; i <= ilastSelected; i ++) { - RealPoint point = pitch -> points.at [i]; - point -> number += dt; - point -> value += df; - if (isdefined (v_minimumLegalValue ()) && point -> value < v_minimumLegalValue ()) - point -> value = v_minimumLegalValue (); - if (isdefined (v_maximumLegalValue ()) && point -> value > v_maximumLegalValue ()) - point -> value = v_maximumLegalValue (); - } - - /* - * Make sure that the same points are still selected (a problem with Undo...). - */ - - if (draggingSelection) our startSelection += dt, our endSelection += dt; - if (ifirstSelected == ilastSelected) { - /* - * Move crosshair to only selected pitch point. - */ - RealPoint point = pitch -> points.at [ifirstSelected]; - our startSelection = our endSelection = point -> number; - our ycursor = point -> value; - } else { - /* - * Move crosshair to mouse location. - */ - /*our cursor += dt;*/ - our ycursor += df; - if (isdefined (v_minimumLegalValue ()) && our ycursor < v_minimumLegalValue ()) - our ycursor = v_minimumLegalValue (); - if (isdefined (v_maximumLegalValue ()) && our ycursor > v_maximumLegalValue ()) - our ycursor = v_maximumLegalValue (); - } - - Editor_broadcastDataChanged (this); - RealTierEditor_updateScaling (this); - return FunctionEditor_UPDATE_NEEDED; + if (event -> isDrop()) + clickedInWideRealTierArea = false; + return result; } -void structRealTierEditor :: v_play (double a_tmin, double a_tmax) { +void structRealTierEditor :: v_play (double startTime, double endTime) { if (our d_sound.data) - Sound_playPart (our d_sound.data, a_tmin, a_tmax, theFunctionEditor_playCallback, this); + Sound_playPart (our d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); +} + +void RealTierEditor_init (RealTierEditor me, autoRealTierArea realTierArea, conststring32 title, RealTier data, Sound sound, bool ownSound) { + Melder_assert (data); + Melder_assert (Thing_isa (data, classRealTier)); + TimeSoundEditor_init (me, title, data, sound, ownSound); + my realTierArea = realTierArea.move(); + RealTierEditor_updateScaling (me); + my realTierArea -> ycursor = 0.382 * my realTierArea -> ymin + 0.618 * my realTierArea -> ymax; } -void RealTierEditor_init (RealTierEditor me, conststring32 title, RealTier data, Sound sound, bool ownSound) { + +void RealTierEditor_init (RealTierEditor me, ClassInfo realTierAreaClass, conststring32 title, RealTier data, Sound sound, bool ownSound) { Melder_assert (data); Melder_assert (Thing_isa (data, classRealTier)); TimeSoundEditor_init (me, title, data, sound, ownSound); - my ymin = -1.0; + my realTierArea = Thing_newFromClass (realTierAreaClass). static_cast_move (); + FunctionArea_init (my realTierArea.get(), me, 0.0, sound ? 1.0 - my SOUND_HEIGHT : 1.0); RealTierEditor_updateScaling (me); - my ycursor = 0.382 * my ymin + 0.618 * my ymax; + my realTierArea -> ycursor = 0.382 * my realTierArea -> ymin + 0.618 * my realTierArea -> ymax; } /* End of file RealTierEditor.cpp */ diff --git a/fon/RealTierEditor.h b/fon/RealTierEditor.h index eb7e1a83..350d128e 100644 --- a/fon/RealTierEditor.h +++ b/fon/RealTierEditor.h @@ -2,7 +2,7 @@ #define _RealTierEditor_h_ /* RealTierEditor.h * - * Copyright (C) 1992-2011,2012,2015,2017 Paul Boersma + * Copyright (C) 1992-2005,2007-2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,10 +19,16 @@ */ #include "TimeSoundEditor.h" -#include "RealTier.h" +#include "RealTierArea.h" Thing_define (RealTierEditor, TimeSoundEditor) { - double ymin, ymax, ycursor; + /* + Access inherited attributes by their derived type. + */ + RealTier & realTier() { return * reinterpret_cast (& our data); } + + autoRealTierArea realTierArea; + constexpr static double SOUND_HEIGHT = 0.382; void v_createMenus () override; @@ -30,19 +36,14 @@ Thing_define (RealTierEditor, TimeSoundEditor) { override; void v_draw () override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) override; void v_play (double tmin, double tmax) override; void v_createMenuItems_view (EditorMenu menu) override; - virtual double v_minimumLegalValue () { return undefined; } - virtual double v_maximumLegalValue () { return undefined; } virtual conststring32 v_quantityText () { return U"Y"; } // normally includes units - virtual conststring32 v_rightTickUnits () { return U""; } - virtual double v_defaultYmin () { return 0.0; } - virtual double v_defaultYmax () { return 1.0; } virtual conststring32 v_setRangeTitle () { return U"Set range..."; } virtual conststring32 v_defaultYminText () { return U"0.0"; } virtual conststring32 v_defaultYmaxText () { return U"1.0"; } @@ -56,7 +57,11 @@ void RealTierEditor_updateScaling (RealTierEditor me); Call after every change in the data. */ -void RealTierEditor_init (RealTierEditor me, conststring32 title, RealTier data, Sound sound, bool ownSound); +/* + Of the following two, the first is better, because the second could do incomplete initialization. +*/ +void RealTierEditor_init (RealTierEditor me, autoRealTierArea realTierArea, conststring32 title, RealTier data, Sound sound, bool ownSound); +void RealTierEditor_init (RealTierEditor me, ClassInfo realTierAreaClass, conststring32 title, RealTier data, Sound sound, bool ownSound); /* `sound` may be null; if `ownSound` is `true`, the editor will contain a deep copy of the Sound, diff --git a/fon/RunnerMFC.cpp b/fon/RunnerMFC.cpp index 674a6e65..bb63b343 100644 --- a/fon/RunnerMFC.cpp +++ b/fon/RunnerMFC.cpp @@ -1,6 +1,6 @@ /* RunnerMFC.cpp * - * Copyright (C) 2001-2019 Paul Boersma + * Copyright (C) 2001-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -61,14 +61,17 @@ static void drawControlButton (RunnerMFC me, double left, double right, double b } static void drawNow (RunnerMFC me) { - if (! my graphics) return; // could be the case in the very beginning + if (! my graphics) + return; // could be the case in the very beginning ExperimentMFC experiment = (ExperimentMFC) my data; integer iresponse; - if (! my data) return; + if (! my data) + return; Graphics_setGrey (my graphics.get(), 0.8); Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setGrey (my graphics.get(), 0.0); - if (my blanked) return; + if (my blanked) + return; if (experiment -> trial == 0) { Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_HALF); Graphics_setFontSize (my graphics.get(), 24); @@ -95,8 +98,8 @@ static void drawNow (RunnerMFC me) { Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_TOP); Graphics_setFontSize (my graphics.get(), 24); /* - * The run text. - */ + The run text. + */ if (visibleText_p [0] != U'\0') { char32 *visibleText_q = str32chr (visibleText_p, U'|'); if (visibleText_q) @@ -115,9 +118,11 @@ static void drawNow (RunnerMFC me) { conststring32 textToDraw = response -> label.get(); // can be overridden if (visibleText_p [0] != U'\0') { char32 *visibleText_q = str32chr (visibleText_p, U'|'); - if (visibleText_q) *visibleText_q = U'\0'; + if (visibleText_q) + *visibleText_q = U'\0'; textToDraw = visibleText_p; // override - if (visibleText_q) visibleText_p = visibleText_q + 1; else visibleText_p += str32len (visibleText_p); + if (visibleText_q) + visibleText_p = visibleText_q + 1; else visibleText_p += str32len (visibleText_p); } if (str32nequ (textToDraw, U"\\FI", 3)) { structMelderFile file { }; @@ -136,14 +141,14 @@ static void drawNow (RunnerMFC me) { Graphics_rectangle (my graphics.get(), response -> left, response -> right, response -> bottom, response -> top); Graphics_setFontSize (my graphics.get(), response -> fontSize ? response -> fontSize : 24); Graphics_text (my graphics.get(), 0.5 * (response -> left + response -> right), - 0.5 * (response -> bottom + response -> top), textToDraw); + 0.5 * (response -> bottom + response -> top), textToDraw); } Graphics_setFontSize (my graphics.get(), 24); } for (iresponse = 1; iresponse <= experiment -> numberOfGoodnessCategories; iresponse ++) { const GoodnessMFC goodness = & experiment -> goodness [iresponse]; Graphics_setColour (my graphics.get(), experiment -> responses [experiment -> trial] == 0 ? Melder_SILVER : - experiment -> goodnesses [experiment -> trial] == iresponse ? Melder_RED : Melder_YELLOW); + experiment -> goodnesses [experiment -> trial] == iresponse ? Melder_RED : Melder_YELLOW); Graphics_setLineWidth (my graphics.get(), 3.0); Graphics_fillRectangle (my graphics.get(), goodness -> left, goodness -> right, goodness -> bottom, goodness -> top); Graphics_setColour (my graphics.get(), Melder_MAROON); @@ -221,8 +226,8 @@ static void do_ok (RunnerMFC me) { Editor_broadcastDataChanged (me); if (experiment -> blankWhilePlaying) { my blanked = true; - drawNow (me); - Graphics_flushWs (my graphics.get()); + Graphics_updateWs (my graphics.get()); + GuiShell_drain (my windowForm); } if (experiment -> stimuliAreSounds) { autoMelderAudioSaveMaximumAsynchronicity saveMaximumAsynchronicity; @@ -250,8 +255,8 @@ static void do_oops (RunnerMFC me) { Editor_broadcastDataChanged (me); if (experiment -> blankWhilePlaying) { my blanked = true; - drawNow (me); - Graphics_flushWs (my graphics.get()); + Graphics_updateWs (my graphics.get()); + GuiShell_drain (my windowForm); } if (experiment -> stimuliAreSounds) { autoMelderAudioSaveMaximumAsynchronicity saveMaximumAsynchronicity; @@ -270,8 +275,8 @@ static void do_replay (RunnerMFC me) { Editor_broadcastDataChanged (me); if (experiment -> blankWhilePlaying) { my blanked = true; - drawNow (me); - Graphics_flushWs (my graphics.get()); + Graphics_updateWs (my graphics.get()); + GuiShell_drain (my windowForm); } if (experiment -> stimuliAreSounds) { autoMelderAudioSaveMaximumAsynchronicity saveMaximumAsynchronicity; @@ -283,10 +288,14 @@ static void do_replay (RunnerMFC me) { Graphics_updateWs (my graphics.get()); } -static void gui_drawingarea_cb_click (RunnerMFC me, GuiDrawingArea_ClickEvent event) { - if (! my graphics) return; // could be the case in the very beginning +static void gui_drawingarea_cb_mouse (RunnerMFC me, GuiDrawingArea_MouseEvent event) { + if (! my graphics) + return; // could be the case in the very beginning ExperimentMFC experiment = (ExperimentMFC) my data; - if (! my data) return; + if (! my data) + return; + if (! event -> isClick()) + return; double reactionTime = Melder_clock () - experiment -> startingTime; if (! experiment -> blankWhilePlaying) reactionTime -= experiment -> stimulusInitialSilenceDuration; @@ -297,8 +306,8 @@ static void gui_drawingarea_cb_click (RunnerMFC me, GuiDrawingArea_ClickEvent ev Editor_broadcastDataChanged (me); if (experiment -> blankWhilePlaying) { my blanked = true; - drawNow (me); - Graphics_flushWs (my graphics.get()); + Graphics_updateWs (my graphics.get()); + GuiShell_drain (my windowForm); } if (experiment -> stimuliAreSounds) { if (experiment -> numberOfTrials < 1) { @@ -324,8 +333,8 @@ static void gui_drawingarea_cb_click (RunnerMFC me, GuiDrawingArea_ClickEvent ev Editor_broadcastDataChanged (me); if (experiment -> blankWhilePlaying) { my blanked = true; - drawNow (me); - Graphics_flushWs (my graphics.get()); + Graphics_updateWs (my graphics.get()); + GuiShell_drain (my windowForm); } if (experiment -> stimuliAreSounds) { autoMelderAudioSaveMaximumAsynchronicity saveMaximumAsynchronicity; @@ -351,9 +360,8 @@ static void gui_drawingarea_cb_click (RunnerMFC me, GuiDrawingArea_ClickEvent ev } else if (x > experiment -> oops_left && x < experiment -> oops_right && y > experiment -> oops_bottom && y < experiment -> oops_top) { - if (experiment -> trial > 1) { + if (experiment -> trial > 1) do_oops (me); - } } else if (experiment -> responses [experiment -> trial] == 0 || experiment -> ok_right > experiment -> ok_left) { for (integer iresponse = 1; iresponse <= experiment -> numberOfDifferentResponses; iresponse ++) { const ResponseMFC response = & experiment -> response [iresponse]; @@ -431,9 +439,8 @@ static void gui_drawingarea_cb_key (RunnerMFC me, GuiDrawingArea_KeyEvent event) { do_replay (me); } else if (experiment -> oops_key && experiment -> oops_key [0] == event -> key) { - if (experiment -> trial > 1) { + if (experiment -> trial > 1) do_oops (me); - } } else if (experiment -> responses [experiment -> trial] == 0 || experiment -> ok_right > experiment -> ok_left) { for (integer iresponse = 1; iresponse <= experiment -> numberOfDifferentResponses; iresponse ++) { const ResponseMFC response = & experiment -> response [iresponse]; @@ -476,7 +483,9 @@ static void gui_drawingarea_cb_key (RunnerMFC me, GuiDrawingArea_KeyEvent event) void structRunnerMFC :: v_createChildren () { our d_drawingArea = GuiDrawingArea_createShown (our windowForm, 0, 0, Machine_getMenuBarHeight (), 0, - gui_drawingarea_cb_expose, gui_drawingarea_cb_click, gui_drawingarea_cb_key, gui_drawingarea_cb_resize, this, 0); + gui_drawingarea_cb_expose, gui_drawingarea_cb_mouse, + gui_drawingarea_cb_key, gui_drawingarea_cb_resize, this, 0 + ); } autoRunnerMFC RunnerMFC_create (conststring32 title, autoExperimentMFCList experiments) { diff --git a/fon/Sampled.cpp b/fon/Sampled.cpp index 8528e55b..5fa61ea5 100644 --- a/fon/Sampled.cpp +++ b/fon/Sampled.cpp @@ -195,7 +195,7 @@ static void Sampled_getSumAndDefinitionRange if (Function_intersectRangeWithDomain (me, & xmin, & xmax)) { if (interpolate) { integer imin, imax; - if (Sampled_getWindowSamples (me, xmin, xmax, & imin, & imax)) { + if (Sampled_getWindowSamples (me, xmin, xmax, & imin, & imax) > 0) { double leftEdge = my x1 - 0.5 * my dx, rightEdge = leftEdge + my nx * my dx; for (integer isamp = imin; isamp <= imax; isamp ++) { const double value = my v_getValueAtSample (isamp, levelNumber, unit); // a fast way to integrate a linearly interpolated curve; works everywhere except at the edges @@ -356,7 +356,7 @@ static void Sampled_getSum2AndDefinitionRange if (Function_intersectRangeWithDomain (me, & xmin, & xmax)) { if (interpolate) { integer imin, imax; - if (Sampled_getWindowSamples (me, xmin, xmax, & imin, & imax)) { + if (Sampled_getWindowSamples (me, xmin, xmax, & imin, & imax) > 0) { const double leftEdge = my x1 - 0.5 * my dx, rightEdge = leftEdge + my nx * my dx; for (integer isamp = imin; isamp <= imax; isamp ++) { double value = my v_getValueAtSample (isamp, levelNumber, unit); // a fast way to integrate a linearly interpolated curve; works everywhere except at the edges @@ -729,7 +729,9 @@ static void Sampled_speckleInside (Sampled me, Graphics g, double xmin, double x { Function_unidirectionalAutowindow (me, & xmin, & xmax); integer ixmin, ixmax; - Sampled_getWindowSamples (me, xmin, xmax, & ixmin, & ixmax); + integer numberOfSamples = Sampled_getWindowSamples (me, xmin, xmax, & ixmin, & ixmax); + if (numberOfSamples <= 0) + return; if (Function_isUnitLogarithmic (me, levelNumber, unit)) { ymin = Function_convertStandardToSpecialUnit (me, ymin, levelNumber, unit); ymax = Function_convertStandardToSpecialUnit (me, ymax, levelNumber, unit); @@ -757,7 +759,9 @@ void Sampled_drawInside (Sampled me, Graphics g, double xmin, double xmax, doubl } Function_unidirectionalAutowindow (me, & xmin, & xmax); integer ixmin, ixmax, startOfDefinedStretch = -1; - Sampled_getWindowSamples (me, xmin, xmax, & ixmin, & ixmax); + integer numberOfSamples = Sampled_getWindowSamples (me, xmin, xmax, & ixmin, & ixmax); + if (numberOfSamples <= 0) + return; if (Function_isUnitLogarithmic (me, levelNumber, unit)) { ymin = Function_convertStandardToSpecialUnit (me, ymin, levelNumber, unit); ymax = Function_convertStandardToSpecialUnit (me, ymax, levelNumber, unit); diff --git a/fon/Sound.cpp b/fon/Sound.cpp index c8281fb2..d7dec4e7 100644 --- a/fon/Sound.cpp +++ b/fon/Sound.cpp @@ -272,7 +272,8 @@ static double getSumOfSquares (Sound me, double xmin, double xmax, integer *n) { Function_unidirectionalAutowindow (me, & xmin, & xmax); integer imin, imax; *n = Sampled_getWindowSamples (me, xmin, xmax, & imin, & imax); - if (*n < 1) return undefined; + if (*n <= 0) + return undefined; longdouble sumOfSquares = 0.0; for (integer ichan = 1; ichan <= my ny; ichan ++) { constVECVU const& channel = my z.row (ichan); diff --git a/fon/SoundEditor.cpp b/fon/SoundEditor.cpp index aaf45dcb..07fa7b9a 100644 --- a/fon/SoundEditor.cpp +++ b/fon/SoundEditor.cpp @@ -1,6 +1,6 @@ /* SoundEditor.cpp * - * Copyright (C) 1992-2018 Paul Boersma, 2007 Erez Volk (FLAC support) + * Copyright (C) 1992-2020 Paul Boersma, 2007 Erez Volk (FLAC support) * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -16,11 +16,10 @@ * along with this work. If not, see . */ -#include "Sound_and_MixingMatrix.h" #include "SoundEditor.h" #include "Sound_and_Spectrogram.h" #include "Pitch.h" -#include "Preferences.h" +#include "Sound_and_MixingMatrix.h" #include "EditorM.h" Thing_implement (SoundEditor, TimeSoundAnalysisEditor, 0); @@ -40,8 +39,9 @@ void structSoundEditor :: v_dataChanged () { static void menu_cb_Copy (SoundEditor me, EDITOR_ARGS_DIRECT) { try { - Sound_clipboard = my d_longSound.data ? LongSound_extractPart ((LongSound) my data, my startSelection, my endSelection, false) : - Sound_extractPart ((Sound) my data, my startSelection, my endSelection, kSound_windowShape::RECTANGULAR, 1.0, false); + Sound_clipboard = my d_longSound.data ? + LongSound_extractPart ((LongSound) my data, my startSelection, my endSelection, false) : + Sound_extractPart ((Sound) my data, my startSelection, my endSelection, kSound_windowShape::RECTANGULAR, 1.0, false); } catch (MelderError) { Melder_throw (U"Sound selection not copied to clipboard."); } @@ -51,7 +51,7 @@ static void menu_cb_Cut (SoundEditor me, EDITOR_ARGS_DIRECT) { try { Sound sound = (Sound) my data; integer first, last, selectionNumberOfSamples = Sampled_getWindowSamples (sound, - my startSelection, my endSelection, & first, & last); + my startSelection, my endSelection, & first, & last); integer oldNumberOfSamples = sound -> nx; integer newNumberOfSamples = oldNumberOfSamples - selectionNumberOfSamples; if (newNumberOfSamples < 1) @@ -89,18 +89,22 @@ static void menu_cb_Cut (SoundEditor me, EDITOR_ARGS_DIRECT) { sound -> z = newData.move(); Sound_clipboard = publish.move(); - /* Start updating the markers of the FunctionEditor, respecting the invariants. */ - + /* + Start updating the markers of the FunctionEditor, respecting the invariants. + */ my tmin = sound -> xmin; my tmax = sound -> xmax; - /* Collapse the selection, */ - /* so that the Cut operation can immediately be undone by a Paste. */ - /* The exact position will be half-way in between two samples. */ - + /* + Collapse the selection, + so that the Cut operation can immediately be undone by a Paste. + The exact position will be half-way in between two samples. + */ my startSelection = my endSelection = sound -> xmin + (first - 1) * sound -> dx; - /* Update the window. */ + /* + Update the window. + */ { double t1 = (first - 1) * sound -> dx; double t2 = last * sound -> dx; @@ -128,8 +132,9 @@ static void menu_cb_Cut (SoundEditor me, EDITOR_ARGS_DIRECT) { } } - /* Force FunctionEditor to show changes. */ - + /* + Force FunctionEditor to show changes. + */ Matrix_getWindowExtrema (sound, 1, sound -> nx, 1, sound -> ny, & my d_sound.minimum, & my d_sound.maximum); my v_reset_analysis (); FunctionEditor_ungroup (me); @@ -151,16 +156,17 @@ static void menu_cb_Paste (SoundEditor me, EDITOR_ARGS_DIRECT) { Melder_warning (U"Clipboard is empty; nothing pasted."); return; } - if (Sound_clipboard -> ny != sound -> ny) - Melder_throw (U"Cannot paste, because\n" - U"the number of channels of the clipboard is not equal to\n" - U"the number of channels of the edited sound."); - if (Sound_clipboard -> dx != sound -> dx) - Melder_throw (U"Cannot paste, because\n" - U"the sampling frequency of the clipboard is not equal to\n" - U"the sampling frequency of the edited sound."); - if (leftSample < 0) leftSample = 0; - if (leftSample > oldNumberOfSamples) leftSample = oldNumberOfSamples; + Melder_require (Sound_clipboard -> ny == sound -> ny, + U"Cannot paste, because\n" + U"the number of channels of the clipboard is not equal to\n" + U"the number of channels of the edited sound." + ); + Melder_require (Sound_clipboard -> dx == sound -> dx, + U"Cannot paste, because\n" + U"the sampling frequency of the clipboard is not equal to\n" + U"the sampling frequency of the edited sound." + ); + Melder_clip (0_integer, & leftSample, oldNumberOfSamples); newNumberOfSamples = oldNumberOfSamples + Sound_clipboard -> nx; /* Check without change. @@ -186,15 +192,19 @@ static void menu_cb_Paste (SoundEditor me, EDITOR_ARGS_DIRECT) { sound -> x1 = 0.5 * sound -> dx; sound -> z = newData.move(); - /* Start updating the markers of the FunctionEditor, respecting the invariants. */ - + /* + Start updating the markers of the FunctionEditor, respecting the invariants. + */ my tmin = sound -> xmin; my tmax = sound -> xmax; + Melder_clipLeft (my tmin, & my startWindow); + Melder_clipRight (& my endWindow, my tmax); my startSelection = leftSample * sound -> dx; my endSelection = (leftSample + Sound_clipboard -> nx) * sound -> dx; - /* Force FunctionEditor to show changes. */ - + /* + Force FunctionEditor to show changes. + */ Matrix_getWindowExtrema (sound, 1, sound -> nx, 1, sound -> ny, & my d_sound.minimum, & my d_sound.maximum); my v_reset_analysis (); FunctionEditor_ungroup (me); @@ -207,11 +217,7 @@ static void menu_cb_SetSelectionToZero (SoundEditor me, EDITOR_ARGS_DIRECT) { integer first, last; Sampled_getWindowSamples (sound, my startSelection, my endSelection, & first, & last); Editor_save (me, U"Set to zero"); - for (integer channel = 1; channel <= sound -> ny; channel ++) { - for (integer i = first; i <= last; i ++) { - sound -> z [channel] [i] = 0.0; - } - } + sound -> z.verticalBand (first, last) <<= 0.0; my v_reset_analysis (); FunctionEditor_redraw (me); Editor_broadcastDataChanged (me); @@ -228,7 +234,7 @@ static void menu_cb_ReverseSelection (SoundEditor me, EDITOR_ARGS_DIRECT) { /***** SELECT MENU *****/ static void menu_cb_MoveCursorToZero (SoundEditor me, EDITOR_ARGS_DIRECT) { - double zero = Sound_getNearestZeroCrossing ((Sound) my data, 0.5 * (my startSelection + my endSelection), 1); // STEREO BUG + const double zero = Sound_getNearestZeroCrossing ((Sound) my data, 0.5 * (my startSelection + my endSelection), 1); // STEREO BUG if (isdefined (zero)) { my startSelection = my endSelection = zero; FunctionEditor_marksChanged (me, true); @@ -236,14 +242,10 @@ static void menu_cb_MoveCursorToZero (SoundEditor me, EDITOR_ARGS_DIRECT) { } static void menu_cb_MoveBtoZero (SoundEditor me, EDITOR_ARGS_DIRECT) { - double zero = Sound_getNearestZeroCrossing ((Sound) my data, my startSelection, 1); // STEREO BUG + const double zero = Sound_getNearestZeroCrossing ((Sound) my data, my startSelection, 1); // STEREO BUG if (isdefined (zero)) { my startSelection = zero; - if (my startSelection > my endSelection) { - double dummy = my startSelection; - my startSelection = my endSelection; - my endSelection = dummy; - } + Melder_sort (& my startSelection, & my endSelection); FunctionEditor_marksChanged (me, true); } } @@ -252,11 +254,7 @@ static void menu_cb_MoveEtoZero (SoundEditor me, EDITOR_ARGS_DIRECT) { double zero = Sound_getNearestZeroCrossing ((Sound) my data, my endSelection, 1); // STEREO BUG if (isdefined (zero)) { my endSelection = zero; - if (my startSelection > my endSelection) { - double dummy = my startSelection; - my startSelection = my endSelection; - my endSelection = dummy; - } + Melder_sort (& my startSelection, & my endSelection); FunctionEditor_marksChanged (me, true); } } @@ -272,15 +270,16 @@ void structSoundEditor :: v_createMenus () { Melder_assert (d_sound.data || d_longSound.data); Editor_addCommand (this, U"Edit", U"-- cut copy paste --", 0, nullptr); - if (d_sound.data) cutButton = Editor_addCommand (this, U"Edit", U"Cut", 'X', menu_cb_Cut); + if (d_sound.data) + cutButton = Editor_addCommand (this, U"Edit", U"Cut", 'X', menu_cb_Cut); copyButton = Editor_addCommand (this, U"Edit", U"Copy selection to Sound clipboard", 'C', menu_cb_Copy); - if (d_sound.data) pasteButton = Editor_addCommand (this, U"Edit", U"Paste after selection", 'V', menu_cb_Paste); + if (d_sound.data) + pasteButton = Editor_addCommand (this, U"Edit", U"Paste after selection", 'V', menu_cb_Paste); if (d_sound.data) { Editor_addCommand (this, U"Edit", U"-- zero --", 0, nullptr); zeroButton = Editor_addCommand (this, U"Edit", U"Set selection to zero", 0, menu_cb_SetSelectionToZero); reverseButton = Editor_addCommand (this, U"Edit", U"Reverse selection", 'R', menu_cb_ReverseSelection); } - if (d_sound.data) { Editor_addCommand (this, U"Select", U"-- move to zero --", 0, 0); Editor_addCommand (this, U"Select", U"Move start of selection to nearest zero crossing", ',', menu_cb_MoveBtoZero); @@ -288,7 +287,6 @@ void structSoundEditor :: v_createMenus () { Editor_addCommand (this, U"Select", U"Move cursor to nearest zero crossing", '0', menu_cb_MoveCursorToZero); Editor_addCommand (this, U"Select", U"Move end of selection to nearest zero crossing", '.', menu_cb_MoveEtoZero); } - v_createMenus_analysis (); } @@ -318,8 +316,8 @@ void structSoundEditor :: v_draw () { Melder_assert (our d_sound.data || our d_longSound.data); /* - * We check beforehand whether the window fits the LongSound buffer. - */ + We check beforehand whether the window fits the LongSound buffer. + */ if (our d_longSound.data && our endWindow - our startWindow > our d_longSound.data -> bufferLength) { Graphics_setColour (our graphics.get(), Melder_WHITE); Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); @@ -332,42 +330,27 @@ void structSoundEditor :: v_draw () { return; } - /* Draw sound. */ - + /* + Draw data. + */ if (showAnalysis) viewport = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 0.5, 1.0); Graphics_setColour (our graphics.get(), Melder_WHITE); Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); + if (p_pulses_show) + v_draw_analysis_pulses (); TimeSoundEditor_drawSound (this, our d_sound.minimum, our d_sound.maximum); - //Graphics_flushWs (our graphics.get()); - if (showAnalysis) - Graphics_resetViewport (our graphics.get(), viewport); - - /* Draw analyses. */ - if (showAnalysis) { - /* Draw spectrogram, pitch, formants. */ + Graphics_resetViewport (our graphics.get(), viewport); viewport = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 0.0, 0.5); v_draw_analysis (); - //Graphics_flushWs (our graphics.get()); Graphics_resetViewport (our graphics.get(), viewport); } - /* Draw pulses. */ - - if (p_pulses_show) { - if (showAnalysis) - viewport = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 0.5, 1.0); - v_draw_analysis_pulses (); - TimeSoundEditor_drawSound (this, our d_sound.minimum, our d_sound.maximum); // second time, partially across the pulses - //Graphics_flushWs (our graphics.get()); - if (showAnalysis) - Graphics_resetViewport (our graphics.get(), viewport); - } - - /* Update buttons. */ - + /* + Update buttons. + */ integer first, last; integer selectedSamples = Sampled_getWindowSamples (data, our startSelection, our endSelection, & first, & last); v_updateMenuItems_file (); @@ -379,7 +362,7 @@ void structSoundEditor :: v_draw () { } } -void structSoundEditor :: v_play (double a_tmin, double a_tmax) { +void structSoundEditor :: v_play (double startTime, double endTime) { integer numberOfChannels = ( our d_longSound.data ? our d_longSound.data -> numberOfChannels : our d_sound.data -> ny ); integer numberOfMuteChannels = 0; Melder_assert (our d_sound.muteChannels.size == numberOfChannels); @@ -391,29 +374,29 @@ void structSoundEditor :: v_play (double a_tmin, double a_tmax) { U"Please select at least one channel to play."); if (our d_longSound.data) { if (numberOfMuteChannels > 0) { - autoSound part = LongSound_extractPart (our d_longSound.data, a_tmin, a_tmax, 1); + autoSound part = LongSound_extractPart (our d_longSound.data, startTime, endTime, 1); autoMixingMatrix thee = MixingMatrix_create (numberOfChannelsToPlay, numberOfChannels); MixingMatrix_muteAndActivateChannels (thee.get(), our d_sound.muteChannels.get()); - Sound_MixingMatrix_playPart (part.get(), thee.get(), a_tmin, a_tmax, theFunctionEditor_playCallback, this); + Sound_MixingMatrix_playPart (part.get(), thee.get(), startTime, endTime, theFunctionEditor_playCallback, this); } else { - LongSound_playPart (our d_longSound.data, a_tmin, a_tmax, theFunctionEditor_playCallback, this); + LongSound_playPart (our d_longSound.data, startTime, endTime, theFunctionEditor_playCallback, this); } } else { if (numberOfMuteChannels > 0) { autoMixingMatrix thee = MixingMatrix_create (numberOfChannelsToPlay, numberOfChannels); MixingMatrix_muteAndActivateChannels (thee.get(), our d_sound.muteChannels.get()); - Sound_MixingMatrix_playPart (our d_sound.data, thee.get(), a_tmin, a_tmax, theFunctionEditor_playCallback, this); + Sound_MixingMatrix_playPart (our d_sound.data, thee.get(), startTime, endTime, theFunctionEditor_playCallback, this); } else { - Sound_playPart (our d_sound.data, a_tmin, a_tmax, theFunctionEditor_playCallback, this); + Sound_playPart (our d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); } } } -bool structSoundEditor :: v_click (double xWC, double yWC, bool shiftKeyPressed) { +bool structSoundEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double xWC, double yWC) { if ((our p_spectrogram_show || our p_formant_show) && yWC < 0.5 && xWC > our startWindow && xWC < our endWindow) our d_spectrogram_cursor = our p_spectrogram_viewFrom + 2.0 * yWC * (our p_spectrogram_viewTo - our p_spectrogram_viewFrom); - return SoundEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); // drag & update + return SoundEditor_Parent :: v_mouseInWideDataView (event, xWC, yWC); } void structSoundEditor :: v_highlightSelection (double left, double right, double bottom, double top) { @@ -423,13 +406,6 @@ void structSoundEditor :: v_highlightSelection (double left, double right, doubl Graphics_highlight (our graphics.get(), left, right, bottom, top); } -void structSoundEditor :: v_unhighlightSelection (double left, double right, double bottom, double top) { - if (our p_spectrogram_show) - Graphics_unhighlight (our graphics.get(), left, right, 0.5 * (bottom + top), top); - else - Graphics_unhighlight (our graphics.get(), left, right, bottom, top); -} - void SoundEditor_init (SoundEditor me, conststring32 title, Sampled data) { /* * my longSound.data or my sound.data have to be set before we call FunctionEditor_init, diff --git a/fon/SoundEditor.h b/fon/SoundEditor.h index 2ece656d..bf0231b0 100644 --- a/fon/SoundEditor.h +++ b/fon/SoundEditor.h @@ -2,7 +2,7 @@ #define _SoundEditor_h_ /* SoundEditor.h * - * Copyright (C) 1992-2011,2012,2015 Paul Boersma + * Copyright (C) 1992-2005,2007,2009-2012,2014-2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -36,12 +36,10 @@ Thing_define (SoundEditor, TimeSoundAnalysisEditor) { override; void v_play (double tmin, double tmax) override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double xWC, double yWC) override; void v_highlightSelection (double left, double right, double bottom, double top) override; - void v_unhighlightSelection (double left, double right, double bottom, double top) - override; }; void SoundEditor_init (SoundEditor me, diff --git a/fon/SoundRecorder.cpp b/fon/SoundRecorder.cpp index a3636122..f2cd470e 100644 --- a/fon/SoundRecorder.cpp +++ b/fon/SoundRecorder.cpp @@ -232,9 +232,6 @@ static void stopRecording (SoundRecorder me) { } catch (MelderError) { Melder_flushError (U"Cannot stop recording."); } - Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setColour (my graphics.get(), Melder_WHITE); - Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); } void structSoundRecorder :: v_destroy () noexcept { @@ -364,7 +361,6 @@ static void showMeter (SoundRecorder me, const short *buffertje, integer nsamp) Graphics_setColour (my graphics.get(), Melder_BLACK); Graphics_fillCircle_mm (my graphics.get(), centreOfGravity, intensity, 3.0); } - Graphics_flushWs (my graphics.get()); } static bool tooManySamplesInBufferToReturnToGui (SoundRecorder me) { @@ -467,7 +463,7 @@ static WORKPROC_RETURN workProc (WORKPROC_ARGS) { if (my recording) memcpy (& my recordBuffer [1 + my nsamp * my numberOfChannels], buffertje, stepje * (sizeof (short) * my numberOfChannels)); - showMeter (me, buffertje, stepje); + //showMeter (me, buffertje, stepje); if (my recording) { my nsamp += stepje; if (my nsamp > my nmax - step) @@ -478,36 +474,33 @@ static WORKPROC_RETURN workProc (WORKPROC_ARGS) { } else { if (my recording) { /* - * We have to know how far the buffer has been filled. - * However, the buffer may be filled at interrupt time, - * so that the buffer may be being filled during this workproc. - * So we ask for the buffer filling just once, namely here at the beginning. - */ - integer lastSample = 0; + We have to know how far the buffer has been filled. + However, the buffer may be filled at interrupt time, + so that the buffer may be being filled during this workproc. + So we ask for the buffer filling just once, namely here at the beginning. + */ + my lastSample = 0; if (my inputUsesPortAudio) { - /* - * The buffer filling is contained in my nsamp, - * which has been set during interrupt time and may again be updated behind our backs during this workproc. - * So we do it in such a way that the compiler cannot ask for my nsamp twice. - */ - lastSample = getMyNsamp (me); + /* + The buffer filling is contained in my nsamp, + which has been set during interrupt time and may again be updated behind our backs during this workproc. + So we do it in such a way that the compiler cannot ask for my nsamp twice. + */ + my lastSample = getMyNsamp (me); Pa_Sleep (10); } else { #if defined (_WIN32) MMTIME mmtime; mmtime. wType = TIME_BYTES; if (waveInGetPosition (my hWaveIn, & mmtime, sizeof (MMTIME)) == MMSYSERR_NOERROR) - lastSample = mmtime. u.cb / (sizeof (short) * my numberOfChannels); + my lastSample = mmtime. u.cb / (sizeof (short) * my numberOfChannels); #elif defined (macintosh) #endif } - integer firstSample = lastSample - 3000; - if (firstSample < 0) - firstSample = 0; - showMeter (me, & my recordBuffer [1 + firstSample * my numberOfChannels], lastSample - firstSample); - GuiScale_setValue (my progressScale, 1000.0 * ((double) lastSample / (double) my nmax)); - } else { - showMeter (me, nullptr, 0); + my firstSample = my lastSample - 3000; + Melder_clipLeft (0_integer, & my firstSample); + GuiScale_setValue (my progressScale, 1000.0 * ((double) my lastSample / (double) my nmax)); + Graphics_updateWs (my graphics.get()); } } } catch (MelderError) { @@ -612,20 +605,17 @@ static void gui_button_cb_record (SoundRecorder me, GuiButtonEvent /* event */) #endif } } - Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setColour (my graphics.get(), Melder_WHITE); - Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); + Graphics_updateWs (my graphics.get()); } catch (MelderError) { - Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setColour (my graphics.get(), Melder_WHITE); - Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); my recording = false; + Graphics_updateWs (my graphics.get()); Melder_flushError (U"The recording was not started."); } } static void gui_button_cb_stop (SoundRecorder me, GuiButtonEvent /* event */) { stopRecording (me); + Graphics_updateWs (my graphics.get()); } static void gui_button_cb_play (SoundRecorder me, GuiButtonEvent /* event */) { @@ -824,6 +814,15 @@ static void gui_radiobutton_cb_fsamp (SoundRecorder me, GuiRadioButtonEvent even } } +static void gui_drawingarea_cb_expose (SoundRecorder me, GuiDrawingArea_ExposeEvent event) { + if (! my graphics) + return; // could be the case in the very beginning + if (my recording) + showMeter (me, & my recordBuffer [1 + my firstSample * my numberOfChannels], my lastSample - my firstSample); + else + showMeter (me, nullptr, 0); +} + static void gui_drawingarea_cb_resize (SoundRecorder me, GuiDrawingArea_ResizeEvent event) { if (! my graphics) return; // could be the case in the very beginning @@ -878,7 +877,9 @@ void structSoundRecorder :: v_createChildren () GuiLabel_createShown (our windowForm, 170, -170, y, y + Gui_LABEL_HEIGHT, U"Meter", GuiLabel_CENTRE); y += Gui_LABEL_HEIGHT; our meter = GuiDrawingArea_createShown (our windowForm, 170, -170, y, -150, - nullptr, nullptr, nullptr, gui_drawingarea_cb_resize, this, GuiDrawingArea_BORDER); + gui_drawingarea_cb_expose, nullptr, + nullptr, gui_drawingarea_cb_resize, this, GuiDrawingArea_BORDER + ); /* Sampling frequency. @@ -1187,9 +1188,6 @@ autoSoundRecorder SoundRecorder_create (int numberOfChannels) { Editor_init (me.get(), 100, 100, 600, 500, U"SoundRecorder", nullptr); my graphics = Graphics_create_xmdrawingarea (my meter); Melder_assert (my graphics); - Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setColour (my graphics.get(), Melder_WHITE); - Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); struct structGuiDrawingArea_ResizeEvent event { my meter, 0 }; event. width = GuiControl_getWidth (my meter); diff --git a/fon/SoundRecorder.h b/fon/SoundRecorder.h index c76dc50e..1e70236c 100644 --- a/fon/SoundRecorder.h +++ b/fon/SoundRecorder.h @@ -76,6 +76,7 @@ struct SoundRecorder_Fsamp { Thing_define (SoundRecorder, Editor) { int numberOfChannels; integer nsamp, nmax; + integer firstSample, lastSample; // for the meter bool synchronous, recording; int lastLeftMaximum, lastRightMaximum; integer numberOfInputDevices; diff --git a/fon/Sound_and_Spectrum.cpp b/fon/Sound_and_Spectrum.cpp index 7c079e15..8044a25a 100644 --- a/fon/Sound_and_Spectrum.cpp +++ b/fon/Sound_and_Spectrum.cpp @@ -104,7 +104,7 @@ autoSound Spectrum_to_Sound (Spectrum me) { bool originalNumberOfSamplesProbablyOdd = ( im [my nx] != 0.0 || my xmax - lastFrequency > 0.25 * my dx ); if (my x1 != 0.0) Melder_throw (U"A Fourier-transformable Spectrum must have a first frequency of 0 Hz, not ", my x1, U" Hz."); - integer numberOfSamples = 2 * my nx - ( originalNumberOfSamplesProbablyOdd ? 1 : 2 ); + const integer numberOfSamples = 2 * my nx - ( originalNumberOfSamplesProbablyOdd ? 1 : 2 ); autoSound thee = Sound_createSimple (1, 1.0 / my dx, numberOfSamples * my dx); VEC amp = thy z.row (1); double scaling = my dx; @@ -115,7 +115,8 @@ autoSound Spectrum_to_Sound (Spectrum me) { } if (originalNumberOfSamplesProbablyOdd) { amp [numberOfSamples] = re [my nx] * scaling; - if (numberOfSamples > 1) amp [2] = im [my nx] * scaling; + if (numberOfSamples > 1) + amp [2] = im [my nx] * scaling; } else { amp [2] = re [my nx] * scaling; } @@ -128,30 +129,31 @@ autoSound Spectrum_to_Sound (Spectrum me) { autoSpectrum Spectrum_lpcSmoothing (Spectrum me, int numberOfPeaks, double preemphasisFrequency) { try { - integer numberOfCoefficients = 2 * numberOfPeaks; + const integer numberOfCoefficients = 2 * numberOfPeaks; autoSound sound = Spectrum_to_Sound (me); VECpreemphasize_f_inplace (sound -> z.row (1), sound -> dx, preemphasisFrequency); autoVEC a = newVECraw (numberOfCoefficients); - double gain = VECburg (a.get(), sound -> z.row(1)); - for (integer i = 1; i <= numberOfCoefficients; i ++) a [i] = - a [i]; + const double gain = VECburg (a.get(), sound -> z.row(1)); + for (integer i = 1; i <= numberOfCoefficients; i ++) + a [i] = - a [i]; autoSpectrum thee = Data_copy (me); - integer nfft = 2 * (thy nx - 1); - integer ndata = numberOfCoefficients < nfft ? numberOfCoefficients : nfft - 1; - double scale = 10.0 * (gain > 0.0 ? sqrt (gain) : 1.0) / numberOfCoefficients; + const integer nfft = 2 * (thy nx - 1); + const integer ndata = Melder_clippedRight (numberOfCoefficients, nfft - 1); + const double scale = 10.0 * (gain > 0.0 ? sqrt (gain) : 1.0) / numberOfCoefficients; autoVEC data = newVECzero (nfft); data [1] = 1.0; for (integer i = 1; i <= ndata; i ++) data [i + 1] = a [i]; NUMrealft (data.get(), 1); - VEC re = thy z.row (1); - VEC im = thy z.row (2); + const VEC re = thy z.row (1); + const VEC im = thy z.row (2); re [1] = scale / data [1]; im [1] = 0.0; - integer halfnfft = nfft / 2; + const integer halfnfft = nfft / 2; for (integer i = 2; i <= halfnfft; i ++) { - double realPart = data [i + i - 1], imaginaryPart = data [i + i]; + const double realPart = data [i + i - 1], imaginaryPart = data [i + i]; re [i] = scale / sqrt (realPart * realPart + imaginaryPart * imaginaryPart) / (1.0 + thy dx * (i - 1) / preemphasisFrequency); im [i] = 0.0; } diff --git a/fon/Sound_audio.cpp b/fon/Sound_audio.cpp index e01fa879..216f22a7 100644 --- a/fon/Sound_audio.cpp +++ b/fon/Sound_audio.cpp @@ -1,6 +1,6 @@ /* Sound_audio.cpp * - * Copyright (C) 1992-2019 Paul Boersma + * Copyright (C) 1992-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -52,41 +52,6 @@ #include #endif -static int ulaw2linear [] = - { -32124, -31100, -30076, -29052, -28028, -27004, -25980, -24956, - -23932, -22908, -21884, -20860, -19836, -18812, -17788, -16764, - -15996, -15484, -14972, -14460, -13948, -13436, -12924, -12412, - -11900, -11388, -10876, -10364, -9852, -9340, -8828, -8316, - -7932, -7676, -7420, -7164, -6908, -6652, -6396, -6140, - -5884, -5628, -5372, -5116, -4860, -4604, -4348, -4092, - -3900, -3772, -3644, -3516, -3388, -3260, -3132, -3004, - -2876, -2748, -2620, -2492, -2364, -2236, -2108, -1980, - -1884, -1820, -1756, -1692, -1628, -1564, -1500, -1436, - -1372, -1308, -1244, -1180, -1116, -1052, -988, -924, - -876, -844, -812, -780, -748, -716, -684, -652, - -620, -588, -556, -524, -492, -460, -428, -396, - -372, -356, -340, -324, -308, -292, -276, -260, - -244, -228, -212, -196, -180, -164, -148, -132, - -120, -112, -104, -96, -88, -80, -72, -64, - -56, -48, -40, -32, -24, -16, -8, 0, - 32124, 31100, 30076, 29052, 28028, 27004, 25980, 24956, - 23932, 22908, 21884, 20860, 19836, 18812, 17788, 16764, - 15996, 15484, 14972, 14460, 13948, 13436, 12924, 12412, - 11900, 11388, 10876, 10364, 9852, 9340, 8828, 8316, - 7932, 7676, 7420, 7164, 6908, 6652, 6396, 6140, - 5884, 5628, 5372, 5116, 4860, 4604, 4348, 4092, - 3900, 3772, 3644, 3516, 3388, 3260, 3132, 3004, - 2876, 2748, 2620, 2492, 2364, 2236, 2108, 1980, - 1884, 1820, 1756, 1692, 1628, 1564, 1500, 1436, - 1372, 1308, 1244, 1180, 1116, 1052, 988, 924, - 876, 844, 812, 780, 748, 716, 684, 652, - 620, 588, 556, 524, 492, 460, 428, 396, - 372, 356, 340, 324, 308, 292, 276, 260, - 244, 228, 212, 196, 180, 164, 148, 132, - 120, 112, 104, 96, 88, 80, 72, 64, - 56, 48, 40, 32, 24, 16, 8, 0 - }; - struct Sound_recordFixedTime_Info { integer numberOfSamples, numberOfSamplesRead; short *buffer; @@ -97,24 +62,22 @@ static integer getNumberOfSamplesRead (volatile struct Sound_recordFixedTime_Inf } static int portaudioStreamCallback ( - const void *input, void *output, + const void *input, void * /*output*/, unsigned long frameCount, - const PaStreamCallbackTimeInfo* timeInfo, - PaStreamCallbackFlags statusFlags, + const PaStreamCallbackTimeInfo * /*timeInfo*/, + PaStreamCallbackFlags /*statusFlags*/, void *void_info) { - (void) output; - (void) timeInfo; - (void) statusFlags; struct Sound_recordFixedTime_Info *info = (struct Sound_recordFixedTime_Info *) void_info; - unsigned long samplesLeft = info -> numberOfSamples - info -> numberOfSamplesRead; + integer samplesLeft = info -> numberOfSamples - info -> numberOfSamplesRead; if (samplesLeft > 0) { - unsigned long dsamples = std::min (samplesLeft, frameCount); - memcpy (info -> buffer + 1 + info -> numberOfSamplesRead, input, 2 * dsamples); + integer dsamples = std::min (samplesLeft, uinteger_to_integer (frameCount)); + memcpy (info -> buffer + 1 + info -> numberOfSamplesRead, input, integer_to_uinteger (2 * dsamples)); info -> numberOfSamplesRead += dsamples; - short *input2 = (short*) input; - trace (U"read ", dsamples, U" samples: ", input2 [0], U", ", input2 [1], U", ", input2 [3], U"..."); - if (info -> numberOfSamplesRead >= info -> numberOfSamples) return paComplete; + const short *input2 = (const short *) input; + Melder_casual (U"read ", dsamples, U" samples: ", input2 [0], U", ", input2 [1], U", ", input2 [3], U"..."); + if (info -> numberOfSamplesRead >= info -> numberOfSamples) + return paComplete; } else /*if (info -> numberOfSamplesRead >= info -> numberOfSamples)*/ { info -> numberOfSamplesRead = info -> numberOfSamples; return paComplete; @@ -143,8 +106,6 @@ autoSound Sound_record_fixedTime (int inputSource, double gain, double balance, #endif try { integer numberOfSamples, i; - bool mulaw = false; - bool can16bit = true; /* Declare platform-dependent data structures. @@ -250,7 +211,16 @@ autoSound Sound_record_fixedTime (int inputSource, double gain, double balance, if (inputUsesPortAudio) { if (inputSource < 1 || inputSource > Pa_GetDeviceCount ()) Melder_throw (U"Unknown device #", inputSource, U"."); - streamParameters. device = inputSource - 1; + /* + Saying + streamParameters. device = inputSource - 1; + would presuppose that the input devices are listed before the output devices. + TODO: cycle through all devices, and determine which of them are input devices + */ + streamParameters. device = Pa_GetDefaultInputDevice (); + Melder_casual (U"streamParameters. device: ", (integer) streamParameters. device); + const PaDeviceInfo *paDeviceInfo = Pa_GetDeviceInfo (streamParameters. device); + Melder_casual (U"Name: ", Melder_peek8to32 (paDeviceInfo -> name)); } else { #if defined (macintosh) #elif defined (linux) && ! defined (NO_AUDIO) @@ -364,20 +334,24 @@ autoSound Sound_record_fixedTime (int inputSource, double gain, double balance, This starts recording now. */ if (inputUsesPortAudio) { - streamParameters. suggestedLatency = Pa_GetDeviceInfo (inputSource - 1) -> defaultLowInputLatency; + streamParameters. suggestedLatency = Pa_GetDeviceInfo (streamParameters. device) -> defaultLowInputLatency; #if defined (macintosh) PaMacCoreStreamInfo macCoreStreamInfo = { 0 }; macCoreStreamInfo. size = sizeof (PaMacCoreStreamInfo); macCoreStreamInfo. hostApiType = paCoreAudio; macCoreStreamInfo. version = 0x01; macCoreStreamInfo. flags = paMacCoreChangeDeviceParameters | paMacCoreFailIfConversionRequired; + macCoreStreamInfo. channelMap = nullptr; + macCoreStreamInfo. channelMapSize = 0; streamParameters. hostApiSpecificStreamInfo = & macCoreStreamInfo; #endif info. numberOfSamples = numberOfSamples; info. numberOfSamplesRead = 0; info. buffer = buffer.begin(); PaError err = Pa_OpenStream (& portaudioStream, & streamParameters, nullptr, - sampleRate, 0, paNoFlag, portaudioStreamCallback, (void *) & info); + sampleRate, + 0, // this gives the default of 64 samples per buffer on Paul's 2018 MacBook Pro (checked 20200813) + paNoFlag, portaudioStreamCallback, (void *) & info); if (err) Melder_throw (U"open ", Melder_peek8to32 (Pa_GetErrorText (err))); Pa_StartStream (portaudioStream); @@ -427,33 +401,22 @@ for (i = 1; i <= numberOfSamples; i ++) trace (U"Recorded ", buffer [i]); if (err != MMSYSERR_NOERROR) Melder_throw (U"Error ", err, U" while unpreparing header."); #else - if (mulaw) - read (fd, (char *) & buffer [1], numberOfSamples); - else { - integer bytesLeft = 2 * numberOfSamples, dbytes, bytesRead = 0; - while (bytesLeft) { - dbytes = read (fd, (char *) & buffer [2 + bytesRead], std::min (bytesLeft, 4000_integer)); - if (dbytes <= 0) - break; - bytesLeft -= dbytes; - bytesRead += dbytes; - }; - } + integer bytesLeft = 2 * numberOfSamples, dbytes, bytesRead = 0; + while (bytesLeft) { + dbytes = read (fd, (char *) & buffer [2 + bytesRead], std::min (bytesLeft, 4000_integer)); + if (dbytes <= 0) + break; + bytesLeft -= dbytes; + bytesRead += dbytes; + }; #endif } /* Copy the buffered data to the sound object, and discard the buffer. */ - if (mulaw) - for (i = 1; i <= numberOfSamples; i ++) - my z [1] [i] = ulaw2linear [((unsigned char *) buffer.begin()) [i]] * (1.0 / 32768); - else if (can16bit) - for (i = 1; i <= numberOfSamples; i ++) - my z [1] [i] = buffer [i] * (1.0 / 32768); - else - for (i = 1; i <= numberOfSamples; i ++) - my z [1] [i] = ((int) ((unsigned char *) buffer.begin()) [i + 1] - 128) * (1.0 / 128); + for (i = 1; i <= numberOfSamples; i ++) + my z [1] [i] = buffer [i] * (1.0 / 32768); /* Close the audio device. diff --git a/fon/Sound_to_Harmonicity_GNE.cpp b/fon/Sound_to_Harmonicity_GNE.cpp index b9237f66..8ca5b1c8 100644 --- a/fon/Sound_to_Harmonicity_GNE.cpp +++ b/fon/Sound_to_Harmonicity_GNE.cpp @@ -1,6 +1,6 @@ /* Sound_to_Harmonicity_GNE.cpp * - * Copyright (C) 1999-2011,2015,2016,2017 Paul Boersma + * Copyright (C) 1999-2012,2015-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -78,7 +78,7 @@ autoMatrix Sound_to_Harmonicity_GNE (Sound me, * in the LPC object of the high frequencies, so that inverse * filtering would yield weakened high frequencies. */ - autoLPC lpc = Sound_to_LPC_auto (original10k.get(), 13, 30e-3, 10e-3, 1e9); + autoLPC lpc = Sound_to_LPC_autocorrelation (original10k.get(), 13, 30e-3, 10e-3, 1e9); autoSound flat = LPC_Sound_filterInverse (lpc.get(), original10k.get()); autoSpectrum flatSpectrum = Sound_to_Spectrum (flat.get(), true); autoSpectrum hilbertSpectrum = Data_copy (flatSpectrum.get()); @@ -138,7 +138,7 @@ autoMatrix Sound_to_Harmonicity_GNE (Sound me, /* * Step 5: the maximum of each correlation function */ - double ccmax = Vector_getMaximum (crossCorrelation.get(), 0.0, 0.0, 0); + double ccmax = Vector_getMaximum (crossCorrelation.get(), 0.0, 0.0, kVector_peakInterpolation :: NONE); cc -> z [row] [col] = ccmax; } } diff --git a/fon/Sound_to_PointProcess.cpp b/fon/Sound_to_PointProcess.cpp index de90818e..fcdbe7a4 100644 --- a/fon/Sound_to_PointProcess.cpp +++ b/fon/Sound_to_PointProcess.cpp @@ -1,6 +1,6 @@ /* Sound_to_PointProcess.cpp * - * Copyright (C) 1992-2008,2011,2014-2018 Paul Boersma + * Copyright (C) 1992-2008,2011,2014-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -20,7 +20,7 @@ #include "Sound_to_Pitch.h" #include "Pitch_to_PointProcess.h" -autoPointProcess Sound_to_PointProcess_extrema (Sound me, integer channelNumber, int interpolation, bool includeMaxima, bool includeMinima) { +autoPointProcess Sound_to_PointProcess_extrema (Sound me, integer channelNumber, kVector_peakInterpolation peakInterpolationType, bool includeMaxima, bool includeMinima) { try { /* * Pass 1: count the extrema. There may be a maximum and minimum in the same interval! @@ -29,8 +29,10 @@ autoPointProcess Sound_to_PointProcess_extrema (Sound me, integer channelNumber, integer numberOfMinima = 0; constVEC y = my z.row (channelNumber); for (integer i = 2; i <= my nx - 1; i ++) { - if (includeMaxima && y [i] > y [i - 1] && y [i] >= y [i + 1]) numberOfMaxima ++; - if (includeMinima && y [i] <= y [i - 1] && y [i] < y [i + 1]) numberOfMinima ++; + if (includeMaxima && y [i] > y [i - 1] && y [i] >= y [i + 1]) + numberOfMaxima ++; + if (includeMinima && y [i] <= y [i - 1] && y [i] < y [i + 1]) + numberOfMinima ++; } /* * Create the empty result. @@ -39,15 +41,16 @@ autoPointProcess Sound_to_PointProcess_extrema (Sound me, integer channelNumber, /* * Pass 2: compute and register the extrema. */ + const integer interpolationDepth = kVector_peakInterpolation_to_interpolationDepth (peakInterpolationType); for (integer i = 2; i <= my nx - 1; i ++) { double time, i_real; if (includeMaxima && y [i] > y [i - 1] && y [i] >= y [i + 1]) { - (void) NUMimproveMaximum (y, i, interpolation, & i_real); + (void) NUMimproveMaximum (y, i, interpolationDepth, & i_real); time = my x1 + (i_real - 1.0) * my dx; PointProcess_addPoint (thee.get(), time); } if (includeMinima && y [i] <= y [i - 1] && y [i] < y [i + 1]) { - (void) NUMimproveMinimum (y, i, interpolation, & i_real); + (void) NUMimproveMinimum (y, i, interpolationDepth, & i_real); time = my x1 + (i_real - 1.0) * my dx; PointProcess_addPoint (thee.get(), time); } @@ -58,12 +61,15 @@ autoPointProcess Sound_to_PointProcess_extrema (Sound me, integer channelNumber, } } -autoPointProcess Sound_to_PointProcess_maxima (Sound me, integer channel, int interpolation) - { return Sound_to_PointProcess_extrema (me, channel, interpolation, true, false); } -autoPointProcess Sound_to_PointProcess_minima (Sound me, integer channel, int interpolation) - { return Sound_to_PointProcess_extrema (me, channel, interpolation, false, true); } -autoPointProcess Sound_to_PointProcess_allExtrema (Sound me, integer channel, int interpolation) - { return Sound_to_PointProcess_extrema (me, channel, interpolation, true, true); } +autoPointProcess Sound_to_PointProcess_maxima (Sound me, integer channel, kVector_peakInterpolation peakInterpolationType) { + return Sound_to_PointProcess_extrema (me, channel, peakInterpolationType, true, false); +} +autoPointProcess Sound_to_PointProcess_minima (Sound me, integer channel, kVector_peakInterpolation peakInterpolationType) { + return Sound_to_PointProcess_extrema (me, channel, peakInterpolationType, false, true); +} +autoPointProcess Sound_to_PointProcess_allExtrema (Sound me, integer channel, kVector_peakInterpolation peakInterpolationType) { + return Sound_to_PointProcess_extrema (me, channel, peakInterpolationType, true, true); +} autoPointProcess Sound_to_PointProcess_zeroes (Sound me, integer channel, bool includeRaisers, bool includeFallers) { try { diff --git a/fon/Sound_to_PointProcess.h b/fon/Sound_to_PointProcess.h index 0ec2ced4..f96456d2 100644 --- a/fon/Sound_to_PointProcess.h +++ b/fon/Sound_to_PointProcess.h @@ -1,6 +1,6 @@ /* Sound_to_PointProcess.h * - * Copyright (C) 1992-2011,2015,2017 Paul Boersma + * Copyright (C) 1992-2005,2007,2011,2015-2017,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,10 +19,10 @@ #include "Sound.h" #include "PointProcess.h" -autoPointProcess Sound_to_PointProcess_extrema (Sound me, integer channel, int interpolation, bool includeMaxima, bool includeMinima); -autoPointProcess Sound_to_PointProcess_maxima (Sound me, integer channel, int interpolation); -autoPointProcess Sound_to_PointProcess_minima (Sound me, integer channel, int interpolation); -autoPointProcess Sound_to_PointProcess_allExtrema (Sound me, integer channel, int interpolation); +autoPointProcess Sound_to_PointProcess_extrema (Sound me, integer channel, kVector_peakInterpolation peakInterpolationType, bool includeMaxima, bool includeMinima); +autoPointProcess Sound_to_PointProcess_maxima (Sound me, integer channel, kVector_peakInterpolation peakInterpolationType); +autoPointProcess Sound_to_PointProcess_minima (Sound me, integer channel, kVector_peakInterpolation peakInterpolationType); +autoPointProcess Sound_to_PointProcess_allExtrema (Sound me, integer channel, kVector_peakInterpolation peakInterpolationType); autoPointProcess Sound_to_PointProcess_zeroes (Sound me, integer channel, bool includeRaisers, bool includeFallers); diff --git a/fon/SpectrogramEditor.cpp b/fon/SpectrogramEditor.cpp index 6aeef381..ac79c300 100644 --- a/fon/SpectrogramEditor.cpp +++ b/fon/SpectrogramEditor.cpp @@ -1,6 +1,6 @@ /* SpectrogramEditor.cpp * - * Copyright (C) 1992-2011,2012,2014,2015,2016,2017 Paul Boersma + * Copyright (C) 1992-2005,2007-2012,2014-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -33,8 +33,8 @@ void structSpectrogramEditor :: v_draw () { Sampled_getWindowSamples (spectrogram, our startWindow, our endWindow, & itmin, & itmax); /* - * Autoscale frequency axis. - */ + Autoscale frequency axis. + */ our maximum = spectrogram -> ymax; Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, our maximum); @@ -42,8 +42,8 @@ void structSpectrogramEditor :: v_draw () { 60, 6.0, 0); /* - * Horizontal scaling lines. - */ + Horizontal scaling lines. + */ Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, our maximum); Graphics_setTextAlignment (our graphics.get(), Graphics_RIGHT, Graphics_HALF); Graphics_setColour (our graphics.get(), Melder_RED); @@ -54,8 +54,8 @@ void structSpectrogramEditor :: v_draw () { } /* - * Vertical cursor lines. - */ + Vertical cursor lines. + */ Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, our maximum); if (our startSelection > our startWindow && our startSelection < our endWindow) Graphics_line (our graphics.get(), our startSelection, 0, our startSelection, our maximum); @@ -64,16 +64,14 @@ void structSpectrogramEditor :: v_draw () { Graphics_setColour (our graphics.get(), Melder_BLACK); } -bool structSpectrogramEditor :: v_click (double xWC, double yWC, bool shiftKeyPressed) { - Spectrogram spectrogram = (Spectrogram) our data; - /*double frequency = yWC * our maximum;*/ - integer bestFrame; - bestFrame = Sampled_xToNearestIndex (spectrogram, xWC); - if (bestFrame < 1) - bestFrame = 1; - else if (bestFrame > spectrogram -> nx) - bestFrame = spectrogram -> nx; - return our SpectrogramEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); +bool structSpectrogramEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) { + if (event -> isClick()) { + Spectrogram spectrogram = (Spectrogram) our data; + double clickedFrequency = y_fraction * our maximum; + const integer clickedFrame = Melder_clipped (1_integer, Sampled_xToNearestIndex (spectrogram, x_world), spectrogram -> nx); + // TODO + } + return our SpectrogramEditor_Parent :: v_mouseInWideDataView (event, x_world, y_fraction); } autoSpectrogramEditor SpectrogramEditor_create (conststring32 title, Spectrogram data) { diff --git a/fon/SpectrogramEditor.h b/fon/SpectrogramEditor.h index 18edc030..634e9109 100644 --- a/fon/SpectrogramEditor.h +++ b/fon/SpectrogramEditor.h @@ -2,7 +2,7 @@ #define _SpectrogramEditor_h_ /* SpectrogramEditor.h * - * Copyright (C) 1992-2011,2012,2015 Paul Boersma + * Copyright (C) 1992-2005,2007-2012,2015,2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -26,7 +26,7 @@ Thing_define (SpectrogramEditor, FunctionEditor) { void v_draw () override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) override; }; diff --git a/fon/Spectrum.cpp b/fon/Spectrum.cpp index 33133abc..18a97e62 100644 --- a/fon/Spectrum.cpp +++ b/fon/Spectrum.cpp @@ -158,7 +158,7 @@ void Spectrum_drawInside (Spectrum me, Graphics g, double fmin, double fmax, dou Graphics_function (g, yWC, ifmin, ifmax, Matrix_columnToX (me, ifmin), Matrix_columnToX (me, ifmax)); } -void Spectrum_draw (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum, int garnish) { +void Spectrum_draw (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum, bool garnish) { Graphics_setInner (g); Spectrum_drawInside (me, g, fmin, fmax, minimum, maximum); Graphics_unsetInner (g); @@ -171,7 +171,7 @@ void Spectrum_draw (Spectrum me, Graphics g, double fmin, double fmax, double mi } } -void Spectrum_drawLogFreq (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum, int garnish) { +void Spectrum_drawLogFreq (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum, bool garnish) { bool autoscaling = ( minimum >= maximum ); if (fmax <= fmin) { fmin = my xmin; diff --git a/fon/Spectrum.h b/fon/Spectrum.h index 7cff06e2..9d018838 100644 --- a/fon/Spectrum.h +++ b/fon/Spectrum.h @@ -2,7 +2,7 @@ #define _Spectrum_h_ /* Spectrum.h * - * Copyright (C) 1992-2011,2015,2017 Paul Boersma + * Copyright (C) 1992-2005,2007,2011,2015-2017,2019,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -74,7 +74,7 @@ double Spectrum_getSkewness (Spectrum me, double power); double Spectrum_getKurtosis (Spectrum me, double power); void Spectrum_drawInside (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum); -void Spectrum_draw (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum, int garnish); +void Spectrum_draw (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum, bool garnish); /* Function: draw a Spectrum into a Graphics. @@ -85,7 +85,7 @@ void Spectrum_draw (Spectrum me, Graphics g, double fmin, double fmax, double mi Autowindowing: if fmax <= fmin, x domain of drawing is [my xmin, my xmax]. [minimum, maximum]: power in dB/Hz; y range of drawing. */ -void Spectrum_drawLogFreq (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum, int garnish); +void Spectrum_drawLogFreq (Spectrum me, Graphics g, double fmin, double fmax, double minimum, double maximum, bool garnish); autoTable Spectrum_tabulate (Spectrum me, bool includeBinNumbers, bool includeFrequency, bool includeRealPart, bool includeImaginaryPart, bool includeEnergyDensity, bool includePowerDensity); diff --git a/fon/SpectrumEditor.cpp b/fon/SpectrumEditor.cpp index fe8c8ae1..8fa6f97e 100644 --- a/fon/SpectrumEditor.cpp +++ b/fon/SpectrumEditor.cpp @@ -1,6 +1,6 @@ /* SpectrumEditor.cpp * - * Copyright (C) 1992-2011,2012,2013,2014,2015,2016,2017 Paul Boersma + * Copyright (C) 1992-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -33,7 +33,8 @@ static void updateRange (SpectrumEditor me) { if (Spectrum_getPowerDensityRange ((Spectrum) my data, & my minimum, & my maximum)) { my minimum = my maximum - my p_dynamicRange; } else { - my minimum = -1000.0, my maximum = 1000.0; + my minimum = -1000.0; + my maximum = 1000.0; } } @@ -57,26 +58,31 @@ void structSpectrumEditor :: v_draw () { FunctionEditor_drawHorizontalHair (this, our cursorHeight, Melder_fixed (our cursorHeight, 1), U" dB"); Graphics_setColour (our graphics.get(), Melder_BLACK); - /* Update buttons. */ - + /* + Update buttons. + TODO: this is not about drawing, so improve the logic. + */ integer first, last; - integer selectedSamples = Sampled_getWindowSamples (spectrum, our startSelection, our endSelection, & first, & last); + const integer selectedSamples = Sampled_getWindowSamples (spectrum, our startSelection, our endSelection, & first, & last); GuiThing_setSensitive (our publishBandButton, selectedSamples != 0); GuiThing_setSensitive (our publishSoundButton, selectedSamples != 0); } -bool structSpectrumEditor :: v_click (double xWC, double yWC, bool shiftKeyPressed) { - our cursorHeight = our minimum + yWC * (our maximum - our minimum); - return our SpectrumEditor_Parent :: v_click (xWC, yWC, shiftKeyPressed); // move cursor or drag selection +bool structSpectrumEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) { + our cursorHeight = our minimum + y_fraction * (our maximum - our minimum); + (void) our SpectrumEditor_Parent :: v_mouseInWideDataView (event, x_world, y_fraction); + return FunctionEditor_UPDATE_NEEDED; } static autoSpectrum Spectrum_band (Spectrum me, double fmin, double fmax) { autoSpectrum band = Data_copy (me); double *re = & band -> z [1] [0], *im = & band -> z [2] [0]; - integer imin = Sampled_xToLowIndex (band.get(), fmin); - integer imax = Sampled_xToHighIndex (band.get(), fmax); - for (integer i = 1; i <= imin; i ++) re [i] = 0.0, im [i] = 0.0; - for (integer i = imax; i <= band -> nx; i ++) re [i] = 0.0, im [i] = 0.0; + const integer imin = Sampled_xToLowIndex (band.get(), fmin); + const integer imax = Sampled_xToHighIndex (band.get(), fmax); + for (integer i = 1; i <= imin; i ++) + re [i] = 0.0, im [i] = 0.0; + for (integer i = imax; i <= band -> nx; i ++) + re [i] = 0.0, im [i] = 0.0; return band; } @@ -108,7 +114,8 @@ static void menu_cb_passBand (SpectrumEditor me, EDITOR_ARGS_FORM) { SET_REAL (bandSmoothing, my p_bandSmoothing) EDITOR_DO my pref_bandSmoothing() = my p_bandSmoothing = bandSmoothing; - if (my endSelection <= my startSelection) Melder_throw (U"To apply a band-pass filter, first make a selection."); + Melder_require (my endSelection > my startSelection, + U"To apply a band-pass filter, first make a selection."); Editor_save (me, U"Pass band"); Spectrum_passHannBand ((Spectrum) my data, my startSelection, my endSelection, my p_bandSmoothing); FunctionEditor_redraw (me); @@ -123,7 +130,8 @@ static void menu_cb_stopBand (SpectrumEditor me, EDITOR_ARGS_FORM) { SET_REAL (bandSmoothing, my p_bandSmoothing) EDITOR_DO my pref_bandSmoothing () = my p_bandSmoothing = bandSmoothing; - if (my endSelection <= my startSelection) Melder_throw (U"To apply a band-stop filter, first make a selection."); + Melder_require (my endSelection > my startSelection, + U"To apply a band-stop filter, first make a selection."); Editor_save (me, U"Stop band"); Spectrum_stopHannBand ((Spectrum) my data, my startSelection, my endSelection, my p_bandSmoothing); FunctionEditor_redraw (me); diff --git a/fon/SpectrumEditor.h b/fon/SpectrumEditor.h index ca2f1602..e307cbae 100644 --- a/fon/SpectrumEditor.h +++ b/fon/SpectrumEditor.h @@ -2,7 +2,7 @@ #define _SpectrumEditor_h_ /* SpectrumEditor.h * - * Copyright (C) 1992-2005,2007-2013,2015,2016,2018,2019 Paul Boersma + * Copyright (C) 1992-2005,2007-2013,2015,2016,2018-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -33,7 +33,7 @@ Thing_define (SpectrumEditor, FunctionEditor) { override; void v_draw () override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) override; void v_play (double tmin, double tmax) override; diff --git a/fon/SpectrumTier.cpp b/fon/SpectrumTier.cpp index 97667842..8bbb548c 100644 --- a/fon/SpectrumTier.cpp +++ b/fon/SpectrumTier.cpp @@ -1,6 +1,6 @@ /* SpectrumTier.cpp * - * Copyright (C) 2007-2012,2015,2016 Paul Boersma + * Copyright (C) 20072008,2010-2012,2015,2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -42,7 +42,7 @@ autoSpectrumTier SpectrumTier_create (double fmin, double fmax) { } void SpectrumTier_draw (SpectrumTier me, Graphics g, double fmin, double fmax, - double pmin, double pmax, int garnish, conststring32 method) + double pmin, double pmax, bool garnish, conststring32 method) { RealTier_draw (me, g, fmin, fmax, pmin, pmax, garnish, method, U"Power spectral density (dB)"); } diff --git a/fon/SpectrumTier.h b/fon/SpectrumTier.h index 21d3b80d..437f618f 100644 --- a/fon/SpectrumTier.h +++ b/fon/SpectrumTier.h @@ -2,7 +2,7 @@ #define _SpectrumTier_h_ /* SpectrumTier.h * - * Copyright (C) 2007-2011,2014,2015,2017 Paul Boersma + * Copyright (C) 2007,2010-2012,2014-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -42,7 +42,7 @@ autoSpectrumTier SpectrumTier_create (double fmin, double fmax); */ void SpectrumTier_draw (SpectrumTier me, Graphics g, double fmin, double fmax, - double pmin, double pmax, int garnish, conststring32 method); + double pmin, double pmax, bool garnish, conststring32 method); void SpectrumTier_list (SpectrumTier me, bool includeIndexes, bool includeFrequency, bool includePowerDensity); diff --git a/fon/SpellingChecker_def.h b/fon/SpellingChecker_def.h index 0bef6f14..c48e06ac 100644 --- a/fon/SpellingChecker_def.h +++ b/fon/SpellingChecker_def.h @@ -1,6 +1,6 @@ /* SpellingChecker_def.h * - * Copyright (C) 1999-2007,2001,2015,2016,2018,2019 Paul Boersma + * Copyright (C) 1999-2007,2011,2015,2016,2018-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by diff --git a/fon/TextGrid.cpp b/fon/TextGrid.cpp index d288d0e7..bb883c07 100644 --- a/fon/TextGrid.cpp +++ b/fon/TextGrid.cpp @@ -412,6 +412,16 @@ TextTier TextGrid_checkSpecifiedTierIsPointTier (TextGrid me, integer tierNumber return static_cast (tier); } +void AnyTextGridTier_identifyClass (Function anyTextGridTier, IntervalTier *intervalTier, TextTier *textTier) { + if (anyTextGridTier -> classInfo == classIntervalTier) { + *intervalTier = static_cast (anyTextGridTier); + *textTier = nullptr; + } else { + *intervalTier = nullptr; + *textTier = static_cast (anyTextGridTier); + } +} + integer TextGrid_countLabels (TextGrid me, integer tierNumber, conststring32 text) { try { Function anyTier = TextGrid_checkSpecifiedTierNumberWithinRange (me, tierNumber); diff --git a/fon/TextGrid.h b/fon/TextGrid.h index 0b6827bf..5ee483a0 100644 --- a/fon/TextGrid.h +++ b/fon/TextGrid.h @@ -2,7 +2,7 @@ #define _TextGrid_h_ /* TextGrid.h * - * Copyright (C) 1992-2012,2014,2015,2017 Paul Boersma + * Copyright (C) 1992-2012,2014-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -81,6 +81,7 @@ autoPointProcess TextGrid_getPoints_followed (TextGrid me, integer tierNumber, Function TextGrid_checkSpecifiedTierNumberWithinRange (TextGrid me, integer tierNumber); IntervalTier TextGrid_checkSpecifiedTierIsIntervalTier (TextGrid me, integer tierNumber); TextTier TextGrid_checkSpecifiedTierIsPointTier (TextGrid me, integer tierNumber); +void AnyTextGridTier_identifyClass (Function anyTextGridTier, IntervalTier *intervalTier, TextTier *textTier); void TextGrid_addTier_copy (TextGrid me, Function tier); autoTextGrid TextGrids_merge (OrderedOf* textGrids); diff --git a/fon/TextGridEditor.cpp b/fon/TextGridEditor.cpp index 788d2270..8a3613ad 100644 --- a/fon/TextGridEditor.cpp +++ b/fon/TextGridEditor.cpp @@ -61,25 +61,12 @@ static double _TextGridEditor_computeSoundY (TextGridEditor me) { return my d_sound.data || my d_longSound.data ? numberOfTiers / (2.0 * numberOfVisibleChannels + numberOfTiers * (showAnalysis ? 1.8 : 1.3)) : 1.0; } -static void _AnyTier_identifyClass (Function anyTier, IntervalTier *intervalTier, TextTier *textTier) { - if (anyTier -> classInfo == classIntervalTier) { - *intervalTier = (IntervalTier) anyTier; - *textTier = nullptr; - } else { - *intervalTier = nullptr; - *textTier = (TextTier) anyTier; - } -} - static integer _TextGridEditor_yWCtoTier (TextGridEditor me, double yWC) { const TextGrid grid = (TextGrid) my data; const integer numberOfTiers = grid -> tiers->size; const double soundY = _TextGridEditor_computeSoundY (me); integer tierNumber = numberOfTiers - Melder_ifloor (yWC / soundY * (double) numberOfTiers); - if (tierNumber < 1) - tierNumber = 1; - if (tierNumber > numberOfTiers) - tierNumber = numberOfTiers; + Melder_clip (1_integer, & tierNumber, numberOfTiers); return tierNumber; } @@ -90,7 +77,7 @@ static void _TextGridEditor_timeToInterval (TextGridEditor me, double t, integer const Function tier = grid -> tiers->at [tierNumber]; IntervalTier intervalTier; TextTier textTier; - _AnyTier_identifyClass (tier, & intervalTier, & textTier); + AnyTextGridTier_identifyClass (tier, & intervalTier, & textTier); if (intervalTier) { integer iinterval = IntervalTier_timeToIndex (intervalTier, t); if (iinterval == 0) { @@ -376,7 +363,7 @@ static void do_selectAdjacentInterval (TextGridEditor me, bool previous, bool sh TextTier textTier; if (my selectedTier < 1 || my selectedTier > grid -> tiers->size) return; - _AnyTier_identifyClass (grid -> tiers->at [my selectedTier], & intervalTier, & textTier); + AnyTextGridTier_identifyClass (grid -> tiers->at [my selectedTier], & intervalTier, & textTier); if (intervalTier) { const integer n = intervalTier -> intervals.size; if (n >= 2) { @@ -455,8 +442,7 @@ static void menu_cb_MoveBtoZero (TextGridEditor me, EDITOR_ARGS_DIRECT) { const double zero = Sound_getNearestZeroCrossing (my d_sound.data, my startSelection, 1); // STEREO BUG if (isdefined (zero)) { my startSelection = zero; - if (my startSelection > my endSelection) - std::swap (my startSelection, my endSelection); + Melder_sort (& my startSelection, & my endSelection); FunctionEditor_marksChanged (me, true); } } @@ -473,8 +459,7 @@ static void menu_cb_MoveEtoZero (TextGridEditor me, EDITOR_ARGS_DIRECT) { const double zero = Sound_getNearestZeroCrossing (my d_sound.data, my endSelection, 1); // STEREO BUG if (isdefined (zero)) { my endSelection = zero; - if (my startSelection > my endSelection) - std::swap (my startSelection, my endSelection); + Melder_sort (& my startSelection, & my endSelection); FunctionEditor_marksChanged (me, true); } } @@ -537,7 +522,7 @@ static void insertBoundaryOrPoint (TextGridEditor me, integer itier, double t1, Melder_throw (U"No tier ", itier, U"."); IntervalTier intervalTier; TextTier textTier; - _AnyTier_identifyClass (grid -> tiers->at [itier], & intervalTier, & textTier); + AnyTextGridTier_identifyClass (grid -> tiers->at [itier], & intervalTier, & textTier); Melder_assert (t1 <= t2); if (intervalTier) { @@ -642,9 +627,10 @@ static void insertBoundaryOrPoint (TextGridEditor me, integer itier, double t1, static void do_insertIntervalOnTier (TextGridEditor me, int itier) { try { insertBoundaryOrPoint (me, itier, - my playingCursor || my playingSelection ? my playCursor : my startSelection, - my playingCursor || my playingSelection ? my playCursor : my endSelection, - true); + my duringPlay ? my playCursor : my startSelection, + my duringPlay ? my playCursor : my endSelection, + true + ); my selectedTier = itier; FunctionEditor_marksChanged (me, true); Editor_broadcastDataChanged (me); @@ -797,8 +783,8 @@ static void menu_cb_MoveToZero (TextGridEditor me, EDITOR_ARGS_DIRECT) { static void do_insertOnTier (TextGridEditor me, integer itier) { try { insertBoundaryOrPoint (me, itier, - my playingCursor || my playingSelection ? my playCursor : my startSelection, - my playingCursor || my playingSelection ? my playCursor : my endSelection, + my duringPlay ? my playCursor : my startSelection, + my duringPlay ? my playCursor : my endSelection, false ); my selectedTier = itier; @@ -1025,7 +1011,7 @@ static void menu_cb_RemoveAllTextFromTier (TextGridEditor me, EDITOR_ARGS_DIRECT checkTierSelection (me, U"remove all text from a tier"); IntervalTier intervalTier; TextTier textTier; - _AnyTier_identifyClass (grid -> tiers->at [my selectedTier], & intervalTier, & textTier); + AnyTextGridTier_identifyClass (grid -> tiers->at [my selectedTier], & intervalTier, & textTier); Editor_save (me, U"Remove text from tier"); if (intervalTier) @@ -1261,7 +1247,7 @@ static void gui_text_cb_changed (TextGridEditor me, GuiTextEvent /* event */) { autostring32 text = GuiText_getString (my text); IntervalTier intervalTier; TextTier textTier; - _AnyTier_identifyClass (grid -> tiers->at [my selectedTier], & intervalTier, & textTier); + AnyTextGridTier_identifyClass (grid -> tiers->at [my selectedTier], & intervalTier, & textTier); if (intervalTier) { const integer selectedInterval = getSelectedInterval (me); if (selectedInterval) { @@ -1365,8 +1351,8 @@ static void do_drawIntervalTier (TextGridEditor me, IntervalTier tier, integer i Graphics_line (my graphics.get(), my endWindow, 0.0, my endWindow, 1.0); /* - * Draw a grey bar and a selection button at the cursor position. - */ + Draw a grey bar and a selection button at the cursor position. + */ if (my startSelection == my endSelection && my startSelection >= my startWindow && my startSelection <= my endWindow) { bool cursorAtBoundary = false; for (integer iinterval = 2; iinterval <= ninterval; iinterval ++) { @@ -1448,8 +1434,8 @@ static void do_drawTextTier (TextGridEditor me, TextTier tier, integer itier) { Graphics_setUnderscoreIsSubscript (my graphics.get(), my p_useTextStyles); /* - * Draw a grey bar and a selection button at the cursor position. - */ + Draw a grey bar and a selection button at the cursor position. + */ if (my startSelection == my endSelection && my startSelection >= my startWindow && my startSelection <= my endWindow) { bool cursorAtPoint = false; for (integer ipoint = 1; ipoint <= npoint; ipoint ++) { @@ -1510,7 +1496,7 @@ static void do_drawTextTier (TextGridEditor me, TextTier tier, integer itier) { void structTextGridEditor :: v_draw () { const TextGrid grid = (TextGrid) data; Graphics_Viewport vp1, vp2; - const integer ntier = grid -> tiers->size; + const integer numberOfTiers = grid -> tiers->size; const enum kGraphics_font oldFont = Graphics_inqFont (our graphics.get()); const double oldFontSize = Graphics_inqFontSize (our graphics.get()); const bool showAnalysis = v_hasAnalysis () && @@ -1527,27 +1513,27 @@ void structTextGridEditor :: v_draw () { Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); TimeSoundEditor_drawSound (this, -1.0, 1.0); - //Graphics_flushWs (our graphics.get()); Graphics_resetViewport (our graphics.get(), vp1); } /* Draw tiers. */ - if (d_longSound.data || d_sound.data) vp1 = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 0.0, soundY); + if (d_longSound.data || d_sound.data) + vp1 = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 0.0, soundY); Graphics_setColour (our graphics.get(), Melder_WHITE); Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setColour (our graphics.get(), Melder_BLACK); Graphics_rectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, 1.0); - for (integer itier = 1; itier <= ntier; itier ++) { + for (integer itier = 1; itier <= numberOfTiers; itier ++) { const Function anyTier = grid -> tiers->at [itier]; const bool tierIsSelected = ( itier == selectedTier ); const bool isIntervalTier = ( anyTier -> classInfo == classIntervalTier ); vp2 = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, - 1.0 - (double) itier / (double) ntier, - 1.0 - (double) (itier - 1) / (double) ntier); + 1.0 - (double) itier / (double) numberOfTiers, + 1.0 - (double) (itier - 1) / (double) numberOfTiers); Graphics_setColour (our graphics.get(), Melder_BLACK); if (itier != 1) Graphics_line (our graphics.get(), our startWindow, 1.0, our endWindow, 1.0); @@ -1563,7 +1549,7 @@ void structTextGridEditor :: v_draw () { Graphics_setFontSize (our graphics.get(), oldFontSize); if (anyTier -> name && anyTier -> name [0]) { Graphics_setTextAlignment (our graphics.get(), Graphics_LEFT, - our p_showNumberOf == kTextGridEditor_showNumberOf::NOTHING ? Graphics_HALF : Graphics_BOTTOM); + our p_showNumberOf == kTextGridEditor_showNumberOf::NOTHING ? Graphics_HALF : Graphics_BOTTOM); Graphics_text (our graphics.get(), our endWindow, 0.5, anyTier -> name.get()); } if (our p_showNumberOf != kTextGridEditor_showNumberOf::NOTHING) { @@ -1613,19 +1599,16 @@ void structTextGridEditor :: v_draw () { Graphics_setFontSize (our graphics.get(), oldFontSize); if (d_longSound.data || d_sound.data) Graphics_resetViewport (our graphics.get(), vp1); - //Graphics_flushWs (our graphics.get()); if (showAnalysis) { vp1 = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, soundY, soundY2); v_draw_analysis (); - //Graphics_flushWs (our graphics.get()); Graphics_resetViewport (our graphics.get(), vp1); /* Draw pulses. */ if (p_pulses_show) { vp1 = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, soundY2, 1.0); v_draw_analysis_pulses (); TimeSoundEditor_drawSound (this, -1.0, 1.0); // second time, partially across the pulses - //Graphics_flushWs (our graphics.get()); Graphics_resetViewport (our graphics.get(), vp1); } } @@ -1638,11 +1621,26 @@ void structTextGridEditor :: v_draw () { Graphics_line (our graphics.get(), our endWindow, soundY, our endWindow, soundY2); } } + if (isdefined (our draggingTime)) { + Graphics_xorOn (our graphics.get(), Melder_MAROON); + for (integer itier = 1; itier <= numberOfTiers; itier ++) { + if (our draggingTiers [itier]) { + const double ymin = soundY * (1.0 - (double) itier / numberOfTiers); + const double ymax = soundY * (1.0 - (double) (itier - 1) / numberOfTiers); + Graphics_setLineWidth (our graphics.get(), 7.0); + Graphics_line (our graphics.get(), our draggingTime, ymin, our draggingTime, ymax); + } + } + Graphics_setLineWidth (our graphics.get(), 1); + Graphics_line (our graphics.get(), our draggingTime, 0.0, our draggingTime, 1.01); + Graphics_text (our graphics.get(), our draggingTime, 1.01, Melder_fixed (our draggingTime, 6)); + Graphics_xorOff (our graphics.get()); + } /* Finally, us usual, update the menus. */ - v_updateMenuItems_file (); + our v_updateMenuItems_file (); } static const conststring32 characters [12] [10] = { @@ -1675,378 +1673,314 @@ void structTextGridEditor :: v_drawSelectionViewer () { Graphics_text (our graphics.get(), 0.0 + 1.0 * icol, 13.0 - 1.0 * irow, characters [irow-1] [icol-1]); } -static void do_drawWhileDragging (TextGridEditor me, double numberOfTiers, bool selectedTier [], double x, double soundY) { - for (integer itier = 1; itier <= numberOfTiers; itier ++) { - if (selectedTier [itier]) { - const double ymin = soundY * (1.0 - (double) itier / numberOfTiers); - const double ymax = soundY * (1.0 - (double) (itier - 1) / numberOfTiers); - Graphics_setLineWidth (my graphics.get(), 7.0); - Graphics_line (my graphics.get(), x, ymin, x, ymax); +bool structTextGridEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double xWC, double yWC) { + const TextGrid grid = (TextGrid) our data; + const integer numberOfTiers = grid -> tiers->size; + const double soundY = _TextGridEditor_computeSoundY (this); + const bool mouseIsInWideSoundOrAnalysisPart = ( yWC > soundY ); + const bool mouseIsInWideTextGridPart = ! mouseIsInWideSoundOrAnalysisPart; + + static bool anchorIsInWideSoundOrAnalysisPart = false; + static bool anchorIsInWideTextGridPart = false; + static double anchorTime = undefined; + static integer clickedLeftBoundary = 0, clickedPoint = 0; + static bool hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = false; + static double leftDraggingBoundary = our tmin, rightDraggingBoundary = our tmax; // initial dragging range + + constexpr double clickingVicinityRadius_mm = 1.0; + constexpr double draggingVicinityRadius_mm = clickingVicinityRadius_mm + 1.0; // muset be greater than `clickingVicinityRadius_mm` + constexpr double droppingVicinityRadius_mm = 1.5; + + if (event -> isClick()) { + anchorIsInWideSoundOrAnalysisPart = mouseIsInWideSoundOrAnalysisPart; + anchorIsInWideTextGridPart = mouseIsInWideTextGridPart; + } + if (mouseIsInWideSoundOrAnalysisPart) { + const bool mouseIsInWideAnalysisPart = ( yWC < 0.5 * (soundY + 1.0) ); + if ((our p_spectrogram_show || our p_formant_show) && mouseIsInWideAnalysisPart) { + our d_spectrogram_cursor = our p_spectrogram_viewFrom + + 2.0 * (yWC - soundY) / (1.0 - soundY) * (our p_spectrogram_viewTo - our p_spectrogram_viewFrom); } } - Graphics_setLineWidth (my graphics.get(), 1); - Graphics_line (my graphics.get(), x, 0.0, x, 1.01); - Graphics_text (my graphics.get(), x, 1.01, Melder_fixed (x, 6)); -} + if (anchorIsInWideSoundOrAnalysisPart) + return our TextGridEditor_Parent :: v_mouseInWideDataView (event, xWC, yWC); + Melder_assert (anchorIsInWideTextGridPart); + integer mouseTier = _TextGridEditor_yWCtoTier (this, yWC); + + our draggingTime = undefined; // information to next expose event + if (event -> isClick()) { + if (event -> isLeftBottomFunctionKeyPressed()) { + const integer clickedTierNumber = _TextGridEditor_yWCtoTier (this, yWC); + double tmin, tmax; + _TextGridEditor_timeToInterval (this, xWC, clickedTierNumber, & tmin, & tmax); + our startSelection = ( xWC - tmin < tmax - xWC ? tmin : tmax ); // to nearest boundary + Melder_sort (& our startSelection, & our endSelection); + return FunctionEditor_UPDATE_NEEDED; + } + if (event -> isRightBottomFunctionKeyPressed()) { + const integer clickedTierNumber = _TextGridEditor_yWCtoTier (this, yWC); + double tmin, tmax; + _TextGridEditor_timeToInterval (this, xWC, clickedTierNumber, & tmin, & tmax); + our endSelection = ( xWC - tmin < tmax - xWC ? tmin : tmax ); + Melder_sort (& our startSelection, & our endSelection); + return FunctionEditor_UPDATE_NEEDED; + } + Melder_assert (isundef (anchorTime)); // sanity check for the fixed order click-drag-drop + Melder_assert (clickedLeftBoundary == 0); + Melder_assert (! hasBeenDraggedBeyondVicinityRadiusAtLeastOnce); // sanity check for the fixed order click-drag-drop + our draggingTiers.reset(); + /* + The user clicked in the grid part. + We select the tier in which they clicked. + */ + our selectedTier = mouseTier; + double tmin, tmax; + _TextGridEditor_timeToInterval (this, xWC, our selectedTier, & tmin, & tmax); + IntervalTier intervalTier; + TextTier textTier; + AnyTextGridTier_identifyClass (grid -> tiers->at [our selectedTier], & intervalTier, & textTier); -static void do_dragBoundary (TextGridEditor me, double xbegin, integer iClickedTier, int shiftKeyPressed) { - const TextGrid grid = (TextGrid) my data; - const integer numberOfTiers = grid -> tiers->size; - double xWC = xbegin, yWC; - double leftDraggingBoundary = my tmin, rightDraggingBoundary = my tmax; // initial dragging range - bool selectedTier [1000]; - const double soundY = _TextGridEditor_computeSoundY (me); + if (xWC <= our startWindow || xWC >= our endWindow) + return FunctionEditor_UPDATE_NEEDED; - /* - Determine the set of selected boundaries and points, and the dragging range. - */ - for (int itier = 1; itier <= numberOfTiers; itier ++) { - selectedTier [itier] = false; // the default /* - If the user has pressed the shift key, let her drag all the boundaries and points at this time. - Otherwise, let her only drag the boundary or point on the clicked tier. + Get the time of the nearest boundary or point. */ - if (itier == iClickedTier || shiftKeyPressed == my p_shiftDragMultiple) { - IntervalTier intervalTier; - TextTier textTier; - _AnyTier_identifyClass (grid -> tiers->at [itier], & intervalTier, & textTier); - if (intervalTier) { - integer ibound = IntervalTier_hasBoundary (intervalTier, xbegin); - if (ibound) { - TextInterval leftInterval = intervalTier -> intervals.at [ibound - 1]; - TextInterval rightInterval = intervalTier -> intervals.at [ibound]; - selectedTier [itier] = true; - /* - Prevent the user from dragging the boundary past its left or right neighbours on the same tier. - */ - if (leftInterval -> xmin > leftDraggingBoundary) - leftDraggingBoundary = leftInterval -> xmin; - if (rightInterval -> xmax < rightDraggingBoundary) - rightDraggingBoundary = rightInterval -> xmax; - } + if (intervalTier) { + const integer clickedIntervalNumber = IntervalTier_timeToIndex (intervalTier, xWC); + const bool theyClickedOutsidetheTimeDomainOfTheIntervals = ( clickedIntervalNumber == 0 ); + if (theyClickedOutsidetheTimeDomainOfTheIntervals) + return FunctionEditor_UPDATE_NEEDED; + const TextInterval interval = intervalTier -> intervals.at [clickedIntervalNumber]; + if (xWC > 0.5 * (interval -> xmin + interval -> xmax)) { + anchorTime = interval -> xmax; + clickedLeftBoundary = clickedIntervalNumber + 1; } else { - if (AnyTier_hasPoint (textTier->asAnyTier(), xbegin)) { - /* - Other than with boundaries on interval tiers, - points on text tiers can be dragged past their neighbours. - */ - selectedTier [itier] = true; - } - } - } - } - - Graphics_xorOn (my graphics.get(), Melder_MAROON); - Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_BOTTOM); - do_drawWhileDragging (me, numberOfTiers, selectedTier, xWC, soundY); // draw at old position - while (Graphics_mouseStillDown (my graphics.get())) { - double xWC_new; - Graphics_getMouseLocation (my graphics.get(), & xWC_new, & yWC); - if (xWC_new != xWC) { - do_drawWhileDragging (me, numberOfTiers, selectedTier, xWC, soundY); // undraw at old position - xWC = xWC_new; - do_drawWhileDragging (me, numberOfTiers, selectedTier, xWC, soundY); // draw at new position - } - } - do_drawWhileDragging (me, numberOfTiers, selectedTier, xWC, soundY); // undraw at new position - Graphics_xorOff (my graphics.get()); - - /* - The simplest way to cancel the dragging operation, is to drag outside the window. - */ - if (xWC <= my startWindow || xWC >= my endWindow) - return; - - /* - If the user dropped near an existing boundary in an unselected tier or near the cursor, - we snap to that mark. - */ - const integer itierDrop = _TextGridEditor_yWCtoTier (me, yWC); - if (yWC > 0.0 && yWC < soundY && ! selectedTier [itierDrop]) { // dropped inside an unselected tier? - const Function anyTierDrop = grid -> tiers->at [itierDrop]; - if (anyTierDrop -> classInfo == classIntervalTier) { - const IntervalTier tierDrop = (IntervalTier) anyTierDrop; - for (integer ibound = 1; ibound < tierDrop -> intervals.size; ibound ++) { - const TextInterval left = tierDrop -> intervals.at [ibound]; - if (fabs (Graphics_dxWCtoMM (my graphics.get(), xWC - left -> xmax)) < 1.5) { // near a boundary? - /* - Snap to boundary. - */ - xWC = left -> xmax; - } + anchorTime = interval -> xmin; + clickedLeftBoundary = clickedIntervalNumber; } } else { - const TextTier tierDrop = (TextTier) anyTierDrop; - for (integer ipoint = 1; ipoint <= tierDrop -> points.size; ipoint ++) { - TextPoint point = tierDrop -> points.at [ipoint]; - if (fabs (Graphics_dxWCtoMM (my graphics.get(), xWC - point -> number)) < 1.5) { // near a point? - /* - Snap to point. - */ - xWC = point -> number; - } + const integer clickedPointNumber = AnyTier_timeToNearestIndex (textTier->asAnyTier(), xWC); + if (clickedPointNumber != 0) { + const TextPoint point = textTier -> points.at [clickedPointNumber]; + anchorTime = point -> number; } } - } else if (xbegin != my startSelection && fabs (Graphics_dxWCtoMM (my graphics.get(), xWC - my startSelection)) < 1.5) { // near the cursor? - /* - Snap to cursor. - */ - xWC = my startSelection; - } else if (xbegin != my endSelection && fabs (Graphics_dxWCtoMM (my graphics.get(), xWC - my endSelection)) < 1.5) { // near the cursor? - /* - Snap to cursor. - */ - xWC = my endSelection; - } - - /* - We cannot move a boundary out of the dragging range. - */ - if (xWC <= leftDraggingBoundary || xWC >= rightDraggingBoundary) { - Melder_beep (); - return; - } + Melder_assert (! (intervalTier && clickedLeftBoundary == 0)); - Editor_save (me, U"Drag"); + const bool nearBoundaryOrPoint = ( isdefined (anchorTime) && fabs (Graphics_dxWCtoMM (our graphics.get(), xWC - anchorTime)) < 1.5 ); + const bool nearCursorCircle = ( our startSelection == our endSelection && Graphics_distanceWCtoMM (our graphics.get(), xWC, yWC, + our startSelection, + (numberOfTiers + 1 - our selectedTier) * soundY / numberOfTiers - Graphics_dyMMtoWC (our graphics.get(), 1.5)) < 1.5 ); - for (integer itier = 1; itier <= numberOfTiers; itier ++) { - if (selectedTier [itier]) { - IntervalTier intervalTier; - TextTier textTier; - _AnyTier_identifyClass (grid -> tiers->at [itier], & intervalTier, & textTier); + if (nearBoundaryOrPoint) { + /* + Possibility 1: the user clicked near a boundary or point. + Select and perhaps drag it. + */ + bool boundaryOrPointIsMovable = true; if (intervalTier) { - const integer numberOfIntervals = intervalTier -> intervals.size; - for (integer ibound = 2; ibound <= numberOfIntervals; ibound ++) { - TextInterval left = intervalTier -> intervals.at [ibound - 1], right = intervalTier -> intervals.at [ibound]; - if (left -> xmax == xbegin) { // boundary dragged? - left -> xmax = right -> xmin = xWC; // move boundary to drop site - break; - } - } + const bool isLeftEdgeOfFirstInterval = ( clickedLeftBoundary <= 1 ); + const bool isRightEdgeOfLastInterval = ( clickedLeftBoundary > intervalTier -> intervals.size ); + boundaryOrPointIsMovable = ! isLeftEdgeOfFirstInterval && ! isRightEdgeOfLastInterval; + } + /* + If the user clicked on an unselected boundary or point, we select it. + */ + if (event -> shiftKeyPressed) { + if (anchorTime > 0.5 * (our startSelection + our endSelection)) + our endSelection = anchorTime; + else + our startSelection = anchorTime; } else { - const integer iDraggedPoint = AnyTier_hasPoint (textTier->asAnyTier(), xbegin); - if (iDraggedPoint) { - integer dropSiteHasPoint = AnyTier_hasPoint (textTier->asAnyTier(), xWC); - if (dropSiteHasPoint != 0) { - Melder_warning (U"Cannot drop point on an existing point."); + our startSelection = our endSelection = anchorTime; // move cursor so that the boundary or point is selected + } + if (! boundaryOrPointIsMovable) { + our draggingTime = undefined; + hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = false; + anchorTime = undefined; + clickedLeftBoundary = 0; + return FunctionEditor_UPDATE_NEEDED; + } + /* + Determine the set of selected boundaries and points, and the dragging range. + */ + our draggingTiers = newBOOLVECzero (numberOfTiers); + leftDraggingBoundary = our tmin; + rightDraggingBoundary = our tmax; + for (int itier = 1; itier <= numberOfTiers; itier ++) { + /* + If the user has pressed the shift key, let her drag all the boundaries and points at this time. + Otherwise, let her only drag the boundary or point on the clicked tier. + */ + if (itier == mouseTier || our clickWasModifiedByShiftKey == our p_shiftDragMultiple) { + IntervalTier intervalTier; + TextTier textTier; + AnyTextGridTier_identifyClass (grid -> tiers->at [itier], & intervalTier, & textTier); + if (intervalTier) { + integer ibound = IntervalTier_hasBoundary (intervalTier, anchorTime); + if (ibound) { + TextInterval leftInterval = intervalTier -> intervals.at [ibound - 1]; + TextInterval rightInterval = intervalTier -> intervals.at [ibound]; + our draggingTiers [itier] = true; + /* + Prevent the user from dragging the boundary past its left or right neighbours on the same tier. + */ + if (leftInterval -> xmin > leftDraggingBoundary) + leftDraggingBoundary = leftInterval -> xmin; + if (rightInterval -> xmax < rightDraggingBoundary) + rightDraggingBoundary = rightInterval -> xmax; + } } else { - const TextPoint point = textTier -> points.at [iDraggedPoint]; - /* - Move point to drop site. May have passed another point. - */ - autoTextPoint newPoint = Data_copy (point); - newPoint -> number = xWC; // move point to drop site - textTier -> points. removeItem (iDraggedPoint); - textTier -> points. addItem_move (newPoint.move()); + if (AnyTier_hasPoint (textTier->asAnyTier(), anchorTime)) { + /* + Other than with boundaries on interval tiers, + points on text tiers can be dragged past their neighbours. + */ + our draggingTiers [itier] = true; + } } } } - } - } - - /* - Select the drop site. - */ - if (my startSelection == xbegin) - my startSelection = xWC; - if (my endSelection == xbegin) - my endSelection = xWC; - if (my startSelection > my endSelection) { - double dummy = my startSelection; - my startSelection = my endSelection; - my endSelection = dummy; - } - FunctionEditor_marksChanged (me, true); - Editor_broadcastDataChanged (me); -} - -bool structTextGridEditor :: v_click (double xclick, double yWC, bool shiftKeyPressed) { - const TextGrid grid = (TextGrid) our data; - - /* - In answer to a click in the sound part, - we keep the same tier selected and move the cursor or drag the "yellow" selection. - */ - const double soundY = _TextGridEditor_computeSoundY (this); - if (yWC > soundY) { // clicked in sound part? - if ((our p_spectrogram_show || our p_formant_show) && yWC < 0.5 * (soundY + 1.0)) { - our d_spectrogram_cursor = our p_spectrogram_viewFrom + - 2.0 * (yWC - soundY) / (1.0 - soundY) * (our p_spectrogram_viewTo - our p_spectrogram_viewFrom); - } - our TextGridEditor_Parent :: v_click (xclick, yWC, shiftKeyPressed); - return FunctionEditor_UPDATE_NEEDED; - } - - /* - The user clicked in the grid part. - We select the tier in which she clicked. - */ - const integer clickedTierNumber = _TextGridEditor_yWCtoTier (this, yWC); - - if (xclick <= our startWindow || xclick >= our endWindow) { - our selectedTier = clickedTierNumber; - return FunctionEditor_UPDATE_NEEDED; - } - - double tmin, tmax; - _TextGridEditor_timeToInterval (this, xclick, clickedTierNumber, & tmin, & tmax); - IntervalTier intervalTier; - TextTier textTier; - _AnyTier_identifyClass (grid -> tiers->at [clickedTierNumber], & intervalTier, & textTier); - - /* - Get the time of the nearest boundary or point. - */ - double tnear = undefined; - integer clickedLeftBoundary = 0; - if (intervalTier) { - const integer clickedIntervalNumber = IntervalTier_timeToIndex (intervalTier, xclick); - if (clickedIntervalNumber != 0) { - const TextInterval interval = intervalTier -> intervals.at [clickedIntervalNumber]; - if (xclick > 0.5 * (interval -> xmin + interval -> xmax)) { - tnear = interval -> xmax; - clickedLeftBoundary = clickedIntervalNumber + 1; - } else { - tnear = interval -> xmin; - clickedLeftBoundary = clickedIntervalNumber; - } + } else if (nearCursorCircle) { + /* + Possibility 2: the user clicked near the cursor circle. + Insert boundary or point. There is no danger that we insert on top of an existing boundary or point, + because we are not 'nearBoundaryOrPoint'. + */ + our v_updateText(); + insertBoundaryOrPoint (this, mouseTier, our startSelection, our startSelection, false); + //FunctionEditor_marksChanged (this, true); + Editor_broadcastDataChanged (this); } else { /* - The user clicked outside the time domain of the intervals. - This can occur when we are grouped with a longer time function. + Possibility 3: the user clicked in empty space. + Select the interval, if any. */ - our selectedTier = clickedTierNumber; - return FunctionEditor_UPDATE_NEEDED; + if (intervalTier) { + our startSelection = tmin; + our endSelection = tmax; + } } - } else { - const integer clickedPointNumber = AnyTier_timeToNearestIndex (textTier->asAnyTier(), xclick); - if (clickedPointNumber != 0) { - const TextPoint point = textTier -> points.at [clickedPointNumber]; - tnear = point -> number; + } else if (event -> isDrag ()) { + if (isdefined (anchorTime) && our draggingTiers.size > 0) { + our draggingTime = xWC; + if (! hasBeenDraggedBeyondVicinityRadiusAtLeastOnce) { + const double distanceToAnchor_mm = fabs (Graphics_dxWCtoMM (our graphics.get(), xWC - anchorTime)); + if (distanceToAnchor_mm > draggingVicinityRadius_mm) + hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = true; + } } - } - Melder_assert (! (intervalTier && clickedLeftBoundary == 0)); - - /* - Where did the user click? - */ - const bool nearBoundaryOrPoint = ( isdefined (tnear) && fabs (Graphics_dxWCtoMM (our graphics.get(), xclick - tnear)) < 1.5 ); - const integer numberOfTiers = grid -> tiers->size; - const bool nearCursorCircle = ( our startSelection == our endSelection && Graphics_distanceWCtoMM (our graphics.get(), xclick, yWC, - our startSelection, (numberOfTiers + 1 - clickedTierNumber) * soundY / numberOfTiers - Graphics_dyMMtoWC (our graphics.get(), 1.5)) < 1.5 ); - - /* - Find out whether this is a click or a drag. - */ - bool drag = false; - while (Graphics_mouseStillDown (our graphics.get())) { - double x, y; - Graphics_getMouseLocation (our graphics.get(), & x, & y); - if (x < our startWindow) - x = our startWindow; - if (x > our endWindow) - x = our endWindow; - if (fabs (Graphics_dxWCtoMM (our graphics.get(), x - xclick)) > 1.5) { - drag = true; - break; + } else if (event -> isDrop ()) { + if (our draggingTiers.size == 0) { + our draggingTime = undefined; + hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = false; + anchorTime = undefined; + clickedLeftBoundary = 0; + return FunctionEditor_UPDATE_NEEDED; } - } - - if (nearBoundaryOrPoint) { /* - Possibility 1: the user clicked near a boundary or point. - Select or drag it. + If the user dropped near an existing boundary in an unselected tier or near the cursor, + we snap to that mark. */ - if (intervalTier && (clickedLeftBoundary < 2 || clickedLeftBoundary > intervalTier -> intervals.size)) { - /* - Ignore click on left edge of first interval or right edge of last interval. - */ - our selectedTier = clickedTierNumber; - } else if (drag) { - /* - The tier that has been clicked becomes the new selected tier. - This has to be done before the next Update, i.e. also before do_dragBoundary! - */ - our selectedTier = clickedTierNumber; - do_dragBoundary (this, tnear, clickedTierNumber, shiftKeyPressed); - return FunctionEditor_NO_UPDATE_NEEDED; - } else { - /* - If the user clicked on an unselected boundary or point, we select it. - */ - if (shiftKeyPressed) { - if (tnear > 0.5 * (our startSelection + our endSelection)) - our endSelection = tnear; - else - our startSelection = tnear; + const integer itierDrop = _TextGridEditor_yWCtoTier (this, yWC); + bool droppedOnABoundaryOrPointInsideAnUnselectedTier = false; + if (yWC > 0.0 && yWC < soundY && ! our draggingTiers [itierDrop]) { // dropped inside an unselected tier? + const Function anyTierDrop = grid -> tiers->at [itierDrop]; + if (anyTierDrop -> classInfo == classIntervalTier) { + const IntervalTier tierDrop = (IntervalTier) anyTierDrop; + for (integer ibound = 1; ibound < tierDrop -> intervals.size; ibound ++) { + const TextInterval left = tierDrop -> intervals.at [ibound]; + const double mouseDistanceToBoundary = fabs (Graphics_dxWCtoMM (our graphics.get(), xWC - left -> xmax)); + if (mouseDistanceToBoundary < droppingVicinityRadius_mm) { + xWC = left -> xmax; // snap to boundary + droppedOnABoundaryOrPointInsideAnUnselectedTier = true; + } + } } else { - our startSelection = our endSelection = tnear; // move cursor so that the boundary or point is selected + const TextTier tierDrop = (TextTier) anyTierDrop; + for (integer ipoint = 1; ipoint <= tierDrop -> points.size; ipoint ++) { + const TextPoint point = tierDrop -> points.at [ipoint]; + const double mouseDistanceToPoint_mm = fabs (Graphics_dxWCtoMM (our graphics.get(), xWC - point -> number)); + if (mouseDistanceToPoint_mm < droppingVicinityRadius_mm) { + xWC = point -> number; // snap to point + droppedOnABoundaryOrPointInsideAnUnselectedTier = true; + } + } } - our selectedTier = clickedTierNumber; } - } else if (nearCursorCircle) { - /* - Possibility 2: the user clicked near the cursor circle. - Insert boundary or point. There is no danger that we insert on top of an existing boundary or point, - because we are not 'nearBoundaryOrPoint'. - */ - insertBoundaryOrPoint (this, clickedTierNumber, our startSelection, our startSelection, false); - our selectedTier = clickedTierNumber; - FunctionEditor_marksChanged (this, true); - Editor_broadcastDataChanged (this); - if (drag) - Graphics_waitMouseUp (our graphics.get()); - return FunctionEditor_NO_UPDATE_NEEDED; - } else { + if (! hasBeenDraggedBeyondVicinityRadiusAtLeastOnce && ! droppedOnABoundaryOrPointInsideAnUnselectedTier) { + our draggingTime = undefined; + hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = false; + anchorTime = undefined; + clickedLeftBoundary = 0; + return FunctionEditor_UPDATE_NEEDED; + } + /* - Possibility 3: the user clicked in empty space. + We cannot move a boundary out of the dragging range. */ - if (intervalTier) { - our startSelection = tmin; - our endSelection = tmax; + if (xWC <= leftDraggingBoundary || xWC >= rightDraggingBoundary) { + Melder_beep (); + our draggingTime = undefined; + hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = false; + anchorTime = undefined; + clickedLeftBoundary = 0; + return FunctionEditor_UPDATE_NEEDED; } - selectedTier = clickedTierNumber; - } - if (drag) - Graphics_waitMouseUp (our graphics.get()); - return FunctionEditor_UPDATE_NEEDED; -} -bool structTextGridEditor :: v_clickB (double t, double yWC) { - const double soundY = _TextGridEditor_computeSoundY (this); - if (yWC > soundY) { // clicked in sound part? - if (t < our endWindow) { - our startSelection = t; - if (our startSelection > our endSelection) - std::swap (our startSelection, our endSelection); - return FunctionEditor_UPDATE_NEEDED; - } else { - return structTimeSoundEditor :: v_clickB (t, yWC); + Editor_save (this, U"Drag"); + + for (integer itier = 1; itier <= numberOfTiers; itier ++) { + if (our draggingTiers [itier]) { + IntervalTier intervalTier; + TextTier textTier; + AnyTextGridTier_identifyClass (grid -> tiers->at [itier], & intervalTier, & textTier); + if (intervalTier) { + const integer numberOfIntervals = intervalTier -> intervals.size; + for (integer ibound = 2; ibound <= numberOfIntervals; ibound ++) { + TextInterval left = intervalTier -> intervals.at [ibound - 1], right = intervalTier -> intervals.at [ibound]; + if (left -> xmax == anchorTime) { // boundary dragged? + left -> xmax = right -> xmin = xWC; // move boundary to drop site + break; + } + } + } else { + const integer iDraggedPoint = AnyTier_hasPoint (textTier->asAnyTier(), anchorTime); + if (iDraggedPoint) { + integer dropSiteHasPoint = AnyTier_hasPoint (textTier->asAnyTier(), xWC); + if (dropSiteHasPoint != 0) { + Melder_warning (U"Cannot drop point on an existing point."); + } else { + const TextPoint point = textTier -> points.at [iDraggedPoint]; + /* + Move point to drop site. May have passed another point. + */ + autoTextPoint newPoint = Data_copy (point); + newPoint -> number = xWC; // move point to drop site + textTier -> points. removeItem (iDraggedPoint); + textTier -> points. addItem_move (newPoint.move()); + } + } + } + } } - } - const integer clickedTierNumber = _TextGridEditor_yWCtoTier (this, yWC); - double tmin, tmax; - _TextGridEditor_timeToInterval (this, t, clickedTierNumber, & tmin, & tmax); - our startSelection = ( t - tmin < tmax - t ? tmin : tmax ); // to nearest boundary - if (our startSelection > our endSelection) - std::swap (our startSelection, our endSelection); - return FunctionEditor_UPDATE_NEEDED; -} -bool structTextGridEditor :: v_clickE (double t, double yWC) { - const double soundY = _TextGridEditor_computeSoundY (this); - if (yWC > soundY) { // clicked in sound part? - our endSelection = t; - if (our startSelection > our endSelection) - std::swap (our startSelection, our endSelection); - return FunctionEditor_UPDATE_NEEDED; + /* + Select the drop site. + */ + if (our startSelection == anchorTime) + our startSelection = xWC; + if (our endSelection == anchorTime) + our endSelection = xWC; + Melder_sort (& our startSelection, & our endSelection); + our draggingTime = undefined; + hasBeenDraggedBeyondVicinityRadiusAtLeastOnce = false; + anchorTime = undefined; + clickedLeftBoundary = 0; + //FunctionEditor_marksChanged (this, true); + Editor_broadcastDataChanged (this); } - const integer clickedTierNumber = _TextGridEditor_yWCtoTier (this, yWC); - double tmin, tmax; - _TextGridEditor_timeToInterval (this, t, clickedTierNumber, & tmin, & tmax); - our endSelection = ( t - tmin < tmax - t ? tmin : tmax ); - if (our startSelection > our endSelection) - std::swap (our startSelection, our endSelection); return FunctionEditor_UPDATE_NEEDED; } @@ -2071,7 +2005,7 @@ void structTextGridEditor :: v_clickSelectionViewer (double xWC, double yWC) { if (our selectedTier) { IntervalTier intervalTier; TextTier textTier; - _AnyTier_identifyClass (grid -> tiers->at [our selectedTier], & intervalTier, & textTier); + AnyTextGridTier_identifyClass (grid -> tiers->at [our selectedTier], & intervalTier, & textTier); if (intervalTier) { integer selectedInterval = getSelectedInterval (this); if (selectedInterval) { @@ -2109,7 +2043,7 @@ void structTextGridEditor :: v_clickSelectionViewer (double xWC, double yWC) { } } -void structTextGridEditor :: v_play (double tmin, double tmax) { +void structTextGridEditor :: v_play (double startTime, double endTime) { if (! d_sound.data && ! d_longSound.data) return; integer numberOfChannels = ( d_longSound.data ? d_longSound.data -> numberOfChannels : d_sound.data -> ny ); @@ -2123,20 +2057,20 @@ void structTextGridEditor :: v_play (double tmin, double tmax) { U"Please select at least one channel to play."); if (our d_longSound.data) { if (numberOfMuteChannels > 0) { - autoSound part = LongSound_extractPart (our d_longSound.data, tmin, tmax, true); + autoSound part = LongSound_extractPart (our d_longSound.data, startTime, endTime, true); autoMixingMatrix thee = MixingMatrix_create (numberOfChannelsToPlay, numberOfChannels); MixingMatrix_muteAndActivateChannels (thee.get(), our d_sound.muteChannels.get()); - Sound_MixingMatrix_playPart (part.get(), thee.get(), tmin, tmax, theFunctionEditor_playCallback, this); + Sound_MixingMatrix_playPart (part.get(), thee.get(), startTime, endTime, theFunctionEditor_playCallback, this); } else { - LongSound_playPart (our d_longSound.data, tmin, tmax, theFunctionEditor_playCallback, this); + LongSound_playPart (our d_longSound.data, startTime, endTime, theFunctionEditor_playCallback, this); } } else { if (numberOfMuteChannels > 0) { autoMixingMatrix thee = MixingMatrix_create (numberOfChannelsToPlay, numberOfChannels); MixingMatrix_muteAndActivateChannels (thee.get(), our d_sound.muteChannels.get()); - Sound_MixingMatrix_playPart (our d_sound.data, thee.get(), tmin, tmax, theFunctionEditor_playCallback, this); + Sound_MixingMatrix_playPart (our d_sound.data, thee.get(), startTime, endTime, theFunctionEditor_playCallback, this); } else { - Sound_playPart (our d_sound.data, tmin, tmax, theFunctionEditor_playCallback, this); + Sound_playPart (our d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); } } } @@ -2148,7 +2082,7 @@ void structTextGridEditor :: v_updateText () { if (our selectedTier) { IntervalTier intervalTier; TextTier textTier; - _AnyTier_identifyClass (grid -> tiers->at [selectedTier], & intervalTier, & textTier); + AnyTextGridTier_identifyClass (grid -> tiers->at [selectedTier], & intervalTier, & textTier); if (intervalTier) { integer iinterval = IntervalTier_timeToIndex (intervalTier, our startSelection); if (iinterval) { @@ -2239,16 +2173,6 @@ void structTextGridEditor :: v_highlightSelection (double left, double right, do } } -void structTextGridEditor :: v_unhighlightSelection (double left, double right, double bottom, double top) { - if (our v_hasAnalysis () && our p_spectrogram_show && (our d_longSound.data || our d_sound.data)) { - const double soundY = _TextGridEditor_computeSoundY (this), soundY2 = 0.5 * (1.0 + soundY); - //Graphics_unhighlight (our graphics.get(), left, right, bottom, soundY * top + (1 - soundY) * bottom); - Graphics_unhighlight (our graphics.get(), left, right, soundY2 * top + (1 - soundY2) * bottom, top); - } else { - Graphics_unhighlight (our graphics.get(), left, right, bottom, top); - } -} - double structTextGridEditor :: v_getBottomOfSoundArea () { return _TextGridEditor_computeSoundY (this); } @@ -2278,6 +2202,7 @@ void TextGridEditor_init (TextGridEditor me, conststring32 title, TextGrid grid, TimeSoundAnalysisEditor_init (me, title, grid, sound, ownSound); my selectedTier = 1; + my draggingTime = undefined; my v_updateText (); // to reflect changed tier selection if (my endWindow - my startWindow > 30.0) { my endWindow = my startWindow + 30.0; diff --git a/fon/TextGridEditor.h b/fon/TextGridEditor.h index b8c458a5..405a7ef5 100644 --- a/fon/TextGridEditor.h +++ b/fon/TextGridEditor.h @@ -2,7 +2,7 @@ #define _TextGridEditor_h_ /* TextGridEditor.h * - * Copyright (C) 1992-2005,2007-2019 Paul Boersma + * Copyright (C) 1992-2005,2007-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -31,6 +31,8 @@ Thing_define (TextGridEditor, TimeSoundAnalysisEditor) { bool suppressRedraw; autostring32 findString; GuiMenuItem extractSelectedTextGridPreserveTimesButton, extractSelectedTextGridTimeFromZeroButton; + double draggingTime; + autoBOOLVEC draggingTiers; void v_info () override; @@ -56,11 +58,7 @@ Thing_define (TextGridEditor, TimeSoundAnalysisEditor) { override; bool v_hasText () override { return true; } - bool v_click (double xWC, double yWC, bool shiftKeyPressed) - override; - bool v_clickB (double xWC, double yWC) - override; - bool v_clickE (double xWC, double yWC) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double xWC, double yWC) override; void v_clickSelectionViewer (double xWC, double yWC) override; @@ -80,8 +78,6 @@ Thing_define (TextGridEditor, TimeSoundAnalysisEditor) { override; void v_highlightSelection (double left, double right, double bottom, double top) override; - void v_unhighlightSelection (double left, double right, double bottom, double top) - override; double v_getBottomOfSoundArea () override; double v_getBottomOfSoundAndAnalysisArea () diff --git a/fon/TextGrid_Sound.cpp b/fon/TextGrid_Sound.cpp index 654cc84f..222d0734 100644 --- a/fon/TextGrid_Sound.cpp +++ b/fon/TextGrid_Sound.cpp @@ -345,9 +345,8 @@ void TextGrid_anySound_alignInterval (TextGrid me, Function anySound, integer ti } void TextGrid_Sound_draw (TextGrid me, Sound sound, Graphics g, double tmin, double tmax, - bool showBoundaries, bool useTextStyles, bool garnish) // STEREO BUG -{ - integer numberOfTiers = my tiers->size; + bool showBoundaries, bool useTextStyles, bool garnish) { + integer numberOfTiers = my tiers ->size; Function_unidirectionalAutowindow (me, & tmin, & tmax); diff --git a/fon/TimeSoundAnalysisEditor.cpp b/fon/TimeSoundAnalysisEditor.cpp index 380ea8ab..47efe812 100644 --- a/fon/TimeSoundAnalysisEditor.cpp +++ b/fon/TimeSoundAnalysisEditor.cpp @@ -108,7 +108,7 @@ void structTimeSoundAnalysisEditor :: v_info () { /* Formant flag: */ MelderInfo_writeLine (U"Formant show: ", p_formant_show); /* Formant settings: */ - MelderInfo_writeLine (U"Formant maximum formant: ", p_formant_maximumFormant, U" Hz"); + MelderInfo_writeLine (U"Formant ceiling: ", p_formant_ceiling, U" Hz"); MelderInfo_writeLine (U"Formant number of poles: ", Melder_iround (2.0 * p_formant_numberOfFormants)); // should be a whole number MelderInfo_writeLine (U"Formant window length: ", p_formant_windowLength, U" seconds"); MelderInfo_writeLine (U"Formant dynamic range: ", p_formant_dynamicRange, U" dB"); @@ -149,10 +149,9 @@ static const conststring32 TimeSoundAnalysisEditor_partString_locative (int part } static int makeQueriable (TimeSoundAnalysisEditor me, int allowCursor, double *tmin, double *tmax) { - if (my endWindow - my startWindow > my p_longestAnalysis) { + if (my endWindow - my startWindow > my p_longestAnalysis) Melder_throw (U"Window too long to show analyses. Zoom in to at most ", Melder_half (my p_longestAnalysis), U" seconds " U"or set the \"longest analysis\" to at least ", Melder_half (my endWindow - my startWindow), U" seconds."); - } if (my startSelection == my endSelection) { if (allowCursor) { *tmin = *tmax = my startSelection; @@ -173,15 +172,15 @@ static int makeQueriable (TimeSoundAnalysisEditor me, int allowCursor, double *t static void menu_cb_logSettings (TimeSoundAnalysisEditor me, EDITOR_ARGS_FORM) { EDITOR_FORM (U"Log settings", U"Log files") OPTIONMENU (writeLog1To, U"Write log 1 to", 3) - OPTION (U"Log file only") + OPTION (U"log file only") OPTION (U"Info window only") - OPTION (U"Log file and Info window") + OPTION (U"log file and Info window") TEXTFIELD (logFile1, U"Log file 1:", my default_log1_fileName ()) TEXTFIELD (log1format, U"Log 1 format:", my default_log1_format ()) OPTIONMENU (writeLog2To, U"Write log 2 to", 3) - OPTION (U"Log file only") + OPTION (U"log file only") OPTION (U"Info window only") - OPTION (U"Log file and Info window") + OPTION (U"log file and Info window") TEXTFIELD (logFile2, U"Log file 2:", my default_log2_fileName ()) TEXTFIELD (log2format, U"Log 2 format:", my default_log2_format ()) TEXTFIELD (logScript3, U"Log script 3:", my default_logScript3 ()) @@ -224,7 +223,7 @@ static void menu_cb_deleteLogFile2 (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRE static void do_log (TimeSoundAnalysisEditor me, int which) { char32 format [Preferences_STRING_BUFFER_SIZE], *p; double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); str32cpy (format, which == 1 ? my p_log1_format : my p_log2_format); for (p = format; *p != U'\0'; p ++) if (*p == U'\'') { /* @@ -241,7 +240,7 @@ static void do_log (TimeSoundAnalysisEditor me, int which) { * Found a right quote. Get potential variable name. */ for (r = p + 1, s = varName; q - r > 0; r ++, s ++) *s = *r; - *s = U'\0'; /* Trailing null byte. */ + *s = U'\0'; // trailing null byte colon = str32chr (varName, U':'); if (colon) { precision = Melder_atoi (colon + 1); @@ -264,20 +263,18 @@ static void do_log (TimeSoundAnalysisEditor me, int which) { } else if (str32equ (varName, U"f0")) { if (! my p_pitch_show) Melder_throw (U"No pitch contour is visible.\nFirst choose \"Show pitch\" from the Pitch menu."); - if (! my d_pitch) { + if (! my d_pitch) Melder_throw (theMessage_Cannot_compute_pitch); - } if (part == TimeSoundAnalysisEditor_PART_CURSOR) { value = Pitch_getValueAtTime (my d_pitch.get(), tmin, my p_pitch_unit, 1); } else { value = Pitch_getMean (my d_pitch.get(), tmin, tmax, my p_pitch_unit); } - } else if (varName [0] == 'f' && varName [1] >= '1' && varName [1] <= '5' && varName [2] == '\0') { + } else if (varName [0] == U'f' && varName [1] >= U'1' && varName [1] <= U'5' && varName [2] == U'\0') { if (! my p_formant_show) Melder_throw (U"No formant contour is visible.\nFirst choose \"Show formants\" from the Formant menu."); - if (! my d_formant) { + if (! my d_formant) Melder_throw (theMessage_Cannot_compute_formant); - } if (part == TimeSoundAnalysisEditor_PART_CURSOR) { value = Formant_getValueAtTime (my d_formant.get(), (int) (varName [1] - U'0'), tmin, kFormant_unit::HERTZ); } else { @@ -286,27 +283,24 @@ static void do_log (TimeSoundAnalysisEditor me, int which) { } else if (varName [0] == U'b' && varName [1] >= U'1' && varName [1] <= U'5' && varName [2] == U'\0') { if (! my p_formant_show) Melder_throw (U"No formant contour is visible.\nFirst choose \"Show formants\" from the Formant menu."); - if (! my d_formant) { + if (! my d_formant) Melder_throw (theMessage_Cannot_compute_formant); - } value = Formant_getBandwidthAtTime (my d_formant.get(), (int) (varName [1] - U'0'), 0.5 * (tmin + tmax), kFormant_unit::HERTZ); } else if (str32equ (varName, U"intensity")) { if (! my p_intensity_show) Melder_throw (U"No intensity contour is visible.\nFirst choose \"Show intensity\" from the Intensity menu."); - if (! my d_intensity) { + if (! my d_intensity) Melder_throw (theMessage_Cannot_compute_intensity); - } if (part == TimeSoundAnalysisEditor_PART_CURSOR) { - value = Vector_getValueAtX (my d_intensity.get(), tmin, Vector_CHANNEL_1, Vector_VALUE_INTERPOLATION_LINEAR); + value = Vector_getValueAtX (my d_intensity.get(), tmin, Vector_CHANNEL_1, kVector_valueInterpolation :: LINEAR); } else { value = Intensity_getAverage (my d_intensity.get(), tmin, tmax, (int) my p_intensity_averagingMethod); } } else if (str32equ (varName, U"power")) { if (! my p_spectrogram_show) Melder_throw (U"No spectrogram is visible.\nFirst choose \"Show spectrogram\" from the Spectrum menu."); - if (! my d_spectrogram) { + if (! my d_spectrogram) Melder_throw (theMessage_Cannot_compute_spectrogram); - } if (part != TimeSoundAnalysisEditor_PART_CURSOR) Melder_throw (U"Click inside the spectrogram first."); value = Matrix_getValueAtXY (my d_spectrogram.get(), tmin, my d_spectrogram_cursor); } @@ -504,7 +498,7 @@ static void menu_cb_getFrequency (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT static void menu_cb_getSpectralPowerAtCursorCross (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); if (! my p_spectrogram_show) Melder_throw (U"No spectrogram is visible.\nFirst choose \"Show spectrogram\" from the Spectrum menu."); if (! my d_spectrogram) { @@ -514,7 +508,7 @@ static void menu_cb_getSpectralPowerAtCursorCross (TimeSoundAnalysisEditor me, E if (part != TimeSoundAnalysisEditor_PART_CURSOR) Melder_throw (U"Click inside the spectrogram first."); MelderInfo_open (); MelderInfo_write (Matrix_getValueAtXY (my d_spectrogram.get(), tmin, my d_spectrogram_cursor), - U" Pa2/Hz (at time = ", tmin, U" seconds and frequency = ", my d_spectrogram_cursor, U" Hz)"); + U" Pa2/Hz (at time = ", tmin, U" seconds and frequency = ", my d_spectrogram_cursor, U" Hz)"); MelderInfo_close (); } @@ -534,12 +528,12 @@ static void menu_cb_moveFrequencyCursorTo (TimeSoundAnalysisEditor me, EDITOR_AR static autoSound extractSound (TimeSoundAnalysisEditor me, double tmin, double tmax) { autoSound sound; if (my d_longSound.data) { - if (tmin < my d_longSound.data -> xmin) tmin = my d_longSound.data -> xmin; - if (tmax > my d_longSound.data -> xmax) tmax = my d_longSound.data -> xmax; + Melder_clipLeft (my d_longSound.data -> xmin, & tmin); + Melder_clipRight (& tmax, my d_longSound.data -> xmax); sound = LongSound_extractPart (my d_longSound.data, tmin, tmax, true); } else if (my d_sound.data) { - if (tmin < my d_sound.data -> xmin) tmin = my d_sound.data -> xmin; - if (tmax > my d_sound.data -> xmax) tmax = my d_sound.data -> xmax; + Melder_clipLeft (my d_sound.data -> xmin, & tmin); + Melder_clipRight (& tmax, my d_sound.data -> xmax); sound = Sound_extractPart (my d_sound.data, tmin, tmax, kSound_windowShape::RECTANGULAR, 1.0, true); } return sound; @@ -557,12 +551,14 @@ static void menu_cb_extractVisibleSpectrogram (TimeSoundAnalysisEditor me, EDITO } static void menu_cb_viewSpectralSlice (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { - double start = my startSelection == my endSelection ? + const double start = ( my startSelection == my endSelection ? my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::GAUSSIAN ? my startSelection - my p_spectrogram_windowLength : - my startSelection - my p_spectrogram_windowLength / 2 : my startSelection; - double finish = my startSelection == my endSelection ? + my startSelection - my p_spectrogram_windowLength / 2 : my startSelection + ); + const double finish = ( my startSelection == my endSelection ? my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::GAUSSIAN ? my endSelection + my p_spectrogram_windowLength : - my endSelection + my p_spectrogram_windowLength / 2 : my endSelection; + my endSelection + my p_spectrogram_windowLength / 2 : my endSelection + ); autoSound sound = extractSound (me, start, finish); Sound_multiplyByWindow (sound.get(), my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::SQUARE ? kSound_windowShape::RECTANGULAR : @@ -570,10 +566,11 @@ static void menu_cb_viewSpectralSlice (TimeSoundAnalysisEditor me, EDITOR_ARGS_D my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::BARTLETT ? kSound_windowShape::TRIANGULAR : my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::WELCH ? kSound_windowShape::PARABOLIC : my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::HANNING ? kSound_windowShape::HANNING : - my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::GAUSSIAN ? kSound_windowShape::GAUSSIAN_2 : kSound_windowShape::RECTANGULAR); + my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::GAUSSIAN ? kSound_windowShape::GAUSSIAN_2 : kSound_windowShape::RECTANGULAR + ); autoSpectrum publish = Sound_to_Spectrum (sound.get(), true); Thing_setName (publish.get(), Melder_cat (( my data ? my data -> name.get() : U"untitled" ), - U"_", Melder_fixed (0.5 * (my startSelection + my endSelection), 3))); + U"_", Melder_fixed (0.5 * (my startSelection + my endSelection), 3))); Editor_broadcastPublication (me, publish.move()); } @@ -602,7 +599,8 @@ static void menu_cb_paintVisibleSpectrogram (TimeSoundAnalysisEditor me, EDITOR_ Editor_openPraatPicture (me); Spectrogram_paint (my d_spectrogram.get(), my pictureGraphics, my startWindow, my endWindow, my p_spectrogram_viewFrom, my p_spectrogram_viewTo, my p_spectrogram_maximum, my p_spectrogram_autoscaling, my p_spectrogram_dynamicRange, my p_spectrogram_preemphasis, - my p_spectrogram_dynamicCompression, my p_spectrogram_picture_garnish); + my p_spectrogram_dynamicCompression, my p_spectrogram_picture_garnish + ); FunctionEditor_garnish (me); Editor_closePraatPicture (me); EDITOR_END @@ -716,7 +714,7 @@ static void menu_cb_advancedPitchSettings (TimeSoundAnalysisEditor me, EDITOR_AR static void menu_cb_pitchListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); if (! my p_pitch_show) Melder_throw (U"No pitch contour is visible.\nFirst choose \"Show pitch\" from the Pitch menu."); if (! my d_pitch) { @@ -733,7 +731,7 @@ static void menu_cb_pitchListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT integer i, i1, i2; Sampled_getWindowSamples (my d_pitch.get(), tmin, tmax, & i1, & i2); for (i = i1; i <= i2; i ++) { - double t = Sampled_indexToX (my d_pitch.get(), i); + const double t = Sampled_indexToX (my d_pitch.get(), i); double f0 = Sampled_getValueAtSample (my d_pitch.get(), i, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); f0 = Function_convertToNonlogarithmic (my d_pitch.get(), f0, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); MelderInfo_writeLine (Melder_fixed (t, 6), U" ", Melder_fixed (f0, 6)); @@ -744,7 +742,7 @@ static void menu_cb_pitchListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT static void menu_cb_getPitch (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); if (! my p_pitch_show) Melder_throw (U"No pitch contour is visible.\nFirst choose \"Show pitch\" from the Pitch menu."); if (! my d_pitch) { @@ -766,7 +764,7 @@ static void menu_cb_getPitch (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { static void menu_cb_getMinimumPitch (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax, f0; - int part = makeQueriable (me, false, & tmin, & tmax); + const int part = makeQueriable (me, false, & tmin, & tmax); if (! my p_pitch_show) Melder_throw (U"No pitch contour is visible.\nFirst choose \"Show pitch\" from the Pitch menu."); if (! my d_pitch) { @@ -781,7 +779,7 @@ static void menu_cb_getMinimumPitch (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIR static void menu_cb_getMaximumPitch (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax, f0; - int part = makeQueriable (me, false, & tmin, & tmax); + const int part = makeQueriable (me, false, & tmin, & tmax); if (! my p_pitch_show) Melder_throw (U"No pitch contour is visible.\nFirst choose \"Show pitch\" from the Pitch menu."); if (! my d_pitch) { @@ -872,14 +870,14 @@ static void menu_cb_drawVisiblePitchContour (TimeSoundAnalysisEditor me, EDITOR_ if (! my d_pitch) Melder_throw (theMessage_Cannot_compute_pitch); } Editor_openPraatPicture (me); - double pitchFloor_hidden = Function_convertStandardToSpecialUnit (my d_pitch.get(), my p_pitch_floor, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); - double pitchCeiling_hidden = Function_convertStandardToSpecialUnit (my d_pitch.get(), my p_pitch_ceiling, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); - double pitchFloor_overt = Function_convertToNonlogarithmic (my d_pitch.get(), pitchFloor_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); - double pitchCeiling_overt = Function_convertToNonlogarithmic (my d_pitch.get(), pitchCeiling_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); - double pitchViewFrom_overt = my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewFrom : pitchFloor_overt; - double pitchViewTo_overt = my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewTo : pitchCeiling_overt; + const double pitchFloor_hidden = Function_convertStandardToSpecialUnit (my d_pitch.get(), my p_pitch_floor, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + const double pitchCeiling_hidden = Function_convertStandardToSpecialUnit (my d_pitch.get(), my p_pitch_ceiling, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + const double pitchFloor_overt = Function_convertToNonlogarithmic (my d_pitch.get(), pitchFloor_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + const double pitchCeiling_overt = Function_convertToNonlogarithmic (my d_pitch.get(), pitchCeiling_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + const double pitchViewFrom_overt = ( my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewFrom : pitchFloor_overt ); + const double pitchViewTo_overt = ( my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewTo : pitchCeiling_overt ); Pitch_draw (my d_pitch.get(), my pictureGraphics, my startWindow, my endWindow, pitchViewFrom_overt, pitchViewTo_overt, - my p_pitch_picture_garnish, my p_pitch_picture_speckle, my p_pitch_unit); + my p_pitch_picture_garnish, my p_pitch_picture_speckle, my p_pitch_unit); FunctionEditor_garnish (me); Editor_closePraatPicture (me); EDITOR_END @@ -959,7 +957,7 @@ static void menu_cb_drawVisibleIntensityContour (TimeSoundAnalysisEditor me, EDI } Editor_openPraatPicture (me); Intensity_draw (my d_intensity.get(), my pictureGraphics, my startWindow, my endWindow, my p_intensity_viewFrom, my p_intensity_viewTo, - my p_intensity_picture_garnish); + my p_intensity_picture_garnish); FunctionEditor_garnish (me); Editor_closePraatPicture (me); EDITOR_END @@ -967,7 +965,7 @@ static void menu_cb_drawVisibleIntensityContour (TimeSoundAnalysisEditor me, EDI static void menu_cb_intensityListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); if (! my p_intensity_show) Melder_throw (U"No intensity contour is visible.\nFirst choose \"Show intensity\" from the Intensity menu."); if (! my d_intensity) { @@ -977,15 +975,15 @@ static void menu_cb_intensityListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DI MelderInfo_open (); MelderInfo_writeLine (U"Time_s Intensity_dB"); if (part == TimeSoundAnalysisEditor_PART_CURSOR) { - double intensity = Vector_getValueAtX (my d_intensity.get(), tmin, Vector_CHANNEL_1, Vector_VALUE_INTERPOLATION_LINEAR); + const double intensity = Vector_getValueAtX (my d_intensity.get(), tmin, Vector_CHANNEL_1, kVector_valueInterpolation :: LINEAR); MelderInfo_writeLine (Melder_fixed (tmin, 6), U" ", Melder_fixed (intensity, 6)); } else { integer i, i1, i2; Sampled_getWindowSamples (my d_intensity.get(), tmin, tmax, & i1, & i2); for (i = i1; i <= i2; i ++) { - double t = Sampled_indexToX (my d_intensity.get(), i); - double intensity = Vector_getValueAtX (my d_intensity.get(), t, Vector_CHANNEL_1, Vector_VALUE_INTERPOLATION_NEAREST); - MelderInfo_writeLine (Melder_fixed (t, 6), U" ", Melder_fixed (intensity, 6)); + const double time = Sampled_indexToX (my d_intensity.get(), i); + const double intensity = Vector_getValueAtX (my d_intensity.get(), time, Vector_CHANNEL_1, kVector_valueInterpolation :: NEAREST); + MelderInfo_writeLine (Melder_fixed (time, 6), U" ", Melder_fixed (intensity, 6)); } } MelderInfo_close (); @@ -993,7 +991,7 @@ static void menu_cb_intensityListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DI static void menu_cb_getIntensity (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); if (! my p_intensity_show) Melder_throw (U"No intensity contour is visible.\nFirst choose \"Show intensity\" from the Intensity menu."); if (! my d_intensity) { @@ -1001,7 +999,7 @@ static void menu_cb_getIntensity (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT if (! my d_intensity) Melder_throw (theMessage_Cannot_compute_intensity); } if (part == TimeSoundAnalysisEditor_PART_CURSOR) { - Melder_information (Vector_getValueAtX (my d_intensity.get(), tmin, Vector_CHANNEL_1, Vector_VALUE_INTERPOLATION_LINEAR), U" dB (intensity at CURSOR)"); + Melder_information (Vector_getValueAtX (my d_intensity.get(), tmin, Vector_CHANNEL_1, kVector_valueInterpolation :: LINEAR), U" dB (intensity at CURSOR)"); } else { static const conststring32 methodString [] = { U"median", U"mean-energy", U"mean-sones", U"mean-dB" }; Melder_information (Intensity_getAverage (my d_intensity.get(), tmin, tmax, (int) my p_intensity_averagingMethod), @@ -1011,27 +1009,27 @@ static void menu_cb_getIntensity (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT static void menu_cb_getMinimumIntensity (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax; - int part = makeQueriable (me, false, & tmin, & tmax); + const int part = makeQueriable (me, false, & tmin, & tmax); if (! my p_intensity_show) Melder_throw (U"No intensity contour is visible.\nFirst choose \"Show intensity\" from the Intensity menu."); if (! my d_intensity) { TimeSoundAnalysisEditor_computeIntensity (me); if (! my d_intensity) Melder_throw (theMessage_Cannot_compute_intensity); } - double intensity = Vector_getMinimum (my d_intensity.get(), tmin, tmax, NUM_PEAK_INTERPOLATE_PARABOLIC); + const double intensity = Vector_getMinimum (my d_intensity.get(), tmin, tmax, kVector_peakInterpolation :: PARABOLIC); Melder_information (intensity, U" dB (minimum intensity ", TimeSoundAnalysisEditor_partString_locative (part), U")"); } static void menu_cb_getMaximumIntensity (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax; - int part = makeQueriable (me, false, & tmin, & tmax); + const int part = makeQueriable (me, false, & tmin, & tmax); if (! my p_intensity_show) Melder_throw (U"No intensity contour is visible.\nFirst choose \"Show intensity\" from the Intensity menu."); if (! my d_intensity) { TimeSoundAnalysisEditor_computeIntensity (me); if (! my d_intensity) Melder_throw (theMessage_Cannot_compute_intensity); } - double intensity = Vector_getMaximum (my d_intensity.get(), tmin, tmax, NUM_PEAK_INTERPOLATE_PARABOLIC); + const double intensity = Vector_getMaximum (my d_intensity.get(), tmin, tmax, kVector_peakInterpolation :: PARABOLIC); Melder_information (intensity, U" dB (maximum intensity ", TimeSoundAnalysisEditor_partString_locative (part), U")"); } @@ -1045,7 +1043,7 @@ static void menu_cb_showFormants (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT static void menu_cb_formantSettings (TimeSoundAnalysisEditor me, EDITOR_ARGS_FORM) { EDITOR_FORM (U"Formant settings", U"Intro 5.2. Configuring the formant contours") - POSITIVE (maximumFormant, U"Maximum formant (Hz)", my default_formant_maximumFormant ()) + POSITIVE (formantCeiling, U"Formant ceiling (Hz)", my default_formant_ceiling ()) POSITIVE (numberOfFormants, U"Number of formants", my default_formant_numberOfFormants ()) POSITIVE (windowLength, U"Window length (s)", my default_formant_windowLength ()) REAL (dynamicRange, U"Dynamic range (dB)", my default_formant_dynamicRange ()) @@ -1053,7 +1051,7 @@ static void menu_cb_formantSettings (TimeSoundAnalysisEditor me, EDITOR_ARGS_FOR MUTABLE_LABEL (note1, U"") MUTABLE_LABEL (note2, U"") EDITOR_OK - SET_REAL (maximumFormant, my p_formant_maximumFormant) + SET_REAL (formantCeiling, my p_formant_ceiling) SET_REAL (numberOfFormants, my p_formant_numberOfFormants) SET_REAL (windowLength, my p_formant_windowLength) SET_REAL (dynamicRange, my p_formant_dynamicRange) @@ -1069,7 +1067,7 @@ static void menu_cb_formantSettings (TimeSoundAnalysisEditor me, EDITOR_ARGS_FOR SET_STRING (note2, U"(your \"time step strategy\" has its standard value: automatic)") } EDITOR_DO - my pref_formant_maximumFormant () = my p_formant_maximumFormant = maximumFormant; + my pref_formant_ceiling () = my p_formant_ceiling = formantCeiling; my pref_formant_numberOfFormants () = my p_formant_numberOfFormants = numberOfFormants; my pref_formant_windowLength () = my p_formant_windowLength = windowLength; my pref_formant_dynamicRange () = my p_formant_dynamicRange = dynamicRange; @@ -1131,7 +1129,8 @@ static void menu_cb_drawVisibleFormantContour (TimeSoundAnalysisEditor me, EDITO Editor_openPraatPicture (me); Formant_drawSpeckles (my d_formant.get(), my pictureGraphics, my startWindow, my endWindow, my p_spectrogram_viewTo, my p_formant_dynamicRange, - my p_formant_picture_garnish); + my p_formant_picture_garnish + ); FunctionEditor_garnish (me); Editor_closePraatPicture (me); EDITOR_END @@ -1139,7 +1138,7 @@ static void menu_cb_drawVisibleFormantContour (TimeSoundAnalysisEditor me, EDITO static void menu_cb_formantListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); if (! my p_formant_show) Melder_throw (U"No formant contour is visible.\nFirst choose \"Show formants\" from the Formant menu."); if (! my d_formant) { @@ -1171,7 +1170,7 @@ static void menu_cb_formantListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRE static void do_getFormant (TimeSoundAnalysisEditor me, integer iformant) { double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); if (! my p_formant_show) Melder_throw (U"No formant contour is visible.\nFirst choose \"Show formants\" from the Formant menu."); if (! my d_formant) { @@ -1188,7 +1187,7 @@ static void do_getFormant (TimeSoundAnalysisEditor me, integer iformant) { } static void do_getBandwidth (TimeSoundAnalysisEditor me, integer iformant) { double tmin, tmax; - int part = makeQueriable (me, true, & tmin, & tmax); + const int part = makeQueriable (me, true, & tmin, & tmax); if (! my p_formant_show) Melder_throw (U"No formant contour is visible.\nFirst choose \"Show formants\" from the Formant menu."); if (! my d_formant) { @@ -1296,7 +1295,7 @@ static void menu_cb_drawVisiblePulses (TimeSoundAnalysisEditor me, EDITOR_ARGS_F } Editor_openPraatPicture (me); PointProcess_draw (my d_pulses.get(), my pictureGraphics, my startWindow, my endWindow, - my p_pulses_picture_garnish); + my p_pulses_picture_garnish); FunctionEditor_garnish (me); Editor_closePraatPicture (me); EDITOR_END @@ -1305,7 +1304,7 @@ static void menu_cb_drawVisiblePulses (TimeSoundAnalysisEditor me, EDITOR_ARGS_F static void menu_cb_voiceReport (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { time_t today = time (nullptr); double tmin, tmax; - int part = makeQueriable (me, false, & tmin, & tmax); + const int part = makeQueriable (me, false, & tmin, & tmax); if (! my p_pulses_show) Melder_throw (U"No pulses are visible.\nFirst choose \"Show pulses\" from the Pulses menu."); if (! my d_pulses) { @@ -1325,7 +1324,6 @@ static void menu_cb_voiceReport (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) } static void menu_cb_pulseListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT) { - integer i, i1, i2; double tmin, tmax; makeQueriable (me, false, & tmin, & tmax); if (! my p_pulses_show) @@ -1336,10 +1334,10 @@ static void menu_cb_pulseListing (TimeSoundAnalysisEditor me, EDITOR_ARGS_DIRECT } MelderInfo_open (); MelderInfo_writeLine (U"Time_s"); - i1 = PointProcess_getHighIndex (my d_pulses.get(), tmin); - i2 = PointProcess_getLowIndex (my d_pulses.get(), tmax); - for (i = i1; i <= i2; i ++) { - double t = my d_pulses -> t [i]; + const integer i1 = PointProcess_getHighIndex (my d_pulses.get(), tmin); + const integer i2 = PointProcess_getLowIndex (my d_pulses.get(), tmax); + for (integer i = i1; i <= i2; i ++) { + const double t = my d_pulses -> t [i]; MelderInfo_writeLine (Melder_fixed (t, 12)); } MelderInfo_close (); @@ -1403,9 +1401,8 @@ void structTimeSoundAnalysisEditor :: v_createMenuItems_view_sound_analysis (Edi void structTimeSoundAnalysisEditor :: v_createMenuItems_query (EditorMenu menu) { TimeSoundAnalysisEditor_Parent :: v_createMenuItems_query (menu); - if (d_sound.data || d_longSound.data) { + if (d_sound.data || d_longSound.data) v_createMenuItems_query_log (menu); - } } void structTimeSoundAnalysisEditor :: v_createMenuItems_query_log (EditorMenu menu) { @@ -1419,13 +1416,37 @@ void structTimeSoundAnalysisEditor :: v_createMenuItems_query_log (EditorMenu me EditorMenu_addCommand (menu, U"Log script 4 (...)", GuiMenu_F12 | GuiMenu_COMMAND, menu_cb_logScript4); } +void structTimeSoundAnalysisEditor :: v_createMenuItems_formant (EditorMenu menu) { + formantToggle = EditorMenu_addCommand (menu, U"Show formants", + GuiMenu_CHECKBUTTON | (pref_formant_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showFormants); + EditorMenu_addCommand (menu, U"Formant settings...", 0, menu_cb_formantSettings); + EditorMenu_addCommand (menu, U"Advanced formant settings...", 0, menu_cb_advancedFormantSettings); + EditorMenu_addCommand (menu, U"-- formant query --", 0, nullptr); + EditorMenu_addCommand (menu, U"Query:", GuiMenu_INSENSITIVE, menu_cb_getFrequency /* dummy */); + EditorMenu_addCommand (menu, U"Formant listing", 0, menu_cb_formantListing); + EditorMenu_addCommand (menu, U"Get first formant", GuiMenu_F1, menu_cb_getFirstFormant); + EditorMenu_addCommand (menu, U"Get first bandwidth", 0, menu_cb_getFirstBandwidth); + EditorMenu_addCommand (menu, U"Get second formant", GuiMenu_F2, menu_cb_getSecondFormant); + EditorMenu_addCommand (menu, U"Get second bandwidth", 0, menu_cb_getSecondBandwidth); + EditorMenu_addCommand (menu, U"Get third formant", GuiMenu_F3, menu_cb_getThirdFormant); + EditorMenu_addCommand (menu, U"Get third bandwidth", 0, menu_cb_getThirdBandwidth); + EditorMenu_addCommand (menu, U"Get fourth formant", GuiMenu_F4, menu_cb_getFourthFormant); + EditorMenu_addCommand (menu, U"Get fourth bandwidth", 0, menu_cb_getFourthBandwidth); + EditorMenu_addCommand (menu, U"Get formant...", 0, menu_cb_getFormant); + EditorMenu_addCommand (menu, U"Get bandwidth...", 0, menu_cb_getBandwidth); + v_createMenuItems_formant_picture (menu); + EditorMenu_addCommand (menu, U"-- formant extract --", 0, nullptr); + EditorMenu_addCommand (menu, U"Extract to objects window:", GuiMenu_INSENSITIVE, menu_cb_extractVisibleFormantContour /* dummy */); + EditorMenu_addCommand (menu, U"Extract visible formant contour", 0, menu_cb_extractVisibleFormantContour); +} + void structTimeSoundAnalysisEditor :: v_createMenus_analysis () { EditorMenu menu; if (v_hasSpectrogram ()) { menu = Editor_addMenu (this, U"Spectrum", 0); spectrogramToggle = EditorMenu_addCommand (menu, U"Show spectrogram", - GuiMenu_CHECKBUTTON | (pref_spectrogram_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showSpectrogram); + GuiMenu_CHECKBUTTON | (pref_spectrogram_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showSpectrogram); EditorMenu_addCommand (menu, U"Spectrogram settings...", 0, menu_cb_spectrogramSettings); EditorMenu_addCommand (menu, U"Advanced spectrogram settings...", 0, menu_cb_advancedSpectrogramSettings); EditorMenu_addCommand (menu, U"-- spectrum query --", 0, nullptr); @@ -1445,7 +1466,7 @@ void structTimeSoundAnalysisEditor :: v_createMenus_analysis () { if (v_hasPitch ()) { menu = Editor_addMenu (this, U"Pitch", 0); pitchToggle = EditorMenu_addCommand (menu, U"Show pitch", - GuiMenu_CHECKBUTTON | (pref_pitch_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showPitch); + GuiMenu_CHECKBUTTON | (pref_pitch_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showPitch); EditorMenu_addCommand (menu, U"Pitch settings...", 0, menu_cb_pitchSettings); EditorMenu_addCommand (menu, U"Advanced pitch settings...", 0, menu_cb_advancedPitchSettings); EditorMenu_addCommand (menu, U"-- pitch query --", 0, nullptr); @@ -1467,7 +1488,7 @@ void structTimeSoundAnalysisEditor :: v_createMenus_analysis () { if (v_hasIntensity ()) { menu = Editor_addMenu (this, U"Intensity", 0); intensityToggle = EditorMenu_addCommand (menu, U"Show intensity", - GuiMenu_CHECKBUTTON | (pref_intensity_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showIntensity); + GuiMenu_CHECKBUTTON | (pref_intensity_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showIntensity); EditorMenu_addCommand (menu, U"Intensity settings...", 0, menu_cb_intensitySettings); EditorMenu_addCommand (menu, U"-- intensity query --", 0, nullptr); EditorMenu_addCommand (menu, U"Query:", GuiMenu_INSENSITIVE, menu_cb_getFrequency /* dummy */); @@ -1480,36 +1501,15 @@ void structTimeSoundAnalysisEditor :: v_createMenus_analysis () { EditorMenu_addCommand (menu, U"Extract to objects window:", GuiMenu_INSENSITIVE, menu_cb_extractVisibleIntensityContour /* dummy */); EditorMenu_addCommand (menu, U"Extract visible intensity contour", 0, menu_cb_extractVisibleIntensityContour); } - if (v_hasFormants ()) { menu = Editor_addMenu (this, U"Formant", 0); - formantToggle = EditorMenu_addCommand (menu, U"Show formants", - GuiMenu_CHECKBUTTON | (pref_formant_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showFormants); - EditorMenu_addCommand (menu, U"Formant settings...", 0, menu_cb_formantSettings); - EditorMenu_addCommand (menu, U"Advanced formant settings...", 0, menu_cb_advancedFormantSettings); - EditorMenu_addCommand (menu, U"-- formant query --", 0, nullptr); - EditorMenu_addCommand (menu, U"Query:", GuiMenu_INSENSITIVE, menu_cb_getFrequency /* dummy */); - EditorMenu_addCommand (menu, U"Formant listing", 0, menu_cb_formantListing); - EditorMenu_addCommand (menu, U"Get first formant", GuiMenu_F1, menu_cb_getFirstFormant); - EditorMenu_addCommand (menu, U"Get first bandwidth", 0, menu_cb_getFirstBandwidth); - EditorMenu_addCommand (menu, U"Get second formant", GuiMenu_F2, menu_cb_getSecondFormant); - EditorMenu_addCommand (menu, U"Get second bandwidth", 0, menu_cb_getSecondBandwidth); - EditorMenu_addCommand (menu, U"Get third formant", GuiMenu_F3, menu_cb_getThirdFormant); - EditorMenu_addCommand (menu, U"Get third bandwidth", 0, menu_cb_getThirdBandwidth); - EditorMenu_addCommand (menu, U"Get fourth formant", GuiMenu_F4, menu_cb_getFourthFormant); - EditorMenu_addCommand (menu, U"Get fourth bandwidth", 0, menu_cb_getFourthBandwidth); - EditorMenu_addCommand (menu, U"Get formant...", 0, menu_cb_getFormant); - EditorMenu_addCommand (menu, U"Get bandwidth...", 0, menu_cb_getBandwidth); - v_createMenuItems_formant_picture (menu); - EditorMenu_addCommand (menu, U"-- formant extract --", 0, nullptr); - EditorMenu_addCommand (menu, U"Extract to objects window:", GuiMenu_INSENSITIVE, menu_cb_extractVisibleFormantContour /* dummy */); - EditorMenu_addCommand (menu, U"Extract visible formant contour", 0, menu_cb_extractVisibleFormantContour); + v_createMenuItems_formant (menu); } - + if (v_hasPulses ()) { menu = Editor_addMenu (this, U"Pulses", 0); pulsesToggle = EditorMenu_addCommand (menu, U"Show pulses", - GuiMenu_CHECKBUTTON | (pref_pulses_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showPulses); + GuiMenu_CHECKBUTTON | (pref_pulses_show () ? GuiMenu_TOGGLE_ON : 0), menu_cb_showPulses); EditorMenu_addCommand (menu, U"Advanced pulses settings...", 0, menu_cb_advancedPulsesSettings); EditorMenu_addCommand (menu, U"-- pulses query --", 0, nullptr); EditorMenu_addCommand (menu, U"Query:", GuiMenu_INSENSITIVE, menu_cb_getFrequency /* dummy */); @@ -1570,13 +1570,15 @@ void TimeSoundAnalysisEditor_computeSpectrogram (TimeSoundAnalysisEditor me) { if (my p_spectrogram_show && my endWindow - my startWindow <= my p_longestAnalysis && (! my d_spectrogram || my d_spectrogram -> xmin != my startWindow || my d_spectrogram -> xmax != my endWindow)) { - double margin = my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::GAUSSIAN ? my p_spectrogram_windowLength : 0.5 * my p_spectrogram_windowLength; + const double margin = ( my p_spectrogram_windowShape == kSound_to_Spectrogram_windowShape::GAUSSIAN ? + my p_spectrogram_windowLength : 0.5 * my p_spectrogram_windowLength ); my d_spectrogram.reset(); try { autoSound sound = extractSound (me, my startWindow - margin, my endWindow + margin); my d_spectrogram = Sound_to_Spectrogram (sound.get(), my p_spectrogram_windowLength, my p_spectrogram_viewTo, (my endWindow - my startWindow) / my p_spectrogram_timeSteps, - my p_spectrogram_viewTo / my p_spectrogram_frequencySteps, my p_spectrogram_windowShape, 8.0, 8.0); + my p_spectrogram_viewTo / my p_spectrogram_frequencySteps, my p_spectrogram_windowShape, 8.0, 8.0 + ); my d_spectrogram -> xmin = my startWindow; my d_spectrogram -> xmax = my endWindow; } catch (MelderError) { @@ -1586,21 +1588,23 @@ void TimeSoundAnalysisEditor_computeSpectrogram (TimeSoundAnalysisEditor me) { } static void computePitch_inside (TimeSoundAnalysisEditor me) { - double margin = my p_pitch_veryAccurate ? 3.0 / my p_pitch_floor : 1.5 / my p_pitch_floor; + const double margin = ( my p_pitch_veryAccurate ? 3.0 / my p_pitch_floor : 1.5 / my p_pitch_floor ); my d_pitch. reset(); try { autoSound sound = extractSound (me, my startWindow - margin, my endWindow + margin); - double pitchTimeStep = + const double pitchTimeStep = ( my p_timeStepStrategy == kTimeSoundAnalysisEditor_timeStepStrategy::FIXED_ ? my p_fixedTimeStep : my p_timeStepStrategy == kTimeSoundAnalysisEditor_timeStepStrategy::VIEW_DEPENDENT ? (my endWindow - my startWindow) / my p_numberOfTimeStepsPerView : - 0.0; // the default: determined by pitch floor + 0.0 // the default: determined by pitch floor + ); my d_pitch = Sound_to_Pitch_any (sound.get(), pitchTimeStep, my p_pitch_floor, my p_pitch_method == kTimeSoundAnalysisEditor_pitch_analysisMethod::AUTOCORRELATION ? 3.0 : 1.0, my p_pitch_maximumNumberOfCandidates, ((int) my p_pitch_method - 1) * 2 + my p_pitch_veryAccurate, my p_pitch_silenceThreshold, my p_pitch_voicingThreshold, - my p_pitch_octaveCost, my p_pitch_octaveJumpCost, my p_pitch_voicedUnvoicedCost, my p_pitch_ceiling); + my p_pitch_octaveCost, my p_pitch_octaveJumpCost, my p_pitch_voicedUnvoicedCost, my p_pitch_ceiling + ); my d_pitch -> xmin = my startWindow; my d_pitch -> xmax = my endWindow; } catch (MelderError) { @@ -1622,13 +1626,14 @@ void TimeSoundAnalysisEditor_computeIntensity (TimeSoundAnalysisEditor me) { if (my p_intensity_show && my endWindow - my startWindow <= my p_longestAnalysis && (! my d_intensity || my d_intensity -> xmin != my startWindow || my d_intensity -> xmax != my endWindow)) { - double margin = 3.2 / my p_pitch_floor; + const double margin = 3.2 / my p_pitch_floor; my d_intensity. reset(); try { autoSound sound = extractSound (me, my startWindow - margin, my endWindow + margin); my d_intensity = Sound_to_Intensity (sound.get(), my p_pitch_floor, my endWindow - my startWindow > my p_longestAnalysis ? (my endWindow - my startWindow) / 100 : 0.0, - my p_intensity_subtractMeanPressure); + my p_intensity_subtractMeanPressure + ); my d_intensity -> xmin = my startWindow; my d_intensity -> xmax = my endWindow; } catch (MelderError) { @@ -1642,22 +1647,25 @@ void TimeSoundAnalysisEditor_computeFormants (TimeSoundAnalysisEditor me) { if (my p_formant_show && my endWindow - my startWindow <= my p_longestAnalysis && (! my d_formant || my d_formant -> xmin != my startWindow || my d_formant -> xmax != my endWindow)) { - double margin = my p_formant_windowLength; + const double margin = my p_formant_windowLength; my d_formant. reset(); try { - autoSound sound = - my endWindow - my startWindow > my p_longestAnalysis ? - extractSound (me, - 0.5 * (my startWindow + my endWindow - my p_longestAnalysis) - margin, - 0.5 * (my startWindow + my endWindow + my p_longestAnalysis) + margin) : - extractSound (me, my startWindow - margin, my endWindow + margin); - double formantTimeStep = + autoSound sound = ( my endWindow - my startWindow > my p_longestAnalysis ? + extractSound (me, + 0.5 * (my startWindow + my endWindow - my p_longestAnalysis) - margin, + 0.5 * (my startWindow + my endWindow + my p_longestAnalysis) + margin + ) : + extractSound (me, my startWindow - margin, my endWindow + margin) + ); + const double formantTimeStep = ( my p_timeStepStrategy == kTimeSoundAnalysisEditor_timeStepStrategy::FIXED_ ? my p_fixedTimeStep : my p_timeStepStrategy == kTimeSoundAnalysisEditor_timeStepStrategy::VIEW_DEPENDENT ? (my endWindow - my startWindow) / my p_numberOfTimeStepsPerView : - 0.0; // the default: determined by analysis window length + 0.0 // the default: determined by analysis window length + ); my d_formant = Sound_to_Formant_any (sound.get(), formantTimeStep, - Melder_iround (my p_formant_numberOfFormants * 2.0), my p_formant_maximumFormant, - my p_formant_windowLength, (int) my p_formant_method, my p_formant_preemphasisFrom, 50.0); + Melder_iround (my p_formant_numberOfFormants * 2.0), my p_formant_ceiling, + my p_formant_windowLength, (int) my p_formant_method, my p_formant_preemphasisFrom, 50.0 + ); my d_formant -> xmin = my startWindow; my d_formant -> xmax = my endWindow; } catch (MelderError) { @@ -1672,9 +1680,8 @@ void TimeSoundAnalysisEditor_computePulses (TimeSoundAnalysisEditor me) { (! my d_pulses || my d_pulses -> xmin != my startWindow || my d_pulses -> xmax != my endWindow)) { my d_pulses. reset(); - if (! my d_pitch || my d_pitch -> xmin != my startWindow || my d_pitch -> xmax != my endWindow) { + if (! my d_pitch || my d_pitch -> xmin != my startWindow || my d_pitch -> xmax != my endWindow) computePitch_inside (me); - } if (my d_pitch) { try { autoSound sound = extractSound (me, my startWindow, my endWindow); @@ -1688,17 +1695,17 @@ void TimeSoundAnalysisEditor_computePulses (TimeSoundAnalysisEditor me) { static void TimeSoundAnalysisEditor_v_draw_analysis (TimeSoundAnalysisEditor me) { /* - * d_pitch may not exist yet (if shown at all, it may be going to be created in TimeSoundAnalysisEditor_computePitch (), - * and even if that fails the user should see what the pitch settings are). So we use a dummy object. - */ - double pitchFloor_hidden = Function_convertStandardToSpecialUnit (Thing_dummyObject (Pitch), my p_pitch_floor, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); - double pitchCeiling_hidden = Function_convertStandardToSpecialUnit (Thing_dummyObject (Pitch), my p_pitch_ceiling, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); - double pitchFloor_overt = Function_convertToNonlogarithmic (Thing_dummyObject (Pitch), pitchFloor_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); - double pitchCeiling_overt = Function_convertToNonlogarithmic (Thing_dummyObject (Pitch), pitchCeiling_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); - double pitchViewFrom_overt = my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewFrom : pitchFloor_overt; - double pitchViewTo_overt = my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewTo : pitchCeiling_overt; - double pitchViewFrom_hidden = Function_isUnitLogarithmic (Thing_dummyObject (Pitch), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit) ? log10 (pitchViewFrom_overt) : pitchViewFrom_overt; - double pitchViewTo_hidden = Function_isUnitLogarithmic (Thing_dummyObject (Pitch), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit) ? log10 (pitchViewTo_overt) : pitchViewTo_overt; + d_pitch may not exist yet (if shown at all, it may be going to be created in TimeSoundAnalysisEditor_computePitch (), + and even if that fails the user should see what the pitch settings are). So we use a dummy object. + */ + const double pitchFloor_hidden = Function_convertStandardToSpecialUnit (Thing_dummyObject (Pitch), my p_pitch_floor, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + const double pitchCeiling_hidden = Function_convertStandardToSpecialUnit (Thing_dummyObject (Pitch), my p_pitch_ceiling, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + const double pitchFloor_overt = Function_convertToNonlogarithmic (Thing_dummyObject (Pitch), pitchFloor_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + const double pitchCeiling_overt = Function_convertToNonlogarithmic (Thing_dummyObject (Pitch), pitchCeiling_hidden, Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit); + const double pitchViewFrom_overt = ( my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewFrom : pitchFloor_overt ); + const double pitchViewTo_overt = ( my p_pitch_viewFrom < my p_pitch_viewTo ? my p_pitch_viewTo : pitchCeiling_overt ); + const double pitchViewFrom_hidden = Function_isUnitLogarithmic (Thing_dummyObject (Pitch), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit) ? log10 (pitchViewFrom_overt) : pitchViewFrom_overt; + const double pitchViewTo_hidden = Function_isUnitLogarithmic (Thing_dummyObject (Pitch), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit) ? log10 (pitchViewTo_overt) : pitchViewTo_overt; Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setColour (my graphics.get(), Melder_WHITE); @@ -1711,7 +1718,7 @@ static void TimeSoundAnalysisEditor_v_draw_analysis (TimeSoundAnalysisEditor me) Graphics_setFontSize (my graphics.get(), 10); Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_HALF); Graphics_text (my graphics.get(), 0.5, 0.67, U"(To see the analyses, zoom in to at most ", Melder_half (my p_longestAnalysis), U" seconds,"); - Graphics_text (my graphics.get(), 0.5, 0.33, U"or raise the \"longest analysis\" setting with \"Show analyses\" in the View menu.)"); + Graphics_text (my graphics.get(), 0.5, 0.33, U"or raise the \"longest analysis\" setting with \"Show analyses\" in the View menu.)"); Graphics_setFontSize (my graphics.get(), 12); return; } @@ -1719,19 +1726,21 @@ static void TimeSoundAnalysisEditor_v_draw_analysis (TimeSoundAnalysisEditor me) if (my p_spectrogram_show && my d_spectrogram) { Spectrogram_paintInside (my d_spectrogram.get(), my graphics.get(), my startWindow, my endWindow, my p_spectrogram_viewFrom, my p_spectrogram_viewTo, my p_spectrogram_maximum, my p_spectrogram_autoscaling, - my p_spectrogram_dynamicRange, my p_spectrogram_preemphasis, my p_spectrogram_dynamicCompression); + my p_spectrogram_dynamicRange, my p_spectrogram_preemphasis, my p_spectrogram_dynamicCompression + ); } TimeSoundAnalysisEditor_computePitch (me); if (my p_pitch_show && my d_pitch) { - double periodsPerAnalysisWindow = my p_pitch_method == kTimeSoundAnalysisEditor_pitch_analysisMethod::AUTOCORRELATION ? 3.0 : 1.0; - double greatestNonUndersamplingTimeStep = 0.5 * periodsPerAnalysisWindow / my p_pitch_floor; - double defaultTimeStep = 0.5 * greatestNonUndersamplingTimeStep; - double timeStep = + const double periodsPerAnalysisWindow = ( my p_pitch_method == kTimeSoundAnalysisEditor_pitch_analysisMethod::AUTOCORRELATION ? 3.0 : 1.0 ); + const double greatestNonUndersamplingTimeStep = 0.5 * periodsPerAnalysisWindow / my p_pitch_floor; + const double defaultTimeStep = 0.5 * greatestNonUndersamplingTimeStep; + const double timeStep = ( my p_timeStepStrategy == kTimeSoundAnalysisEditor_timeStepStrategy::FIXED_ ? my p_fixedTimeStep : my p_timeStepStrategy == kTimeSoundAnalysisEditor_timeStepStrategy::VIEW_DEPENDENT ? (my endWindow - my startWindow) / my p_numberOfTimeStepsPerView : - defaultTimeStep; - int undersampled = timeStep > greatestNonUndersamplingTimeStep; - integer numberOfVisiblePitchPoints = (integer) ((my endWindow - my startWindow) / timeStep); + defaultTimeStep + ); + const bool undersampled = ( timeStep > greatestNonUndersamplingTimeStep ); + const integer numberOfVisiblePitchPoints = (integer) ((my endWindow - my startWindow) / timeStep); Graphics_setColour (my graphics.get(), Melder_CYAN); Graphics_setLineWidth (my graphics.get(), 3.0); if ((my p_pitch_drawingMethod == kTimeSoundAnalysisEditor_pitch_drawingMethod::AUTOMATIC && (undersampled || numberOfVisiblePitchPoints < 101)) || @@ -1763,21 +1772,16 @@ static void TimeSoundAnalysisEditor_v_draw_analysis (TimeSoundAnalysisEditor me) Graphics_setColour (my graphics.get(), my p_spectrogram_show ? Melder_YELLOW : Melder_LIME); Graphics_setLineWidth (my graphics.get(), my p_spectrogram_show ? 1.0 : 3.0); Intensity_drawInside (my d_intensity.get(), my graphics.get(), my startWindow, my endWindow, - my p_intensity_viewFrom, my p_intensity_viewTo); + my p_intensity_viewFrom, my p_intensity_viewTo); Graphics_setLineWidth (my graphics.get(), 1.0); Graphics_setColour (my graphics.get(), Melder_BLACK); } - TimeSoundAnalysisEditor_computeFormants (me); - if (my p_formant_show && my d_formant) { - Graphics_setColour (my graphics.get(), Melder_RED); - Graphics_setSpeckleSize (my graphics.get(), my p_formant_dotSize); - Formant_drawSpeckles_inside (my d_formant.get(), my graphics.get(), my startWindow, my endWindow, - my p_spectrogram_viewFrom, my p_spectrogram_viewTo, my p_formant_dynamicRange); - Graphics_setColour (my graphics.get(), Melder_BLACK); - } + + my v_draw_analysis_formants (); + /* - * Draw vertical scales. - */ + Draw vertical scales. + */ if (my p_pitch_show) { double pitchCursor_overt = undefined, pitchCursor_hidden = undefined; Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, pitchViewFrom_hidden, pitchViewTo_hidden); @@ -1792,25 +1796,28 @@ static void TimeSoundAnalysisEditor_v_draw_analysis (TimeSoundAnalysisEditor me) Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_HALF); Graphics_text (my graphics.get(), my endWindow, pitchCursor_hidden, Melder_float (Melder_half (pitchCursor_overt)), U" ", - Function_getUnitText (my d_pitch.get(), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit, Function_UNIT_TEXT_SHORT | Function_UNIT_TEXT_GRAPHICAL)); + Function_getUnitText (my d_pitch.get(), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit, Function_UNIT_TEXT_SHORT | Function_UNIT_TEXT_GRAPHICAL) + ); } if (isundef (pitchCursor_hidden) || Graphics_dyWCtoMM (my graphics.get(), pitchCursor_hidden - pitchViewFrom_hidden) > 5.0) { Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_BOTTOM); Graphics_text (my graphics.get(), my endWindow, pitchViewFrom_hidden - Graphics_dyMMtoWC (my graphics.get(), 0.5), Melder_float (Melder_half (pitchViewFrom_overt)), U" ", - Function_getUnitText (my d_pitch.get(), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit, Function_UNIT_TEXT_SHORT | Function_UNIT_TEXT_GRAPHICAL)); + Function_getUnitText (my d_pitch.get(), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit, Function_UNIT_TEXT_SHORT | Function_UNIT_TEXT_GRAPHICAL) + ); } if (isundef (pitchCursor_hidden) || Graphics_dyWCtoMM (my graphics.get(), pitchViewTo_hidden - pitchCursor_hidden) > 5.0) { Graphics_setTextAlignment (my graphics.get(), Graphics_LEFT, Graphics_TOP); Graphics_text (my graphics.get(), my endWindow, pitchViewTo_hidden, Melder_float (Melder_half (pitchViewTo_overt)), U" ", - Function_getUnitText (my d_pitch.get(), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit, Function_UNIT_TEXT_SHORT | Function_UNIT_TEXT_GRAPHICAL)); + Function_getUnitText (my d_pitch.get(), Pitch_LEVEL_FREQUENCY, (int) my p_pitch_unit, Function_UNIT_TEXT_SHORT | Function_UNIT_TEXT_GRAPHICAL) + ); } } else { Graphics_setTextAlignment (my graphics.get(), Graphics_CENTRE, Graphics_HALF); Graphics_setFontSize (my graphics.get(), 10); Graphics_text (my graphics.get(), 0.5 * (my startWindow + my endWindow), 0.5 * (pitchViewFrom_hidden + pitchViewTo_hidden), - U"(Cannot show pitch contour. Zoom out or change bottom of pitch range in pitch settings.)"); + U"(Cannot show pitch contour. Zoom out or change bottom of pitch range in pitch settings.)"); Graphics_setFontSize (my graphics.get(), 12); } Graphics_setColour (my graphics.get(), Melder_BLACK); @@ -1837,59 +1844,60 @@ static void TimeSoundAnalysisEditor_v_draw_analysis (TimeSoundAnalysisEditor me) Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my p_intensity_viewFrom, my p_intensity_viewTo); if (my d_intensity) { if (my startSelection == my endSelection) { - intensityCursor = Vector_getValueAtX (my d_intensity.get(), my startSelection, Vector_CHANNEL_1, Vector_VALUE_INTERPOLATION_LINEAR); + intensityCursor = Vector_getValueAtX (my d_intensity.get(), my startSelection, Vector_CHANNEL_1, kVector_valueInterpolation :: LINEAR); } else { intensityCursor = Intensity_getAverage (my d_intensity.get(), my startSelection, my endSelection, (int) my p_intensity_averagingMethod); } } Graphics_setColour (my graphics.get(), textColour); - bool intensityCursorVisible = isdefined (intensityCursor) && - intensityCursor > my p_intensity_viewFrom && intensityCursor < my p_intensity_viewTo; + const bool intensityCursorVisible = ( isdefined (intensityCursor) && + intensityCursor > my p_intensity_viewFrom && intensityCursor < my p_intensity_viewTo ); if (intensityCursorVisible) { static const conststring32 methodString [] = { U" (.5)", U" (μE)", U" (μS)", U" (μ)" }; Graphics_setTextAlignment (my graphics.get(), alignment, Graphics_HALF); Graphics_text (my graphics.get(), y, intensityCursor, Melder_float (Melder_half (intensityCursor)), U" dB", - my startSelection == my endSelection ? U"" : methodString [(int) my p_intensity_averagingMethod]); + my startSelection == my endSelection ? U"" : methodString [(int) my p_intensity_averagingMethod] + ); } if (! intensityCursorVisible || Graphics_dyWCtoMM (my graphics.get(), intensityCursor - my p_intensity_viewFrom) > 5.0) { Graphics_setTextAlignment (my graphics.get(), alignment, Graphics_BOTTOM); Graphics_text (my graphics.get(), y, my p_intensity_viewFrom - Graphics_dyMMtoWC (my graphics.get(), 0.5), - Melder_float (Melder_half (my p_intensity_viewFrom)), U" dB"); + Melder_float (Melder_half (my p_intensity_viewFrom)), U" dB"); } if (! intensityCursorVisible || Graphics_dyWCtoMM (my graphics.get(), my p_intensity_viewTo - intensityCursor) > 5.0) { Graphics_setTextAlignment (my graphics.get(), alignment, Graphics_TOP); Graphics_text (my graphics.get(), y, my p_intensity_viewTo, - Melder_float (Melder_half (my p_intensity_viewTo)), U" dB"); + Melder_float (Melder_half (my p_intensity_viewTo)), U" dB"); } Graphics_setColour (my graphics.get(), Melder_BLACK); } } if (my p_spectrogram_show || my p_formant_show) { - bool frequencyCursorVisible = my d_spectrogram_cursor > my p_spectrogram_viewFrom && my d_spectrogram_cursor < my p_spectrogram_viewTo; + const bool frequencyCursorVisible = ( my d_spectrogram_cursor > my p_spectrogram_viewFrom && my d_spectrogram_cursor < my p_spectrogram_viewTo ); Graphics_setWindow (my graphics.get(), my startWindow, my endWindow, my p_spectrogram_viewFrom, my p_spectrogram_viewTo); /* - * Range marks. - */ + Range marks. + */ Graphics_setLineType (my graphics.get(), Graphics_DRAWN); Graphics_setColour (my graphics.get(), Melder_BLACK); if (! frequencyCursorVisible || Graphics_dyWCtoMM (my graphics.get(), my d_spectrogram_cursor - my p_spectrogram_viewFrom) > 5.0) { Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_BOTTOM); Graphics_text (my graphics.get(), my startWindow, my p_spectrogram_viewFrom - Graphics_dyMMtoWC (my graphics.get(), 0.5), - Melder_float (Melder_half (my p_spectrogram_viewFrom)), U" Hz"); + Melder_float (Melder_half (my p_spectrogram_viewFrom)), U" Hz"); } if (! frequencyCursorVisible || Graphics_dyWCtoMM (my graphics.get(), my p_spectrogram_viewTo - my d_spectrogram_cursor) > 5.0) { Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_TOP); Graphics_text (my graphics.get(), my startWindow, my p_spectrogram_viewTo, - Melder_float (Melder_half (my p_spectrogram_viewTo)), U" Hz"); + Melder_float (Melder_half (my p_spectrogram_viewTo)), U" Hz"); } /* - * Cursor lines. - */ + Cursor lines. + */ Graphics_setLineType (my graphics.get(), Graphics_DOTTED); Graphics_setColour (my graphics.get(), Melder_RED); if (frequencyCursorVisible) { - double x = my startWindow, y = my d_spectrogram_cursor; + const double x = my startWindow, y = my d_spectrogram_cursor; Graphics_setTextAlignment (my graphics.get(), Graphics_RIGHT, Graphics_HALF); Graphics_text (my graphics.get(), x, y, Melder_float (Melder_half (y)), U" Hz"); Graphics_line (my graphics.get(), x, y, my endWindow, y); @@ -1900,8 +1908,8 @@ static void TimeSoundAnalysisEditor_v_draw_analysis (TimeSoundAnalysisEditor me) if (our endSelection > our startWindow && our endSelection < our endWindow && our endSelection != our startSelection) Graphics_line (our graphics, our endSelection, our p_spectrogram_viewFrom, our endSelection, our p_spectrogram_viewTo);*/ /* - * Cadre. - */ + Cadre. + */ Graphics_setLineType (my graphics.get(), Graphics_DRAWN); Graphics_setColour (my graphics.get(), Melder_BLACK); Graphics_rectangle (my graphics.get(), my startWindow, my endWindow, my p_spectrogram_viewFrom, my p_spectrogram_viewTo); @@ -1911,6 +1919,18 @@ void structTimeSoundAnalysisEditor :: v_draw_analysis () { TimeSoundAnalysisEditor_v_draw_analysis (this); } +void structTimeSoundAnalysisEditor :: v_draw_analysis_formants () { + TimeSoundAnalysisEditor_computeFormants (this); + if (our p_formant_show && our d_formant) { + Graphics_setSpeckleSize (our graphics.get(), our p_formant_dotSize); + Formant_drawSpeckles_inside (our d_formant.get(), our graphics.get(), our startWindow, our endWindow, + our p_spectrogram_viewFrom, our p_spectrogram_viewTo, our p_formant_dynamicRange, + Melder_RED, Melder_PINK, true + ); + Graphics_setColour (our graphics.get(), Melder_BLACK); + } +} + void structTimeSoundAnalysisEditor :: v_draw_analysis_pulses () { TimeSoundAnalysisEditor_computePulses (this); if (our p_pulses_show && our endWindow - our startWindow <= our p_longestAnalysis && our d_pulses) { @@ -1918,7 +1938,7 @@ void structTimeSoundAnalysisEditor :: v_draw_analysis_pulses () { Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, -1.0, 1.0); Graphics_setColour (our graphics.get(), Melder_BLUE); if (point -> nt < 2000) for (integer i = 1; i <= point -> nt; i ++) { - double t = point -> t [i]; + const double t = point -> t [i]; if (t >= our startWindow && t <= our endWindow) Graphics_line (our graphics.get(), t, -0.9, t, 0.9); } @@ -1926,25 +1946,26 @@ void structTimeSoundAnalysisEditor :: v_draw_analysis_pulses () { } } -bool structTimeSoundAnalysisEditor :: v_click (double xbegin, double ybegin, bool shiftKeyPressed) { - if (our p_pitch_show) { - //Melder_warning (xbegin, U" ", ybegin); - if (xbegin >= our endWindow && ybegin > 0.48 && ybegin <= 0.50) { - our pref_pitch_ceiling () = our p_pitch_ceiling = our p_pitch_ceiling * 1.26; - our d_pitch. reset(); - our d_intensity.reset(); - our d_pulses. reset(); - return FunctionEditor_UPDATE_NEEDED; - } - if (xbegin >= our endWindow && ybegin > 0.46 && ybegin <= 0.48) { - our pref_pitch_ceiling () = our p_pitch_ceiling = our p_pitch_ceiling / 1.26; - our d_pitch. reset(); - our d_intensity. reset(); - our d_pulses. reset(); - return FunctionEditor_UPDATE_NEEDED; +bool structTimeSoundAnalysisEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) { + if (event -> isClick()) { + if (our p_pitch_show) { + if (x_world >= our endWindow && y_fraction > 0.48 && y_fraction <= 0.50) { + our pref_pitch_ceiling () = our p_pitch_ceiling = our p_pitch_ceiling * 1.26; + our d_pitch. reset(); + our d_intensity.reset(); + our d_pulses. reset(); + return FunctionEditor_UPDATE_NEEDED; + } + if (x_world >= our endWindow && y_fraction > 0.46 && y_fraction <= 0.48) { + our pref_pitch_ceiling () = our p_pitch_ceiling = our p_pitch_ceiling / 1.26; + our d_pitch. reset(); + our d_intensity. reset(); + our d_pulses. reset(); + return FunctionEditor_UPDATE_NEEDED; + } } } - return TimeSoundAnalysisEditor_Parent :: v_click (xbegin, ybegin, shiftKeyPressed); + return TimeSoundEditor_Parent :: v_mouseInWideDataView (event, x_world, y_fraction); } void TimeSoundAnalysisEditor_init (TimeSoundAnalysisEditor me, conststring32 title, Function data, Sampled sound, bool ownSound) { diff --git a/fon/TimeSoundAnalysisEditor.h b/fon/TimeSoundAnalysisEditor.h index 20040e4b..c9988388 100644 --- a/fon/TimeSoundAnalysisEditor.h +++ b/fon/TimeSoundAnalysisEditor.h @@ -2,7 +2,7 @@ #define _TimeSoundAnalysisEditor_h_ /* TimeSoundAnalysisEditor.h * - * Copyright (C) 1992-2011,2012,2013,2014 Paul Boersma + * Copyright (C) 1992-2007,2009-2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -42,7 +42,7 @@ Thing_define (TimeSoundAnalysisEditor, TimeSoundEditor) { override; void v_createMenuItems_query (EditorMenu menu) override; - bool v_click (double xWC, double yWC, bool shiftKeyPressed) + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) override; void v_createMenuItems_view_sound (EditorMenu menu) override; @@ -66,8 +66,10 @@ Thing_define (TimeSoundAnalysisEditor, TimeSoundEditor) { virtual void v_createMenuItems_pulses_picture (EditorMenu menu); virtual void v_draw_analysis (); virtual void v_draw_analysis_pulses (); + virtual void v_draw_analysis_formants (); virtual void v_createMenuItems_query_log (EditorMenu menu); virtual void v_createMenus_analysis (); + virtual void v_createMenuItems_formant (EditorMenu menu); virtual void v_createMenuItems_view_sound_analysis (EditorMenu menu); #include "TimeSoundAnalysisEditor_prefs.h" diff --git a/fon/TimeSoundAnalysisEditor_prefs.h b/fon/TimeSoundAnalysisEditor_prefs.h index a4821471..5b42eea3 100644 --- a/fon/TimeSoundAnalysisEditor_prefs.h +++ b/fon/TimeSoundAnalysisEditor_prefs.h @@ -60,7 +60,7 @@ prefs_begin (TimeSoundAnalysisEditor) prefs_add_bool_with_data (TimeSoundAnalysisEditor, intensity_subtractMeanPressure, 1, true) prefs_add_bool_with_data (TimeSoundAnalysisEditor, intensity_picture_garnish, 1, true) prefs_add_bool_with_data (TimeSoundAnalysisEditor, formant_show, 1, false) - prefs_add_double_with_data (TimeSoundAnalysisEditor, formant_maximumFormant, 1, U"5500.0") // Hz + prefs_add_double_with_data (TimeSoundAnalysisEditor, formant_ceiling, 1, U"5500.0") // Hz prefs_add_double_with_data (TimeSoundAnalysisEditor, formant_numberOfFormants, 1, U"5.0") prefs_add_double_with_data (TimeSoundAnalysisEditor, formant_windowLength, 1, U"0.025") // seconds prefs_add_double_with_data (TimeSoundAnalysisEditor, formant_dynamicRange, 1, U"30.0") // dB diff --git a/fon/TimeSoundEditor.cpp b/fon/TimeSoundEditor.cpp index d51a72ab..9d34266f 100644 --- a/fon/TimeSoundEditor.cpp +++ b/fon/TimeSoundEditor.cpp @@ -425,7 +425,7 @@ void structTimeSoundEditor :: v_createMenuItems_view_sound (EditorMenu menu) { void structTimeSoundEditor :: v_updateMenuItems_file () { Sampled sound; - if (our d_sound.data) // cannot do this with "?:", because d_sound.data and d_longSound.data have differemt types + if (our d_sound.data) // cannot do this with "?:", because d_sound.data and d_longSound.data have different types sound = our d_sound.data; else sound = our d_longSound.data; @@ -508,7 +508,7 @@ void TimeSoundEditor_drawSound (TimeSoundEditor me, double globalMinimum, double } for (integer ichan = firstVisibleChannel; ichan <= lastVisibleChannel; ichan ++) { const double cursorFunctionValue = ( longSound ? 0.0 : - Vector_getValueAtX (sound, 0.5 * (my startSelection + my endSelection), ichan, 70) ); + Vector_getValueAtX (sound, 0.5 * (my startSelection + my endSelection), ichan, kVector_valueInterpolation :: SINC70) ); const double ymin = (double) (numberOfVisibleChannels - ichan + my d_sound.channelOffset) / numberOfVisibleChannels; const double ymax = (double) (numberOfVisibleChannels + 1 - ichan + my d_sound.channelOffset) / numberOfVisibleChannels; Graphics_Viewport vp = Graphics_insetViewport (my graphics.get(), 0.0, 1.0, ymin, ymax); @@ -631,45 +631,40 @@ void TimeSoundEditor_drawSound (TimeSoundEditor me, double globalMinimum, double Graphics_rectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); } -bool structTimeSoundEditor :: v_click (double xbegin, double ybegin, bool shiftKeyPressed) { - Sound sound = our d_sound.data; - LongSound longSound = our d_longSound.data; - if (!! sound != !! longSound) { - ybegin = (ybegin - v_getBottomOfSoundArea ()) / (1.0 - v_getBottomOfSoundArea ()); - integer numberOfChannels = ( sound ? sound -> ny : longSound -> numberOfChannels ); - if (numberOfChannels > 8) { - trace (xbegin, U" ", ybegin, U" ", numberOfChannels, U" ", our d_sound.channelOffset); - if (xbegin >= our endWindow && ybegin > 0.875 && ybegin <= 1.000 && our d_sound.channelOffset > 0) { - our d_sound.channelOffset -= 8; - return FunctionEditor_UPDATE_NEEDED; - } - if (xbegin >= our endWindow && ybegin > 0.000 && ybegin <= 0.125 && our d_sound.channelOffset < numberOfChannels - 8) { - our d_sound.channelOffset += 8; - return FunctionEditor_UPDATE_NEEDED; +bool structTimeSoundEditor :: v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) { + if (event -> isClick()) { + Sound sound = our d_sound.data; + LongSound longSound = our d_longSound.data; + if (!! sound != !! longSound) { + y_fraction = (y_fraction - v_getBottomOfSoundArea ()) / (1.0 - v_getBottomOfSoundArea ()); + const integer numberOfChannels = ( sound ? sound -> ny : longSound -> numberOfChannels ); + if (event -> isLeftBottomFunctionKeyPressed()) { + if (numberOfChannels > 1) { + const integer numberOfVisibleChannels = Melder_clippedRight (numberOfChannels, 8_integer); + const integer clickedChannel = our d_sound.channelOffset + + Melder_clipped (1_integer, Melder_ifloor ((1.0 - y_fraction) * numberOfVisibleChannels + 1), numberOfVisibleChannels); + const integer firstVisibleChannel = our d_sound.channelOffset + 1; + const integer lastVisibleChannel = Melder_clippedRight (our d_sound.channelOffset + numberOfVisibleChannels, numberOfChannels); + if (clickedChannel >= firstVisibleChannel && clickedChannel <= lastVisibleChannel) { + our d_sound.muteChannels [clickedChannel] = ! our d_sound.muteChannels [clickedChannel]; + return FunctionEditor_UPDATE_NEEDED; + } + } + } else { + if (numberOfChannels > 8) { + if (x_world >= our endWindow && y_fraction > 0.875 && y_fraction <= 1.000 && our d_sound.channelOffset > 0) { + our d_sound.channelOffset -= 8; + return FunctionEditor_UPDATE_NEEDED; + } + if (x_world >= our endWindow && y_fraction > 0.000 && y_fraction <= 0.125 && our d_sound.channelOffset < numberOfChannels - 8) { + our d_sound.channelOffset += 8; + return FunctionEditor_UPDATE_NEEDED; + } + } } } } - return TimeSoundEditor_Parent :: v_click (xbegin, ybegin, shiftKeyPressed); -} - -bool structTimeSoundEditor :: v_clickB (double xbegin, double ybegin) { - Sound sound = our d_sound.data; - LongSound longSound = our d_longSound.data; - if (!! sound != !! longSound) { - ybegin = (ybegin - v_getBottomOfSoundArea ()) / (1.0 - v_getBottomOfSoundArea ()); - integer numberOfChannels = ( sound ? sound -> ny : longSound -> numberOfChannels ); - if (numberOfChannels > 1) { - integer numberOfVisibleChannels = ( numberOfChannels > 8 ? 8 : numberOfChannels ); - trace (xbegin, U" ", ybegin, U" ", numberOfChannels, U" ", d_sound.channelOffset); - const integer box = Melder_clipped (1_integer, Melder_ifloor (ybegin * numberOfVisibleChannels + 1), numberOfVisibleChannels); - const integer channel = numberOfVisibleChannels - box + 1 + d_sound.channelOffset; - if (Melder_debug == 24) - Melder_casual (U"structTimeSoundEditor :: v_clickB ", ybegin, U" ", channel); - our d_sound.muteChannels [channel] = ! our d_sound.muteChannels [channel]; - return FunctionEditor_UPDATE_NEEDED; - } - } - return TimeSoundEditor_Parent :: v_clickB (xbegin, ybegin); + return TimeSoundEditor_Parent :: v_mouseInWideDataView (event, x_world, y_fraction); } void TimeSoundEditor_init (TimeSoundEditor me, conststring32 title, Function data, Sampled sound, bool ownSound) { diff --git a/fon/TimeSoundEditor.h b/fon/TimeSoundEditor.h index 93ce9f34..ea9a8f99 100644 --- a/fon/TimeSoundEditor.h +++ b/fon/TimeSoundEditor.h @@ -54,10 +54,8 @@ Thing_define (TimeSoundEditor, FunctionEditor) { override; void v_createMenuItems_view (EditorMenu menu) override; - bool v_click (double xbegin, double ybegin, bool shiftKeyPressed) - override; // catch channel scrolling - bool v_clickB (double xbegin, double ybegin) - override; // catch channel muting + bool v_mouseInWideDataView (GuiDrawingArea_MouseEvent event, double x_world, double y_fraction) + override; // catch channel scrolling and channel muting (last checked 2020-07-22) virtual void v_createMenuItems_view_sound (EditorMenu menu); virtual void v_updateMenuItems_file (); diff --git a/fon/Vector.cpp b/fon/Vector.cpp index fc4442b6..fd520fa5 100644 --- a/fon/Vector.cpp +++ b/fon/Vector.cpp @@ -18,76 +18,90 @@ #include "Vector.h" -// -// Vector::getVector () returns a channel or the average of all the channels. -// -double structVector :: v_getVector (integer irow, integer icol) { - if (icol < 1 || icol > our nx) +#include "enums_getText.h" +#include "Vector_enums.h" +#include "enums_getValue.h" +#include "Vector_enums.h" + +Thing_implement (Vector, Matrix, 2); + +/* + Vector::v_getVector () returns the value in channel `rowNumber`, + or if `rowNumber` == 0, then the average value of all the channels. + The value is assumed to be zero in columns outside the domain. +*/ +double structVector :: v_getVector (integer rowNumber, integer columnNumber) { + if (columnNumber < 1 || columnNumber > our nx) return 0.0; - if (ny == 1) - return our z [1] [icol]; // optimization - if (irow == 0) { + if (our ny == 1) + return our z [1] [columnNumber]; // optimization + if (rowNumber == 0) { if (our ny == 2) - return 0.5 * (our z [1] [icol] + our z [2] [icol]); // optimization + return 0.5 * (our z [1] [columnNumber] + our z [2] [columnNumber]); // optimization longdouble sum = 0.0; for (integer channel = 1; channel <= our ny; channel ++) - sum += our z [channel] [icol]; + sum += our z [channel] [columnNumber]; return double (sum / our ny); } - Melder_assert (irow > 0 && irow <= our ny); - return our z [irow] [icol]; + Melder_assert (rowNumber > 0 && rowNumber <= our ny); + return our z [rowNumber] [columnNumber]; } -// -// Vector::getFunction1 () returns a channel or the average of all the channels. -// -double structVector :: v_getFunction1 (integer irow, double x) { - double rcol = (x - our x1) / our dx + 1.0; - integer icol = Melder_ifloor (rcol); - double dcol = rcol - icol; - double z1; - if (icol < 1 || icol > our nx) { - z1 = 0.0; // outside the definition region, Formula is expected to return zero +/* + Vector::v_getFunction1 () returns a channel or the average of all the channels. + There is linear interpolation between columns. + The value is assumed to be zero in columns outside the domain. +*/ +double structVector :: v_getFunction1 (integer rowNumber, double x) { + const double columnNumber_real = (x - our x1) / our dx + 1.0; + const integer leftColumnNumber = Melder_ifloor (columnNumber_real); + const double columnNumber_phase = columnNumber_real - leftColumnNumber; + double leftValue; + if (leftColumnNumber < 1 || leftColumnNumber > our nx) { + leftValue = 0.0; // outside the definition region, Formula is expected to return zero } else if (our ny == 1) { - z1 = z [1] [icol]; // optimization - } else if (irow == 0) { + leftValue = z [1] [leftColumnNumber]; // optimization + } else if (rowNumber == 0) { if (our ny == 2) { - z1 = 0.5 * (our z [1] [icol] + our z [2] [icol]); // optimization + leftValue = 0.5 * (our z [1] [leftColumnNumber] + our z [2] [leftColumnNumber]); // optimization } else { longdouble sum = 0.0; for (integer channel = 1; channel <= ny; channel ++) - sum += our z [channel] [icol]; - z1 = double (sum / our ny); + sum += our z [channel] [leftColumnNumber]; + leftValue = double (sum / our ny); } } else { - Melder_assert (irow > 0 && irow <= our ny); - z1 = our z [irow] [icol]; + Melder_assert (rowNumber > 0 && rowNumber <= our ny); + leftValue = our z [rowNumber] [leftColumnNumber]; } - double z2; - if (icol < 0 || icol >= our nx) { - z2 = 0.0; // outside the definition region, Formula is expected to return zero + const integer rightColumnNumber = leftColumnNumber + 1; + double rightValue; + if (rightColumnNumber < 1 || rightColumnNumber > our nx) { + rightValue = 0.0; // outside the definition region, Formula is expected to return zero } else if (our ny == 1) { - z2 = z [1] [icol + 1]; // optimization - } else if (irow == 0) { + rightValue = z [1] [rightColumnNumber]; // optimization + } else if (rowNumber == 0) { if (our ny == 2) { - z2 = 0.5 * (our z [1] [icol + 1] + our z [2] [icol + 1]); // optimization + rightValue = 0.5 * (our z [1] [rightColumnNumber] + our z [2] [rightColumnNumber]); // optimization } else { longdouble sum = 0.0; for (integer channel = 1; channel <= our ny; channel ++) - sum += our z [channel] [icol + 1]; - z2 = double (sum / our ny); + sum += our z [channel] [rightColumnNumber]; + rightValue = double (sum / our ny); } } else { - Melder_assert (irow > 0 && irow <= our ny); - z2 = z [irow] [icol + 1]; + Melder_assert (rowNumber > 0 && rowNumber <= our ny); + rightValue = z [rowNumber] [rightColumnNumber]; } - return (1.0 - dcol) * z1 + dcol * z2; + return (1.0 - columnNumber_phase) * leftValue + columnNumber_phase * rightValue; } double structVector :: v_getValueAtSample (integer isamp, integer ilevel, int unit) { -// Preconditions: -// 1 <= isamp <= my nx -// 0 <= ilevel <= my ny +/* + Preconditions: + 1 <= isamp <= my nx + 0 <= ilevel <= my ny +*/ double value; if (ilevel > Vector_CHANNEL_AVERAGE) { value = our z [ilevel] [isamp]; @@ -104,39 +118,69 @@ double structVector :: v_getValueAtSample (integer isamp, integer ilevel, int un return isdefined (value) ? our v_convertStandardToSpecialUnit (value, ilevel, unit) : undefined; } -Thing_implement (Vector, Matrix, 2); - /***** Get content. *****/ -// -// Vector_getValueAtX () returns the average of all the interpolated channels. -// -double Vector_getValueAtX (Vector me, double x, integer ilevel, int interpolation) { - double leftEdge = my x1 - 0.5 * my dx, rightEdge = leftEdge + my nx * my dx; +integer kVector_valueInterpolation_to_interpolationDepth (kVector_valueInterpolation valueInterpolationType) { + switch (valueInterpolationType) { + case kVector_valueInterpolation :: UNDEFINED: + return NUM_VALUE_INTERPOLATE_LINEAR; + case kVector_valueInterpolation :: NEAREST: + return NUM_VALUE_INTERPOLATE_NEAREST; + case kVector_valueInterpolation :: LINEAR: + return NUM_VALUE_INTERPOLATE_LINEAR; + case kVector_valueInterpolation :: CUBIC: + return NUM_VALUE_INTERPOLATE_CUBIC; + case kVector_valueInterpolation :: SINC70: + return NUM_VALUE_INTERPOLATE_SINC70; + case kVector_valueInterpolation :: SINC700: + return NUM_VALUE_INTERPOLATE_SINC700; + } + return 0; // never reached +} + +integer kVector_peakInterpolation_to_interpolationDepth (kVector_peakInterpolation peakInterpolationType) { + switch (peakInterpolationType) { + case kVector_peakInterpolation :: UNDEFINED: + return NUM_PEAK_INTERPOLATE_PARABOLIC; + case kVector_peakInterpolation :: NONE: + return NUM_PEAK_INTERPOLATE_NONE; + case kVector_peakInterpolation :: PARABOLIC: + return NUM_PEAK_INTERPOLATE_PARABOLIC; + case kVector_peakInterpolation :: CUBIC: + return NUM_PEAK_INTERPOLATE_CUBIC; + case kVector_peakInterpolation :: SINC70: + return NUM_PEAK_INTERPOLATE_SINC70; + case kVector_peakInterpolation :: SINC700: + return NUM_PEAK_INTERPOLATE_SINC700; + } + return 0; // never reached +} + +/* + Vector_getValueAtX () returns the interpolated value in channel `ilevel`, + or if `ilevel` == 0, then the average of all the interpolated channels. +*/ +double Vector_getValueAtX (Vector me, double x, integer ilevel, kVector_valueInterpolation valueInterpolationType) { + const double leftEdge = my x1 - 0.5 * my dx, rightEdge = leftEdge + my nx * my dx; if (x < leftEdge || x > rightEdge) return undefined; + const integer interpolationDepth = kVector_valueInterpolation_to_interpolationDepth (valueInterpolationType); if (ilevel > Vector_CHANNEL_AVERAGE) { Melder_assert (ilevel <= my ny); - double index_real = (x - my x1) / my dx + 1.0; - return NUM_interpolate_sinc (my z.row (ilevel), index_real, - interpolation == Vector_VALUE_INTERPOLATION_SINC70 ? NUM_VALUE_INTERPOLATE_SINC70 : - interpolation == Vector_VALUE_INTERPOLATION_SINC700 ? NUM_VALUE_INTERPOLATE_SINC700 : - interpolation); + const double index_real = (x - my x1) / my dx + 1.0; + return NUM_interpolate_sinc (my z.row (ilevel), index_real, interpolationDepth); } longdouble sum = 0.0; for (integer ichan = 1; ichan <= my ny; ichan ++) { - double index_real = (x - my x1) / my dx + 1.0; - sum += NUM_interpolate_sinc (my z.row (ichan), index_real, - interpolation == Vector_VALUE_INTERPOLATION_SINC70 ? NUM_VALUE_INTERPOLATE_SINC70 : - interpolation == Vector_VALUE_INTERPOLATION_SINC700 ? NUM_VALUE_INTERPOLATE_SINC700 : - interpolation); + const double index_real = (x - my x1) / my dx + 1.0; + sum += NUM_interpolate_sinc (my z.row (ichan), index_real, interpolationDepth); } return double (sum / my ny); } /***** Get shape. *****/ -void Vector_getMinimumAndX (Vector me, double xmin, double xmax, integer channelNumber, int interpolation, +void Vector_getMinimumAndX (Vector me, double xmin, double xmax, integer channelNumber, kVector_peakInterpolation peakInterpolationType, double *out_minimum, double *out_xOfMinimum) { Melder_assert (channelNumber >= 1 && channelNumber <= my ny); @@ -149,12 +193,12 @@ void Vector_getMinimumAndX (Vector me, double xmin, double xmax, integer channel No samples between xmin and xmax. Try to return the lesser of the values at these two points. */ - double yleft = Vector_getValueAtX (me, xmin, channelNumber, - interpolation > Vector_VALUE_INTERPOLATION_NEAREST ? Vector_VALUE_INTERPOLATION_LINEAR : Vector_VALUE_INTERPOLATION_NEAREST); - double yright = Vector_getValueAtX (me, xmax, channelNumber, - interpolation > Vector_VALUE_INTERPOLATION_NEAREST ? Vector_VALUE_INTERPOLATION_LINEAR : Vector_VALUE_INTERPOLATION_NEAREST); - minimum = yleft < yright ? yleft : yright; - x = yleft == yright ? (xmin + xmax) / 2 : yleft < yright ? xmin : xmax; + kVector_valueInterpolation valueInterpolationType = ( peakInterpolationType > kVector_peakInterpolation :: NONE ? + kVector_valueInterpolation :: LINEAR : kVector_valueInterpolation :: NEAREST ); + const double yleft = Vector_getValueAtX (me, xmin, channelNumber, valueInterpolationType); + const double yright = Vector_getValueAtX (me, xmax, channelNumber, valueInterpolationType); + minimum = std::min (yleft, yright); + x = ( yleft == yright ? (xmin + xmax) / 2.0 : yleft < yright ? xmin : xmax ); } else { minimum = y [imin]; x = imin; @@ -168,7 +212,8 @@ void Vector_getMinimumAndX (Vector me, double xmin, double xmax, integer channel imax --; for (integer i = imin; i <= imax; i ++) { if (y [i] < y [i - 1] && y [i] <= y [i + 1]) { - double i_real, localMinimum = NUMimproveMinimum (y, i, interpolation, & i_real); + double i_real; + const double localMinimum = NUMimproveMinimum (y, i, kVector_peakInterpolation_to_interpolationDepth (peakInterpolationType), & i_real); if (localMinimum < minimum) { minimum = localMinimum; x = i_real; @@ -184,15 +229,15 @@ void Vector_getMinimumAndX (Vector me, double xmin, double xmax, integer channel *out_xOfMinimum = x; } -void Vector_getMinimumAndXAndChannel (Vector me, double xmin, double xmax, int interpolation, +void Vector_getMinimumAndXAndChannel (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType, double *out_minimum, double *out_xOfMinimum, integer *out_channelOfMinimum) { double minimum, xOfMinimum; integer channelOfMinimum = 1; - Vector_getMinimumAndX (me, xmin, xmax, 1, interpolation, & minimum, & xOfMinimum); + Vector_getMinimumAndX (me, xmin, xmax, 1, peakInterpolationType, & minimum, & xOfMinimum); for (integer channel = 2; channel <= my ny; channel ++) { double minimumOfChannel, xOfMinimumOfChannel; - Vector_getMinimumAndX (me, xmin, xmax, channel, interpolation, & minimumOfChannel, & xOfMinimumOfChannel); + Vector_getMinimumAndX (me, xmin, xmax, channel, peakInterpolationType, & minimumOfChannel, & xOfMinimumOfChannel); if (minimumOfChannel < minimum) { minimum = minimumOfChannel; xOfMinimum = xOfMinimumOfChannel; @@ -207,25 +252,25 @@ void Vector_getMinimumAndXAndChannel (Vector me, double xmin, double xmax, int i *out_channelOfMinimum = channelOfMinimum; } -double Vector_getMinimum (Vector me, double xmin, double xmax, int interpolation) { +double Vector_getMinimum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType) { double minimum; - Vector_getMinimumAndXAndChannel (me, xmin, xmax, interpolation, & minimum, nullptr, nullptr); + Vector_getMinimumAndXAndChannel (me, xmin, xmax, peakInterpolationType, & minimum, nullptr, nullptr); return minimum; } -double Vector_getXOfMinimum (Vector me, double xmin, double xmax, int interpolation) { +double Vector_getXOfMinimum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType) { double xOfMinimum; - Vector_getMinimumAndXAndChannel (me, xmin, xmax, interpolation, nullptr, & xOfMinimum, nullptr); + Vector_getMinimumAndXAndChannel (me, xmin, xmax, peakInterpolationType, nullptr, & xOfMinimum, nullptr); return xOfMinimum; } -integer Vector_getChannelOfMinimum (Vector me, double xmin, double xmax, int interpolation) { +integer Vector_getChannelOfMinimum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType) { integer channelOfMinimum; - Vector_getMinimumAndXAndChannel (me, xmin, xmax, interpolation, nullptr, nullptr, & channelOfMinimum); + Vector_getMinimumAndXAndChannel (me, xmin, xmax, peakInterpolationType, nullptr, nullptr, & channelOfMinimum); return channelOfMinimum; } -void Vector_getMaximumAndX (Vector me, double xmin, double xmax, integer channelNumber, int interpolation, +void Vector_getMaximumAndX (Vector me, double xmin, double xmax, integer channelNumber, kVector_peakInterpolation peakInterpolationType, double *out_maximum, double *out_xOfMaximum) { Melder_assert (channelNumber >= 1 && channelNumber <= my ny); @@ -238,12 +283,12 @@ void Vector_getMaximumAndX (Vector me, double xmin, double xmax, integer channel No samples between xmin and xmax. Try to return the greater of the values at these two points. */ - double yleft = Vector_getValueAtX (me, xmin, channelNumber, - interpolation > Vector_VALUE_INTERPOLATION_NEAREST ? Vector_VALUE_INTERPOLATION_LINEAR : Vector_VALUE_INTERPOLATION_NEAREST); - double yright = Vector_getValueAtX (me, xmax, channelNumber, - interpolation > Vector_VALUE_INTERPOLATION_NEAREST ? Vector_VALUE_INTERPOLATION_LINEAR : Vector_VALUE_INTERPOLATION_NEAREST); - maximum = yleft > yright ? yleft : yright; - x = yleft == yright ? (xmin + xmax) / 2 : yleft > yright ? xmin : xmax; + kVector_valueInterpolation valueInterpolationType = ( peakInterpolationType > kVector_peakInterpolation :: NONE ? + kVector_valueInterpolation :: LINEAR : kVector_valueInterpolation :: NEAREST ); + const double yleft = Vector_getValueAtX (me, xmin, channelNumber, valueInterpolationType); + const double yright = Vector_getValueAtX (me, xmax, channelNumber, valueInterpolationType); + maximum = std::max (yleft, yright); + x = ( yleft == yright ? (xmin + xmax) / 2.0 : yleft > yright ? xmin : xmax ); } else { maximum = y [imin]; x = imin; @@ -251,11 +296,14 @@ void Vector_getMaximumAndX (Vector me, double xmin, double xmax, integer channel maximum = y [imax]; x = imax; } - if (imin == 1) imin ++; - if (imax == my nx) imax --; + if (imin == 1) + imin ++; + if (imax == my nx) + imax --; for (i = imin; i <= imax; i ++) { if (y [i] > y [i - 1] && y [i] >= y [i + 1]) { - double i_real, localMaximum = NUMimproveMaximum (y, i, interpolation, & i_real); + double i_real; + const double localMaximum = NUMimproveMaximum (y, i, kVector_peakInterpolation_to_interpolationDepth (peakInterpolationType), & i_real); if (localMaximum > maximum) { maximum = localMaximum; x = i_real; @@ -271,15 +319,15 @@ void Vector_getMaximumAndX (Vector me, double xmin, double xmax, integer channel *out_xOfMaximum = x; } -void Vector_getMaximumAndXAndChannel (Vector me, double xmin, double xmax, int interpolation, +void Vector_getMaximumAndXAndChannel (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType, double *out_maximum, double *out_xOfMaximum, integer *out_channelOfMaximum) { double maximum, xOfMaximum; integer channelOfMaximum = 1; - Vector_getMaximumAndX (me, xmin, xmax, 1, interpolation, & maximum, & xOfMaximum); + Vector_getMaximumAndX (me, xmin, xmax, 1, peakInterpolationType, & maximum, & xOfMaximum); for (integer channel = 2; channel <= my ny; channel ++) { double maximumOfChannel, xOfMaximumOfChannel; - Vector_getMaximumAndX (me, xmin, xmax, channel, interpolation, & maximumOfChannel, & xOfMaximumOfChannel); + Vector_getMaximumAndX (me, xmin, xmax, channel, peakInterpolationType, & maximumOfChannel, & xOfMaximumOfChannel); if (maximumOfChannel > maximum) { maximum = maximumOfChannel; xOfMaximum = xOfMaximumOfChannel; @@ -294,27 +342,27 @@ void Vector_getMaximumAndXAndChannel (Vector me, double xmin, double xmax, int i *out_channelOfMaximum = channelOfMaximum; } -double Vector_getMaximum (Vector me, double xmin, double xmax, int interpolation) { +double Vector_getMaximum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType) { double maximum; - Vector_getMaximumAndXAndChannel (me, xmin, xmax, interpolation, & maximum, nullptr, nullptr); + Vector_getMaximumAndXAndChannel (me, xmin, xmax, peakInterpolationType, & maximum, nullptr, nullptr); return maximum; } -double Vector_getXOfMaximum (Vector me, double xmin, double xmax, int interpolation) { +double Vector_getXOfMaximum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType) { double xOfMaximum; - Vector_getMaximumAndXAndChannel (me, xmin, xmax, interpolation, nullptr, & xOfMaximum, nullptr); + Vector_getMaximumAndXAndChannel (me, xmin, xmax, peakInterpolationType, nullptr, & xOfMaximum, nullptr); return xOfMaximum; } -integer Vector_getChannelOfMaximum (Vector me, double xmin, double xmax, int interpolation) { +integer Vector_getChannelOfMaximum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType) { integer channelOfMaximum; - Vector_getMaximumAndXAndChannel (me, xmin, xmax, interpolation, nullptr, nullptr, & channelOfMaximum); + Vector_getMaximumAndXAndChannel (me, xmin, xmax, peakInterpolationType, nullptr, nullptr, & channelOfMaximum); return channelOfMaximum; } -double Vector_getAbsoluteExtremum (Vector me, double xmin, double xmax, int interpolation) { - double minimum = Vector_getMinimum (me, xmin, xmax, interpolation); - double maximum = Vector_getMaximum (me, xmin, xmax, interpolation); +double Vector_getAbsoluteExtremum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType) { + const double minimum = Vector_getMinimum (me, xmin, xmax, peakInterpolationType); + const double maximum = Vector_getMaximum (me, xmin, xmax, peakInterpolationType); return std::max (fabs (minimum), fabs (maximum)); } @@ -332,9 +380,9 @@ double Vector_getStandardDeviation (Vector me, double xmin, double xmax, integer if (ilevel == Vector_CHANNEL_AVERAGE) { longdouble sum2 = 0.0; for (integer channel = 1; channel <= my ny; channel ++) { - double mean = Vector_getMean (me, xmin, xmax, channel); + const double mean = Vector_getMean (me, xmin, xmax, channel); for (integer i = imin; i <= imax; i ++) { - double diff = my z [channel] [i] - mean; + const double diff = my z [channel] [i] - mean; sum2 += diff * diff; } } @@ -342,10 +390,10 @@ double Vector_getStandardDeviation (Vector me, double xmin, double xmax, integer // because from every channel its own mean was subtracted. // Corollary: a two-channel mono sound will have the same stdev as the corresponding one-channel sound. } - double mean = Vector_getMean (me, xmin, xmax, ilevel); + const double mean = Vector_getMean (me, xmin, xmax, ilevel); longdouble sum2 = 0.0; for (integer i = imin; i <= imax; i ++) { - double diff = my z [ilevel] [i] - mean; + const double diff = my z [ilevel] [i] - mean; sum2 += diff * diff; } return sqrt (double (sum2 / (n - 1))); @@ -376,10 +424,10 @@ void Vector_scale (Vector me, double scale) { /***** Graphics. *****/ -void Vector_draw (Vector me, Graphics g, double *pxmin, double *pxmax, double *pymin, double *pymax, +void Vector_draw (Vector me, Graphics graphics, double *pxmin, double *pxmax, double *pymin, double *pymax, double defaultDy, conststring32 method) { - bool xreversed = *pxmin > *pxmax, yreversed = *pymin > *pymax; + const bool xreversed = ( *pxmin > *pxmax ), yreversed = ( *pymin > *pymax ); if (xreversed) std::swap (*pxmin, *pxmax); if (yreversed) @@ -389,7 +437,7 @@ void Vector_draw (Vector me, Graphics g, double *pxmin, double *pxmax, double *p Domain expressed in sample numbers. */ integer ixmin, ixmax; - integer n = Matrix_getWindowSamplesX (me, *pxmin, *pxmax, & ixmin, & ixmax); + const integer n = Matrix_getWindowSamplesX (me, *pxmin, *pxmax, & ixmin, & ixmax); if (n < 1) return; /* @@ -405,40 +453,41 @@ void Vector_draw (Vector me, Graphics g, double *pxmin, double *pxmax, double *p /* Set coordinates for drawing. */ - Graphics_setInner (g); - Graphics_setWindow (g, xreversed ? *pxmax : *pxmin, xreversed ? *pxmin : *pxmax, yreversed ? *pymax : *pymin, yreversed ? *pymin : *pymax); + Graphics_setInner (graphics); + Graphics_setWindow (graphics, ( xreversed ? *pxmax : *pxmin ), ( xreversed ? *pxmin : *pxmax ), + ( yreversed ? *pymax : *pymin ), ( yreversed ? *pymin : *pymax )); if (str32str (method, U"bars") || str32str (method, U"Bars")) { for (integer ix = ixmin; ix <= ixmax; ix ++) { - double x = Sampled_indexToX (me, ix); + const double x = Sampled_indexToX (me, ix); double y = my z [1] [ix]; double left = x - 0.5 * my dx, right = x + 0.5 * my dx; Melder_clipRight (& y, *pymax); Melder_clipLeft (*pxmin, & left); Melder_clipRight (& right, *pxmax); if (y > *pymin) { - Graphics_line (g, left, y, right, y); - Graphics_line (g, left, y, left, *pymin); - Graphics_line (g, right, y, right, *pymin); + Graphics_line (graphics, left, y, right, y); + Graphics_line (graphics, left, y, left, *pymin); + Graphics_line (graphics, right, y, right, *pymin); } } } else if (str32str (method, U"poles") || str32str (method, U"Poles")) { for (integer ix = ixmin; ix <= ixmax; ix ++) { - double x = Sampled_indexToX (me, ix); - Graphics_line (g, x, 0.0, x, my z [1] [ix]); + const double x = Sampled_indexToX (me, ix); + Graphics_line (graphics, x, 0.0, x, my z [1] [ix]); } } else if (str32str (method, U"speckles") || str32str (method, U"Speckles")) { for (integer ix = ixmin; ix <= ixmax; ix ++) { - double x = Sampled_indexToX (me, ix); - Graphics_speckle (g, x, my z [1] [ix]); + const double x = Sampled_indexToX (me, ix); + Graphics_speckle (graphics, x, my z [1] [ix]); } } else { /* The default: draw as a curve. */ - Graphics_function (g, & my z [1] [0], ixmin, ixmax, + Graphics_function (graphics, & my z [1] [0], ixmin, ixmax, Matrix_columnToX (me, ixmin), Matrix_columnToX (me, ixmax)); } - Graphics_unsetInner (g); + Graphics_unsetInner (graphics); } /* End of file Vector.cpp */ diff --git a/fon/Vector.h b/fon/Vector.h index ce170d31..bc1918ea 100644 --- a/fon/Vector.h +++ b/fon/Vector.h @@ -2,7 +2,7 @@ #define _Vector_h_ /* Vector.h * - * Copyright (C) 1992-2011,2015,2017 Paul Boersma + * Copyright (C) 1992-2005,2007,2011,2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -42,31 +42,30 @@ Thing_define (Vector, Matrix) { VEC channel (integer channelNumber) { return z.row (channelNumber); } }; +#include "Vector_enums.h" +integer kVector_valueInterpolation_to_interpolationDepth (kVector_valueInterpolation valueInterpolationType); +integer kVector_peakInterpolation_to_interpolationDepth (kVector_peakInterpolation peakInterpolationType); + #define Vector_CHANNEL_AVERAGE 0 #define Vector_CHANNEL_1 1 #define Vector_CHANNEL_2 2 -#define Vector_VALUE_INTERPOLATION_NEAREST 0 -#define Vector_VALUE_INTERPOLATION_LINEAR 1 -#define Vector_VALUE_INTERPOLATION_CUBIC 2 -#define Vector_VALUE_INTERPOLATION_SINC70 3 -#define Vector_VALUE_INTERPOLATION_SINC700 4 -double Vector_getValueAtX (Vector me, double x, integer channel, int interpolation); +double Vector_getValueAtX (Vector me, double x, integer channel, kVector_valueInterpolation valueInterpolationType); -void Vector_getMinimumAndX (Vector me, double xmin, double xmax, integer channel, int interpolation, +void Vector_getMinimumAndX (Vector me, double xmin, double xmax, integer channel, kVector_peakInterpolation peakInterpolationType, double *return_minimum, double *return_xOfMinimum); -void Vector_getMinimumAndXAndChannel (Vector me, double xmin, double xmax, int interpolation, +void Vector_getMinimumAndXAndChannel (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType, double *return_minimum, double *return_xOfMinimum, integer *return_channelOfMinimum); -void Vector_getMaximumAndX (Vector me, double xmin, double xmax, integer channel, int interpolation, +void Vector_getMaximumAndX (Vector me, double xmin, double xmax, integer channel, kVector_peakInterpolation peakInterpolationType, double *return_maximum, double *return_xOfMaximum); -void Vector_getMaximumAndXAndChannel (Vector me, double xmin, double xmax, int interpolation, +void Vector_getMaximumAndXAndChannel (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType, double *return_maximum, double *return_xOfMaximum, integer *return_channelOfMaximum); -double Vector_getMinimum (Vector me, double xmin, double xmax, int interpolation); -double Vector_getMaximum (Vector me, double xmin, double xmax, int interpolation); -double Vector_getAbsoluteExtremum (Vector me, double xmin, double xmax, int interpolation); -double Vector_getXOfMinimum (Vector me, double xmin, double xmax, int interpolation); -double Vector_getXOfMaximum (Vector me, double xmin, double xmax, int interpolation); -integer Vector_getChannelOfMinimum (Vector me, double xmin, double xmax, int interpolation); -integer Vector_getChannelOfMaximum (Vector me, double xmin, double xmax, int interpolation); +double Vector_getMinimum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType); +double Vector_getMaximum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType); +double Vector_getAbsoluteExtremum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType); +double Vector_getXOfMinimum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType); +double Vector_getXOfMaximum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType); +integer Vector_getChannelOfMinimum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType); +integer Vector_getChannelOfMaximum (Vector me, double xmin, double xmax, kVector_peakInterpolation peakInterpolationType); double Vector_getMean (Vector me, double xmin, double xmax, integer channel); double Vector_getStandardDeviation (Vector me, double xmin, double xmax, integer channel); diff --git a/fon/Vector_enums.h b/fon/Vector_enums.h new file mode 100644 index 00000000..de92da30 --- /dev/null +++ b/fon/Vector_enums.h @@ -0,0 +1,35 @@ +/* Vector_enums.h + * + * Copyright (C) 2020 Paul Boersma + * + * This code is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or (at + * your option) any later version. + * + * This code is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this work. If not, see . + */ + +enums_begin (kVector_valueInterpolation, 0) + enums_add (kVector_valueInterpolation, 0, NEAREST, U"nearest") + enums_add (kVector_valueInterpolation, 1, LINEAR, U"linear") + enums_add (kVector_valueInterpolation, 2, CUBIC, U"cubic") + enums_add (kVector_valueInterpolation, 3, SINC70, U"sinc70") + enums_add (kVector_valueInterpolation, 4, SINC700, U"sinc700") +enums_end (kVector_valueInterpolation, 4, LINEAR) + +enums_begin (kVector_peakInterpolation, 0) + enums_add (kVector_peakInterpolation, 0, NONE, U"none") + enums_add (kVector_peakInterpolation, 1, PARABOLIC, U"parabolic") + enums_add (kVector_peakInterpolation, 2, CUBIC, U"cubic") + enums_add (kVector_peakInterpolation, 3, SINC70, U"sinc70") + enums_add (kVector_peakInterpolation, 4, SINC700, U"sinc700") +enums_end (kVector_peakInterpolation, 4, PARABOLIC) + +/* End of file Vector_enums.h */ diff --git a/fon/VoiceAnalysis.cpp b/fon/VoiceAnalysis.cpp index c0f66232..2243c923 100644 --- a/fon/VoiceAnalysis.cpp +++ b/fon/VoiceAnalysis.cpp @@ -1,6 +1,6 @@ /* VoiceAnalysis.cpp * - * Copyright (C) 1992-2007,2011,2012,2015-2019 Paul Boersma + * Copyright (C) 1992-2007,2011,2012,2015-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -23,11 +23,12 @@ double PointProcess_getJitter_local (PointProcess me, double tmin, double tmax, double pmin, double pmax, double maximumPeriodFactor) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - integer imin, imax; - integer numberOfPeriods = PointProcess_getWindowPoints (me, tmin, tmax, & imin, & imax) - 1; - if (numberOfPeriods < 2) return undefined; + const MelderIntegerRange pointNumbers = PointProcess_getWindowPoints (me, tmin, tmax); + integer numberOfPeriods = pointNumbers.size() - 1; + if (numberOfPeriods < 2) + return undefined; longdouble sum = 0.0; - for (integer i = imin + 1; i < imax; i ++) { + for (integer i = pointNumbers.first + 1; i < pointNumbers.last; i ++) { const double p1 = my t [i] - my t [i - 1], p2 = my t [i + 1] - my t [i]; const double intervalFactor = p1 > p2 ? p1 / p2 : p2 / p1; if (pmin == pmax || (p1 >= pmin && p1 <= pmax && p2 >= pmin && p2 <= pmax && intervalFactor <= maximumPeriodFactor)) { @@ -44,11 +45,12 @@ double PointProcess_getJitter_local_absolute (PointProcess me, double tmin, doub double pmin, double pmax, double maximumPeriodFactor) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - integer imin, imax; - integer numberOfPeriods = PointProcess_getWindowPoints (me, tmin, tmax, & imin, & imax) - 1; - if (numberOfPeriods < 2) return undefined; + const MelderIntegerRange pointNumbers = PointProcess_getWindowPoints (me, tmin, tmax); + integer numberOfPeriods = pointNumbers.size() - 1; + if (numberOfPeriods < 2) + return undefined; longdouble sum = 0.0; - for (integer i = imin + 1; i < imax; i ++) { + for (integer i = pointNumbers.first + 1; i < pointNumbers.last; i ++) { const double p1 = my t [i] - my t [i - 1], p2 = my t [i + 1] - my t [i]; const double intervalFactor = p1 > p2 ? p1 / p2 : p2 / p1; if (pmin == pmax || (p1 >= pmin && p1 <= pmax && p2 >= pmin && p2 <= pmax && intervalFactor <= maximumPeriodFactor)) { @@ -65,11 +67,12 @@ double PointProcess_getJitter_rap (PointProcess me, double tmin, double tmax, double pmin, double pmax, double maximumPeriodFactor) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - integer imin, imax; - integer numberOfPeriods = PointProcess_getWindowPoints (me, tmin, tmax, & imin, & imax) - 1; - if (numberOfPeriods < 3) return undefined; + const MelderIntegerRange pointNumbers = PointProcess_getWindowPoints (me, tmin, tmax); + integer numberOfPeriods = pointNumbers.size() - 1; + if (numberOfPeriods < 3) + return undefined; longdouble sum = 0.0; - for (integer i = imin + 2; i < imax; i ++) { + for (integer i = pointNumbers.first + 2; i < pointNumbers.last; i ++) { const double p1 = my t [i - 1] - my t [i - 2], p2 = my t [i] - my t [i - 1], p3 = my t [i + 1] - my t [i]; const double intervalFactor1 = p1 > p2 ? p1 / p2 : p2 / p1, intervalFactor2 = p2 > p3 ? p2 / p3 : p3 / p2; if (pmin == pmax || (p1 >= pmin && p1 <= pmax && p2 >= pmin && p2 <= pmax && p3 >= pmin && p3 <= pmax @@ -88,11 +91,12 @@ double PointProcess_getJitter_ppq5 (PointProcess me, double tmin, double tmax, double pmin, double pmax, double maximumPeriodFactor) { Function_unidirectionalAutowindow (me, & tmin, & tmax); - integer imin, imax; - integer numberOfPeriods = PointProcess_getWindowPoints (me, tmin, tmax, & imin, & imax) - 1; - if (numberOfPeriods < 5) return undefined; + const MelderIntegerRange pointNumbers = PointProcess_getWindowPoints (me, tmin, tmax); + integer numberOfPeriods = pointNumbers.size() - 1; + if (numberOfPeriods < 5) + return undefined; longdouble sum = 0.0; - for (integer i = imin + 5; i <= imax; i ++) { + for (integer i = pointNumbers.first + 5; i <= pointNumbers.last; i ++) { const double p1 = my t [i - 4] - my t [i - 5], p2 = my t [i - 3] - my t [i - 4], @@ -264,81 +268,73 @@ void Sound_Pitch_PointProcess_voiceReport (Sound sound, Pitch pitch, PointProces /* Time domain. Should be preceded by something like "Time range of SELECTION:" or so. */ - MelderInfo_write (U" From ", Melder_fixed (tmin, 6), U" to ", Melder_fixed (tmax, 6), U" seconds"); - MelderInfo_writeLine (U" (duration: ", Melder_fixed (tmax - tmin, 6), U" seconds)"); + MelderInfo_writeLine (U" From ", Melder_fixed (tmin, 6), U" to ", Melder_fixed (tmax, 6), U" seconds", + U" (duration: ", Melder_fixed (tmax - tmin, 6), U" seconds)" + ); /* Pitch statistics. */ + const double medianPitch = Pitch_getQuantile (pitch, tmin, tmax, 0.50, kPitch_unit::HERTZ); + const double meanPitch = Pitch_getMean (pitch, tmin, tmax, kPitch_unit::HERTZ); + const double stdevPitch = Pitch_getStandardDeviation (pitch, tmin, tmax, kPitch_unit::HERTZ); + const double minimumPitch = Pitch_getMinimum (pitch, tmin, tmax, kPitch_unit::HERTZ, 1); + const double maximumPitch = Pitch_getMaximum (pitch, tmin, tmax, kPitch_unit::HERTZ, 1); MelderInfo_writeLine (U"Pitch:"); - MelderInfo_writeLine (U" Median pitch: ", Melder_fixed (Pitch_getQuantile (pitch, tmin, tmax, 0.50, kPitch_unit::HERTZ), 3), U" Hz"); - MelderInfo_writeLine (U" Mean pitch: ", Melder_fixed (Pitch_getMean (pitch, tmin, tmax, kPitch_unit::HERTZ), 3), U" Hz"); - MelderInfo_writeLine (U" Standard deviation: ", Melder_fixed (Pitch_getStandardDeviation (pitch, tmin, tmax, kPitch_unit::HERTZ), 3), U" Hz"); - MelderInfo_writeLine (U" Minimum pitch: ", Melder_fixed (Pitch_getMinimum (pitch, tmin, tmax, kPitch_unit::HERTZ, 1), 3), U" Hz"); - MelderInfo_writeLine (U" Maximum pitch: ", Melder_fixed (Pitch_getMaximum (pitch, tmin, tmax, kPitch_unit::HERTZ, 1), 3), U" Hz"); + MelderInfo_writeLine (U" Median pitch: ", Melder_fixed (medianPitch, 3), U" Hz"); + MelderInfo_writeLine (U" Mean pitch: ", Melder_fixed (meanPitch, 3), U" Hz"); + MelderInfo_writeLine (U" Standard deviation: ", Melder_fixed (stdevPitch, 3), U" Hz"); + MelderInfo_writeLine (U" Minimum pitch: ", Melder_fixed (minimumPitch, 3), U" Hz"); + MelderInfo_writeLine (U" Maximum pitch: ", Melder_fixed (maximumPitch, 3), U" Hz"); /* Pulses statistics. */ - double pmin = 0.8 / ceiling, pmax = 1.25 / floor; + const double pmin = 0.8 / ceiling, pmax = 1.25 / floor; // minimum period, maximum period (abbreviated for space) + const MelderIntegerRange pulseNumbers = PointProcess_getWindowPoints (pulses, tmin, tmax); + const integer numberOfPeriods = PointProcess_getNumberOfPeriods (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor); + const double meanPeriod = PointProcess_getMeanPeriod (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor); + const double stdevPeriod = PointProcess_getStdevPeriod (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor); MelderInfo_writeLine (U"Pulses:"); - MelderInfo_writeLine (U" Number of pulses: ", PointProcess_getWindowPoints (pulses, tmin, tmax, nullptr, nullptr)); - MelderInfo_writeLine (U" Number of periods: ", PointProcess_getNumberOfPeriods (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor)); - MelderInfo_writeLine (U" Mean period: ", Melder_fixedExponent (PointProcess_getMeanPeriod (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor), -3, 6), U" seconds"); - MelderInfo_writeLine (U" Standard deviation of period: ", Melder_fixedExponent (PointProcess_getStdevPeriod (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor), -3, 6), U" seconds"); + MelderInfo_writeLine (U" Number of pulses: ", pulseNumbers.size()); + MelderInfo_writeLine (U" Number of periods: ", numberOfPeriods); + MelderInfo_writeLine (U" Mean period: ", Melder_fixedExponent (meanPeriod, -3, 6), U" seconds"); + MelderInfo_writeLine (U" Standard deviation of period: ", Melder_fixedExponent (stdevPeriod, -3, 6), U" seconds"); /* Voicing. */ - integer imin, imax, n = Sampled_getWindowSamples (pitch, tmin, tmax, & imin, & imax), nunvoiced = n; - for (integer i = imin; i <= imax; i ++) { - const Pitch_Frame frame = & pitch -> frames [i]; - if (frame -> intensity >= silenceThreshold) { - for (integer icand = 1; icand <= frame -> nCandidates; icand ++) { - const Pitch_Candidate cand = & frame -> candidates [icand]; - if (cand -> frequency > 0.0 && cand -> frequency < ceiling && cand -> strength >= voicingThreshold) { - nunvoiced --; - break; // next frame - } - } - } - } + const MelderFraction unvoicedFraction = + Pitch_getFractionOfLocallyUnvoicedFrames (pitch, tmin, tmax, ceiling, silenceThreshold, voicingThreshold); + const MelderCountAndFraction breaks = + PointProcess_getCountAndFractionOfVoiceBreaks (pulses, tmin, tmax, pmax); MelderInfo_writeLine (U"Voicing:"); - MelderInfo_write (U" Fraction of locally unvoiced frames: ", Melder_percent (n <= 0 ? undefined : (double) nunvoiced / n, 3)); - MelderInfo_writeLine (U" (", nunvoiced, U" / ", n, U")"); - n = PointProcess_getWindowPoints (pulses, tmin, tmax, & imin, & imax); - integer numberOfVoiceBreaks = 0; - double durationOfVoiceBreaks = 0.0; - if (n > 1) { - bool previousPeriodVoiced = true; - for (integer i = imin + 1; i < imax; i ++) { - double period = pulses -> t [i] - pulses -> t [i - 1]; - if (period > pmax) { - durationOfVoiceBreaks += period; - if (previousPeriodVoiced) { - numberOfVoiceBreaks ++; - previousPeriodVoiced = false; - } - } else { - previousPeriodVoiced = true; - } - } - } - MelderInfo_writeLine (U" Number of voice breaks: ", numberOfVoiceBreaks); - MelderInfo_write (U" Degree of voice breaks: ", Melder_percent (durationOfVoiceBreaks / (tmax - tmin), 3)); - MelderInfo_writeLine (U" (", Melder_fixed (durationOfVoiceBreaks, 6), U" seconds / ", Melder_fixed (tmax - tmin, 6), U" seconds)"); + MelderInfo_writeLine (U" Fraction of locally unvoiced frames: ", Melder_percent (unvoicedFraction.get(), 3), + U" (", unvoicedFraction.numerator, U" / ", unvoicedFraction.denominator, U")" + ); + MelderInfo_writeLine (U" Number of voice breaks: ", breaks.count); + MelderInfo_writeLine (U" Degree of voice breaks: ", Melder_percent (breaks.getFraction (), 3), + U" (", Melder_fixed (breaks.numerator, 6), U" seconds / ", Melder_fixed (breaks.denominator, 6), U" seconds)" + ); /* Jitter. */ - double shimmerLocal, shimmerLocal_dB, apq3, apq5, apq11, dda; + const double jitterLocal = PointProcess_getJitter_local (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor); + const double jitterLocal_s = PointProcess_getJitter_local_absolute (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor); + const double rap = PointProcess_getJitter_rap (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor); + const double ppq5 = PointProcess_getJitter_ppq5 (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor); + const double ddp = PointProcess_getJitter_ddp (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor); MelderInfo_writeLine (U"Jitter:"); - MelderInfo_writeLine (U" Jitter (local): ", Melder_percent (PointProcess_getJitter_local (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor), 3)); - MelderInfo_writeLine (U" Jitter (local, absolute): ", Melder_fixedExponent (PointProcess_getJitter_local_absolute (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor), -6, 3), U" seconds"); - MelderInfo_writeLine (U" Jitter (rap): ", Melder_percent (PointProcess_getJitter_rap (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor), 3)); - MelderInfo_writeLine (U" Jitter (ppq5): ", Melder_percent (PointProcess_getJitter_ppq5 (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor), 3)); - MelderInfo_writeLine (U" Jitter (ddp): ", Melder_percent (PointProcess_getJitter_ddp (pulses, tmin, tmax, pmin, pmax, maximumPeriodFactor), 3)); + MelderInfo_writeLine (U" Jitter (local): ", Melder_percent (jitterLocal, 3)); + MelderInfo_writeLine (U" Jitter (local, absolute): ", Melder_fixedExponent (jitterLocal_s, -6, 3), U" seconds"); + MelderInfo_writeLine (U" Jitter (rap): ", Melder_percent (rap, 3)); + MelderInfo_writeLine (U" Jitter (ppq5): ", Melder_percent (ppq5, 3)); + MelderInfo_writeLine (U" Jitter (ddp): ", Melder_percent (ddp, 3)); /* Shimmer. */ - PointProcess_Sound_getShimmer_multi (pulses, sound, tmin, tmax, pmin, pmax, maximumPeriodFactor, maximumAmplitudeFactor, - & shimmerLocal, & shimmerLocal_dB, & apq3, & apq5, & apq11, & dda); + double shimmerLocal, shimmerLocal_dB, apq3, apq5, apq11, dda; + PointProcess_Sound_getShimmer_multi (pulses, sound, tmin, tmax, pmin, pmax, + maximumPeriodFactor, maximumAmplitudeFactor, + & shimmerLocal, & shimmerLocal_dB, & apq3, & apq5, & apq11, & dda + ); MelderInfo_writeLine (U"Shimmer:"); MelderInfo_writeLine (U" Shimmer (local): ", Melder_percent (shimmerLocal, 3)); MelderInfo_writeLine (U" Shimmer (local, dB): ", Melder_fixed (shimmerLocal_dB, 3), U" dB"); @@ -349,10 +345,13 @@ void Sound_Pitch_PointProcess_voiceReport (Sound sound, Pitch pitch, PointProces /* Harmonicity. */ + const double meanAutocorrelation = Pitch_getMeanStrength (pitch, tmin, tmax, Pitch_STRENGTH_UNIT_AUTOCORRELATION); + const double meanNHR = Pitch_getMeanStrength (pitch, tmin, tmax, Pitch_STRENGTH_UNIT_NOISE_HARMONICS_RATIO); + const double meanHNR_dB = Pitch_getMeanStrength (pitch, tmin, tmax, Pitch_STRENGTH_UNIT_HARMONICS_NOISE_DB); MelderInfo_writeLine (U"Harmonicity of the voiced parts only:"); - MelderInfo_writeLine (U" Mean autocorrelation: ", Melder_fixed (Pitch_getMeanStrength (pitch, tmin, tmax, Pitch_STRENGTH_UNIT_AUTOCORRELATION), 6)); - MelderInfo_writeLine (U" Mean noise-to-harmonics ratio: ", Melder_fixed (Pitch_getMeanStrength (pitch, tmin, tmax, Pitch_STRENGTH_UNIT_NOISE_HARMONICS_RATIO), 6)); - MelderInfo_writeLine (U" Mean harmonics-to-noise ratio: ", Melder_fixed (Pitch_getMeanStrength (pitch, tmin, tmax, Pitch_STRENGTH_UNIT_HARMONICS_NOISE_DB), 3), U" dB"); + MelderInfo_writeLine (U" Mean autocorrelation: ", Melder_fixed (meanAutocorrelation, 6)); + MelderInfo_writeLine (U" Mean noise-to-harmonics ratio: ", Melder_fixed (meanNHR, 6)); + MelderInfo_writeLine (U" Mean harmonics-to-noise ratio: ", Melder_fixed (meanHNR_dB, 3), U" dB"); } catch (MelderError) { Melder_throw (sound, U" & ", pitch, U" & ", pulses, U": voice report not computed."); } diff --git a/fon/manual_Fon.cpp b/fon/manual_Fon.cpp index 0f77baa8..5feefcd9 100644 --- a/fon/manual_Fon.cpp +++ b/fon/manual_Fon.cpp @@ -450,7 +450,7 @@ Excitation Excitation_create (double df, integer nf); result -> z [1] [1..nt] == 0.0; double Excitation_getDistance (Excitation me, Excitation thee); -void Excitation_draw (Excitation me, Graphics g, double fmin, double fmax, double minimum, double maximum, int garnish); +void Excitation_draw (Excitation me, Graphics g, double fmin, double fmax, double minimum, double maximum, bool garnish); Matrix Excitation_to_Matrix (Excitation me); Function: @@ -508,7 +508,7 @@ NORMAL (U"An Intensity object represents an intensity contour at linearly spaced "which is the normative auditory threshold for a 1000-Hz sine wave.") MAN_END -MAN_BEGIN (U"Intensity: Get maximum...", U"ppgb", 20041107) +MAN_BEGIN (U"Intensity: Get maximum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Intensity object.") ENTRY (U"Return value") NORMAL (U"the maximum value within the specified time domain, expressed in dB.") @@ -517,7 +517,7 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored. " "If %t__1_ is not less than %t__2_, the entire time domain of the Intensity is considered.") TAG (U"%%Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " "The standard is Parabolic because of the usual nonlinearity (logarithm) in the computation of intensity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END @@ -549,7 +549,7 @@ NORMAL (U"After you do @@Sound: To Intensity...@, the mean intensity of the resu "which can be found with #Info.") MAN_END -MAN_BEGIN (U"Intensity: Get minimum...", U"ppgb", 20041107) +MAN_BEGIN (U"Intensity: Get minimum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Intensity object.") ENTRY (U"Return value") NORMAL (U"the minimum value within a specified time domain, expressed in dB.") @@ -558,7 +558,7 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored. " "If %t__1_ is not less than %t__2_, the entire time domain of the Intensity is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " "The standard is Parabolic because of the usual nonlinearity (logarithm) in the computation of intensity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END @@ -580,7 +580,7 @@ FORMULA (U"√ {1/(%n-1) ∑__%i=%m..%m+%n-1_ (%x__%i_ - %μ)^2}") NORMAL (U"where %n is the number of frames between %t__1_ and %t__2_. Note the \"minus 1\".") MAN_END -MAN_BEGIN (U"Intensity: Get time of maximum...", U"ppgb", 20041107) +MAN_BEGIN (U"Intensity: Get time of maximum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Intensity object.") ENTRY (U"Return value") NORMAL (U"the time (in seconds) associated with the maximum intensity within a specified time domain.") @@ -589,12 +589,12 @@ TAG (U"%%Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the Intensity is considered.") TAG (U"%%Interpolation") -DEFINITION (U"the interpolation method (None, Parabolic, Cubic, Sinc) of the @@vector peak interpolation@. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " "The standard is Parabolic because of the usual nonlinearity (logarithm) in the computation of intensity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END -MAN_BEGIN (U"Intensity: Get time of minimum...", U"ppgb", 20041107) +MAN_BEGIN (U"Intensity: Get time of minimum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Intensity object.") ENTRY (U"Return value") NORMAL (U"the time (in seconds) associated with the minimum intensity within a specified time domain.") @@ -603,7 +603,7 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the Intensity is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (None, Parabolic, Cubic, Sinc) of the @@vector peak interpolation@. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " "The standard is Parabolic because of the usual nonlinearity (logarithm) in the computation of intensity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END @@ -617,7 +617,7 @@ TAG (U"##Time (s)") DEFINITION (U"the time at which the value is to be evaluated.") TAG (U"##Interpolation") DEFINITION (U"the interpolation method, see @@vector value interpolation@. " - "The standard is Cubic because of the usual nonlinearity (logarithm) in the computation of intensity; " + "The standard is “cubic” because of the usual nonlinearity (logarithm) in the computation of intensity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END diff --git a/fon/manual_Script.cpp b/fon/manual_Script.cpp index 7f5d1ad3..6893f5da 100644 --- a/fon/manual_Script.cpp +++ b/fon/manual_Script.cpp @@ -789,7 +789,7 @@ TAG (U"##undefined") DEFINITION (U"a special value, see @undefined") MAN_END -MAN_BEGIN (U"Formulas 5. Mathematical functions", U"ppgb", 20200405) +MAN_BEGIN (U"Formulas 5. Mathematical functions", U"ppgb", 20200801) TAG (U"##abs (%x)") DEFINITION (U"absolute value") TAG (U"##round (%x)") @@ -870,7 +870,7 @@ DEFINITION (U"a random number drawn from a Gamma distribution with shape paramet TAG (U"##random\\_ initializeWithSeedUnsafelyButPredictably (%seed)") DEFINITION (U"can be used in a script to create a reproducible sequence of random numbers " "(warning: this exceptional situation will continue to exist throughout Praat until you call the following function)") -TAG (U"##random\\_ initializeSafelyAndPredictably ()") +TAG (U"##random\\_ initializeSafelyAndUnpredictably ()") DEFINITION (U"undoes the exceptional situation caused by the previous function") TAG (U"##lnGamma (%x)") DEFINITION (U"logarithm of the \\Ga function") @@ -3349,7 +3349,7 @@ CODE (U"time = stopwatch") CODE (U"writeInfoLine: a, \" \", fixed\\$ (time, 3)") MAN_END -MAN_BEGIN (U"Scripting 6.6. Controlling the user", U"ppgb", 20190827) +MAN_BEGIN (U"Scripting 6.6. Controlling the user", U"ppgb", 20201020) INTRO (U"You can temporarily halt a Praat script:") TAG (U"#pauseScript: %message") DEFINITION (U"suspends execution of the script, and allows the user to interrupt it. " @@ -3372,7 +3372,8 @@ CODE (U"for i to 5") CODE2 (U"#positive: \"Sampling frequency (Hz)\", \"44100.0 (= CD quality)\"") CODE2 (U"#word: \"hi\", \"hhh\"") CODE2 (U"#sentence: \"lo\", \"two words\"") - CODE2 (U"#text: \"ko\", \"jkgkjhkj g gdfg dfg\"") + CODE2 (U"#text: \"shortText\", \"some one-line text here\"") + CODE2 (U"#text: \"longText\", \"some scrollable text here, within a height of 7 lines\", 7") CODE2 (U"#boolean: \"You like it?\", 1") CODE2 (U"if worth < 6") CODE3 (U"#choice: \"Compression\", compression") @@ -3389,6 +3390,8 @@ CODE (U"for i to 5") CODE1 (U"appendInfoLine: number_of_people, \" \", worth, \" \", sampling_frequency, \" \", clicked") CODE1 (U"appendInfoLine: \"Compression: \", compression, \" (\", compression\\$ , \")\"") CODE1 (U"appendInfoLine: \"Number of channels: \", number_of_channels\\$ ") + CODE1 (U"appendInfoLine: \"Short text: \", shortText\\$ ") + CODE1 (U"appendInfoLine: \"Long text: \", longText\\$ ") CODE (U"endfor") NORMAL (U"This example uses several tricks. A useful one is seen with %number_of_channels: " "this is at the same time the value that is passed to #optionMenu (and therefore determines the setting of " @@ -4165,7 +4168,7 @@ NORMAL (U"If you want to see this in a text file, you can copy and paste from th CODE (U"appendFile: \"out.txt\", info\\$ ( )") MAN_END -MAN_BEGIN (U"Script for listing time\\--F0\\--intensity", U"ppgb", 20140112) +MAN_BEGIN (U"Script for listing time\\--F0\\--intensity", U"ppgb", 20200912) INTRO (U"\"I want a list of pitch and intensity values at the same times.\"") NORMAL (U"Since @@Sound: To Pitch...@ and @@Sound: To Intensity...@ do not give values at the same times, " "you create separate pitch and intensity contours with high time resolution, then interpolate. " @@ -4183,9 +4186,9 @@ CODE (U"writeInfoLine: \"Here are the results:\"") CODE (U"for i to (tmax-tmin)/0.01") CODE1 (U"time = tmin + i * 0.01") CODE1 (U"selectObject: \"Pitch pitch\"") - CODE1 (U"pitch = Get value at time: time, \"Hertz\", \"Linear\"") + CODE1 (U"pitch = Get value at time: time, \"Hertz\", \"linear\"") CODE1 (U"selectObject: \"Intensity intensity\"") - CODE1 (U"intensity = Get value at time: time, \"Cubic\"") + CODE1 (U"intensity = Get value at time: time, \"cubic\"") CODE1 (U"appendInfoLine: fixed\\$ (time, 2), \" \", fixed\\$ (pitch, 3), \" \", fixed\\$ (intensity, 3)") CODE (U"endfor") MAN_END @@ -4291,7 +4294,7 @@ CODE (U"endfor") CODE (U"selectObject: sound, textgrid") MAN_END -MAN_BEGIN (U"Demo window", U"ppgb", 20170327) +MAN_BEGIN (U"Demo window", U"ppgb", 20200707) INTRO (U"The Demo window is a window in which you can draw and ask for user input. " "You can use it for demonstrations, presentations, simulations, adaptive listening experiments, " "and stand-alone programs (see @@Scripting 9.1. Turning a script into a stand-alone program@).") @@ -4468,8 +4471,7 @@ NORMAL (U"which returns immediately without waiting and will tell you (via e.g. "whether a mouse or key event happened during drawing or sleeping.") ENTRY (U"Miscellaneous") NORMAL (U"To see whether any function keys are pressed (during a mouse click or key press), " - "you can use ##demoShiftKeyPressed ( )#, ##demoCommandKeyPressed ( )#, ##demoOptionKeyPressed ( )#, and " - "##demoExtraControlKeyPressed ( )#.") + "you can use ##demoShiftKeyPressed ( )#, ##demoCommandKeyPressed ( )#, and ##demoOptionKeyPressed ( )#.") NORMAL (U"To put some text in the title bar of the Demo window, try") CODE (U"#demoWindowTitle: \"This is the title of my presentation\"") ENTRY (U"Tips and Tricks") diff --git a/fon/manual_formant.cpp b/fon/manual_formant.cpp index 77a96b01..a2e7997b 100644 --- a/fon/manual_formant.cpp +++ b/fon/manual_formant.cpp @@ -513,7 +513,7 @@ NORMAL (U"If you want to remove all formant points in F2 between 0.5 and 0.7 sec "you set ##Formant number# to 2, ##From time# to 0.5 s, and ##To time# to 0.7.") MAN_END -MAN_BEGIN (U"Sound: To Formant (burg)...", U"ppgb", 20190331) +MAN_BEGIN (U"Sound: To Formant (burg)...", U"ppgb", 20200608) INTRO (U"A command that creates a @Formant object from every selected @Sound object. " "It performs a short-term spectral analysis, approximating the spectrum of each " "analysis frame by a number of formants.") @@ -526,13 +526,13 @@ DEFINITION (U"the time between the centres of consecutive analysis frames. If th "that is equal to 25 percent of the analysis window length (see below).") TAG (U"##Maximum number of formants") DEFINITION (U"for most analyses of human speech, you will want to extract 5 formants per frame. " - "This, in combination with the ##Maximum formant# setting, is the only way " + "This, in combination with the ##Formant ceiling# setting, is the only way " "in which this procedure will give you results compatible with how people " "tend to interpret formants for vowels, i.e. in terms of " "vowel height (F1) and vowel place (F2). Otherwise, the ##Maximum number of formants# can be any multiple of 0.5, " "you can choose 4, 4.5, 5, 5.5, 6, and so on (see below).") -TAG (U"##Maximum formant (Hz)") -DEFINITION (U"the ceiling of the formant search range, in hertz. It is crucial that you set this to a value suitable for your speaker. " +TAG (U"##Formant ceiling (Hz)") +DEFINITION (U"the maximum frequency of the formant search range, in hertz. It is crucial that you set this to a value suitable for your speaker. " "An average adult female speaker has a vocal tract length that requires an average ceiling of 5500 Hz (which is Praat's standard value), " "an average adult male speaker has a vocal tract length that requires an average ceiling of 5000 Hz, " "and a young child may have a vocal tract length that requires an average ceiling of 8000 Hz. " @@ -563,7 +563,7 @@ DEFINITION (U"the +3 dB point for an inverted low-pass filter with a slope of +6 "See the @@source-filter synthesis@ tutorial for a technical explanation, " "and @@Sound: Pre-emphasize (in-place)...@ for the algorithm.") ENTRY (U"Algorithm") -NORMAL (U"The sound will be resampled to a sampling frequency of twice the value of %%Maximum formant%, " +NORMAL (U"The sound will be resampled to a sampling frequency of twice the value of %%Formant ceiling%, " "with the algorithm described at @@Sound: Resample...@. " "After this, pre-emphasis is applied with the algorithm described at @@Sound: Pre-emphasize (in-place)...@. " "For each analysis window, Praat applies a Gaussian-like window, " @@ -571,12 +571,12 @@ NORMAL (U"The sound will be resampled to a sampling frequency of twice the value "and @@Press et al. (1992)@. The number of \"poles\" that this algorithm computes is twice the %%Maximum number of formants%; " "that's why you can set the %%Maximum number of formants% to any multiple of 0.5).") NORMAL (U"The algorithm will initially find ##Maximum number of formants# formants in the whole range between 0 Hz " - "and ##Maximum formant#. The initially found formants can therefore sometimes have very low frequencies (near 0 Hz) " - "or very high frequencies (near ##Maximum formant#). Such low or high \"formants\" tend to be artefacts of the LPC algorithm, " + "and ##Formant ceiling#. The initially found formants can therefore sometimes have very low frequencies (near 0 Hz) " + "or very high frequencies (near ##Formant ceiling#). Such low or high \"formants\" tend to be artefacts of the LPC algorithm, " "i.e., the algorithm tends to use them to match the spectral slope if that slope differs from the 6 dB/octave assumption. " "Therefore, such low or high \"formants\" cannot usually be associated with the vocal tract resonances that you are looking for. " "In order for you to be able to identify the traditional F1 and F2, " - "all formants below 50 Hz and all formants above ##Maximum formant# minus 50 Hz, " + "all formants below 50 Hz and all formants above ##Formant ceiling# minus 50 Hz, " "are therefore removed. If you don't want this removal, you may experiment with @@Sound: To Formant (keep all)...@ instead. " "If you prefer an algorithm that always yields the requested number of formants, nicely distributed " "across the frequency domain, you may try the otherwise rather unreliable Split-Levinson procedure @@Sound: To Formant (sl)...@.") @@ -590,12 +590,12 @@ ENTRY (U"Settings") NORMAL (U"The same as with @@Sound: To Formant (burg)...@.") ENTRY (U"Algorithm") NORMAL (U"The same as with @@Sound: To Formant (burg)...@. In contrast with that command, " - "however, all formant values are kept, even those below 50 Hz and those above %%Maximum formant% minus 50 Hz. " + "however, all formant values are kept, even those below 50 Hz and those above %%Formant ceiling% minus 50 Hz. " "Although this makes the identification of the traditional F1 and F2 more difficult, " "this might give better results in resynthesis (see @@Sound & Formant: Filter@), but it usually generates funny values instead.") MAN_END -MAN_BEGIN (U"Sound: To Formant (sl)...", U"ppgb", 20021215) +MAN_BEGIN (U"Sound: To Formant (sl)...", U"ppgb", 20200608) INTRO (U"A command that creates a @Formant object from every selected @Sound object. Not recommended for general use.") ENTRY (U"Purpose") NORMAL (U"to perform a short-term spectral analysis, approximating the spectrum of each frame by a number of formants.") @@ -605,7 +605,7 @@ ENTRY (U"Algorithm") NORMAL (U"The algorithm is based on the implementation of the `Split Levinson' algorithm by @@Willems (1986)@. " "This algorithm will always find the requested number of formants in every frame, even if they do not exist. " "The standard routine (@@Sound: To Formant (burg)...@) yields much more reliable formant values, though it is more sensitive " - "to the %%Maximum formant% argument.") + "to the %%Formant ceiling% argument.") NORMAL (U"Because of the general funny behaviour of the Split-Levinson algorithm, we did not bother to implement an analysis " "of the bandwidths. They are all set arbitrarily to 50 Hz.") MAN_END diff --git a/fon/manual_glossary.cpp b/fon/manual_glossary.cpp index 431335e0..b850b0c5 100644 --- a/fon/manual_glossary.cpp +++ b/fon/manual_glossary.cpp @@ -521,7 +521,7 @@ MAN_BEGIN (U"total duration", U"ppgb", 20040505) INTRO (U"- the extent of the @@time domain@ (see there).") MAN_END -MAN_BEGIN (U"vector peak interpolation", U"ppgb", 20010410) +MAN_BEGIN (U"vector peak interpolation", U"ppgb", 20200912) INTRO (U"An algorithm for finding a maximum or a minimum in a sampled signal.") ENTRY (U"Overview") NORMAL (U"The signal is described with the sequence %y__%i_, %i = 1...%n, where %n is the number of samples. " @@ -536,11 +536,11 @@ LIST_ITEM (U"2. The local maxima, which are at or %near %y__%i_, where %y__%i-1_ LIST_ITEM (U"3. %y__%n_.") NORMAL (U"We will now see what %near means. The precision of the result depends on the %%interpolation method% of this algorithm.") ENTRY (U"1. Lowest precision: round to sample") -NORMAL (U"If the interpolation method is None, the local maxima are %at the samples %m that satisfy %y__%m-1_ < %y__%m_ ≤ %y__%m+1_. " +NORMAL (U"If the interpolation method is “none”, the local maxima are %at the samples %m that satisfy %y__%m-1_ < %y__%m_ ≤ %y__%m+1_. " "Thus, their %x values are at %x__%m_ = %x__1_ + (%m - 1) %dx, and their %y values are %y__%m_.") NORMAL (U"This kind of precision is appropriate for an unordered sequence of values %y__%i_: the result is simply the greatest available value.") ENTRY (U"2. Middle precision: parabolic interpolation") -NORMAL (U"If the interpolation method is Parabolic, the algorithm uses one point on each side of every local maximum %y__%m_ " +NORMAL (U"If the interpolation method is “parabolic”, the algorithm uses one point on each side of every local maximum %y__%m_ " "to estimate the location and value of the local maximum. Because a Taylor expansion shows that any smooth curve " "can be approximated as a parabola in the vicinity of any local maximum, the location %x__%max_ and value %y__%max_ can be found " "with the following procedure:") @@ -559,12 +559,12 @@ LIST_ITEM (U"@@Intensity: Get time of minimum...") LIST_ITEM (U"@@Intensity: Get maximum...") LIST_ITEM (U"@@Intensity: Get time of maximum...") ENTRY (U"3. Higher precision: cubic interpolation") -NORMAL (U"If the interpolation method is Cubic, the interpolation is performed over four points (see @@vector value interpolation@). " +NORMAL (U"If the interpolation method is “cubic”, the interpolation is performed over four points (see @@vector value interpolation@). " "The results are similar to those of the parabolic interpolation method, but you can use it (or sinc interpolation) if you want the result of a " "command like ##Get maximum...# to be equal to the result of a sequence of commands like " "##Get time of maximum...# and ##Get value at time...#.") ENTRY (U"4. Highest precision: sinc interpolation") -NORMAL (U"If the interpolation method is Sinc70 or Sinc700, the algorithm assumes that the signal " +NORMAL (U"If the interpolation method is “sinc70” or “sinc700”, the algorithm assumes that the signal " "is a sum of sinc functions, so that a number of points (namely, 70 or 700) on each side of the initial guess %m must be taken into account " "(see @@vector value interpolation@). The algorithm finds the maximum of this continuous function by Brent's method (see @@Press et al. (1992)@).") NORMAL (U"This method is appropriate for signals that result from sampling a continuous signal after it has been low-pass filtered " @@ -576,7 +576,7 @@ LIST_ITEM (U"@@Sound: Get time of maximum...") LIST_ITEM (U"@@Sound: Get absolute extremum...") MAN_END -MAN_BEGIN (U"vector value interpolation", U"ppgb", 19980104) +MAN_BEGIN (U"vector value interpolation", U"ppgb", 20200912) INTRO (U"An algorithm for estimating the value of a sampled signal at a specified location.") ENTRY (U"Overview") NORMAL (U"The signal is described with the sequence %y__%i_, %i = 1...%n, where %n is the number of samples. " @@ -586,7 +586,7 @@ FORMULA (U"%s = (%x - %x__1_) / %dx + 1") NORMAL (U"If the resulting %s is an integer number, the %y value must be %y__%s_. Otherwise, the estimated %y value %y(%s) must be interpolated " "from nearby values of %y. The precision of the result depends on the %%interpolation method% of this algorithm.") ENTRY (U"1. Lowest precision: round to sample") -NORMAL (U"If the interpolation method is Nearest, we take the value of the nearest point:") +NORMAL (U"If the interpolation method is “nearest”, we take the value of the nearest point in either direction:") FORMULA (U"%near ≡ round (%s)") FORMULA (U"%y(%s) ≈ %y__%near_") ENTRY (U"2. Middle precision: linear interpolation") @@ -600,7 +600,7 @@ ENTRY (U"3. Higher precision: cubic interpolation") NORMAL (U"If you know or assume that the function that underlies your points is %smooth, i.e. its derivative is defined for every %x, " "linear interpolation would probably be poor, because the derivative of the interpolated function would abruptly change at every " "sample point.") -NORMAL (U"The next higher interpolation (Cubic), therefore, is differentiable at sample points. To enforce this, we define the " +NORMAL (U"The next higher interpolation (“cubic”), therefore, is differentiable at sample points. To enforce this, we define the " "derivatives %y′__%l_ and %y′__%r_ at the left and right sample points on the basis of %their immediate neighbours " "(i.e., the algorithm needs four sample points), perhaps by a parabolic interpolation through these three points. " "A parabolic interpolation has the advantage that the extrema will be computed correctly if " @@ -635,7 +635,7 @@ LIST_ITEM (U"3. If %y′__%l_ + %y′__%r_ equals 2(%y__%r_ - %y__%l_), the thir LIST_ITEM (U"4. At the left and right points, one of the %φ is 0 and the other is 1, so that at these boundary points, " "%y is computed with exact precision.") ENTRY (U"4. Highest precision: sinc interpolation") -NORMAL (U"If the interpolation method is Sinc70 or Sinc700, the algorithm assumes that the signal " +NORMAL (U"If the interpolation method is “sinc70” or “sinc700”, the algorithm assumes that the signal " "is a sum of sinc functions, so that a number of points (the %%interpolation depth%: 70 or 700) on each side of %s must be taken into account.") NORMAL (U"Because the interpolation depth must be finite, the sum of sinc functions is multiplied by a Hanning window:") FORMULA (U"%s__%l_ ≡ floor (%s); %s__%r_ ≡ %s__%l_ + 1") diff --git a/fon/manual_pitch.cpp b/fon/manual_pitch.cpp index 8ffccf76..d5e17b93 100644 --- a/fon/manual_pitch.cpp +++ b/fon/manual_pitch.cpp @@ -56,7 +56,7 @@ INTRO (U"A command for changing the data in all selected @Harmonicity objects.") NORMAL (U"See the @Formulas tutorial for examples and explanations.") MAN_END -MAN_BEGIN (U"Harmonicity: Get maximum...", U"ppgb", 20030916) +MAN_BEGIN (U"Harmonicity: Get maximum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Harmonicity object.") ENTRY (U"Return value") NORMAL (U"the maximum value, expressed in dB.") @@ -66,7 +66,7 @@ TAG (U"##To time (s)") DEFINITION (U"the selected time domain. Values outside this domain are ignored. " "If ##To time# is not greater than ##From time#, the entire time domain of the Harmonicity object is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc, #sinc700) of the @@vector peak interpolation@. " "The standard is Parabolic because of the usual nonlinearity (logarithm) in the computation of harmonicity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END @@ -87,7 +87,7 @@ NORMAL (U"where %x(%t) is the harmonicity (in dB) as a function of time. " "are ignored. If all the frames are silent, the returned value is @undefined.") MAN_END -MAN_BEGIN (U"Harmonicity: Get minimum...", U"ppgb", 20041107) +MAN_BEGIN (U"Harmonicity: Get minimum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Harmonicity object.") ENTRY (U"Return value") NORMAL (U"the minimum value, expressed in dB.") @@ -96,7 +96,7 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the Harmonicity is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " "The standard is Parabolic because of the usual nonlinearity (logarithm) in the computation of harmonicity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END @@ -118,7 +118,7 @@ FORMULA (U"1/(%n-1) \\su__%i=%m..%m+%n-1_ (%x__%i_ - %\\mu)^2") NORMAL (U"where %n is the number of frame centres between %t__1_ and %t__2_. Note the \"minus 1\".") MAN_END -MAN_BEGIN (U"Harmonicity: Get time of maximum...", U"ppgb", 20041107) +MAN_BEGIN (U"Harmonicity: Get time of maximum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Harmonicity object for the time associated with its maximum value.") ENTRY (U"Return value") NORMAL (U"the time (in seconds) associated with the maximum HNR value.") @@ -127,12 +127,12 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the Harmonicity is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " "The standard is Parabolic because of the usual nonlinearity (logarithm) in the computation of harmonicity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END -MAN_BEGIN (U"Harmonicity: Get time of minimum...", U"ppgb", 20041107) +MAN_BEGIN (U"Harmonicity: Get time of minimum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Harmonicity object.") ENTRY (U"Return value") NORMAL (U"the time (in seconds) associated with the minimum HNR value.") @@ -141,7 +141,7 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the Harmonicity is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " "The standard is Parabolic because of the usual nonlinearity (logarithm) in the computation of harmonicity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END @@ -156,7 +156,7 @@ TAG (U"##Time (s)") DEFINITION (U"the time at which the value is to be evaluated.") TAG (U"##Interpolation") DEFINITION (U"the interpolation method, see @@vector value interpolation@. " - "The standard is Cubic because of the usual nonlinearity (logarithm) in the computation of harmonicity; " + "The standard is “cubic” because of the usual nonlinearity (logarithm) in the computation of harmonicity; " "sinc interpolation would be too stiff and may give unexpected results.") MAN_END diff --git a/fon/manual_programming.cpp b/fon/manual_programming.cpp index de15284f..e3e05d21 100644 --- a/fon/manual_programming.cpp +++ b/fon/manual_programming.cpp @@ -387,7 +387,7 @@ NORMAL (U"Besides the TextGrid text file format described above, TextGrid object "and save the resulting TextGrid object as a text file with @@Save as text file...@.") MAN_END -MAN_BEGIN (U"Programming with Praat", U"ppgb", 20151028) +MAN_BEGIN (U"Programming with Praat", U"ppgb", 20200924) INTRO (U"You can extend the functionality of the Praat program " "by adding modules written in C or C++ to it. All of Praat's source code " "is available under the General Public Licence.") @@ -399,11 +399,11 @@ NORMAL (U"Before trying the task of learning how to write Praat extensions in C "If you have a set of scripts, you can distribute them as a @@plug-ins|plug-in@.") ENTRY (U"2. Getting the existing source code") NORMAL (U"You obtain the Praat source code from GitHub (https://github.com/praat), in a file with a name like " - "##praat5423_sources.zip# or ##praat5423_sources.tar.gz# (depending on the Praat version), and unpack this by double-clicking. " + "##praat6121_sources.zip# or ##praat6121_sources.tar.gz# (depending on the Praat version), and unpack this by double-clicking. " "The result will be a set of directories " - "called #kar, #num, #external (with #GSL, #glpk, #FLAC, #mp3, #portaudio and #espeak in it), " - "#sys, #dwsys, #stat, #fon, #dwtools, #LPC, #FFNet, #gram, #artsynth, #EEG, #contrib, #main, #makefiles, #test, and #dwtest, " - "plus a makefile and an Xcode project for MacOS X.") + "called #kar, #melder, #external (with #clapack, #gsl, #glpk, #flac, #mp3, #portaudio and #espeak in it), " + "#sys, #dwsys, #stat, #fon, #dwtools, #LPC, #FFNet, #gram, #artsynth, #EEG, #main, #makefiles, #test, #dwtest, and #generate," + "plus a makefile and Xcode project for MacOS X and a README.md file.") ENTRY (U"3. Building Praat") NORMAL (U"Consult the README file on GitHub for directions to compile and link Praat for your platform.") ENTRY (U"4. Extending Praat") @@ -412,9 +412,9 @@ NORMAL (U"To start extending Praat’s functionality, you can edit ##main/main_P "of the Praat program, and a single bit more (namely an additional command in the New menu):") CODE (U"\\# include \"praat.h\"") CODE (U"") -CODE (U"DIRECT (HelloFromJane)") +CODE (U"DIRECT (HelloFromJane) {") CODE1 (U"Melder_information (U\"Hello, I am Jane.\");") -CODE (U"END") +CODE (U"}") CODE (U"") CODE (U"int main (int argc, char **argv) {") CODE1 (U"praat_init (U\"Praat_Jane\", argc, argv);") @@ -430,8 +430,8 @@ NORMAL (U"To see how objects are defined, take a look at ##sys/Thing.h#, ##sys/D "in the fixed and dynamic menus, take a look at the large interface description file " "##fon/praat_Fon.cpp#.") ENTRY (U"6. Using the Praat shell only") -NORMAL (U"For building the Praat shell (the Objects and Picture windows) only, you need only the code in the eight directories " - "#kar, #GSL, #num, ##external/{FLAC,MP3,portaudio}#, #sys, and #dwsys. You delete the inclusion of praat_uvafon_init from #main. " +NORMAL (U"For building the Praat shell (the Objects and Picture windows) only, you need only the code in the nine directories " + "#kar, #melder, ##external/{clapack,gsl,flac,mp3,portaudio}#, #sys, and #dwsys. You delete the inclusion of praat_uvafon_init from #main. " "You will be able to build a Praat shell, i.e. an Objects and a Picture window, " "which has no knowledge of the world, i.e., which does not know any objects " "that can be included in the list of objects. You could use this Praat shell " diff --git a/fon/manual_sound.cpp b/fon/manual_sound.cpp index 23f27331..83fb5231 100644 --- a/fon/manual_sound.cpp +++ b/fon/manual_sound.cpp @@ -731,7 +731,7 @@ NORMAL (U"For the intensity in Watt/m^2, see @@Sound: Get power in air@. For an "see @@Excitation: Get loudness@.") MAN_END -MAN_BEGIN (U"Sound: Get maximum...", U"ppgb", 20041123) +MAN_BEGIN (U"Sound: Get maximum...", U"ppgb", 20200912) INTRO (U"A command available in the #Query menu if you select a @Sound object. " "The Info window will show the maximum amplitude (sound pressure in Pascal) within a specified time window.") ENTRY (U"Settings") @@ -739,8 +739,8 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the sound is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " - "The standard is #Sinc70 because a Sound object is normally a sampled band-limited signal, " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " + "The standard is “sinc70” because a Sound object is normally a sampled band-limited signal, " "which can be seen as a sum of sinc functions.") MAN_END @@ -757,7 +757,7 @@ FORMULA (U"1/(%t__2_ - %t__1_) \\in__%%t%1_^^%%t%2^ %x(%t) %dt") NORMAL (U"where %x(%t) is the amplitude of the sound in Pa.") MAN_END -MAN_BEGIN (U"Sound: Get minimum...", U"ppgb", 20041123) +MAN_BEGIN (U"Sound: Get minimum...", U"ppgb", 20200912) INTRO (U"A command available in the #Query menu if you select a @Sound object. " "The Info window will show the minimum amplitude (sound pressure in Pascal) within a specified time window.") ENTRY (U"Settings") @@ -765,8 +765,8 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the sound is considered.") TAG (U"%%Interpolation") -DEFINITION (U"the interpolation method (None, Parabolic, Cubic, Sinc) of the @@vector peak interpolation@. " - "The standard is Sinc70 because a Sound object is normally a sampled band-limited signal, " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " + "The standard is “sinc70” because a Sound object is normally a sampled band-limited signal, " "which can be seen as a sum of sinc functions.") MAN_END @@ -843,7 +843,7 @@ FORMULA (U"1/(%n-1) \\su__%i=%m..%m+%n-1_ (%x__%i_ - %\\mu)^2") NORMAL (U"where %n is the number of sample centres between %t__1_ and %t__2_. Note the \"minus 1\".") MAN_END -MAN_BEGIN (U"Sound: Get time of maximum...", U"ppgb", 20041123) +MAN_BEGIN (U"Sound: Get time of maximum...", U"ppgb", 20200912) INTRO (U"A command available in the #Query menu if you select a @Sound object. " "The Info window will show the time (in seconds) associated with the maximum pressure in a specified time range.") ENTRY (U"Settings") @@ -851,12 +851,12 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the sound is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " - "The standard is #Sinc70 because a Sound object is normally a sampled band-limited signal, " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " + "The standard is “sinc70” because a Sound object is normally a sampled band-limited signal, " "which can be seen as a sum of sinc functions.") MAN_END -MAN_BEGIN (U"Sound: Get time of minimum...", U"ppgb", 20041107) +MAN_BEGIN (U"Sound: Get time of minimum...", U"ppgb", 20200912) INTRO (U"A command available in the #Query menu if you select a @Sound object. " "The Info window will show the time (in seconds) associated with the minimum pressure in a specified time range.") ENTRY (U"Settings") @@ -864,8 +864,8 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored, except for purposes of interpolation. " "If %t__1_ is not less than %t__2_, the entire time domain of the sound is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " - "The standard is #Sinc70 because a Sound object is normally a sampled band-limited signal, " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " + "The standard is “sinc70” because a Sound object is normally a sampled band-limited signal, " "which can be seen as a sum of sinc functions.") MAN_END @@ -878,7 +878,7 @@ TAG (U"##Sample number") DEFINITION (U"the sample number at which the value is to be evaluated.") MAN_END -MAN_BEGIN (U"Sound: Get value at time...", U"ppgb", 20030916) +MAN_BEGIN (U"Sound: Get value at time...", U"ppgb", 20200912) INTRO (U"A command available in the #Query menu if you select a @Sound object. " "The Info window will show an estimate of the amplitude (sound pressure in Pascal) at a specified time. " "If that time is outside the samples of the Sound, the result is equal to the value of the nearest sample; " @@ -888,7 +888,7 @@ TAG (U"##Time (s)") DEFINITION (U"the time at which the value is to be evaluated.") TAG (U"##Interpolation") DEFINITION (U"the interpolation method, see @@vector value interpolation@. " - "The standard is #Sinc70 because a Sound object is normally a sampled band-limited signal, " + "The standard is “sinc70” because a Sound object is normally a sampled band-limited signal, " "which can be seen as a sum of sinc functions.") MAN_END diff --git a/fon/manual_spectrum.cpp b/fon/manual_spectrum.cpp index 4abbc449..9540af97 100644 --- a/fon/manual_spectrum.cpp +++ b/fon/manual_spectrum.cpp @@ -1,6 +1,6 @@ /* manual_spectrum.cpp * - * Copyright (C) 1992-2008,2010,2012,2014-2017 Paul Boersma + * Copyright (C) 1992-2008,2010-2012,2014-2017,2019,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -20,7 +20,7 @@ #include "Sound.h" -static void draw_SpectrumHann (Graphics g, double f1, double f2, bool stop, int garnish) { +static void draw_SpectrumHann (Graphics g, double f1, double f2, bool stop, bool garnish) { try { double fmin = garnish == 1 ? 300 : 0, fmax = garnish == 1 ? 1300 : 4000, df = garnish == 1 ? 1 : 4; autoSound me = Sound_create (1, fmin, fmax, (long) floor ((fmax - fmin) / df) + 1, df, fmin); @@ -144,7 +144,7 @@ NORMAL (U"where %f__1_ is the frequency associated with the centre of the first "and Δ%f is the bin width.") MAN_END -MAN_BEGIN (U"Ltas: Get frequency of maximum...", U"ppgb", 20110701) +MAN_BEGIN (U"Ltas: Get frequency of maximum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Ltas object.") ENTRY (U"Return value") NORMAL (U"the frequency (in hertz) associated with the maximum energy density.") @@ -155,13 +155,13 @@ DEFINITION (U"the selected frequency domain. Values outside this domain are igno "If ##To frequency# is not greater than ##From frequency#, " "the entire frequency domain of the Ltas object is considered.") TAG (U"##Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " - "The standard is #None because of the usual large binning. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " + "The standard is #none because of the usual large binning. " "If the Ltas was computed with @@Spectrum: To Ltas (1-to-1)@, " - "a #Parabolic or #Cubic interpolation would be more appropriate.") + "a #parabolic or #cubic interpolation would be more appropriate.") MAN_END -MAN_BEGIN (U"Ltas: Get frequency of minimum...", U"ppgb", 20030916) +MAN_BEGIN (U"Ltas: Get frequency of minimum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Ltas object.") ENTRY (U"Return value") NORMAL (U"the frequency (in hertz) associated with the minimum energy density.") @@ -170,10 +170,10 @@ TAG (U"##Time range (s)") DEFINITION (U"the time range (%t__1_, %t__2_). Values outside this range are ignored. " "If %t__1_ is not less than %t__2_, the entire frequency domain of the Ltas is considered.") TAG (U"%%Interpolation") -DEFINITION (U"the interpolation method (None, Parabolic, Cubic, Sinc) of the @@vector peak interpolation@. " - "The standard is None because of the usual large binning. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc) of the @@vector peak interpolation@. " + "The standard is #none because of the usual large binning. " "If the Ltas was computed with @@Spectrum: To Ltas (1-to-1)@, " - "a Parabolic or Cubic interpolation would be more appropriate.") + "a #parabolic or #cubic interpolation would be more appropriate.") MAN_END MAN_BEGIN (U"Ltas: Get highest frequency", U"ppgb", 20041122) @@ -188,7 +188,7 @@ ENTRY (U"Return value") NORMAL (U"the lowest frequency, expressed in Hertz. It is usually 0 Hz.") MAN_END -MAN_BEGIN (U"Ltas: Get maximum...", U"ppgb", 20101228) +MAN_BEGIN (U"Ltas: Get maximum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Ltas object.") ENTRY (U"Return value") NORMAL (U"the maximum value (in dB) within a specified frequency range.") @@ -199,10 +199,10 @@ DEFINITION (U"the selected frequency domain. Values outside this domain are igno "If %%To frequency% is not greater than %%From frequency%, " "the entire frequency domain of the Ltas object is considered.") TAG (U"%%Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " - "The standard is #None because of the usual large binning. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " + "The standard is #none because of the usual large binning. " "If the Ltas was computed with @@Spectrum: To Ltas (1-to-1)@, " - "a Parabolic or Cubic interpolation would be more appropriate.") + "a #parabolic or #cubic interpolation would be more appropriate.") MAN_END MAN_BEGIN (U"Ltas: Get mean...", U"ppgb", 20041122) @@ -223,7 +223,7 @@ FORMULA (U"1/%n ∑__%i=%m..%m+%n-1_ %x__%i_") NORMAL (U"where %n is the number of band centres between %f__1_ and %f__2_.") MAN_END -MAN_BEGIN (U"Ltas: Get minimum...", U"ppgb", 20030916) +MAN_BEGIN (U"Ltas: Get minimum...", U"ppgb", 20200912) INTRO (U"A @query to the selected @Ltas object.") ENTRY (U"Return value") NORMAL (U"the minimum value (in dB) within a specified frequency range.") @@ -234,10 +234,10 @@ DEFINITION (U"the selected frequency domain. Values outside this domain are igno "If ##To frequency# is not greater than ##From frequency#, " "the entire frequency domain of the Ltas object is considered.") TAG (U"%%Interpolation") -DEFINITION (U"the interpolation method (#None, #Parabolic, #Cubic, #Sinc) of the @@vector peak interpolation@. " - "The standard is #None because of the usual large binning. " +DEFINITION (U"the interpolation method (#none, #parabolic, #cubic, #sinc70, #sinc700) of the @@vector peak interpolation@. " + "The standard is #none because of the usual large binning. " "If the Ltas was computed with @@Spectrum: To Ltas (1-to-1)@, " - "a #Parabolic or #Cubic interpolation would be more appropriate.") + "a #parabolic or #cubic interpolation would be more appropriate.") MAN_END MAN_BEGIN (U"Ltas: Get number of bins", U"ppgb", 20041122) diff --git a/fon/manual_tutorials.cpp b/fon/manual_tutorials.cpp index d2ea940c..be10d6bb 100644 --- a/fon/manual_tutorials.cpp +++ b/fon/manual_tutorials.cpp @@ -22,8 +22,58 @@ void manual_tutorials_init (ManPages me); void manual_tutorials_init (ManPages me) { -MAN_BEGIN (U"What's new?", U"ppgb", 20200520) +MAN_BEGIN (U"What's new?", U"ppgb", 20201027) INTRO (U"Latest changes in Praat.") +NORMAL (U"##6.1.29# (27 October 2020)") +LIST_ITEM (U"• Mac: corrected a bug revealed by Xcode 12 since 6.1.22 that could cause Praat to crash when using empty vectors, " + "such as when querying a Harmonicity for its mean in regions without frames.") +NORMAL (U"##6.1.28# (20 October 2020)") +LIST_ITEM (U"• Pause forms: text fields can be multi-line.") +LIST_ITEM (U"• Removed a bug that caused Praat to crash when editing a PitchTier.") +LIST_ITEM (U"• Script window: got rid of too many history entries after dragging in the Picture window.") +NORMAL (U"##6.1.27# (13 October 2020)") +LIST_ITEM (U"• Demo window: make sure that the contents of the window become visible " + "more often without calling demoShow() or demoWaitForInput().") +NORMAL (U"##6.1.26# (5 October 2020)") +LIST_ITEM (U"• Windows: removed a bug that caused Praat to crash if you clicked in the Sound window, " + "then dragged the mouse out of that window, then released the mouse button, and then clicked in the Sound window again.") +LIST_ITEM (U"• Linux: removed a bug that caused Praat to crash when clicking Change in the Inspect window.") +NORMAL (U"##6.1.25# (4 October 2020)") +LIST_ITEM (U"• @FormantPath and @FormantPathEditor.") +LIST_ITEM (U"• Windows: implemented vertical scrolling with the mouse wheel in the manual and in the Picture window.") +LIST_ITEM (U"• Linux: removed a bug that caused Praat to crash when double-clicking in the Sound window.") +LIST_ITEM (U"• Linux: removed a bug that caused Praat to crash when raising the About window twice.") +LIST_ITEM (U"• Removed a bug that caused Praat to crash when zooming in " + "to a region in the Sound window without samples, when a pitch curve was visible.") +LIST_ITEM (U"• Removed a bug that caused Praat to crash when pasting in " + "a region in the Sound window without samples.") +NORMAL (U"##6.1.24# (29 September 2020)") +LIST_ITEM (U"• Linux: got rid of flashing during a running cursor or " + "when making a selection in the Sound window or the Picture window.") +NORMAL (U"##6.1.23# (28 September 2020)") +LIST_ITEM (U"• Windows: got rid of flashing during a running cursor or " + "when making a selection in the Sound window or the Picture window.") +LIST_ITEM (U"• Linux: corrected a bug that caused the buttons at the top of a manual window " + "to be overwritten with text when scrolling.") +NORMAL (U"##6.1.22# (24 September 2020)") +LIST_ITEM (U"• Windows: made the running cursor visible again.") +LIST_ITEM (U"• Corrected a bug introduced in 6.1.17alpha that could cause incorrect line spacing in the Picture window, " + "such as in ##TableOfReal: Draw as numbers#.") +NORMAL (U"##6.1.21# (20 September 2020)") +LIST_ITEM (U"• First fully functional version for BigSur.") +LIST_ITEM (U"• Removed a decades-old bug by which an extremum allegedly computed by cubic interpolation " + "would actually have been computed by sinc700.") +NORMAL (U"##6.1.20beta# (10 September 2020)") +LIST_ITEM (U"• Second beta version for macOS Big Sur.") +NORMAL (U"##6.1.19beta# (7 September 2020)") +LIST_ITEM (U"• First beta version for macOS Big Sur.") +NORMAL (U"##6.1.18alpha# (1 September 2020)") +LIST_ITEM (U"• Second alpha version for macOS Big Sur.") +NORMAL (U"##6.1.17alpha# (16 August 2020)") +LIST_ITEM (U"• Alpha version for macOS Big Sur.") +NORMAL (U"##6.1.16# (6 June 2020)") +LIST_ITEM (U"• ##Record fixed time...#: more reliable choice of input device.") +LIST_ITEM (U"• Mac: notice plugging and unplugging of headphones.") NORMAL (U"##6.1.15# (20 May 2020)") LIST_ITEM (U"• Repaired a bug introduced in 6.0.44 that could cause an incorrect (namely, totally constant) ClassificationTable.") NORMAL (U"##6.1.14# (2 May 2020)") @@ -3120,15 +3170,15 @@ LIST_ITEM (U"@@Intro 8.2. Manipulation of duration") LIST_ITEM (U"@@Intro 8.3. Manipulation of intensity") MAN_END -MAN_BEGIN (U"Intro 8.1. Manipulation of pitch", U"ppgb", 20110128) +MAN_BEGIN (U"Intro 8.1. Manipulation of pitch", U"ppgb", 20200901) INTRO (U"To modify the pitch contour of an existing @Sound object, " "you select this @Sound and click ##To Manipulation#. " "A @Manipulation object will then appear in the list. " "You can then click @@View & Edit@ to raise a @ManipulationEditor, " - "which will show the pitch contour (@PitchTier) as a series of thick dots. " + "which will show the pitch contour (@PitchTier) as a series of thick blue dots. " "To reduce the number of dots, choose ##Stylize pitch (2 st)# " "from the #Pitch menu; it will then be easy to drag the dots " - "about the time-pitch area.") + "around the time–pitch area.") NORMAL (U"If you click any of the rectangles " "(or choose any of the #Play commands from the #View menu), " "you will hear the modified sound. By shift-clicking, you will hear " @@ -3153,15 +3203,15 @@ NORMAL (U"For instance, suppose you want to have a pitch that falls from 350 to "You can put this PitchTier into a Manipulation object in the way described above.") MAN_END -MAN_BEGIN (U"Intro 8.2. Manipulation of duration", U"ppgb", 20140421) +MAN_BEGIN (U"Intro 8.2. Manipulation of duration", U"ppgb", 20200901) INTRO (U"You can use Praat to modify the relative durations in an existing sound.") NORMAL (U"First, you select a @Sound object and click \"To Manipulation\". " "A @Manipulation object will then appear in the list. " "You can then click @@View & Edit@ to raise a @ManipulationEditor, " "which will show an empty @DurationTier. " "You can add targets to this tier by choosing \"Add duration point at cursor\" " - "from the \"Dur\" menu. The targets will show up as green dots, which you can easily drag " - "about the duration area.") + "from the \"Dur\" menu. The targets will show up as blue dots, which you can easily drag " + "around the duration area.") NORMAL (U"If you click any of the rectangles " "(or choose any of the @Play commands from the @View menu), " "you will hear the modified sound. By shift-clicking, you will hear " @@ -3179,7 +3229,7 @@ NORMAL (U"In your first 85 ms, your relative duration should be 70/85, " "The DurationTier does linear interpolation, so it can only be approximate these precise times, " "but fortunately to any precision you like:") CODE (U"Create DurationTier: \"shorten\", 0, 0.085 + 0.270") -CODE (U"Add point: 0.000 70/85") +CODE (U"Add point: 0.000, 70/85") CODE (U"Add point: 0.084999, 70/85") CODE (U"Add point: 0.085001, 200/270") CODE (U"Add point: 0.355, 200/270") diff --git a/fon/praat_Fon.cpp b/fon/praat_Fon.cpp index c85a07ee..a2f65267 100644 --- a/fon/praat_Fon.cpp +++ b/fon/praat_Fon.cpp @@ -391,7 +391,7 @@ FORM (REAL_Formant_getValueAtTime, U"Formant: Get value", U"Formant: Get value a REAL (time, U"Time (s)", U"0.5") RADIO_ENUM (kFormant_unit, unit, U"Unit", kFormant_unit::HERTZ) RADIO (interpolation, U"Interpolation", 1) // ignored - RADIOBUTTON (U"Linear") + RADIOBUTTON (U"linear") OK DO NUMBER_ONE (Formant) @@ -404,7 +404,7 @@ FORM (REAL_Formant_getBandwidthAtTime, U"Formant: Get bandwidth", U"Formant: Get REAL (time, U"Time (s)", U"0.5") RADIO_ENUM (kFormant_unit, unit, U"Unit", kFormant_unit::HERTZ) RADIO (interpolation, U"Interpolation", 1) // ignored - RADIOBUTTON (U"Linear") + RADIOBUTTON (U"linear") OK DO NUMBER_ONE (Formant) @@ -417,8 +417,8 @@ FORM (REAL_Formant_getMinimum, U"Formant: Get minimum", U"Formant: Get minimum.. praat_TimeFunction_RANGE (fromTime, toTime) RADIO_ENUM (kFormant_unit, unit, U"Unit", kFormant_unit::HERTZ) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") + RADIOBUTTON (U"none") + RADIOBUTTON (U"parabolic") OK DO NUMBER_ONE (Formant) @@ -431,8 +431,8 @@ FORM (REAL_Formant_getMaximum, U"Formant: Get maximum", U"Formant: Get maximum.. praat_TimeFunction_RANGE (fromTime, toTime) RADIO_ENUM (kFormant_unit, unit, U"Unit", kFormant_unit::HERTZ) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") + RADIOBUTTON (U"none") + RADIOBUTTON (U"parabolic") OK DO NUMBER_ONE (Formant) @@ -445,8 +445,8 @@ FORM (REAL_Formant_getTimeOfMinimum, U"Formant: Get time of minimum", U"Formant: praat_TimeFunction_RANGE (fromTime, toTime) RADIO_ENUM (kFormant_unit, unit, U"Unit", kFormant_unit::HERTZ) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") + RADIOBUTTON (U"none") + RADIOBUTTON (U"parabolic") OK DO NUMBER_ONE (Formant) @@ -459,8 +459,8 @@ FORM (REAL_Formant_getTimeOfMaximum, U"Formant: Get time of maximum", U"Formant: praat_TimeFunction_RANGE (fromTime, toTime) RADIO_ENUM (kFormant_unit, unit, U"Unit", kFormant_unit::HERTZ) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") + RADIOBUTTON (U"none") + RADIOBUTTON (U"parabolic") OK DO NUMBER_ONE (Formant) @@ -583,7 +583,8 @@ DO CONVERT_EACH (Formant) autoFormant result = Formant_tracker (me, numberOfTracks, referenceF1, referenceF2, referenceF3, referenceF4, referenceF5, - frequencyCost, bandwidthCost, transitionCost); + frequencyCost, bandwidthCost, transitionCost + ); CONVERT_EACH_END (my name.get()) } @@ -660,7 +661,7 @@ FORM (REAL_Harmonicity_getMaximum, U"Harmonicity: Get maximum", U"Harmonicity: G OK DO NUMBER_ONE (Harmonicity) - double result = Vector_getMaximum (me, fromTime, toTime, interpolation); + const double result = Vector_getMaximum (me, fromTime, toTime, interpolation); NUMBER_ONE_END (U" dB") } @@ -669,7 +670,7 @@ FORM (REAL_Harmonicity_getMean, U"Harmonicity: Get mean", U"Harmonicity: Get mea OK DO NUMBER_ONE (Harmonicity) - double result = Harmonicity_getMean (me, fromTime, toTime); + const double result = Harmonicity_getMean (me, fromTime, toTime); NUMBER_ONE_END (U" dB") } @@ -678,7 +679,7 @@ FORM (REAL_Harmonicity_getMinimum, U"Harmonicity: Get minimum", U"Harmonicity: G OK DO NUMBER_ONE (Harmonicity) - double result = Vector_getMinimum (me, fromTime, toTime, interpolation); + const double result = Vector_getMinimum (me, fromTime, toTime, interpolation); NUMBER_ONE_END (U" dB") } @@ -687,7 +688,7 @@ FORM (REAL_Harmonicity_getStandardDeviation, U"Harmonicity: Get standard deviati OK DO NUMBER_ONE (Harmonicity) - double result = Harmonicity_getStandardDeviation (me, fromTime, toTime); + const double result = Harmonicity_getStandardDeviation (me, fromTime, toTime); NUMBER_ONE_END (U" dB") } @@ -696,7 +697,7 @@ FORM (REAL_Harmonicity_getTimeOfMaximum, U"Harmonicity: Get time of maximum", U" OK DO NUMBER_ONE (Harmonicity) - double result = Vector_getXOfMaximum (me, fromTime, toTime, interpolation); + const double result = Vector_getXOfMaximum (me, fromTime, toTime, interpolation); NUMBER_ONE_END (U" seconds") } @@ -705,7 +706,7 @@ FORM (REAL_Harmonicity_getTimeOfMinimum, U"Harmonicity: Get time of minimum", U" OK DO NUMBER_ONE (Harmonicity) - double result = Vector_getXOfMinimum (me, fromTime, toTime, interpolation); + const double result = Vector_getXOfMinimum (me, fromTime, toTime, interpolation); NUMBER_ONE_END (U" seconds") } @@ -714,7 +715,7 @@ FORM (REAL_Harmonicity_getValueAtTime, U"Harmonicity: Get value", U"Harmonicity: OK DO NUMBER_ONE (Harmonicity) - double result = Vector_getValueAtX (me, time, 1, interpolation); + const double result = Vector_getValueAtX (me, time, 1, interpolation); NUMBER_ONE_END (U" dB") } @@ -723,7 +724,7 @@ FORM (REAL_Harmonicity_getValueInFrame, U"Get value in frame", U"Harmonicity: Ge OK DO NUMBER_ONE (Harmonicity) - double result = ( frameNumber < 1 || frameNumber > my nx ? undefined : my z [1] [frameNumber] ); + const double result = ( frameNumber < 1 || frameNumber > my nx ? undefined : my z [1] [frameNumber] ); NUMBER_ONE_END (U" dB") } @@ -777,7 +778,7 @@ FORM (REAL_Intensity_getValueAtTime, U"Intensity: Get value", U"Intensity: Get v OK DO NUMBER_ONE (Intensity) - double result = Vector_getValueAtX (me, time, 1, interpolation); + const double result = Vector_getValueAtX (me, time, 1, interpolation); NUMBER_ONE_END (U" dB") } @@ -786,7 +787,7 @@ FORM (REAL_Intensity_getValueInFrame, U"Get value in frame", U"Intensity: Get va OK DO NUMBER_ONE (Intensity) - double result = ( frameNumber < 1 || frameNumber > my nx ? undefined : my z [1] [frameNumber] ); + const double result = ( frameNumber < 1 || frameNumber > my nx ? undefined : my z [1] [frameNumber] ); NUMBER_ONE_END (U" dB") } @@ -795,7 +796,7 @@ FORM (REAL_Intensity_getMinimum, U"Intensity: Get minimum", U"Intensity: Get min OK DO NUMBER_ONE (Intensity) - double result = Vector_getMinimum (me, fromTime, toTime, interpolation); + const double result = Vector_getMinimum (me, fromTime, toTime, interpolation); NUMBER_ONE_END (U" dB") } @@ -804,7 +805,7 @@ FORM (REAL_Intensity_getTimeOfMinimum, U"Intensity: Get time of minimum", U"Inte OK DO NUMBER_ONE (Intensity) - double result = Vector_getXOfMinimum (me, fromTime, toTime, interpolation); + const double result = Vector_getXOfMinimum (me, fromTime, toTime, interpolation); NUMBER_ONE_END (U" seconds") } @@ -813,7 +814,7 @@ FORM (REAL_Intensity_getMaximum, U"Intensity: Get maximum", U"Intensity: Get max OK DO NUMBER_ONE (Intensity) - double result = Vector_getMaximum (me, fromTime, toTime, interpolation); + const double result = Vector_getMaximum (me, fromTime, toTime, interpolation); NUMBER_ONE_END (U" dB") } @@ -822,7 +823,7 @@ FORM (REAL_Intensity_getTimeOfMaximum, U"Intensity: Get time of maximum", U"Inte OK DO NUMBER_ONE (Intensity) - double result = Vector_getXOfMaximum (me, fromTime, toTime, interpolation); + const double result = Vector_getXOfMaximum (me, fromTime, toTime, interpolation); NUMBER_ONE_END (U" seconds") } @@ -832,7 +833,7 @@ FORM (REAL_Intensity_getQuantile, U"Intensity: Get quantile", 0) { OK DO NUMBER_ONE (Intensity) - double result = Intensity_getQuantile (me, fromTime, toTime, quantile); + const double result = Intensity_getQuantile (me, fromTime, toTime, quantile); NUMBER_ONE_END (U" dB") } @@ -841,7 +842,7 @@ FORM (REAL_old_Intensity_getMean, U"Intensity: Get mean", U"Intensity: Get mean. OK DO NUMBER_ONE (Intensity) - double result = Sampled_getMean_standardUnit (me, fromTime, toTime, 0, 0, true); + const double result = Sampled_getMean_standardUnit (me, fromTime, toTime, 0, 0, true); NUMBER_ONE_END (U" dB") } @@ -854,7 +855,7 @@ FORM (REAL_Intensity_getMean, U"Intensity: Get mean", U"Intensity: Get mean...") OK DO_ALTERNATIVE (REAL_old_Intensity_getMean) NUMBER_ONE (Intensity) - double result = Sampled_getMean_standardUnit (me, fromTime, toTime, 0, averagingMethod, true); + const double result = Sampled_getMean_standardUnit (me, fromTime, toTime, 0, averagingMethod, true); NUMBER_ONE_END (U" dB") } @@ -863,7 +864,7 @@ FORM (REAL_Intensity_getStandardDeviation, U"Intensity: Get standard deviation", OK DO NUMBER_ONE (Intensity) - double result = Vector_getStandardDeviation (me, fromTime, toTime, 1); + const double result = Vector_getStandardDeviation (me, fromTime, toTime, 1); NUMBER_ONE_END (U" dB") } @@ -917,9 +918,9 @@ FORM (GRAPHICS_Pitch_Intensity_draw, U"Plot intensity by pitch", nullptr) { REAL (toIntensity, U"To intensity (dB)", U"100.0") BOOLEAN (garnish, U"Garnish", true) RADIO (drawingMethod, U"Drawing method", 1) - RADIOBUTTON (U"Speckles") - RADIOBUTTON (U"Curve") - RADIOBUTTON (U"Speckles and curve") + RADIOBUTTON (U"speckles") + RADIOBUTTON (U"curve") + RADIOBUTTON (U"speckles and curve") OK DO GRAPHICS_TWO (Pitch, Intensity) @@ -995,10 +996,10 @@ FORM (GRAPHICS_Ltas_draw, U"Ltas: Draw", nullptr) { BOOLEAN (garnish, U"Garnish", true) LABEL (U"") OPTIONMENUSTR (drawingMethod, U"Drawing method", 2) - OPTION (U"Curve") - OPTION (U"Bars") - OPTION (U"Poles") - OPTION (U"Speckles") + OPTION (U"curve") + OPTION (U"bars") + OPTION (U"poles") + OPTION (U"speckles") OK DO_ALTERNATIVE (GRAPHICS_old_Ltas_draw) GRAPHICS_EACH (Ltas) @@ -1019,19 +1020,19 @@ DO DIRECT (REAL_Ltas_getLowestFrequency) { NUMBER_ONE (Ltas) - double result = my xmin; + const double result = my xmin; NUMBER_ONE_END (U" hertz") } DIRECT (REAL_Ltas_getHighestFrequency) { NUMBER_ONE (Ltas) - double result = my xmax; + const double result = my xmax; NUMBER_ONE_END (U" hertz") } DIRECT (REAL_Ltas_getBinWidth) { NUMBER_ONE (Ltas) - double result = my dx; + const double result = my dx; NUMBER_ONE_END (U" hertz") } @@ -1040,7 +1041,7 @@ FORM (REAL_Ltas_getFrequencyFromBinNumber, U"Ltas: Get frequency from bin number OK DO NUMBER_ONE (Ltas) - double result = Sampled_indexToX (me, binNumber); + const double result = Sampled_indexToX (me, binNumber); NUMBER_ONE_END (U" hertz") } @@ -1049,39 +1050,31 @@ FORM (REAL_Ltas_getBinNumberFromFrequency, U"Ltas: Get band from frequency", U"L OK DO NUMBER_ONE (Ltas) - double result = Sampled_xToIndex (me, frequency); + const double result = Sampled_xToIndex (me, frequency); NUMBER_ONE_END (U"") } FORM (REAL_Ltas_getFrequencyOfMinimum, U"Ltas: Get frequency of minimum", U"Ltas: Get frequency of minimum...") { REAL (fromFrequency, U"From frequency (Hz)", U"0.0") REAL (toFrequency, U"To frequency (Hz)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 1, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::NONE) OK DO NUMBER_ONE (Ltas) - double result = Vector_getXOfMinimum (me, fromFrequency, toFrequency, interpolation); + const double result = Vector_getXOfMinimum (me, fromFrequency, toFrequency, peakInterpolationType); NUMBER_ONE_END (U" hertz"); } FORM (REAL_Ltas_getFrequencyOfMaximum, U"Ltas: Get frequency of maximum", U"Ltas: Get frequency of maximum...") { REAL (fromFrequency, U"From frequency (Hz)", U"0.0") REAL (toFrequency, U"To frequency (Hz)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 1, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::NONE) OK DO NUMBER_ONE (Ltas) - double result = Vector_getXOfMaximum (me, fromFrequency, toFrequency, interpolation); + const double result = Vector_getXOfMaximum (me, fromFrequency, toFrequency, peakInterpolationType); NUMBER_ONE_END (U" hertz"); } @@ -1110,16 +1103,12 @@ DO FORM (REAL_Ltas_getMaximum, U"Ltas: Get maximum", U"Ltas: Get maximum...") { REAL (fromFrequency, U"From frequency (Hz)", U"0.0") REAL (toFrequency, U"To frequency (Hz)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 1, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::NONE) OK DO NUMBER_ONE (Ltas) - double result = Vector_getMaximum (me, fromFrequency, toFrequency, interpolation); + const double result = Vector_getMaximum (me, fromFrequency, toFrequency, peakInterpolationType); NUMBER_ONE_END (U" dB") } @@ -1133,30 +1122,26 @@ FORM (REAL_Ltas_getMean, U"Ltas: Get mean", U"Ltas: Get mean...") { OK DO NUMBER_ONE (Ltas) - double result = Sampled_getMean_standardUnit (me, fromFrequency, toFrequency, - 0, averagingMethod, false); + const double result = Sampled_getMean_standardUnit (me, fromFrequency, toFrequency, + 0, averagingMethod, false); NUMBER_ONE_END (U" dB") } FORM (REAL_Ltas_getMinimum, U"Ltas: Get minimum", U"Ltas: Get minimum...") { REAL (fromFrequency, U"From frequency (Hz)", U"0.0") REAL (toFrequency, U"To frequency (Hz)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 1, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::NONE) OK DO NUMBER_ONE (Ltas) - double result = Vector_getMinimum (me, fromFrequency, toFrequency, interpolation); + const double result = Vector_getMinimum (me, fromFrequency, toFrequency, peakInterpolationType); NUMBER_ONE_END (U" dB") } DIRECT (INTEGER_Ltas_getNumberOfBins) { NUMBER_ONE (Ltas) - integer result = my nx; + const integer result = my nx; NUMBER_ONE_END (U" bins") } @@ -1172,7 +1157,7 @@ FORM (REAL_Ltas_getSlope, U"Ltas: Get slope", 0) { OK DO NUMBER_ONE (Ltas) - double result = Ltas_getSlope (me, lowBandFrom, lowBandTo, highBandFrom, highBandTo, averagingMethod); + const double result = Ltas_getSlope (me, lowBandFrom, lowBandTo, highBandFrom, highBandTo, averagingMethod); NUMBER_ONE_END (U" dB") } @@ -1186,27 +1171,25 @@ FORM (REAL_Ltas_getStandardDeviation, U"Ltas: Get standard deviation", U"Ltas: G OK DO NUMBER_ONE (Ltas) - double result = Sampled_getStandardDeviation_standardUnit (me, fromFrequency, toFrequency, + const double result = Sampled_getStandardDeviation_standardUnit (me, fromFrequency, toFrequency, 0, // level (irrelevant) averagingMethod, - false); // interpolate (don't) + false // interpolate (don't) + ); NUMBER_ONE_END (U" dB") } FORM (REAL_Ltas_getValueAtFrequency, U"Ltas: Get value", U"Ltas: Get value at frequency...") { REAL (frequency, U"Frequency (Hz)", U"1500.0") - RADIOx (interpolation, U"Interpolation", 1, 0) - RADIOBUTTON (U"Nearest") - RADIOBUTTON (U"Linear") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_valueInterpolation, valueInterpolationType, + U"Interpolation", kVector_valueInterpolation :: NEAREST) OK DO NUMBER_ONE (Ltas) - double result = Vector_getValueAtX (me, frequency, + const double result = Vector_getValueAtX (me, frequency, 1, // level - interpolation); + valueInterpolationType + ); NUMBER_ONE_END (U" dB") } @@ -1215,7 +1198,7 @@ FORM (REAL_Ltas_getValueInBin, U"Get value in bin", U"Ltas: Get value in bin..." OK DO NUMBER_ONE (Ltas) - double result = binNumber < 1 || binNumber > my nx ? undefined : my z [1] [binNumber]; + const double result = binNumber < 1 || binNumber > my nx ? undefined : my z [1] [binNumber]; NUMBER_ONE_END (U" dB") } @@ -1445,7 +1428,7 @@ DO if (toFrequency <= fromFrequency) Melder_throw (U"Maximum frequency must be greater than minimum frequency."); GRAPHICS_EACH (Pitch) Pitch_draw (me, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - garnish, Pitch_speckle_NO, kPitch_unit::HERTZ); + garnish, Pitch_speckle_NO, kPitch_unit::HERTZ); GRAPHICS_EACH_END } @@ -1458,7 +1441,7 @@ FORM (GRAPHICS_Pitch_drawErb, U"Pitch: Draw erb", U"Pitch: Draw...") { DO GRAPHICS_EACH (Pitch) Pitch_draw (me, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - garnish, Pitch_speckle_NO, kPitch_unit::ERB); + garnish, Pitch_speckle_NO, kPitch_unit::ERB); GRAPHICS_EACH_END } @@ -1472,7 +1455,7 @@ DO if (toFrequency <= fromFrequency) Melder_throw (U"Maximum frequency must be greater than minimum frequency."); GRAPHICS_EACH (Pitch) Pitch_draw (me, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - garnish, Pitch_speckle_NO, kPitch_unit::HERTZ_LOGARITHMIC); + garnish, Pitch_speckle_NO, kPitch_unit::HERTZ_LOGARITHMIC); GRAPHICS_EACH_END } @@ -1485,7 +1468,7 @@ FORM (GRAPHICS_Pitch_drawMel, U"Pitch: Draw mel", U"Pitch: Draw...") { DO GRAPHICS_EACH (Pitch) Pitch_draw (me, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - garnish, Pitch_speckle_NO, kPitch_unit::MEL); + garnish, Pitch_speckle_NO, kPitch_unit::MEL); GRAPHICS_EACH_END } @@ -1499,7 +1482,7 @@ FORM (GRAPHICS_Pitch_drawSemitones100, U"Pitch: Draw semitones (re 100 Hz)", U"P DO GRAPHICS_EACH (Pitch) Pitch_draw (me, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - garnish, Pitch_speckle_NO, kPitch_unit::SEMITONES_100); + garnish, Pitch_speckle_NO, kPitch_unit::SEMITONES_100); GRAPHICS_EACH_END } @@ -1513,7 +1496,7 @@ FORM (GRAPHICS_Pitch_drawSemitones200, U"Pitch: Draw semitones (re 200 Hz)", U"P DO GRAPHICS_EACH (Pitch) Pitch_draw (me, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - garnish, Pitch_speckle_NO, kPitch_unit::SEMITONES_200); + garnish, Pitch_speckle_NO, kPitch_unit::SEMITONES_200); GRAPHICS_EACH_END } @@ -1527,7 +1510,7 @@ FORM (GRAPHICS_Pitch_drawSemitones440, U"Pitch: Draw semitones (re 440 Hz)", U"P DO GRAPHICS_EACH (Pitch) Pitch_draw (me, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - garnish, Pitch_speckle_NO, kPitch_unit::SEMITONES_440); + garnish, Pitch_speckle_NO, kPitch_unit::SEMITONES_440); GRAPHICS_EACH_END } @@ -1578,8 +1561,8 @@ FORM (REAL_Pitch_getMinimum, U"Pitch: Get minimum", nullptr) { praat_TimeFunction_RANGE (fromTime, toTime) OPTIONMENU_ENUM (kPitch_unit, unit, U"Unit", kPitch_unit::DEFAULT) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") + RADIOBUTTON (U"none") + RADIOBUTTON (U"parabolic") OK DO NUMBER_ONE (Pitch) @@ -1592,8 +1575,8 @@ FORM (REAL_Pitch_getMaximum, U"Pitch: Get maximum", nullptr) { praat_TimeFunction_RANGE (fromTime, toTime) OPTIONMENU_ENUM (kPitch_unit, unit, U"Unit", kPitch_unit::DEFAULT) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") + RADIOBUTTON (U"none") + RADIOBUTTON (U"parabolic") OK DO NUMBER_ONE (Pitch) @@ -1616,14 +1599,14 @@ DO FORM (REAL_Pitch_getMeanAbsoluteSlope, U"Pitch: Get mean absolute slope", 0) { RADIO (unit, U"Unit", 1) RADIOBUTTON (U"Hertz") - RADIOBUTTON (U"Mel") - RADIOBUTTON (U"Semitones") + RADIOBUTTON (U"mel") + RADIOBUTTON (U"semitones") RADIOBUTTON (U"ERB") OK DO FIND_ONE (Pitch) double slope; - integer nVoiced = (unit == 1 ? Pitch_getMeanAbsSlope_hertz : unit == 2 ? Pitch_getMeanAbsSlope_mel : unit == 3 ? Pitch_getMeanAbsSlope_semitones : Pitch_getMeanAbsSlope_erb) + const integer nVoiced = (unit == 1 ? Pitch_getMeanAbsSlope_hertz : unit == 2 ? Pitch_getMeanAbsSlope_mel : unit == 3 ? Pitch_getMeanAbsSlope_semitones : Pitch_getMeanAbsSlope_erb) (me, & slope); if (nVoiced < 2) { Melder_information (U"--undefined--"); @@ -1664,14 +1647,14 @@ FORM (REAL_Pitch_getStandardDeviation, U"Pitch: Get standard deviation", nullptr OPTION (U"ERB") OK DO - kPitch_unit unit = + const kPitch_unit unit = unit_i == 1 ? kPitch_unit::HERTZ : unit_i == 2 ? kPitch_unit::MEL : unit_i == 3 ? kPitch_unit::LOG_HERTZ : unit_i == 4 ? kPitch_unit::SEMITONES_1 : kPitch_unit::ERB; NUMBER_ONE (Pitch) - double result = Pitch_getStandardDeviation (me, fromTime, toTime, unit); + const double result = Pitch_getStandardDeviation (me, fromTime, toTime, unit); conststring32 unitText = unit == kPitch_unit::HERTZ ? U"Hz" : unit == kPitch_unit::MEL ? U"mel" : @@ -1685,12 +1668,12 @@ FORM (REAL_Pitch_getTimeOfMaximum, U"Pitch: Get time of maximum", nullptr) { praat_TimeFunction_RANGE (fromTime, toTime) OPTIONMENU_ENUM (kPitch_unit, unit, U"Unit", kPitch_unit::DEFAULT) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") + RADIOBUTTON (U"none") + RADIOBUTTON (U"parabolic") OK DO NUMBER_ONE (Pitch) - double result = Pitch_getTimeOfMaximum (me, fromTime, toTime, unit, interpolation); + const double result = Pitch_getTimeOfMaximum (me, fromTime, toTime, unit, interpolation); NUMBER_ONE_END (U" seconds") } @@ -1698,12 +1681,12 @@ FORM (REAL_Pitch_getTimeOfMinimum, U"Pitch: Get time of minimum", nullptr) { praat_TimeFunction_RANGE (fromTime, toTime) OPTIONMENU_ENUM (kPitch_unit, unit, U"Unit", kPitch_unit::DEFAULT) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") + RADIOBUTTON (U"none") + RADIOBUTTON (U"parabolic") OK DO NUMBER_ONE (Pitch) - double result = Pitch_getTimeOfMinimum (me, fromTime, toTime, unit, interpolation); + const double result = Pitch_getTimeOfMinimum (me, fromTime, toTime, unit, interpolation); NUMBER_ONE_END (U" seconds") } @@ -1711,8 +1694,8 @@ FORM (REAL_Pitch_getValueAtTime, U"Pitch: Get value at time", U"Pitch: Get value REAL (time, U"Time (s)", U"0.5") OPTIONMENU_ENUM (kPitch_unit, unit, U"Unit", kPitch_unit::DEFAULT) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"Nearest") - RADIOBUTTON (U"Linear") + RADIOBUTTON (U"nearest") + RADIOBUTTON (U"linear") OK DO NUMBER_ONE (Pitch) @@ -1758,8 +1741,8 @@ FORM (NUMVEC_Pitch_listValuesAtTimes, U"Pitch: List values at times", U"Pitch: L NUMVEC (times, U"Times (s)", U"{ 0.5, 0.7, 2.0 }") OPTIONMENU_ENUM (kPitch_unit, unit, U"Unit", kPitch_unit::DEFAULT) RADIOx (interpolation, U"Interpolation", 2, 0) - RADIOBUTTON (U"Nearest") - RADIOBUTTON (U"Linear") + RADIOBUTTON (U"nearest") + RADIOBUTTON (U"linear") OK DO NUMVEC_ONE (Pitch) @@ -1893,7 +1876,7 @@ FORM (NEW_Pitch_subtractLinearFit, U"Pitch: subtract linear fit", nullptr) { OPTION (U"ERB") OK DO - kPitch_unit unit = + const kPitch_unit unit = unit_i == 1 ? kPitch_unit::HERTZ : unit_i == 2 ? kPitch_unit::MEL : unit_i == 3 ? kPitch_unit::LOG_HERTZ : @@ -1975,15 +1958,15 @@ FORM (GRAPHICS_old_PitchTier_Pitch_draw, U"PitchTier & Pitch: Draw", nullptr) { REAL (fromFrequency, U"From frequency (Hz)", U"0.0") REAL (toFrequency, U"To frequency (Hz)", U"500.0") RADIOx (lineTypeForNonperiodicIntervals, U"Line type for non-periodic intervals", 2, 0) - RADIOBUTTON (U"Normal") - RADIOBUTTON (U"Dotted") - RADIOBUTTON (U"Blank") + RADIOBUTTON (U"normal") + RADIOBUTTON (U"dotted") + RADIOBUTTON (U"blank") BOOLEAN (garnish, U"Garnish", true) OK DO GRAPHICS_TWO (PitchTier, Pitch) PitchTier_Pitch_draw (me, you, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - lineTypeForNonperiodicIntervals, garnish, U"lines and speckles"); + lineTypeForNonperiodicIntervals, garnish, U"lines and speckles"); GRAPHICS_TWO_END } @@ -1992,9 +1975,9 @@ FORM (GRAPHICS_PitchTier_Pitch_draw, U"PitchTier & Pitch: Draw", nullptr) { REAL (fromFrequency, U"From frequency (Hz)", U"0.0") REAL (toFrequency, U"To frequency (Hz)", U"500.0") RADIOx (lineTypeForNonperiodicIntervals, U"Line type for non-periodic intervals", 2, 0) - RADIOBUTTON (U"Normal") - RADIOBUTTON (U"Dotted") - RADIOBUTTON (U"Blank") + RADIOBUTTON (U"normal") + RADIOBUTTON (U"dotted") + RADIOBUTTON (U"blank") BOOLEAN (garnish, U"Garnish", true) LABEL (U"") OPTIONMENUSTR (drawingMethod, U"Drawing method", 1) @@ -2005,7 +1988,7 @@ FORM (GRAPHICS_PitchTier_Pitch_draw, U"PitchTier & Pitch: Draw", nullptr) { DO_ALTERNATIVE (GRAPHICS_old_PitchTier_Pitch_draw) GRAPHICS_TWO (PitchTier, Pitch) PitchTier_Pitch_draw (me, you, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - lineTypeForNonperiodicIntervals, garnish, drawingMethod); + lineTypeForNonperiodicIntervals, garnish, drawingMethod); GRAPHICS_TWO_END } @@ -2166,7 +2149,7 @@ DO INFO_THREE (Sound, Pitch, PointProcess) MelderInfo_open (); Sound_Pitch_PointProcess_voiceReport (me, you, him, fromTime, toTime, fromPitch, toPitch, - maximumPeriodFactor, maximumAmplitudeFactor, silenceThreshold, voicingThreshold); + maximumPeriodFactor, maximumAmplitudeFactor, silenceThreshold, voicingThreshold); MelderInfo_close (); INFO_THREE_END } @@ -2198,7 +2181,7 @@ FORM (GRAPHICS_Spectrogram_paint, U"Spectrogram: Paint", U"Spectrogram: Paint... DO GRAPHICS_EACH (Spectrogram) Spectrogram_paint (me, GRAPHICS, fromTime, toTime, fromFrequency, toFrequency, - maximum, autoscaling, dynamicRange, preEmphasis, dynamicCompression, garnish); + maximum, autoscaling, dynamicRange, preEmphasis, dynamicCompression, garnish); GRAPHICS_EACH_END } @@ -2221,7 +2204,7 @@ FORM (REAL_Spectrogram_getPowerAt, U"Spectrogram: Get power at (time, frequency) OK DO NUMBER_ONE (Spectrogram) - double result = Matrix_getValueAtXY (me, time, frequency); + const double result = Matrix_getValueAtXY (me, time, frequency); NUMBER_ONE_END (U" Pa2/Hz (at time = ", time, U" seconds and frequency = ", frequency, U" Hz)") } @@ -2328,7 +2311,7 @@ FORM (NEW_Spectrum_tabulate, U"Spectrum: Tabulate", 0) { DO CONVERT_EACH (Spectrum) autoTable result = Spectrum_tabulate (me, includeBinNumber, includeFrequency, includeRealPart, includeImaginaryPart, - includeEnergyDensity, includePowerDensity); + includeEnergyDensity, includePowerDensity); CONVERT_EACH_END (my name.get()) } @@ -2340,7 +2323,7 @@ FORM (REAL_Spectrum_getBandDensity, U"Spectrum: Get band density", nullptr) { OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getBandDensity (me, bandFloor, bandCeiling); + const double result = Spectrum_getBandDensity (me, bandFloor, bandCeiling); NUMBER_ONE_END (U" Pa2 / Hz2") } @@ -2352,8 +2335,8 @@ FORM (REAL_Spectrum_getBandDensityDifference, U"Spectrum: Get band density diffe OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getBandDensityDifference (me, - lowBandFloor, lowBandCeiling, highBandFloor, highBandCeiling); + const double result = Spectrum_getBandDensityDifference (me, + lowBandFloor, lowBandCeiling, highBandFloor, highBandCeiling); NUMBER_ONE_END (U" dB") } @@ -2363,7 +2346,7 @@ FORM (REAL_Spectrum_getBandEnergy, U"Spectrum: Get band energy", nullptr) { OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getBandEnergy (me, bandFloor, bandCeiling); + const double result = Spectrum_getBandEnergy (me, bandFloor, bandCeiling); NUMBER_ONE_END (U" Pa2 sec") } @@ -2375,8 +2358,8 @@ FORM (REAL_Spectrum_getBandEnergyDifference, U"Spectrum: Get band energy differe OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getBandEnergyDifference (me, - lowBandFloor, lowBandCeiling, highBandFloor, highBandCeiling); + const double result = Spectrum_getBandEnergyDifference (me, + lowBandFloor, lowBandCeiling, highBandFloor, highBandCeiling); NUMBER_ONE_END (U" dB") } @@ -2385,13 +2368,13 @@ FORM (REAL_Spectrum_getBinNumberFromFrequency, U"Spectrum: Get bin number from f OK DO NUMBER_ONE (Spectrum) - double result = Sampled_xToIndex (me, frequency); + const double result = Sampled_xToIndex (me, frequency); NUMBER_ONE_END (U" (bin number as a real value)") } DIRECT (REAL_Spectrum_getBinWidth) { NUMBER_ONE (Spectrum) - double result = my dx; + const double result = my dx; NUMBER_ONE_END (U" hertz") } @@ -2401,7 +2384,7 @@ FORM (REAL_Spectrum_getCentralMoment, U"Spectrum: Get central moment", U"Spectru OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getCentralMoment (me, moment, power); + const double result = Spectrum_getCentralMoment (me, moment, power); NUMBER_ONE_END (U" hertz to the power ", moment) } @@ -2410,7 +2393,7 @@ FORM (REAL_Spectrum_getCentreOfGravity, U"Spectrum: Get centre of gravity", U"Sp OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getCentreOfGravity (me, power); + const double result = Spectrum_getCentreOfGravity (me, power); NUMBER_ONE_END (U" hertz") } @@ -2419,19 +2402,19 @@ FORM (REAL_Spectrum_getFrequencyFromBin, U"Spectrum: Get frequency from bin", nu OK DO NUMBER_ONE (Spectrum) - double result = Sampled_indexToX (me, bandNumber); + const double result = Sampled_indexToX (me, bandNumber); NUMBER_ONE_END (U" hertz") } DIRECT (REAL_Spectrum_getLowestFrequency) { NUMBER_ONE (Spectrum) - double result = my xmin; + const double result = my xmin; NUMBER_ONE_END (U" hertz") } DIRECT (REAL_Spectrum_getHighestFrequency) { NUMBER_ONE (Spectrum) - double result = my xmax; + const double result = my xmax; NUMBER_ONE_END (U" hertz"); } @@ -2441,7 +2424,7 @@ FORM (REAL_Spectrum_getRealValueInBin, U"Spectrum: Get real value in bin", nullp DO NUMBER_ONE (Spectrum) if (binNumber > my nx) Melder_throw (U"Bin number should not exceed number of bins."); - double result = my z [1] [binNumber]; + const double result = my z [1] [binNumber]; NUMBER_ONE_END (U" (real value in bin ", binNumber, U")") } @@ -2451,7 +2434,7 @@ FORM (REAL_Spectrum_getImaginaryValueInBin, U"Spectrum: Get imaginary value in b DO NUMBER_ONE (Spectrum) if (binNumber > my nx) Melder_throw (U"The bin number should not exceed the number of bins."); - double result = my z [2] [binNumber]; + const double result = my z [2] [binNumber]; NUMBER_ONE_END (U" (imaginary value in bin ", binNumber, U")") } @@ -2460,7 +2443,7 @@ FORM (REAL_Spectrum_getKurtosis, U"Spectrum: Get kurtosis", U"Spectrum: Get kurt OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getKurtosis (me, power); + const double result = Spectrum_getKurtosis (me, power); NUMBER_ONE_END (U" (kurtosis)") } @@ -2470,7 +2453,7 @@ FORM (REAL_Spectrum_getSoundPressureLevelOfNearestMaximum, U"Spectrum: Get sound DO NUMBER_ONE (Spectrum) MelderPoint maximum = Spectrum_getNearestMaximum (me, frequency); - double result = maximum. y; + const double result = maximum. y; NUMBER_ONE_END (U" \"dB/Hz\"") } @@ -2480,13 +2463,13 @@ FORM (REAL_Spectrum_getFrequencyOfNearestMaximum, U"Spectrum: Get frequency of n DO NUMBER_ONE (Spectrum) MelderPoint maximum = Spectrum_getNearestMaximum (me, frequency); - double result = maximum. x; + const double result = maximum. x; NUMBER_ONE_END (U" Hz") } DIRECT (INTEGER_Spectrum_getNumberOfBins) { NUMBER_ONE (Spectrum) - integer result = my nx; + const integer result = my nx; NUMBER_ONE_END (U" bins") } @@ -2495,7 +2478,7 @@ FORM (REAL_Spectrum_getSkewness, U"Spectrum: Get skewness", U"Spectrum: Get skew OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getSkewness (me, power); + const double result = Spectrum_getSkewness (me, power); NUMBER_ONE_END (U" (skewness)") } @@ -2504,7 +2487,7 @@ FORM (REAL_Spectrum_getStandardDeviation, U"Spectrum: Get standard deviation", U OK DO NUMBER_ONE (Spectrum) - double result = Spectrum_getStandardDeviation (me, power); + const double result = Spectrum_getStandardDeviation (me, power); NUMBER_ONE_END (U" hertz") } @@ -2715,13 +2698,13 @@ DIRECT (WINDOW_Strings_viewAndEdit) { DIRECT (BOOLEAN_Strings_equal) { NUMBER_COUPLE (Strings) - integer result = (integer) Data_equal (me, you); // cast bool to 0 or 1 + const integer result = (integer) Data_equal (me, you); // cast bool to 0 or 1 NUMBER_COUPLE_END (result ? U" (equal)" : U" (unequal)") } DIRECT (INTEGER_Strings_getNumberOfStrings) { NUMBER_ONE (Strings) - integer result = my numberOfStrings; + const integer result = my numberOfStrings; NUMBER_ONE_END (U" strings") } @@ -2803,7 +2786,7 @@ DO CONVERT_EACH (Strings) integer numberOfMatches, numberOfStringMatches; autoStrings result = Strings_change (me, find, replaceWith, - replaceLimitPerString, & numberOfMatches, & numberOfStringMatches, findAndReplaceStringsAre); // FIXME: boolean inappropriate + replaceLimitPerString, & numberOfMatches, & numberOfStringMatches, findAndReplaceStringsAre); // FIXME: boolean inappropriate CONVERT_EACH_END (my name.get(), U"_replaced") } @@ -2984,6 +2967,7 @@ void praat_uvafon_init () { Data_recognizeFileType (chronologicalTextGridTextFileRecognizer); Data_recognizeFileType (IDXFormattedMatrixFileRecognizer); + structPitchTierArea :: f_preferences (); structManipulationEditor :: f_preferences (); structSpectrumEditor :: f_preferences (); structFormantGridEditor :: f_preferences (); diff --git a/fon/praat_Matrix.cpp b/fon/praat_Matrix.cpp index 9b61c8ad..846ec31b 100644 --- a/fon/praat_Matrix.cpp +++ b/fon/praat_Matrix.cpp @@ -1,6 +1,6 @@ /* praat_Matrix.cpp * - * Copyright (C) 1992-2018 Paul Boersma + * Copyright (C) 1992-2005,2007,2011-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -79,6 +79,17 @@ DO CREATE_ONE_END (name); } +FORM (NEW1_Matrix_createSimpleFromValues, U"Create simple Matrix from values", U"Create simple Matrix from values...") { + WORD (name, U"Name", U"xy") + NUMMAT (values, U"Values", U"{ { 10, 20, 30 }, { 60, 70, 80 } }") + OK +DO + CREATE_ONE + autoMatrix result = Matrix_createSimple (values.nrow, values.ncol); + result -> z.all() <<= values; + CREATE_ONE_END (name); +} + // MARK: Open FORM_READ (READ1_Matrix_readFromRawTextFile, U"Read Matrix from raw text file", nullptr, true) { @@ -127,7 +138,8 @@ extern "C" Graphics Movie_create (conststring32 title, int width, int height) { static GuiDrawingArea drawingArea; if (! theMovieGraphics) { dialog = GuiDialog_create (theCurrentPraatApplication -> topShell, 100, 100, width + 2, height + 2, title, nullptr, nullptr, 0); - drawingArea = GuiDrawingArea_createShown (dialog, 0, width, 0, height, gui_drawingarea_cb_expose, nullptr, nullptr, nullptr, nullptr, 0); + drawingArea = GuiDrawingArea_createShown (dialog, 0, width, 0, height, + gui_drawingarea_cb_expose, nullptr, nullptr, nullptr, nullptr, 0); GuiThing_show (dialog); theMovieGraphics = Graphics_create_xmdrawingarea (drawingArea); } @@ -818,6 +830,7 @@ void praat_Matrix_init () { praat_addMenuCommand (U"Objects", U"New", U"Matrix", nullptr, 0, nullptr); praat_addMenuCommand (U"Objects", U"New", U"Create Matrix...", nullptr, 1, NEW1_Matrix_create); praat_addMenuCommand (U"Objects", U"New", U"Create simple Matrix...", nullptr, 1, NEW1_Matrix_createSimple); + praat_addMenuCommand (U"Objects", U"New", U"Create simple Matrix from values...", nullptr, 1, NEW1_Matrix_createSimpleFromValues); praat_addMenuCommand (U"Objects", U"New", U"-- colour matrix --", nullptr, 1, nullptr); praat_addMenuCommand (U"Objects", U"New", U"Create Photo...", nullptr, 1, NEW1_Photo_create); praat_addMenuCommand (U"Objects", U"New", U"Create simple Photo...", nullptr, 1, NEW1_Photo_createSimple); diff --git a/fon/praat_Sound.cpp b/fon/praat_Sound.cpp index a149b803..568cadc9 100644 --- a/fon/praat_Sound.cpp +++ b/fon/praat_Sound.cpp @@ -45,8 +45,10 @@ DIRECT (INFO_LongSound_concatenate) { INFO_NONE - Melder_information (U"To concatenate LongSound objects, select them in the list\nand choose \"Save as WAV file...\" or a similar command.\n" - "The result will be a sound file that contains\nthe concatenation of the selected sounds."); + Melder_information (U"To concatenate LongSound objects, " + "select them in the list\nand choose \"Save as WAV file...\" or a similar command.\n" + "The result will be a sound file that contains\nthe concatenation of the selected sounds." + ); INFO_NONE_END } @@ -66,19 +68,19 @@ FORM (REAL_LongSound_getIndexFromTime, U"LongSound: Get sample index from time", OK DO NUMBER_ONE (LongSound) - double result = Sampled_xToIndex (me, time); + const double result = Sampled_xToIndex (me, time); NUMBER_ONE_END (U" (index at ", time, U" seconds)") } DIRECT (REAL_LongSound_getSamplePeriod) { NUMBER_ONE (LongSound) - double result = my dx; + const double result = my dx; NUMBER_ONE_END (U" seconds"); } DIRECT (REAL_LongSound_getSampleRate) { NUMBER_ONE (LongSound) - double result = 1.0 / my dx; + const double result = 1.0 / my dx; NUMBER_ONE_END (U" Hz") } @@ -87,13 +89,13 @@ FORM (REAL_LongSound_getTimeFromIndex, U"LongSound: Get time from sample index", OK DO NUMBER_ONE (LongSound) - double result = Sampled_indexToX (me, sampleIndex); + const double result = Sampled_indexToX (me, sampleIndex); NUMBER_ONE_END (U" seconds") } DIRECT (INTEGER_LongSound_getNumberOfSamples) { NUMBER_ONE (LongSound) - integer result = my nx; + const integer result = my nx; NUMBER_ONE_END (U" samples") } @@ -352,7 +354,7 @@ DO DIRECT (NEW1_Sounds_combineToStereo) { CONVERT_LIST (Sound) autoSound result = Sounds_combineToStereo (& list); - integer numberOfChannels = result -> ny; // dereference before transferring + const integer numberOfChannels = result -> ny; // dereference before transferring CONVERT_LIST_END (U"combined_", numberOfChannels) } @@ -401,7 +403,7 @@ DIRECT (NEW2_Sounds_concatenateRecoverably) { dx = my dx; } else if (my dx != dx) { Melder_throw (U"To concatenate sounds, their sampling frequencies should be equal.\n" - "You could resample one or more of the sounds before concatenating."); + "You could resample one or more of the sounds before concatenating."); } nx += my nx; } @@ -410,7 +412,7 @@ DIRECT (NEW2_Sounds_concatenateRecoverably) { nx = 0; LOOP { iam (Sound); - double tmax = tmin + my nx * dx; + const double tmax = tmin + my nx * dx; thy z.verticalBand (nx + 1, nx + my nx) <<= my z.all(); iinterval ++; if (iinterval > 1) @@ -458,7 +460,7 @@ DO static void common_Sound_create (conststring32 name, integer numberOfChannels, double startTime, double endTime, double samplingFrequency, conststring32 formula, Interpreter interpreter) { - double numberOfSamples_real = round ((endTime - startTime) * samplingFrequency); + const double numberOfSamples_real = round ((endTime - startTime) * samplingFrequency); if (endTime <= startTime) { if (endTime == startTime) Melder_appendError (U"A Sound cannot have a duration of zero."); @@ -484,17 +486,17 @@ static void common_Sound_create (conststring32 name, integer numberOfChannels, d } if (numberOfSamples_real > INT54_MAX) { Melder_appendError (U"A Sound cannot have ", numberOfSamples_real, U" samples; the maximum is ", - Melder_bigInteger (INT54_MAX), U" samples (or less, depending on your computer's memory)."); + Melder_bigInteger (INT54_MAX), U" samples (or less, depending on your computer's memory)."); if (startTime == 0.0) Melder_throw (U"Please lower the end time or the sampling frequency."); else Melder_throw (U"Please raise the start time, lower the end time, or lower the sampling frequency."); } - int64 numberOfSamples = (int64) numberOfSamples_real; + const integer numberOfSamples = (int64) numberOfSamples_real; autoSound sound; try { sound = Sound_create (numberOfChannels, startTime, endTime, numberOfSamples, 1.0 / samplingFrequency, - startTime + 0.5 * (endTime - startTime - (numberOfSamples - 1) / samplingFrequency)); + startTime + 0.5 * (endTime - startTime - (numberOfSamples - 1) / samplingFrequency)); } catch (MelderError) { if (str32str (Melder_getError (), U"memory")) { Melder_clearError (); @@ -549,7 +551,7 @@ FORM (NEW1_Sound_createAsPureTone, U"Create Sound as pure tone", U"Create Sound DO CREATE_ONE autoSound result = Sound_createAsPureTone (numberOfChannels, startTime, endTime, - samplingFrequency, toneFrequency, amplitude, fadeInDuration, fadeOutDuration); + samplingFrequency, toneFrequency, amplitude, fadeInDuration, fadeOutDuration); CREATE_ONE_END (name) } @@ -569,7 +571,7 @@ FORM (NEW1_Sound_createAsToneComplex, U"Create Sound as tone complex", U"Create DO CREATE_ONE autoSound result = Sound_createAsToneComplex (startTime, endTime, - samplingFrequency, phase, frequencyStep, firstFrequency, ceiling, numberOfComponents); + samplingFrequency, phase, frequencyStep, firstFrequency, ceiling, numberOfComponents); CREATE_ONE_END (name) } @@ -617,7 +619,7 @@ FORM (NEW_Sound_deepenBandModulation, U"Deepen band modulation", U"Sound: Deepen DO CONVERT_EACH (Sound) autoSound result = Sound_deepenBandModulation (me, enhancement, fromFrequency, toFrequency, - slowModulation, fastModulation, bandSmoothing); + slowModulation, fastModulation, bandSmoothing); CONVERT_EACH_END (my name.get(), U"_", Melder_roundTowardsZero (enhancement)) } @@ -631,7 +633,7 @@ FORM (GRAPHICS_old_Sound_draw, U"Sound: Draw", nullptr) { DO GRAPHICS_EACH (Sound) Sound_draw (me, GRAPHICS, fromTime, toTime, - fromAmplitude, toAmplitude, garnish, U"curve"); + fromAmplitude, toAmplitude, garnish, U"curve"); GRAPHICS_EACH_END } @@ -643,15 +645,15 @@ FORM (GRAPHICS_Sound_draw, U"Sound: Draw", nullptr) { BOOLEAN (garnish, U"Garnish", true) LABEL (U"") OPTIONMENUSTR (drawingMethod, U"Drawing method", 1) - OPTION (U"Curve") - OPTION (U"Bars") - OPTION (U"Poles") - OPTION (U"Speckles") + OPTION (U"curve") + OPTION (U"bars") + OPTION (U"poles") + OPTION (U"speckles") OK DO_ALTERNATIVE (GRAPHICS_old_Sound_draw) GRAPHICS_EACH (Sound) Sound_draw (me, GRAPHICS, fromTime, toTime, - fromAmplitude, toAmplitude, garnish, drawingMethod); + fromAmplitude, toAmplitude, garnish, drawingMethod); GRAPHICS_EACH_END } @@ -660,7 +662,7 @@ static void cb_SoundEditor_publication (Editor /* me */, autoDaata publication) * Keep the gate for error handling. */ try { - bool isaSpectrum = Thing_isa (publication.get(), classSpectrum); + const bool isaSpectrum = Thing_isa (publication.get(), classSpectrum); praat_new (publication.move(), U""); praat_updateSelection (); if (isaSpectrum) { @@ -729,7 +731,7 @@ FORM (NEW_Sound_extractPart, U"Sound: Extract part", nullptr) { DO CONVERT_EACH (Sound) autoSound result = Sound_extractPart (me, fromTime, toTime, - windowShape, relativeWidth, preserveTimes); + windowShape, relativeWidth, preserveTimes); CONVERT_EACH_END (my name.get(), U"_part") } @@ -844,25 +846,20 @@ FORM (MODIFY_Sound_formula_part, U"Sound: Formula (part)", U"Sound: Formula...") OK DO MODIFY_EACH_WEAK (Sound) - Matrix_formula_part (me, fromTime, toTime, - fromChannel - 0.5, toChannel + 0.5, - formula, interpreter, nullptr); + Matrix_formula_part (me, fromTime, toTime, fromChannel - 0.5, toChannel + 0.5, + formula, interpreter, nullptr); MODIFY_EACH_WEAK_END } FORM (REAL_Sound_getAbsoluteExtremum, U"Sound: Get absolute extremum", U"Sound: Get absolute extremum...") { REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (Sound) - double result = Vector_getAbsoluteExtremum (me, fromTime, toTime, interpolation); + const double result = Vector_getAbsoluteExtremum (me, fromTime, toTime, peakInterpolationType); NUMBER_ONE_END (U" Pascal") } @@ -872,13 +869,13 @@ FORM (REAL_Sound_getEnergy, U"Sound: Get energy", U"Sound: Get energy...") { OK DO NUMBER_ONE (Sound) - double result = Sound_getEnergy (me, fromTime, toTime); + const double result = Sound_getEnergy (me, fromTime, toTime); NUMBER_ONE_END (U" Pa2 sec") } DIRECT (REAL_Sound_getEnergyInAir) { NUMBER_ONE (Sound) - double result = Sound_getEnergyInAir (me); + const double result = Sound_getEnergyInAir (me); NUMBER_ONE_END (U" Joule/m2") } @@ -887,29 +884,25 @@ FORM (REAL_Sound_getIndexFromTime, U"Get sample number from time", U"Get sample OK DO NUMBER_ONE (Sound) - double result = Sampled_xToIndex (me, time); + const double result = Sampled_xToIndex (me, time); NUMBER_ONE_END (U" (index at time ", time, U" seconds)") } DIRECT (REAL_Sound_getIntensity_dB) { NUMBER_ONE (Sound) - double result = Sound_getIntensity_dB (me); + const double result = Sound_getIntensity_dB (me); NUMBER_ONE_END (U" dB") } FORM (REAL_Sound_getMaximum, U"Sound: Get maximum", U"Sound: Get maximum...") { REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (Sound) - double result = Vector_getMaximum (me, fromTime, toTime, interpolation); + const double result = Vector_getMaximum (me, fromTime, toTime, peakInterpolationType); NUMBER_ONE_END (U" Pascal") } @@ -919,7 +912,7 @@ FORM (REAL_old_Sound_getMean, U"Sound: Get mean", U"Sound: Get mean...") { OK DO NUMBER_ONE (Sound) - double result = Vector_getMean (me, fromTime, toTime, Vector_CHANNEL_AVERAGE); + const double result = Vector_getMean (me, fromTime, toTime, Vector_CHANNEL_AVERAGE); NUMBER_ONE_END (U" Pascal") } @@ -931,23 +924,19 @@ FORM (REAL_Sound_getMean, U"Sound: Get mean", U"Sound: Get mean...") { DO_ALTERNATIVE (REAL_old_Sound_getMean) NUMBER_ONE (Sound) if (channel > my ny) channel = 1; - double result = Vector_getMean (me, fromTime, toTime, channel); + const double result = Vector_getMean (me, fromTime, toTime, channel); NUMBER_ONE_END (U" Pascal") } FORM (REAL_Sound_getMinimum, U"Sound: Get minimum", U"Sound: Get minimum...") { REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (Sound) - double result = Vector_getMinimum (me, fromTime, toTime, interpolation); + const double result = Vector_getMinimum (me, fromTime, toTime, peakInterpolationType); NUMBER_ONE_END (U" Pascal") } @@ -957,7 +946,7 @@ FORM (REAL_old_Sound_getNearestZeroCrossing, U"Sound: Get nearest zero crossing" DO NUMBER_ONE (Sound) if (my ny > 1) Melder_throw (U"Cannot determine a zero crossing for a stereo sound."); - double result = Sound_getNearestZeroCrossing (me, time, 1); + const double result = Sound_getNearestZeroCrossing (me, time, 1); NUMBER_ONE_END (U" seconds") } @@ -968,19 +957,19 @@ FORM (REAL_Sound_getNearestZeroCrossing, U"Sound: Get nearest zero crossing", U" DO_ALTERNATIVE (REAL_old_Sound_getNearestZeroCrossing) NUMBER_ONE (Sound) if (channel > my ny) channel = 1; - double result = Sound_getNearestZeroCrossing (me, time, channel); + const double result = Sound_getNearestZeroCrossing (me, time, channel); NUMBER_ONE_END (U" seconds") } DIRECT (INTEGER_Sound_getNumberOfChannels) { NUMBER_ONE (Sound) - integer result = my ny; + const integer result = my ny; NUMBER_ONE_END (result == 1 ? U" channel (mono)" : result == 2 ? U" channels (stereo)" : U" channels") } DIRECT (INTEGER_Sound_getNumberOfSamples) { NUMBER_ONE (Sound) - integer result = my nx; + const integer result = my nx; NUMBER_ONE_END (U" samples") } @@ -990,13 +979,13 @@ FORM (REAL_Sound_getPower, U"Sound: Get power", U"Sound: Get power...") { OK DO NUMBER_ONE (Sound) - double result = Sound_getPower (me, fromTime, toTime); + const double result = Sound_getPower (me, fromTime, toTime); NUMBER_ONE_END (U" Pa2") } DIRECT (REAL_Sound_getPowerInAir) { NUMBER_ONE (Sound) - double result = Sound_getPowerInAir (me); + const double result = Sound_getPowerInAir (me); NUMBER_ONE_END (U" Watt/m2") } @@ -1006,19 +995,19 @@ FORM (REAL_Sound_getRootMeanSquare, U"Sound: Get root-mean-square", U"Sound: Get OK DO NUMBER_ONE (Sound) - double result = Sound_getRootMeanSquare (me, fromTime, toTime); + const double result = Sound_getRootMeanSquare (me, fromTime, toTime); NUMBER_ONE_END (U" Pascal") } DIRECT (REAL_Sound_getSamplePeriod) { NUMBER_ONE (Sound) - double result = my dx; + const double result = my dx; NUMBER_ONE_END (U" seconds") } DIRECT (REAL_Sound_getSampleRate) { NUMBER_ONE (Sound) - double result = 1.0 / my dx; + const double result = 1.0 / my dx; NUMBER_ONE_END (U" Hz") } @@ -1028,7 +1017,7 @@ FORM (REAL_old_Sound_getStandardDeviation, U"Sound: Get standard deviation", U"S OK DO NUMBER_ONE (Sound) - double result = Vector_getStandardDeviation (me, fromTime, toTime, Vector_CHANNEL_AVERAGE); + const double result = Vector_getStandardDeviation (me, fromTime, toTime, Vector_CHANNEL_AVERAGE); NUMBER_ONE_END (U" Pascal") } @@ -1040,7 +1029,7 @@ FORM (REAL_Sound_getStandardDeviation, U"Sound: Get standard deviation", U"Sound DO_ALTERNATIVE (REAL_old_Sound_getStandardDeviation) NUMBER_ONE (Sound) if (channel > my ny) channel = 1; - double result = Vector_getStandardDeviation (me, fromTime, toTime, channel); + const double result = Vector_getStandardDeviation (me, fromTime, toTime, channel); NUMBER_ONE_END (U" Pascal") } @@ -1049,7 +1038,7 @@ FORM (REAL_Sound_getTimeFromIndex, U"Get time from sample number", U"Get time fr OK DO NUMBER_ONE (Sound) - double result = Sampled_indexToX (me, sampleNumber); + const double result = Sampled_indexToX (me, sampleNumber); NUMBER_ONE_END (U" seconds") } @@ -1062,32 +1051,24 @@ DIRECT (NUMVEC_Sound_listAllSampleTimes) { FORM (REAL_Sound_getTimeOfMaximum, U"Sound: Get time of maximum", U"Sound: Get time of maximum...") { REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (Sound) - double result = Vector_getXOfMaximum (me, fromTime, toTime, interpolation); + const double result = Vector_getXOfMaximum (me, fromTime, toTime, peakInterpolationType); NUMBER_ONE_END (U" seconds") } FORM (REAL_Sound_getTimeOfMinimum, U"Sound: Get time of minimum", U"Sound: Get time of minimum...") { REAL (fromTime, U"left Time range (s)", U"0.0") REAL (toTime, U"right Time range (s)", U"0.0 (= all)") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO NUMBER_ONE (Sound) - double result = Vector_getXOfMinimum (me, fromTime, toTime, interpolation); + const double result = Vector_getXOfMinimum (me, fromTime, toTime, peakInterpolationType); NUMBER_ONE_END (U" seconds") } @@ -1096,8 +1077,8 @@ FORM (REAL_old_Sound_getValueAtIndex, U"Sound: Get value at sample number", U"So OK DO NUMBER_ONE (Sound) - double result = sampleNumber < 1 || sampleNumber > my nx ? undefined : - my ny == 1 ? my z [1] [sampleNumber] : 0.5 * (my z [1] [sampleNumber] + my z [2] [sampleNumber]); + const double result = sampleNumber < 1 || sampleNumber > my nx ? undefined : + my ny == 1 ? my z [1] [sampleNumber] : 0.5 * (my z [1] [sampleNumber] + my z [2] [sampleNumber]); NUMBER_ONE_END (U" Pascal") } @@ -1108,40 +1089,32 @@ FORM (REAL_Sound_getValueAtIndex, U"Sound: Get value at sample number", U"Sound: DO_ALTERNATIVE (REAL_old_Sound_getValueAtIndex) NUMBER_ONE (Sound) if (channel > my ny) channel = 1; - double result = sampleNumber < 1 || sampleNumber > my nx ? undefined : - Sampled_getValueAtSample (me, sampleNumber, channel, 0); + const double result = sampleNumber < 1 || sampleNumber > my nx ? undefined : + Sampled_getValueAtSample (me, sampleNumber, channel, 0); NUMBER_ONE_END (U" Pascal") } FORM (REAL_old_Sound_getValueAtTime, U"Sound: Get value at time", U"Sound: Get value at time...") { REAL (time, U"Time (s)", U"0.5") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"Nearest") - RADIOBUTTON (U"Linear") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_valueInterpolation, valueInterpolationType, + U"Interpolation", kVector_valueInterpolation::SINC70) OK DO NUMBER_ONE (Sound) - double result = Vector_getValueAtX (me, time, Vector_CHANNEL_AVERAGE, interpolation); + const double result = Vector_getValueAtX (me, time, Vector_CHANNEL_AVERAGE, valueInterpolationType); NUMBER_ONE_END (U" Pascal") } FORM (REAL_Sound_getValueAtTime, U"Sound: Get value at time", U"Sound: Get value at time...") { CHANNEL (channel, U"Channel", U"0 (= average)") REAL (time, U"Time (s)", U"0.5") - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"Nearest") - RADIOBUTTON (U"Linear") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_valueInterpolation, valueInterpolationType, + U"Interpolation", kVector_valueInterpolation::SINC70) OK DO_ALTERNATIVE (REAL_old_Sound_getValueAtTime) NUMBER_ONE (Sound) if (channel > my ny) channel = 1; - double result = Vector_getValueAtX (me, time, channel, interpolation); + const double result = Vector_getValueAtX (me, time, channel, valueInterpolationType); NUMBER_ONE_END (U" Pascal") } @@ -1276,36 +1249,32 @@ DIRECT (WINDOW_Sound_recordStereo) { END } FORM (RECORD1_Sound_record_fixedTime, U"Record Sound", nullptr) { + LABEL (U"This menu command is usually hidden,") + LABEL (U" because its behaviour is platform-dependent.") + LABEL (U"The combination of “microphone” and “44100 Hz” is likely") + LABEL (U" to work on all computers.") + LABEL (U"The “Gain” and “Balance” settings tend to be obsolete") + LABEL (U" and may not work at all on your computer.") RADIO (inputSource, U"Input source", 1) - RADIOBUTTON (U"Microphone") - RADIOBUTTON (U"Line") - REAL (gain, U"Gain (0-1)", U"0.1") + OPTION (U"microphone") + OPTION (U"line") + REAL (gain, U"Gain (0-1)", U"1.0") REAL (balance, U"Balance (0-1)", U"0.5") - RADIOSTR (samplingFrequency, U"Sampling frequency", 1) - #ifdef UNIX - RADIOBUTTON (U"8000") - #endif - #ifndef macintosh - RADIOBUTTON (U"11025") - #endif - #ifdef UNIX - RADIOBUTTON (U"16000") - #endif - #ifndef macintosh - RADIOBUTTON (U"22050") - #endif - #ifdef UNIX - RADIOBUTTON (U"32000") - #endif - RADIOBUTTON (U"44100") - RADIOBUTTON (U"48000") - RADIOBUTTON (U"96000") + OPTIONMENUSTR (samplingFrequency, U"Sampling frequency (Hz)", 6) + OPTION (U"8000") + OPTION (U"11025") + OPTION (U"16000") + OPTION (U"22050") + OPTION (U"32000") + OPTION (U"44100") + OPTION (U"48000") + OPTION (U"96000") POSITIVE (duration, U"Duration (seconds)", U"1.0") OK DO CREATE_ONE autoSound result = Sound_record_fixedTime (inputSource, - gain, balance, Melder_atof (samplingFrequency), duration); + gain, balance, Melder_atof (samplingFrequency), duration); CREATE_ONE_END (U"untitled") } @@ -1415,9 +1384,8 @@ DO_ALTERNATIVE (MODIFY_old_Sound_setValueAtIndex) if (channel > 0) { my z [channel] [sampleNumber] = newValue; } else { - for (channel = 1; channel <= my ny; channel ++) { + for (channel = 1; channel <= my ny; channel ++) my z [channel] [sampleNumber] = newValue; - } } MODIFY_EACH_END } @@ -1447,7 +1415,8 @@ FORM (NEW_Sound_to_Manipulation, U"Sound: To Manipulation", U"Manipulation") { POSITIVE (maximumPitch, U"Maximum pitch (Hz)", U"600.0") OK DO - if (maximumPitch <= minimumPitch) Melder_throw (U"The maximum pitch should be greater than the minimum pitch."); + if (maximumPitch <= minimumPitch) + Melder_throw (U"The maximum pitch should be greater than the minimum pitch."); CONVERT_EACH (Sound) autoManipulation result = Sound_to_Manipulation (me, timeStep, minimumPitch, maximumPitch); CONVERT_EACH_END (my name.get()) @@ -1479,49 +1448,49 @@ FORM (NEW_Sound_to_Cochleagram_edb, U"Sound: To Cochleagram (De Boer, Meddis & H DO CONVERT_EACH (Sound) autoCochleagram result = Sound_to_Cochleagram_edb (me, timeStep, frequencyResolution, hasSynapse, - replenishmentRate, lossRate, returnRate, reprocessingRate); + replenishmentRate, lossRate, returnRate, reprocessingRate); CONVERT_EACH_END (my name.get()) } FORM (NEW_Sound_to_Formant_burg, U"Sound: To Formant (Burg method)", U"Sound: To Formant (burg)...") { REAL (timeStep, U"Time step (s)", U"0.0 (= auto)") POSITIVE (maximumNumberOfFormants, U"Max. number of formants", U"5.0") - REAL (maximumFormant, U"Maximum formant (Hz)", U"5500.0 (= adult female)") + REAL (formantCeiling, U"Formant ceiling (Hz)", U"5500.0 (= adult female)") POSITIVE (windowLength, U"Window length (s)", U"0.025") POSITIVE (preEmphasisFrom, U"Pre-emphasis from (Hz)", U"50.0") OK DO CONVERT_EACH (Sound) autoFormant result = Sound_to_Formant_burg (me, timeStep, - maximumNumberOfFormants, maximumFormant, windowLength, preEmphasisFrom); + maximumNumberOfFormants, formantCeiling, windowLength, preEmphasisFrom); CONVERT_EACH_END (my name.get()) } FORM (NEW_Sound_to_Formant_keepAll, U"Sound: To Formant (keep all)", U"Sound: To Formant (keep all)...") { REAL (timeStep, U"Time step (s)", U"0.0 (= auto)") POSITIVE (maximumNumberOfFormants, U"Max. number of formants", U"5.0") - REAL (maximumFormant, U"Maximum formant (Hz)", U"5500.0 (= adult female)") + REAL (formantCeiling, U"Formant ceiling (Hz)", U"5500.0 (= adult female)") POSITIVE (windowLength, U"Window length (s)", U"0.025") POSITIVE (preEmphasisFrom, U"Pre-emphasis from (Hz)", U"50.0") OK DO CONVERT_EACH (Sound) autoFormant result = Sound_to_Formant_keepAll (me, timeStep, - maximumNumberOfFormants, maximumFormant, windowLength, preEmphasisFrom); + maximumNumberOfFormants, formantCeiling, windowLength, preEmphasisFrom); CONVERT_EACH_END (my name.get()) } FORM (NEW_Sound_to_Formant_willems, U"Sound: To Formant (split Levinson (Willems))", U"Sound: To Formant (sl)...") { REAL (timeStep, U"Time step (s)", U"0.0 (= auto)") POSITIVE (numberOfFormants, U"Number of formants", U"5.0") - REAL (maximumFormant, U"Maximum formant (Hz)", U"5500.0 (= adult female)") + REAL (formantCeiling, U"Formant ceiling (Hz)", U"5500.0 (= adult female)") POSITIVE (windowLength, U"Window length (s)", U"0.025") POSITIVE (preEmphasisFrom, U"Pre-emphasis from (Hz)", U"50.0") OK DO CONVERT_EACH (Sound) autoFormant result = Sound_to_Formant_willems (me, timeStep, - numberOfFormants, maximumFormant, windowLength, preEmphasisFrom); + numberOfFormants, formantCeiling, windowLength, preEmphasisFrom); CONVERT_EACH_END (my name.get()) } @@ -1535,7 +1504,7 @@ DO if (periodsPerWindow < 3.0) Melder_throw (U"Number of periods per window must be at least 3.0."); CONVERT_EACH (Sound) autoHarmonicity result = Sound_to_Harmonicity_ac (me, timeStep, - minimumPitch, silenceThreshold, periodsPerWindow); + minimumPitch, silenceThreshold, periodsPerWindow); CONVERT_EACH_END (my name.get()) } @@ -1548,7 +1517,7 @@ FORM (NEW_Sound_to_Harmonicity_cc, U"Sound: To Harmonicity (cc)", U"Sound: To Ha DO CONVERT_EACH (Sound) autoHarmonicity result = Sound_to_Harmonicity_cc (me, timeStep, - minimumPitch, silenceThreshold, periodsPerWindow); + minimumPitch, silenceThreshold, periodsPerWindow); CONVERT_EACH_END (my name.get()) } @@ -1561,7 +1530,7 @@ FORM (NEW_Sound_to_Harmonicity_gne, U"Sound: To Harmonicity (gne)", nullptr) { DO CONVERT_EACH (Sound) autoMatrix result = Sound_to_Harmonicity_GNE (me, minimumFrequency, - maximumFrequency, bandwidth, step); + maximumFrequency, bandwidth, step); CONVERT_EACH_END (my name.get()) } @@ -1572,7 +1541,7 @@ FORM (NEW_old_Sound_to_Intensity, U"Sound: To Intensity", U"Sound: To Intensity. DO CONVERT_EACH (Sound) autoIntensity result = Sound_to_Intensity (me, - minimumPitch, timeStep, false); + minimumPitch, timeStep, false); CONVERT_EACH_END (my name.get()) } @@ -1584,7 +1553,7 @@ FORM (NEW_Sound_to_Intensity, U"Sound: To Intensity", U"Sound: To Intensity...") DO_ALTERNATIVE (NEW_old_Sound_to_Intensity) CONVERT_EACH (Sound) autoIntensity result = Sound_to_Intensity (me, - minimumPitch, timeStep, subtractMean); + minimumPitch, timeStep, subtractMean); CONVERT_EACH_END (my name.get()) } @@ -1596,7 +1565,7 @@ FORM (NEW_Sound_to_IntensityTier, U"Sound: To IntensityTier", nullptr) { DO CONVERT_EACH (Sound) autoIntensityTier result = Sound_to_IntensityTier (me, - minimumPitch, timeStep, subtractMean); + minimumPitch, timeStep, subtractMean); CONVERT_EACH_END (my name.get()) } @@ -1628,7 +1597,7 @@ DO if (maximumPitch <= minimumPitch) Melder_throw (U"Your maximum pitch should be greater than your minimum pitch."); CONVERT_EACH (Sound) autoLtas result = Sound_to_Ltas_pitchCorrected (me, minimumPitch, maximumPitch, - maximumFrequency, bandwidth, shortestPeriod, longestPeriod, maximumPeriodFactor); + maximumFrequency, bandwidth, shortestPeriod, longestPeriod, maximumPeriodFactor); CONVERT_EACH_END (my name.get()) } @@ -1679,7 +1648,8 @@ DO CONVERT_EACH (Sound) autoPitch result = Sound_to_Pitch_ac (me, timeStep, pitchFloor, 3.0, maximumNumberOfCandidates, veryAccurate, - silenceThreshold, voicingThreshold, octaveCost, octaveJumpCost, voicedUnvoicedCost, pitchCeiling); + silenceThreshold, voicingThreshold, octaveCost, octaveJumpCost, voicedUnvoicedCost, pitchCeiling + ); CONVERT_EACH_END (my name.get()) } @@ -1702,7 +1672,8 @@ DO CONVERT_EACH (Sound) autoPitch result = Sound_to_Pitch_cc (me, timeStep, pitchFloor, 1.0, maximumNumberOfCandidates, veryAccurate, - silenceThreshold, voicingThreshold, octaveCost, octaveJumpCost, voicedUnvoicedCost, pitchCeiling); + silenceThreshold, voicingThreshold, octaveCost, octaveJumpCost, voicedUnvoicedCost, pitchCeiling + ); CONVERT_EACH_END (my name.get()) } @@ -1710,17 +1681,13 @@ FORM (NEW_Sound_to_PointProcess_extrema, U"Sound: To PointProcess (extrema)", nu CHANNEL (channel, U"Channel (number, Left, or Right)", U"1") BOOLEAN (includeMaxima, U"Include maxima", true) BOOLEAN (includeMinima, U"Include minima", false) - RADIOx (interpolation, U"Interpolation", 4, 0) - RADIOBUTTON (U"None") - RADIOBUTTON (U"Parabolic") - RADIOBUTTON (U"Cubic") - RADIOBUTTON (U"Sinc70") - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, + U"Interpolation", kVector_peakInterpolation::SINC70) OK DO CONVERT_EACH (Sound) autoPointProcess result = Sound_to_PointProcess_extrema (me, channel > my ny ? 1 : channel, - interpolation, includeMaxima, includeMinima); + peakInterpolationType, includeMaxima, includeMinima); CONVERT_EACH_END (my name.get()) } @@ -1747,7 +1714,7 @@ DO Melder_throw (U"Your maximum pitch should be greater than your minimum pitch."); CONVERT_EACH (Sound) autoPointProcess result = Sound_to_PointProcess_periodic_peaks (me, - minimumPitch, maximumPitch, includeMaxima, includeMinima); + minimumPitch, maximumPitch, includeMaxima, includeMinima); CONVERT_EACH_END (my name.get()) } @@ -1759,7 +1726,7 @@ FORM (NEW_Sound_to_PointProcess_zeroes, U"Get zeroes", nullptr) { DO CONVERT_EACH (Sound) autoPointProcess result = Sound_to_PointProcess_zeroes (me, channel > my ny ? 1 : channel, - includeRaisers, includeFallers); + includeRaisers, includeFallers); CONVERT_EACH_END (my name.get()) } @@ -1774,7 +1741,7 @@ FORM (NEW_Sound_to_Spectrogram, U"Sound: To Spectrogram", U"Sound: To Spectrogra DO CONVERT_EACH (Sound) autoSpectrogram result = Sound_to_Spectrogram (me, windowLength, - maximumFrequency, timeStep, frequencyStep, windowShape, 8.0, 8.0); + maximumFrequency, timeStep, frequencyStep, windowShape, 8.0, 8.0); CONVERT_EACH_END (my name.get()) } @@ -1823,7 +1790,8 @@ OK SET_INTEGER (bufferSize, SoundRecorder_getBufferSizePref_MB ()) SET_ENUM (inputSoundSystem, kMelder_inputSoundSystem, MelderAudio_getInputSoundSystem()) DO - if (bufferSize > 1000) Melder_throw (U"Buffer size cannot exceed 1000 megabytes."); + if (bufferSize > 1000) + Melder_throw (U"Buffer size cannot exceed 1000 megabytes."); SoundRecorder_setBufferSizePref_MB (bufferSize); MelderAudio_setInputSoundSystem (inputSoundSystem); END } @@ -2032,7 +2000,7 @@ DO FIND_TWO (SoundSet, Table) autoPatternList inputs, outputs; SoundSet_Table_getRandomizedPatterns (me, you, columnName, numberOfPatterns, inputSize, outputSize, - & inputs, & outputs); + & inputs, & outputs); praat_new (inputs.move(), U"inputs"); praat_new (outputs.move(), U"outputs"); END diff --git a/fon/praat_TextGrid_init.cpp b/fon/praat_TextGrid_init.cpp index d73e4adb..ada86789 100644 --- a/fon/praat_TextGrid_init.cpp +++ b/fon/praat_TextGrid_init.cpp @@ -145,7 +145,7 @@ FORM (GRAPHICS_TextGrid_Pitch_draw, U"TextGrid & Pitch: Draw", nullptr) { POSITIVE (toFrequency, STRING_TO_FREQUENCY_HZ, U"500.0") POSITIVE (fontSize, U"Font size (points)", U"18") BOOLEAN (useTextStyles, U"Use text styles", true) - OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"Left") OPTION (U"Centre") OPTION (U"Right") + OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"left") OPTION (U"centre") OPTION (U"right") BOOLEAN (garnish, U"Garnish", true) OK DO @@ -162,7 +162,7 @@ FORM (GRAPHICS_TextGrid_Pitch_drawErb, U"TextGrid & Pitch: Draw erb", nullptr) { REAL (toFrequency, U"right Frequency range (ERB)", U"10.0") POSITIVE (fontSize, U"Font size (points)", U"18") BOOLEAN (useTextStyles, U"Use text styles", true) - OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"Left") OPTION (U"Centre") OPTION (U"Right") + OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"left") OPTION (U"centre") OPTION (U"right") BOOLEAN (garnish, U"Garnish", true) OK DO @@ -179,7 +179,7 @@ FORM (GRAPHICS_TextGrid_Pitch_drawLogarithmic, U"TextGrid & Pitch: Draw logarith POSITIVE (toFrequency, STRING_TO_FREQUENCY_HZ, U"500.0") POSITIVE (fontSize, U"Font size (points)", U"18") BOOLEAN (useTextStyles, U"Use text styles", true) - OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"Left") OPTION (U"Centre") OPTION (U"Right") + OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"left") OPTION (U"centre") OPTION (U"right") BOOLEAN (garnish, U"Garnish", true) OK DO @@ -196,7 +196,7 @@ FORM (GRAPHICS_TextGrid_Pitch_drawMel, U"TextGrid & Pitch: Draw mel", nullptr) { REAL (toFrequency, U"right Frequency range (mel)", U"500.0") POSITIVE (fontSize, U"Font size (points)", U"18") BOOLEAN (useTextStyles, U"Use text styles", true) - OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"Left") OPTION (U"Centre") OPTION (U"Right") + OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"left") OPTION (U"centre") OPTION (U"right") BOOLEAN (garnish, U"Garnish", true) OK DO @@ -214,7 +214,7 @@ FORM (GRAPHICS_TextGrid_Pitch_drawSemitones, U"TextGrid & Pitch: Draw semitones" REAL (toFrequency, U"right Frequency range (st)", U"30.0") POSITIVE (fontSize, U"Font size (points)", U"18") BOOLEAN (useTextStyles, U"Use text styles", true) - OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"Left") OPTION (U"Centre") OPTION (U"Right") + OPTIONMENUx (textAlignment, U"Text alignment", 2, 0) OPTION (U"left") OPTION (U"centre") OPTION (U"right") BOOLEAN (garnish, U"Garnish", true) OK DO @@ -461,9 +461,9 @@ DO FORM (NEW1_Pitch_TextTier_to_PitchTier, U"Pitch & TextTier to PitchTier", U"Pitch & TextTier: To PitchTier...") { RADIOx (unvoicedStrategy, U"Unvoiced strategy", 3, 0) - RADIOBUTTON (U"Zero") - RADIOBUTTON (U"Error") - RADIOBUTTON (U"Interpolate") + RADIOBUTTON (U"zero") + RADIOBUTTON (U"error") + RADIOBUTTON (U"interpolate") OK DO CONVERT_TWO (Pitch, TextTier) diff --git a/fon/praat_Tiers.cpp b/fon/praat_Tiers.cpp index c0b4f193..61b6b48e 100644 --- a/fon/praat_Tiers.cpp +++ b/fon/praat_Tiers.cpp @@ -760,7 +760,7 @@ DIRECT (NEW_PitchTier_downto_PointProcess) { FORM (NEW_PitchTier_downto_TableOfReal, U"PitchTier: Down to TableOfReal", nullptr) { RADIOx (unit, U"Unit", 1, 0) RADIOBUTTON (U"Hertz") - RADIOBUTTON (U"Semitones") + RADIOBUTTON (U"semitones") OK DO CONVERT_EACH (PitchTier) @@ -895,7 +895,7 @@ FORM (MODIFY_PitchTier_interpolateQuadratically, U"PitchTier: Interpolate quadra NATURAL (numberOfPointsPerParabola, U"Number of points per parabola", U"4") RADIOx (unit, U"Unit", 2, 0) RADIOBUTTON (U"Hz") - RADIOBUTTON (U"Semitones") + RADIOBUTTON (U"semitones") OK DO MODIFY_EACH (PitchTier) @@ -953,7 +953,7 @@ FORM (MODIFY_PitchTier_stylize, U"PitchTier: Stylize", U"PitchTier: Stylize...") REAL (frequencyResolution, U"Frequency resolution", U"4.0") RADIOx (unit, U"Unit", 2, 0) RADIOBUTTON (U"Hz") - RADIOBUTTON (U"Semitones") + RADIOBUTTON (U"semitones") OK DO MODIFY_EACH (PitchTier) diff --git a/fon/praat_TimeVector.h b/fon/praat_TimeVector.h index b257eb83..ba371734 100644 --- a/fon/praat_TimeVector.h +++ b/fon/praat_TimeVector.h @@ -2,7 +2,7 @@ #define _praat_TimeVector_h_ /* praat_TimeVector.h * - * Copyright (C) 2016,2017 Paul Boersma + * Copyright (C) 2016,2017,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -29,23 +29,15 @@ Prompting for interpolated values at a time or within a time range. */ -#define praat_TimeVector_INTERPOLATED_VALUE(time,interpolation) \ +#define praat_TimeVector_INTERPOLATED_VALUE(time,valueInterpolationType) \ REAL (time, U"Time (s)", U"0.5") \ - RADIOx (interpolation, U"Interpolation", 3, 0) \ - RADIOBUTTON (U"Nearest") \ - RADIOBUTTON (U"Linear") \ - RADIOBUTTON (U"Cubic") \ - RADIOBUTTON (U"Sinc70") \ - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_valueInterpolation, valueInterpolationType, \ + U"Interpolation", kVector_valueInterpolation::CUBIC) -#define praat_TimeVector_INTERPOLATED_EXTREMUM(fromTime,toTime,interpolation) \ +#define praat_TimeVector_INTERPOLATED_EXTREMUM(fromTime,toTime,peakInterpolationType) \ praat_TimeFunction_RANGE (fromTime, toTime) \ - RADIOx (interpolation, U"Interpolation", 2, 0) \ - RADIOBUTTON (U"None") \ - RADIOBUTTON (U"Parabolic") \ - RADIOBUTTON (U"Cubic") \ - RADIOBUTTON (U"Sinc70") \ - RADIOBUTTON (U"Sinc700") + RADIO_ENUM (kVector_peakInterpolation, peakInterpolationType, \ + U"Interpolation", kVector_peakInterpolation::PARABOLIC) /* End of file praat_TimeVector.h */ #endif diff --git a/gram/NoulliGrid.cpp b/gram/NoulliGrid.cpp index ff14ae13..7038e74e 100644 --- a/gram/NoulliGrid.cpp +++ b/gram/NoulliGrid.cpp @@ -87,5 +87,10 @@ autoNoulliPoint NoulliGrid_average (NoulliGrid me, integer tierNumber, double tm } } +autoVEC NoulliGrid_getAverageProbabilities (NoulliGrid me, integer tierNumber, double tmin, double tmax) { + autoNoulliPoint point = NoulliGrid_average (me, tierNumber, tmin, tmax); + return newVECcopy (point -> probabilities.get()); +} + /* End of file NoulliGrid.cpp */ diff --git a/gram/NoulliGrid.h b/gram/NoulliGrid.h index ce3d8627..73f7c205 100644 --- a/gram/NoulliGrid.h +++ b/gram/NoulliGrid.h @@ -2,7 +2,7 @@ #define _NoulliGrid_h_ /* NoulliGrid.h * - * Copyright (C) 2018 Paul Boersma + * Copyright (C) 2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -27,6 +27,8 @@ integer NoulliPoint_getWinningCategory (NoulliPoint me); autoNoulliPoint NoulliGrid_average (NoulliGrid me, integer tierNumber, double tmin, double tmax); +autoVEC NoulliGrid_getAverageProbabilities (NoulliGrid me, integer tierNumber, double tmin, double tmax); + /* End of file NoulliGrid.h */ #endif diff --git a/gram/NoulliGridEditor.cpp b/gram/NoulliGridEditor.cpp index bdbd9fda..2cbf229c 100644 --- a/gram/NoulliGridEditor.cpp +++ b/gram/NoulliGridEditor.cpp @@ -1,6 +1,6 @@ /* NoulliGridEditor.cpp * - * Copyright (C) 2018 Paul Boersma + * Copyright (C) 2018-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -39,9 +39,8 @@ Thing_implement (NoulliGridEditor, TimeSoundEditor, 0); void structNoulliGridEditor :: v_draw () { NoulliGrid data = (NoulliGrid) our data; - Graphics_Viewport viewport; if (our d_sound.data) { - viewport = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 1.0 - SOUND_HEIGHT, 1.0); + Graphics_Viewport viewport = Graphics_insetViewport (our graphics.get(), 0.0, 1.0, 1.0 - SOUND_HEIGHT, 1.0); Graphics_setColour (our graphics.get(), Melder_WHITE); Graphics_setWindow (our graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_fillRectangle (our graphics.get(), 0.0, 1.0, 0.0, 1.0); @@ -59,9 +58,10 @@ void structNoulliGridEditor :: v_draw () { NoulliTier tier = data -> tiers.at [itier]; for (integer ipoint = 1; ipoint < tier -> points.size; ipoint ++) { NoulliPoint point = tier -> points.at [ipoint], nextPoint = tier -> points.at [ipoint + 1]; - double time = 0.5 * (point -> xmin + point -> xmax), nextTime = 0.5 * (nextPoint -> xmin + nextPoint -> xmax); + const double time = 0.5 * (point -> xmin + point -> xmax); + const double nextTime = 0.5 * (nextPoint -> xmin + nextPoint -> xmax); if (time > our startWindow && nextTime < our endWindow) { - double prob = point -> probabilities [1], nextProb = nextPoint -> probabilities [1]; + const double prob = point -> probabilities [1], nextProb = nextPoint -> probabilities [1]; Graphics_setColour (our graphics.get(), Melder_cyclingBackgroundColour (itier)); Graphics_line (our graphics.get(), time, prob, nextTime, nextProb); } @@ -72,18 +72,19 @@ void structNoulliGridEditor :: v_draw () { Graphics_setWindow (our graphics.get(), our startWindow, our endWindow, 0.0, data -> tiers.size); for (integer itier = 1; itier <= data -> tiers.size; itier ++) { NoulliTier tier = data -> tiers.at [itier]; - double ymin = data -> tiers.size - itier, ymax = ymin + 1; + const double ymin = data -> tiers.size - itier, ymax = ymin + 1; for (integer ipoint = 1; ipoint <= tier -> points.size; ipoint ++) { NoulliPoint point = tier -> points.at [ipoint]; if (point -> xmax > our startWindow && point -> xmin < our endWindow) { - double xmin = point -> xmin > our startWindow ? point -> xmin : our startWindow; - double xmax = point -> xmax < our endWindow ? point -> xmax : our endWindow; - double prob1 = 1.0, prob2; + const double xmin = Melder_clippedLeft (our startWindow, point -> xmin); + const double xmax = Melder_clippedRight (point -> xmax, our endWindow); + double prob1 = 1.0; for (integer icategory = 1; icategory <= point -> numberOfCategories; icategory ++) { - prob2 = prob1; + const double prob2 = prob1; prob1 -= point -> probabilities [icategory]; Graphics_setColour (our graphics.get(), Melder_cyclingBackgroundColour (icategory)); - Graphics_fillRectangle (our graphics.get(), xmin, xmax, ymin + prob1 * (ymax - ymin), ymin + prob2 * (ymax - ymin)); + Graphics_fillRectangle (our graphics.get(), xmin, xmax, + ymin + prob1 * (ymax - ymin), ymin + prob2 * (ymax - ymin)); } } } @@ -99,17 +100,14 @@ void structNoulliGridEditor :: v_draw () { our v_updateMenuItems_file (); } -void structNoulliGridEditor :: v_play (double a_tmin, double a_tmax) { +void structNoulliGridEditor :: v_play (double startTime, double endTime) { if (our d_sound.data) - Sound_playPart (our d_sound.data, a_tmin, a_tmax, theFunctionEditor_playCallback, this); + Sound_playPart (our d_sound.data, startTime, endTime, theFunctionEditor_playCallback, this); } static void drawSelectionOrWindow (NoulliGridEditor me, double xmin, double xmax, double tmin, double tmax, conststring32 header) { NoulliGrid grid = (NoulliGrid) my data; for (integer itier = 1; itier <= grid -> tiers.size; itier ++) { - Graphics_Viewport vp = Graphics_insetViewport (my graphics.get(), xmin, xmax, - (grid -> tiers.size - itier + 0.0) / grid -> tiers.size * (1.0 - SOUND_HEIGHT), - (grid -> tiers.size - itier + 1.0) / grid -> tiers.size * (1.0 - SOUND_HEIGHT)); if (itier == 1) { Graphics_setColour (my graphics.get(), Melder_BLACK); Graphics_setTextAlignment (my graphics.get(), kGraphics_horizontalAlignment::CENTRE, Graphics_BOTTOM); @@ -119,7 +117,7 @@ static void drawSelectionOrWindow (NoulliGridEditor me, double xmin, double xmax integer winningCategory = NoulliPoint_getWinningCategory (average.get()); conststring32 winningCategoryName = grid -> categoryNames [winningCategory].get(); if (winningCategory != 0 && average -> probabilities [winningCategory] > 1.0/3.0) { - bool shouldDrawPicture = + const bool shouldDrawPicture = (my p_showCategoryInSelectionViewerAs == kNoulliGridEditor_showCategoryInSelectionViewerAs::PICTURE || my p_showCategoryInSelectionViewerAs == kNoulliGridEditor_showCategoryInSelectionViewerAs::PICTURE_AND_TEXT) && @@ -203,7 +201,6 @@ static void drawSelectionOrWindow (NoulliGridEditor me, double xmin, double xmax Graphics_setTextAlignment (my graphics.get(), kGraphics_horizontalAlignment::CENTRE, Graphics_HALF); Graphics_text (my graphics.get(), 0.0, 0.0, U"?"); } - Graphics_resetViewport (my graphics.get(), vp); } Graphics_setColour (my graphics.get(), Melder_BLACK); } @@ -218,7 +215,7 @@ void structNoulliGridEditor :: v_drawSelectionViewer () { //drawSelectionOrWindow (this, 0.5, 1.0, our startWindow, our endWindow, U"Window"); } -void structNoulliGridEditor :: v_drawRealTimeSelectionViewer (int /* phase */, double time) { +void structNoulliGridEditor :: v_drawRealTimeSelectionViewer (double time) { Graphics_setWindow (our graphics.get(), -1.0, +1.0, -1.0, +1.0); drawSelectionOrWindow (this, 0.0, 1.0, time - 1.0, time + 1.0, U""); } diff --git a/gram/NoulliGridEditor.h b/gram/NoulliGridEditor.h index eb07b068..83e82e47 100644 --- a/gram/NoulliGridEditor.h +++ b/gram/NoulliGridEditor.h @@ -2,7 +2,7 @@ #define _NoulliGridEditor_h_ /* NoulliGridEditor.h * - * Copyright (C) 2018 Paul Boersma + * Copyright (C) 2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -26,7 +26,7 @@ Thing_define (NoulliGridEditor, TimeSoundEditor) { void v_draw () override; - void v_play (double tmin, double tmax) + void v_play (double startTime, double endTime) override; void v_prefs_addFields (EditorCommand cmd) override; @@ -36,7 +36,7 @@ Thing_define (NoulliGridEditor, TimeSoundEditor) { override; void v_drawSelectionViewer () override; - void v_drawRealTimeSelectionViewer (int phase, double time) + void v_drawRealTimeSelectionViewer (double time) override; #include "NoulliGridEditor_prefs.h" diff --git a/gram/OTGrammar.cpp b/gram/OTGrammar.cpp index 52170712..61d863fe 100644 --- a/gram/OTGrammar.cpp +++ b/gram/OTGrammar.cpp @@ -982,7 +982,6 @@ void OTGrammar_drawTableau (OTGrammar me, Graphics g, bool vertical, conststring if (my decisionStrategy == kOTGrammar_decisionStrategy::EXPONENTIAL_HG || my decisionStrategy == kOTGrammar_decisionStrategy::EXPONENTIAL_MAXIMUM_ENTROPY) { - //value = value > 1e-308 ? 1000 : value < -1e308 ? -1000 : - log (- value); Graphics_text (g, x, y + descent, Melder_float (Melder_half (value))); } else { Graphics_text (g, x, y + descent, Melder_fixed (value, 3)); @@ -1715,8 +1714,10 @@ void OTGrammar_learnOne (OTGrammar me, conststring32 input, conststring32 adultO double plasticity, double relativePlasticityNoise, bool newDisharmonies, bool warnIfStalled, bool *out_grammarHasChanged) { try { - if (newDisharmonies) OTGrammar_newDisharmonies (me, evaluationNoise); - if (out_grammarHasChanged) *out_grammarHasChanged = false; + if (newDisharmonies) + OTGrammar_newDisharmonies (me, evaluationNoise); + if (out_grammarHasChanged) + *out_grammarHasChanged = false; /* Evaluate the input in the learner's hypothesis. @@ -1764,17 +1765,18 @@ void OTGrammar_learn (OTGrammar me, Strings inputs, Strings outputs, double evaluationNoise, enum kOTGrammar_rerankingStrategy updateRule, bool honourLocalRankings, double plasticity, double relativePlasticityNoise, integer numberOfChews) { - if (! inputs) inputs = outputs; + if (! inputs) + inputs = outputs; try { - integer n = inputs -> numberOfStrings; - if (outputs -> numberOfStrings != n) - Melder_throw (U"Numbers of strings in input and output are not equal."); + const integer n = inputs -> numberOfStrings; + Melder_require (outputs -> numberOfStrings == n, + U"Numbers of strings in input and output should be equal."); for (integer i = 1; i <= n; i ++) { - for (integer ichew = 1; ichew <= numberOfChews; ichew ++) { + for (integer ichew = 1; ichew <= numberOfChews; ichew ++) OTGrammar_learnOne (me, inputs -> strings [i].get(), outputs -> strings [i].get(), evaluationNoise, updateRule, honourLocalRankings, - plasticity, relativePlasticityNoise, true, true, nullptr); - } + plasticity, relativePlasticityNoise, true, true, nullptr + ); } } catch (MelderError) { Melder_throw (me, U": not learned from ", inputs, U" (inputs) and ", outputs, U" (outputs)."); @@ -1790,8 +1792,6 @@ void OTGrammar_PairDistribution_learn (OTGrammar me, PairDistribution thee, try { double plasticity = initialPlasticity; autoMelderMonitor monitor (U"Learning with full knowledge..."); - if (monitor.graphics()) - Graphics_clearWs (monitor.graphics()); for (integer iplasticity = 1; iplasticity <= numberOfPlasticities; iplasticity ++) { for (integer ireplication = 1; ireplication <= replicationsPerPlasticity; ireplication ++) { conststring32 input, output; @@ -1803,19 +1803,21 @@ void OTGrammar_PairDistribution_learn (OTGrammar me, PairDistribution thee, for (integer icons = 1; icons <= 14 && icons <= my numberOfConstraints; icons ++) { Graphics_setGrey (monitor.graphics(), (double) icons / 14); Graphics_line (monitor.graphics(), - idatum, my constraints [icons]. ranking, - idatum, my constraints [icons]. ranking + 1); + idatum, my constraints [icons]. ranking, + idatum, my constraints [icons]. ranking + 1.0 + ); } Graphics_endMovieFrame (monitor.graphics(), 0.0); } Melder_monitor ((double) idatum / numberOfData, U"Processing input-output pair ", idatum, - U" out of ", numberOfData, U": ", input, U" -> ", output); - for (integer ichew = 1; ichew <= numberOfChews; ichew ++) { + U" out of ", numberOfData, U": ", input, U" -> ", output + ); + for (integer ichew = 1; ichew <= numberOfChews; ichew ++) OTGrammar_learnOne (me, input, output, - evaluationNoise, updateRule, honourLocalRankings, - plasticity, relativePlasticityNoise, true, true, nullptr); - } + evaluationNoise, updateRule, honourLocalRankings, + plasticity, relativePlasticityNoise, true, true, nullptr + ); } plasticity *= plasticityDecrement; } @@ -2275,8 +2277,6 @@ void OTGrammar_Distributions_learnFromPartialOutputs (OTGrammar me, Distribution autoOTHistory history; OTGrammar_Distributions_opt_createOutputMatching (me, thee, columnNumber); autoMelderMonitor monitor (U"Learning with limited knowledge..."); - if (monitor.graphics()) - Graphics_clearWs (monitor.graphics()); if (storeHistoryEvery) history = OTGrammar_createHistory (me, storeHistoryEvery, numberOfData); try { @@ -2289,23 +2289,26 @@ void OTGrammar_Distributions_learnFromPartialOutputs (OTGrammar me, Distribution ++ idatum; if (monitor.graphics() && idatum % (numberOfData / 400 + 1) == 0) { Graphics_beginMovieFrame (monitor.graphics(), nullptr); - Graphics_setWindow (monitor.graphics(), 0, numberOfData, 50, 150); + Graphics_setWindow (monitor.graphics(), 0, numberOfData, 50.0, 150.0); for (integer icons = 1; icons <= 14 && icons <= my numberOfConstraints; icons ++) { Graphics_setGrey (monitor.graphics(), (double) icons / 14); Graphics_line (monitor.graphics(), - idatum, my constraints [icons]. ranking, - idatum, my constraints [icons]. ranking + 1); + idatum, my constraints [icons]. ranking, + idatum, my constraints [icons]. ranking + 10.0 + ); } Graphics_endMovieFrame (monitor.graphics(), 0.0); } Melder_monitor ((double) idatum / numberOfData, U"Processing partial output ", idatum, U" out of ", numberOfData, U": ", - thy rowLabels [ipartialOutput].get()); + thy rowLabels [ipartialOutput].get() + ); try { OTGrammar_learnOneFromPartialOutput_opt (me, partialOutput, ipartialOutput, evaluationNoise, updateRule, honourLocalRankings, plasticity, relativePlasticityNoise, numberOfChews, false, - resampleForVirtualProduction, compareOnlyPartialOutput, resampleForCorrectForm); // no warning if stalled: RIP form is allowed to be harmonically bounded + resampleForVirtualProduction, compareOnlyPartialOutput, resampleForCorrectForm + ); // no warning if stalled: RIP form is allowed to be harmonically bounded } catch (MelderError) { if (history) OTGrammar_updateHistory (me, history.get(), storeHistoryEvery, idatum, thy rowLabels [ipartialOutput].get()); diff --git a/gram/OTGrammarEditor.cpp b/gram/OTGrammarEditor.cpp index d8235ece..3d2a3b1d 100644 --- a/gram/OTGrammarEditor.cpp +++ b/gram/OTGrammarEditor.cpp @@ -1,6 +1,6 @@ /* OTGrammarEditor.cpp * - * Copyright (C) 1997-2005,2007-2019 Paul Boersma + * Copyright (C) 1997-2005,2007-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -196,7 +196,6 @@ static void drawTableau (Graphics g) { void structOTGrammarEditor :: v_draw () { OTGrammar ot = (OTGrammar) data; static char32 text [1000]; - Graphics_clearWs (graphics.get()); if (ot -> decisionStrategy == kOTGrammar_decisionStrategy::EXPONENTIAL_HG || ot -> decisionStrategy == kOTGrammar_decisionStrategy::EXPONENTIAL_MAXIMUM_ENTROPY) { diff --git a/gram/OTMulti.cpp b/gram/OTMulti.cpp index c41a22bd..2a2dbb03 100644 --- a/gram/OTMulti.cpp +++ b/gram/OTMulti.cpp @@ -931,8 +931,6 @@ void OTMulti_PairDistribution_learn (OTMulti me, PairDistribution thee, double e try { double plasticity = initialPlasticity; autoMelderMonitor monitor (U"Learning from partial pairs..."); - if (monitor.graphics()) - Graphics_clearWs (monitor.graphics()); autoTable history; if (storeHistoryEvery) history = OTMulti_createHistory (me, storeHistoryEvery, numberOfData); diff --git a/gram/OTMultiEditor.cpp b/gram/OTMultiEditor.cpp index 23be2619..8c5eddac 100644 --- a/gram/OTMultiEditor.cpp +++ b/gram/OTMultiEditor.cpp @@ -187,7 +187,6 @@ void structOTMultiEditor :: v_draw () { static MelderString buffer; const double rowHeight = 0.25; longdouble tableauHeight = 2 * rowHeight; - Graphics_clearWs (graphics.get()); HyperPage_listItem (this, U"\t\t %%ranking value\t %disharmony\t %plasticity"); for (integer icons = 1; icons <= grammar -> numberOfConstraints; icons ++) { const OTConstraint constraint = & grammar -> constraints [grammar -> index [icons]]; diff --git a/gram/praat_gram.cpp b/gram/praat_gram.cpp index abeb4947..8b0b494b 100644 --- a/gram/praat_gram.cpp +++ b/gram/praat_gram.cpp @@ -25,6 +25,7 @@ #include "NoulliGridEditor.h" #include "praat_TableOfReal.h" +#include "praat_TimeFunction.h" #undef iam #define iam iam_LOOP @@ -1756,6 +1757,17 @@ DIRECT (WINDOW_NoulliGrid_viewAndEdit) { END } +FORM (NUMVEC_NoulliGrid_getAverageProbabilities, U"NoulliGrid: Get average probabilities", nullptr) { + NATURAL (tierNumber, U"Tier number", U"1") + REAL (fromTime, U"From time (s)", U"0") + REAL (toTime, U"To time (s)", U"0 (= all)") + OK +DO + NUMVEC_ONE (NoulliGrid) + autoVEC result = NoulliGrid_getAverageProbabilities (me, tierNumber, fromTime, toTime); + NUMVEC_ONE_END +} + // MARK: - buttons void praat_uvafon_gram_init (); @@ -1947,6 +1959,9 @@ void praat_uvafon_gram_init () { praat_addAction2 (classNet, 1, classPatternList, 1, U"To ActivationList", nullptr, 0, NEW1_Net_PatternList_to_ActivationList); praat_addAction1 (classNoulliGrid, 1, U"View & Edit", nullptr, praat_ATTRACTIVE, WINDOW_NoulliGrid_viewAndEdit); + praat_addAction1 (classNoulliGrid, 0, U"Query -", nullptr, 0, nullptr); + praat_TimeFunction_query_init (classNoulliGrid); + praat_addAction1 (classNoulliGrid, 1, U"Get average probabilities...", nullptr, 1, NUMVEC_NoulliGrid_getAverageProbabilities); praat_addAction2 (classNoulliGrid, 1, classSound, 1, U"View & Edit", nullptr, praat_ATTRACTIVE, WINDOW_NoulliGrid_viewAndEdit); } diff --git a/main/Praat.icns b/main/Praat.icns index 7894e1fd..e4420a13 100644 Binary files a/main/Praat.icns and b/main/Praat.icns differ diff --git a/main/main_Praat.cpp b/main/main_Praat.cpp index 69118e21..a7c98c74 100644 --- a/main/main_Praat.cpp +++ b/main/main_Praat.cpp @@ -21,6 +21,8 @@ static void logo (Graphics graphics) { Graphics_setWindow (graphics, 0.0, 1.0, 0.0, 0.8); + Graphics_setGrey (graphics, 0.95); + Graphics_fillRectangle (graphics, 0.0, 1.0, 0.0, 0.8); Graphics_setTextAlignment (graphics, Graphics_CENTRE, Graphics_HALF); Graphics_setFont (graphics, kGraphics_font::TIMES); Graphics_setFontSize (graphics, 45.0); diff --git a/main/praat.plist b/main/praat.plist index fef37ead..5526d97e 100644 --- a/main/praat.plist +++ b/main/praat.plist @@ -533,9 +533,11 @@ NSHumanReadableCopyright Copyright © 1992-PRAAT_YEAR by Paul Boersma & David Weenink + NSMicrophoneUsageDescription + Praat needs access to your microphone to record speech. NSPrincipalClass NSApplication NSRequiresAquaSystemAppearance - + diff --git a/main/praat_win.ico b/main/praat_win.ico index d9d31ac6..7ee8aa99 100644 Binary files a/main/praat_win.ico and b/main/praat_win.ico differ diff --git a/makefiles/makefile.defs.chrome64 b/makefiles/makefile.defs.chrome64 index 346bccc8..5e0dff90 100644 --- a/makefiles/makefile.defs.chrome64 +++ b/makefiles/makefile.defs.chrome64 @@ -1,7 +1,7 @@ # File: makefile.defs.chrome64 # System: Linux on Chromebook -# Paul Boersma, 23 March 2020 +# Paul Boersma, 20 May 2020 CC = gcc @@ -17,7 +17,7 @@ LINK = g++ EXECUTABLE = praat -LIBS = `pkg-config --libs gtk+-2.0` -lm -lpulse -lasound -lpthread +LIBS = `pkg-config --libs gtk+-2.0` -lm -lpulse -lasound -static-libgcc -static-libstdc++ -lpthread AR = ar RANLIB = ls diff --git a/makefiles/makefile.defs.linux.alsa b/makefiles/makefile.defs.linux.alsa index 99ef0758..5e70fcef 100644 --- a/makefiles/makefile.defs.linux.alsa +++ b/makefiles/makefile.defs.linux.alsa @@ -1,7 +1,7 @@ # File: makefile.defs.linux.alsa # System: Linux -# Paul Boersma 2020-04-16 +# Paul Boersma 2020-05-20 CC = gcc @@ -19,7 +19,7 @@ LINK = g++ EXECUTABLE = praat -LIBS = `$(PKG_CONFIG) --libs gtk+-2.0` -lm -lasound -lpthread +LIBS = `$(PKG_CONFIG) --libs gtk+-2.0` -lm -lasound -static-libgcc -static-libstdc++ -lpthread AR = ar RANLIB = ls diff --git a/makefiles/makefile.defs.linux.jack b/makefiles/makefile.defs.linux.jack index be4c5d65..fbb2c3db 100644 --- a/makefiles/makefile.defs.linux.jack +++ b/makefiles/makefile.defs.linux.jack @@ -1,7 +1,7 @@ # File: makefile.defs.linux.jack # System: Linux -# Paul Boersma 2020-04-16 +# Paul Boersma 2020-05-20 CC = gcc @@ -19,7 +19,7 @@ LINK = g++ EXECUTABLE = praat -LIBS = `$(PKG_CONFIG) --libs gtk+-2.0` -lm -ljack -lpthread +LIBS = `$(PKG_CONFIG) --libs gtk+-2.0` -lm -ljack -static-libgcc -static-libstdc++ -lpthread AR = ar RANLIB = ls diff --git a/makefiles/makefile.defs.linux.pulse b/makefiles/makefile.defs.linux.pulse index 53e1fda3..c6b8230e 100644 --- a/makefiles/makefile.defs.linux.pulse +++ b/makefiles/makefile.defs.linux.pulse @@ -1,7 +1,7 @@ # File: makefile.defs.linux.pulse # System: Linux -# David Weenink and Paul Boersma 2020-04-16 +# David Weenink and Paul Boersma 2020-09-17 CC = gcc @@ -19,7 +19,7 @@ LINK = $(CXX) EXECUTABLE = praat -LIBS = `$(PKG_CONFIG) --libs gtk+-2.0` -lm -lpulse -lasound -static-libgcc -static-libstdc++ -lpthread +LIBS = `$(PKG_CONFIG) --libs gtk+-2.0` -lm -lpulse -lasound -lpthread AR = ar RANLIB = ls diff --git a/makefiles/makefile.defs.linux.pulse_static b/makefiles/makefile.defs.linux.pulse_static new file mode 100644 index 00000000..ff660584 --- /dev/null +++ b/makefiles/makefile.defs.linux.pulse_static @@ -0,0 +1,32 @@ +# File: makefile.defs.linux.pulse_static + +# System: Linux +# David Weenink and Paul Boersma 2020-09-17 + +# statically linked with the standard C and C++ libraries, +# hence avoiding `gethostbyname` by defining NO_NETWORK + +CC = gcc + +CXX = g++ + +PKG_CONFIG ?= "pkg-config" + +COMMONFLAGS = -DNO_NETWORK -DUNIX -Dlinux -DALSA -DHAVE_PULSEAUDIO -D_FILE_OFFSET_BITS=64 `$(PKG_CONFIG) --cflags gtk+-2.0` -Wreturn-type -Wunused -Wunused-parameter -Wuninitialized -O3 -g1 -pthread + +CFLAGS = -std=gnu99 $(COMMONFLAGS) -Werror=missing-prototypes -Werror=implicit + +CXXFLAGS = -std=c++17 $(COMMONFLAGS) -Wshadow + +LINK = $(CXX) + +EXECUTABLE = praat_static + +LIBS = `$(PKG_CONFIG) --libs gtk+-2.0` -lm -lpulse -lasound -static-libgcc -static-libstdc++ -lpthread + +AR = ar +RANLIB = ls +ICON = +MAIN_ICON = + +INSTALL = install -p praat /usr/local/bin diff --git a/melder/MelderString.h b/melder/MelderString.h index cf5a026d..cc99b277 100644 --- a/melder/MelderString.h +++ b/melder/MelderString.h @@ -27,16 +27,16 @@ - automatically convert numbers, objects, file names, vectors, and matrices to strings */ -typedef struct { +struct MelderString16 { int64 length = 0; int64 bufferSize = 0; char16 *string = nullptr; // a growing buffer, rarely shrunk (can only be freed by MelderString16_free) -} MelderString16; -typedef struct { +}; +struct MelderString { int64 length = 0; int64 bufferSize = 0; char32 *string = nullptr; // a growing buffer, rarely shrunk (can only be freed by MelderString_free) -} MelderString; +}; void MelderString16_free (MelderString16 *me); // frees the buffer (and sets other attributes to zero) void MelderString_free (MelderString *me); // frees the buffer (and sets other attributes to zero) diff --git a/melder/NUM.cpp b/melder/NUM.cpp index ca4710c1..687eee70 100644 --- a/melder/NUM.cpp +++ b/melder/NUM.cpp @@ -23,11 +23,25 @@ */ static longdouble NUMsum_longdouble (constVECVU const& vec) { + /* + This function started to crash on October 27, 2020. + The cause was that if `vec.firstCell == nullptr`, + `& vec [1]` is a "null reference" (see the definition of constvectorview::operator[]). + This causes "undefined behaviour", even if `p` is never read from that address + (which it isn't, because if `vec.firstCell == nullptr`, then `vec.size` must be 0). + What precisely happened was that although `vec.size` was null, + the processor would branch-predict into the `if (_n & 1)` branch of PAIRWISE_SUM, + thereby pre-fetching `p` from the address `& vec [1]`, + which would lead to a Bad Access exception. + + A possible repair is to use a pointer instead of a reference. + */ if (vec.stride == 1) { PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + //const double *p = & vec [1], // valid C++ only if vec is well-defined + const double *p = & vec. firstCell [1 - 1], // null *pointers* are fine longdouble (*p), p += 1 ) @@ -36,7 +50,8 @@ static longdouble NUMsum_longdouble (constVECVU const& vec) { PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + //const double *p = & vec [1], // valid C++ only if vec is well-defined + const double *p = & vec. firstCell [1 - 1], // null *pointers* are fine longdouble (*p), p += vec.stride ) @@ -69,7 +84,7 @@ static longdouble NUMsumOfSquaredDifferences_longdouble (constVECVU const& vec, PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, longdouble (*p - mean) * longdouble (*p - mean), p += 1 ) @@ -78,7 +93,7 @@ static longdouble NUMsumOfSquaredDifferences_longdouble (constVECVU const& vec, PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, longdouble (*p - mean) * longdouble (*p - mean), p += vec.stride ) @@ -90,7 +105,7 @@ static longdouble NUMsum2_longdouble (constVECVU const& vec) { PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, longdouble (*p) * longdouble (*p), p += 1 ) @@ -99,7 +114,7 @@ static longdouble NUMsum2_longdouble (constVECVU const& vec) { PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, longdouble (*p) * longdouble (*p), p += vec.stride ) @@ -132,7 +147,7 @@ static longdouble NUMsumAbs_longdouble (constVECVU const& vec) { PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, longdouble (fabs (*p)), p += 1 ) @@ -141,7 +156,7 @@ static longdouble NUMsumAbs_longdouble (constVECVU const& vec) { PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, longdouble (fabs (*p)), p += vec.stride ) @@ -174,7 +189,7 @@ static longdouble NUMsumPower_longdouble (constVECVU const& vec, longdouble powe PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, powl (longdouble (fabs (*p)), power), p += 1 ) @@ -183,7 +198,7 @@ static longdouble NUMsumPower_longdouble (constVECVU const& vec, longdouble powe PAIRWISE_SUM ( longdouble, sum, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, powl (longdouble (fabs (*p)), power), p += vec.stride ) @@ -222,14 +237,14 @@ static MelderMeanSumsq_longdouble NUMmeanSumsq (constVECVU const& vec) noexcept double mean = double (result.mean); if (vec.stride == 1) { PAIRWISE_SUM (longdouble, sumsq, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, longdouble (*p - mean) * longdouble (*p - mean), p += 1 ) result.sumsq = sumsq; } else { PAIRWISE_SUM (longdouble, sumsq, integer, vec.size, - const double *p = & vec [1], + const double *p = vec. firstCell, longdouble (*p - mean) * longdouble (*p - mean), p += vec.stride ) @@ -276,16 +291,16 @@ double NUMinner (constVECVU const& x, constVECVU const& y) noexcept { if (x.stride == 1) { if (y.stride == 1) { PAIRWISE_SUM (longdouble, sum, integer, x.size, - const double *px = & x [1]; - const double *py = & y [1], + const double *px = x. firstCell; + const double *py = y. firstCell, longdouble (*px) * longdouble (*py), (px += 1, py += 1) ) return double (sum); } else { PAIRWISE_SUM (longdouble, sum, integer, x.size, - const double *px = & x [1]; - const double *py = & y [1], + const double *px = x. firstCell; + const double *py = y. firstCell, longdouble (*px) * longdouble (*py), (px += 1, py += y.stride) ) @@ -293,16 +308,16 @@ double NUMinner (constVECVU const& x, constVECVU const& y) noexcept { } } else if (y.stride == 1) { PAIRWISE_SUM (longdouble, sum, integer, x.size, - const double *px = & x [1]; - const double *py = & y [1], + const double *px = x. firstCell; + const double *py = y. firstCell, longdouble (*px) * longdouble (*py), (px += x.stride, py += 1) ) return double (sum); } else { PAIRWISE_SUM (longdouble, sum, integer, x.size, - const double *px = & x [1]; - const double *py = & y [1], + const double *px = x. firstCell; + const double *py = y. firstCell, longdouble (*px) * longdouble (*py), (px += x.stride, py += y.stride) ) @@ -311,12 +326,14 @@ double NUMinner (constVECVU const& x, constVECVU const& y) noexcept { } double NUMmean (constVECVU const& vec) { - //Melder_require (vec.size >= 1, - // U"mean(vector#): the size of the vector should be greater than 0."); - longdouble sum = NUMsum_longdouble (vec); - return double (sum / vec.size); + if (vec.size <= 0) + return undefined; + longdouble sum = NUMsum_longdouble (vec); + return double (sum / vec.size); } double NUMmean (constMATVU const& mat) noexcept { + if (mat.nrow * mat.ncol <= 0) + return undefined; longdouble sum = NUMsum_longdouble (mat); return double (sum / (mat.nrow * mat.ncol)); } diff --git a/melder/NUMfilter.cpp b/melder/NUMfilter.cpp index 030ab4c7..d7dca0d5 100644 --- a/melder/NUMfilter.cpp +++ b/melder/NUMfilter.cpp @@ -1,6 +1,6 @@ /* NUMfilter.cpp * - * Copyright (C) 1992-2008,2011,2012,2014,2015,2017,2018 Paul Boersma + * Copyright (C) 1992-2008,2011,2012,2014-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -16,18 +16,11 @@ * along with this work. If not, see . */ -/* - * pb 2002/03/07 GPL - * pb 2003/07/09 gsl - * pb 2008/01/19 double - * pb 2011/03/29 C++ - */ - #include "melder.h" void NUMfbtoa (double formant, double bandwidth, double dt, double *a1, double *a2) { - *a1 = 2 * exp (- NUMpi * bandwidth * dt) * cos (2 * NUMpi * formant * dt); - *a2 = exp (- 2 * NUMpi * bandwidth * dt); + *a1 = 2.0 * exp (- NUMpi * bandwidth * dt) * cos (2.0 * NUMpi * formant * dt); + *a2 = exp (- 2.0 * NUMpi * bandwidth * dt); } void VECfilterSecondOrderSection_a_inplace (VECVU const& x, double a1, double a2) { diff --git a/melder/NUMinterpol.cpp b/melder/NUMinterpol.cpp index a5965d0d..327e6e41 100644 --- a/melder/NUMinterpol.cpp +++ b/melder/NUMinterpol.cpp @@ -27,134 +27,156 @@ #include "melder.h" #include "../dwsys/NUM2.h" -#define SIGN(x,s) ((s) < 0 ? -fabs (x) : fabs(x)) -#define NUM_interpolate_simple_cases \ - if (y.size < 1) return undefined; \ - if (x > y.size) return y [y.size]; \ - if (x < 1) return y [1]; \ - if (x == midleft) return y [midleft]; \ - /* 1 < x < y.size && x not integer: interpolate. */ \ - if (maxDepth > midright - 1) maxDepth = midright - 1; \ - if (maxDepth > y.size - midleft) maxDepth = y.size - midleft; \ - if (maxDepth <= NUM_VALUE_INTERPOLATE_NEAREST) return y [(integer) floor (x + 0.5)]; \ - if (maxDepth == NUM_VALUE_INTERPOLATE_LINEAR) return y [midleft] + (x - midleft) * (y [midright] - y [midleft]); \ - if (maxDepth == NUM_VALUE_INTERPOLATE_CUBIC) { \ - double yl = y [midleft], yr = y [midright]; \ - double dyl = 0.5 * (yr - y [midleft - 1]), dyr = 0.5 * (y [midright + 1] - yl); \ - double fil = x - midleft, fir = midright - x; \ - return yl * fir + yr * fil - fil * fir * (0.5 * (dyr - dyl) + (fil - 0.5) * (dyl + dyr - 2 * (yr - yl))); \ - } - -#if defined (__POWERPC__) -double NUM_interpolate_sinc (constVEC const& y, double x, integer maxDepth) { - integer ix, midleft = (integer) floor (x), midright = midleft + 1, left, right; - double result = 0.0, a, halfsina, aa, daa, cosaa, sinaa, cosdaa, sindaa; - NUM_interpolate_simple_cases - left = midright - maxDepth, right = midleft + maxDepth; - a = NUMpi * (x - midleft); - halfsina = 0.5 * sin (a); - aa = a / (x - left + 1); cosaa = cos (aa); sinaa = sin (aa); - daa = NUMpi / (x - left + 1); cosdaa = cos (daa); sindaa = sin (daa); - for (ix = midleft; ix >= left; ix --) { - double d = halfsina / a * (1.0 + cosaa), help; - result += y [ix] * d; - a += NUMpi; - help = cosaa * cosdaa - sinaa * sindaa; - sinaa = cosaa * sindaa + sinaa * cosdaa; - cosaa = help; - halfsina = - halfsina; - } - a = NUMpi * (midright - x); - halfsina = 0.5 * sin (a); - aa = a / (right - x + 1); cosaa = cos (aa); sinaa = sin (aa); - daa = NUMpi / (right - x + 1); cosdaa = cos (daa); sindaa = sin (daa); - for (ix = midright; ix <= right; ix ++) { - double d = halfsina / a * (1.0 + cosaa), help; - result += y [ix] * d; - a += NUMpi; - help = cosaa * cosdaa - sinaa * sindaa; - sinaa = cosaa * sindaa + sinaa * cosdaa; - cosaa = help; - halfsina = - halfsina; - } - return result; -} +#if defined (__POWERPC__)||1 + #define RECOMPUTE_SINES 0 #else + #define RECOMPUTE_SINES 1 +#endif double NUM_interpolate_sinc (constVEC const& y, double x, integer maxDepth) { - integer ix, midleft = (integer) floor (x), midright = midleft + 1, left, right; - double result = 0.0, a, halfsina, aa, daa; - NUM_interpolate_simple_cases - left = midright - maxDepth; - right = midleft + maxDepth; - a = NUMpi * (x - midleft); - halfsina = 0.5 * sin (a); - aa = a / (x - left + 1); - daa = NUMpi / (x - left + 1); - for (ix = midleft; ix >= left; ix --) { - double d = halfsina / a * (1.0 + cos (aa)); + const integer midleft = (integer) floor (x), midright = midleft + 1; + double result = 0.0; + if (y.size < 1) + return undefined; // there exists no best guess + if (x < 1) + return y [1]; // offleft: constant extrapolation + if (x > y.size) + return y [y.size]; // offright: constant extrapolation + if (x == midleft) + return y [midleft]; // the interpolated curve goes through the points + /* + 1 < x < y.size && x not integer: interpolate. + */ + Melder_clipRight (& maxDepth, midright - 1); + Melder_clipRight (& maxDepth, y.size - midleft); + if (maxDepth <= NUM_VALUE_INTERPOLATE_NEAREST) + return y [(integer) floor (x + 0.5)]; + if (maxDepth == NUM_VALUE_INTERPOLATE_LINEAR) + return y [midleft] + (x - midleft) * (y [midright] - y [midleft]); + if (maxDepth == NUM_VALUE_INTERPOLATE_CUBIC) { + const double yl = y [midleft], yr = y [midright]; + const double dyl = 0.5 * (yr - y [midleft - 1]), dyr = 0.5 * (y [midright + 1] - yl); + const double fil = x - midleft, fir = midright - x; + return yl * fir + yr * fil - fil * fir * (0.5 * (dyr - dyl) + (fil - 0.5) * (dyl + dyr - 2 * (yr - yl))); + } + /* + maxDepth >= 3: sinc interpolation + */ + const integer left = midright - maxDepth; + const integer right = midleft + maxDepth; + double a = NUMpi * (x - midleft); + double halfsina = 0.5 * sin (a); + double aa = a / (x - left + 1.0); + double daa = NUMpi / (x - left + 1.0); + #if ! RECOMPUTE_SINES + double cosaa = cos (aa); + double sinaa = sin (aa); + double cosdaa = cos (daa); + double sindaa = sin (daa); + #endif + for (integer ix = midleft; ix >= left; ix --) { + #if RECOMPUTE_SINES + const double d = halfsina / a * (1.0 + cos (aa)); + #else + const double d = halfsina / a * (1.0 + cosaa); + #endif result += y [ix] * d; a += NUMpi; - aa += daa; + #if RECOMPUTE_SINES + aa += daa; + #else + const double help = cosaa * cosdaa - sinaa * sindaa; + sinaa = cosaa * sindaa + sinaa * cosdaa; + cosaa = help; + #endif halfsina = - halfsina; } a = NUMpi * (midright - x); halfsina = 0.5 * sin (a); - aa = a / (right - x + 1); - daa = NUMpi / (right - x + 1); \ - for (ix = midright; ix <= right; ix ++) { - double d = halfsina / a * (1.0 + cos (aa)); + aa = a / (right - x + 1.0); + daa = NUMpi / (right - x + 1.0); + #if ! RECOMPUTE_SINES + cosaa = cos (aa); + sinaa = sin (aa); + cosdaa = cos (daa); + sindaa = sin (daa); + #endif + for (integer ix = midright; ix <= right; ix ++) { + #if RECOMPUTE_SINES + const double d = halfsina / a * (1.0 + cos (aa)); + #else + const double d = halfsina / a * (1.0 + cosaa); + #endif result += y [ix] * d; a += NUMpi; - aa += daa; + #if RECOMPUTE_SINES + aa += daa; + #else + const double help = cosaa * cosdaa - sinaa * sindaa; + sinaa = cosaa * sindaa + sinaa * cosdaa; + cosaa = help; + #endif halfsina = - halfsina; } return result; } -#endif /********** Improving extrema **********/ #pragma mark Improving extrema struct improve_params { - int depth; + integer depth; constVEC y; - int isMaximum; + bool isMaximum; }; static double improve_evaluate (double x, void *closure) { struct improve_params *me = (struct improve_params *) closure; - double y = NUM_interpolate_sinc (my y, x, my depth); + const double y = NUM_interpolate_sinc (my y, x, my depth); return my isMaximum ? - y : y; } -double NUMimproveExtremum (constVEC const& y, integer ixmid, int interpolation, double *ixmid_real, bool isMaximum) { +double NUMimproveExtremum (constVEC const& y, integer ixmid, integer interpolationDepth, double *ixmid_real, bool isMaximum) { struct improve_params params; double result; - if (ixmid <= 1) { *ixmid_real = 1; return y [1]; } - if (ixmid >= y.size) { *ixmid_real = y.size; return y [y.size]; } - if (interpolation <= NUM_PEAK_INTERPOLATE_NONE) { *ixmid_real = ixmid; return y [ixmid]; } - if (interpolation == NUM_PEAK_INTERPOLATE_PARABOLIC) { - double dy = 0.5 * (y [ixmid + 1] - y [ixmid - 1]); - double d2y = 2 * y [ixmid] - y [ixmid - 1] - y [ixmid + 1]; + if (ixmid <= 1) { + *ixmid_real = double (1); + return y [1]; + } + if (ixmid >= y.size) { + *ixmid_real = double (y.size); + return y [y.size]; + } + if (interpolationDepth <= NUM_PEAK_INTERPOLATE_NONE) { + *ixmid_real = double (ixmid); + return y [ixmid]; + } + if (interpolationDepth == NUM_PEAK_INTERPOLATE_PARABOLIC) { + const double dy = 0.5 * (y [ixmid + 1] - y [ixmid - 1]); + const double d2y = 2 * y [ixmid] - y [ixmid - 1] - y [ixmid + 1]; *ixmid_real = ixmid + dy / d2y; return y [ixmid] + 0.5 * dy * dy / d2y; } - /* Sinc interpolation. */ - params. depth = interpolation == NUM_PEAK_INTERPOLATE_SINC70 ? 70 : 700; + /* + Cubic or sinc interpolation. + */ + params. depth = ( + interpolationDepth == NUM_PEAK_INTERPOLATE_CUBIC ? NUM_VALUE_INTERPOLATE_CUBIC : + interpolationDepth == NUM_PEAK_INTERPOLATE_SINC70 ? NUM_VALUE_INTERPOLATE_SINC70 : + NUM_VALUE_INTERPOLATE_SINC700 + ); params. y = y; params. isMaximum = isMaximum; - /*return isMaximum ? - - NUM_minimize (ixmid - 1, ixmid, ixmid + 1, improve_evaluate, & params, 1e-10, 1e-11, ixmid_real) : - NUM_minimize (ixmid - 1, ixmid, ixmid + 1, improve_evaluate, & params, 1e-10, 1e-11, ixmid_real);*/ *ixmid_real = NUMminimize_brent (improve_evaluate, ixmid - 1, ixmid + 1, & params, 1e-10, & result); return isMaximum ? - result : result; } -double NUMimproveMaximum (constVEC const& y, integer ixmid, int interpolation, double *ixmid_real) - { return NUMimproveExtremum (y, ixmid, interpolation, ixmid_real, true); } -double NUMimproveMinimum (constVEC const& y, integer ixmid, int interpolation, double *ixmid_real) - { return NUMimproveExtremum (y, ixmid, interpolation, ixmid_real, false); } +double NUMimproveMinimum (constVEC const& y, integer ixmid, integer interpolationDepth, double *ixmid_real) { + return NUMimproveExtremum (y, ixmid, interpolationDepth, ixmid_real, false); +} +double NUMimproveMaximum (constVEC const& y, integer ixmid, integer interpolationDepth, double *ixmid_real) { + return NUMimproveExtremum (y, ixmid, interpolationDepth, ixmid_real, true); +} /********** Viterbi **********/ @@ -179,9 +201,12 @@ void NUM_viterbi ( double maximum = -1e308; integer place = 0; for (integer icand1 = 1; icand1 <= numberOfCandidates [iframe - 1]; icand1 ++) { - double value = delta [iframe - 1] [icand1] + delta [iframe] [icand2] + const double value = delta [iframe - 1] [icand1] + delta [iframe] [icand2] - getTransitionCost (iframe, icand1, icand2, closure); - if (value > maximum) { maximum = value; place = icand1; } + if (value > maximum) { + maximum = value; + place = icand1; + } } if (place == 0) Melder_throw (U"Viterbi algorithm cannot compute a track because of weird values."); @@ -256,7 +281,7 @@ void NUM_viterbi_multi ( if (ntrack > ncand) Melder_throw (U"(NUM_viterbi_multi:) " U"Number of tracks (", ntrack, U") should not exceed number of candidates (", ncand, U")."); - integer ncomb = Melder_iround (NUMcombinations (ncand, ntrack)); + const integer ncomb = Melder_iround (NUMcombinations (ncand, ntrack)); if (ncomb > 10'000'000) Melder_throw (U"(NUM_viterbi_multi:) " U"Unrealistically high number of combinations (", ncomb, U")."); parm. ntrack = ntrack; diff --git a/melder/NUMinterpol.h b/melder/NUMinterpol.h index 55b4c2ba..0573e68c 100644 --- a/melder/NUMinterpol.h +++ b/melder/NUMinterpol.h @@ -35,9 +35,9 @@ double NUM_interpolate_sinc (constVEC const& y, double x, integer interpolationD #define NUM_PEAK_INTERPOLATE_SINC70 3 #define NUM_PEAK_INTERPOLATE_SINC700 4 -double NUMimproveExtremum (constVEC const& y, integer ixmid, int interpolation, double *ixmid_real, bool isMaximum); -double NUMimproveMaximum (constVEC const& y, integer ixmid, int interpolation, double *ixmid_real); -double NUMimproveMinimum (constVEC const& y, integer ixmid, int interpolation, double *ixmid_real); +double NUMimproveExtremum (constVEC const& y, integer ixmid, integer interpolationDepth, double *ixmid_real, bool isMaximum); +double NUMimproveMaximum (constVEC const& y, integer ixmid, integer interpolationDepth, double *ixmid_real); +double NUMimproveMinimum (constVEC const& y, integer ixmid, integer interpolationDepth, double *ixmid_real); void NUM_viterbi ( integer numberOfFrames, integer maxnCandidates, diff --git a/melder/NUMmath.h b/melder/NUMmath.h index 4b4cbafd..df9ddc76 100644 --- a/melder/NUMmath.h +++ b/melder/NUMmath.h @@ -115,21 +115,5 @@ constexpr double NUM_goldenSection = 0.6180339887498948482045868343656381177203; // Instead we use the 40 digits computed by Johann von Soldner in 1809. constexpr double NUM_euler = 0.5772156649015328606065120900824024310422; -const double undefined = (0.0/0.0); // NaN - -/* - isdefined() shall capture not only `undefined`, but all infinities and NaNs. - This can be done with a single test for the set bits in 0x7FF0'0000'0000'0000, - at least for 64-bit IEEE implementations. The correctness of this assumption is checked in sys/praat.cpp. - The portable version of isdefined() involves both isinf() and isnan(), or perhaps just isfinite(), - but that would be slower (as tested in fon/Praat_tests.cpp) - and it would also run into problems on some platforms when both and are included, - as in dwsys/NUMcomplex.cpp. -*/ -//inline bool isdefined (double x) { return ! isinf (x) && ! isnan (x); } /* portable */ -//inline bool isdefined (double x) { return isfinite (x); } /* portable */ -inline bool isdefined (double x) { return ((* (uint64 *) & x) & 0x7FF0'0000'0000'0000) != 0x7FF0'0000'0000'0000; } -inline bool isundef (double x) { return ((* (uint64 *) & x) & 0x7FF0'0000'0000'0000) == 0x7FF0'0000'0000'0000; } - /* End of file NUMmath.h */ #endif diff --git a/melder/NUMrandom.cpp b/melder/NUMrandom.cpp index c4acba53..33231366 100644 --- a/melder/NUMrandom.cpp +++ b/melder/NUMrandom.cpp @@ -170,7 +170,7 @@ void NUMrandom_initializeSafelyAndUnpredictably () { const uint64 ticksSince1969 = getTicksSince1969 (); // possibly microseconds const uint64 ticksSinceBoot = getTicksSinceBoot (); // possibly nanoseconds for (int threadNumber = 0; threadNumber <= 16; threadNumber ++) { - constexpr integer numberOfKeys = 6; + constexpr integer numberOfKeys = 7; uint64 keys [numberOfKeys]; keys [0] = ticksSince1969; // unique between boots of the same computer keys [1] = UINT64_C (7320321686725470078) + uint64 (threadNumber); // unique between threads in the same process @@ -196,6 +196,8 @@ void NUMrandom_initializeSafelyAndUnpredictably () { } keys [4] = (uint64) (int64) getpid (); // unique between processes that run simultaneously on the same computer keys [5] = ticksSinceBoot; // some extra randomness + static uint64 callInstance = 0; + keys [6] = UINT64_C (3642334578453) + (++ callInstance); states [threadNumber]. init_by_array64 (keys, numberOfKeys); } theInited = true; diff --git a/melder/STR.cpp b/melder/STR.cpp index f6508484..aa4c3e2e 100644 --- a/melder/STR.cpp +++ b/melder/STR.cpp @@ -1,6 +1,6 @@ /* STR.cpp * - * Copyright (C) 2012-2017 David Weenink, 2008,2018,2020s Paul Boersma + * Copyright (C) 2012-2017 David Weenink, 2008,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -18,6 +18,35 @@ #include "melder.h" +static char hexSymbols [] = "0123456789ABCDEF"; + +static uint64 hexSecret = UINT64_C (5'847'171'831'059'823'557); + +autostring8 newSTRhex8 (conststring8 str, uint64 key) { + if (key != 0) + NUMrandom_initializeWithSeedUnsafelyButPredictably (key ^ hexSecret); + autostring8 result (uinteger_to_integer (strlen (str)) * 2); + char *to = & result [0]; + for (const char8 *from = (char8 *) & str [0]; *from != '\0'; from ++) { + integer value = *from; + Melder_assert (value > 0 && value < 256); + if (key != 0) + value = (value + NUMrandomInteger (0, 255)) % 256; + *to ++ = hexSymbols [value / 16]; + *to ++ = hexSymbols [value % 16]; + } + *to = '\0'; + if (key != 0) + NUMrandom_initializeSafelyAndUnpredictably (); + return result; +} + +autostring32 newSTRhex (conststring32 str, uint64 key) { + autostring8 str8 = Melder_32to8 (str); + str8 = newSTRhex8 (str8.get(), key); + return Melder_8to32 (str8.get()); +} + autostring32 newSTRleft (conststring32 str, integer newLength) { integer length = str32len (str); if (newLength < 0) @@ -47,9 +76,15 @@ autostring32 newSTRreplace (conststring32 string, conststring32 search, conststring32 replace, integer maximumNumberOfReplaces, integer *out_numberOfMatches) { - if (string == 0 || search == 0 || replace == 0) - return autostring32(); - + /* + Sanitize input. + */ + if (! string) + string = U""; + if (! search) + search = U""; + if (! replace) + replace = U""; integer len_string = str32len (string); if (len_string == 0) maximumNumberOfReplaces = 1; @@ -127,6 +162,16 @@ autostring32 newSTRreplace_regex (conststring32 string, regexp *compiledSearchRE, conststring32 replaceRE, integer maximumNumberOfReplaces, integer *out_numberOfMatches) { + /* + Sanitize input. + */ + if (! string) + string = U""; + if (! compiledSearchRE) + return autostring32(); + if (! replaceRE) + replaceRE = U""; + integer buf_nchar = 0; // number of characters in 'buf' integer gap_copied = 0; integer nchar; @@ -139,8 +184,6 @@ autostring32 newSTRreplace_regex (conststring32 string, if (out_numberOfMatches) *out_numberOfMatches = 0; - if (string == 0 || compiledSearchRE == 0 || replaceRE == 0) - return 0; integer string_length = str32len (string); //int replace_length = str32len (replaceRE); @@ -185,7 +228,7 @@ autostring32 newSTRreplace_regex (conststring32 string, gap_copied = 1; /* - Do the substitution. We can only check afterwards for buffer overflow. + Do the substitution. We can check for buffer overflow only afterwards. SubstituteRE puts null byte at last replaced position and signals when overflow. */ if (! SubstituteRE (compiledSearchRE, replaceRE, buf.get() + buf_nchar, bufferLength + 1 - buf_nchar, & errorType)) { @@ -199,13 +242,15 @@ autostring32 newSTRreplace_regex (conststring32 string, Melder_throw (U"Error during substitution."); } - // Buffer is not full, get number of characters added; - + /* + Buffer is not full; get number of characters added. + */ nchar = str32len (buf.get() + buf_nchar); buf_nchar += nchar; - // Update next start position in search string. - + /* + Update next start position in search string. + */ posp = pos; pos = (char32 *) compiledSearchRE -> endp [0]; if (pos != posp) @@ -220,12 +265,14 @@ autostring32 newSTRreplace_regex (conststring32 string, break; } - // Copy last part of string to destination string - + /* + Copy last part of string to destination string + */ nchar = (string + string_length) - pos; bufferLength = buf_nchar + nchar; buf. resize (bufferLength); str32ncpy (buf.get() + buf_nchar, pos, nchar); + return buf; } @@ -238,4 +285,40 @@ autostring32 newSTRright (conststring32 str, integer newLength) { return Melder_dup (str + length - newLength); } +autostring8 newSTRunhex8 (conststring8 str, uint64 key) { + if (key != 0) + NUMrandom_initializeWithSeedUnsafelyButPredictably (key ^ hexSecret); + autostring8 result (uinteger_to_integer (strlen (str)) / 2); + char *to = & result [0]; + for (const char8 *from = (char8 *) & str [0];;) { + char8 code1 = *from ++; + while (Melder_isHorizontalOrVerticalSpace (code1)) + code1 = *from ++; + if (code1 == '\0') + break; + char8 code2 = *from ++; + while (Melder_isHorizontalOrVerticalSpace (code2)) + code2 = *from ++; + if (code2 == '\0') + Melder_throw (U"(unhex$:) incomplete hexadecimal string."); + const char *index1 = strchr (hexSymbols, code1), *index2 = strchr (hexSymbols, code2); + if (! index1 || ! index2) + Melder_throw (U"(unhex$:) not a hexadecimal string: ", Melder_peek8to32 (str)); + integer value = (index1 - hexSymbols) * 16 + (index2 - hexSymbols); + if (key != 0) + value = (value + 256 - NUMrandomInteger (0, 255)) % 256; + *to ++ = char (value); + } + *to = '\0'; + if (key != 0) + NUMrandom_initializeSafelyAndUnpredictably (); + return result; +} + +autostring32 newSTRunhex (conststring32 str, uint64 key) { + autostring8 str8 = Melder_32to8 (str); + str8 = newSTRunhex8 (str8.get(), key); + return Melder_8to32 (str8.get()); +} + /* End of file STR.cpp */ diff --git a/melder/STR.h b/melder/STR.h index 439ba05a..ed8f6436 100644 --- a/melder/STR.h +++ b/melder/STR.h @@ -17,6 +17,9 @@ * along with this work. If not, see . */ +autostring8 newSTRhex8 (conststring8 str, uint64 key = 0); +autostring32 newSTRhex (conststring32 str, uint64 key = 0); + autostring32 newSTRleft (conststring32 str, integer newLength = 1); autostring32 newSTRmid (conststring32 str, integer startingPosition_1, integer numberOfCharacters = 1); @@ -42,4 +45,7 @@ autostring32 newSTRreplace_regex (conststring32 string, regexp *search_compiled, autostring32 newSTRright (conststring32 str, integer newLength = 1); +autostring8 newSTRunhex8 (conststring8 str, uint64 key = 0); +autostring32 newSTRunhex (conststring32 str, uint64 key = 0); + /* End of file STR.h */ diff --git a/melder/abcio.cpp b/melder/abcio.cpp index 89267c56..b04be212 100644 --- a/melder/abcio.cpp +++ b/melder/abcio.cpp @@ -277,7 +277,8 @@ static int getEnum (MelderReadText me, int (*getValue) (conststring32)) { c = MelderReadText_getChar (me); // read past first '<' if (c == U'\0') Melder_throw (U"Early end of text detected while reading an enumerated value (line ", MelderReadText_getLineNumber (me), U")."); - if (Melder_isHorizontalOrVerticalSpace (c)) + constexpr char32 theOnlySpaceAllowedInAnEnum = U' '; + if (Melder_isHorizontalOrVerticalSpace (c) && c != theOnlySpaceAllowedInAnEnum) Melder_throw (U"No matching '>' while reading an enumerated value (line ", MelderReadText_getLineNumber (me), U")."); if (c == U'>') break; // the expected closing bracket; not added to the buffer diff --git a/melder/melder_audio.cpp b/melder/melder_audio.cpp index e51f7fa4..c8f948c3 100644 --- a/melder/melder_audio.cpp +++ b/melder/melder_audio.cpp @@ -18,6 +18,7 @@ #if defined (macintosh) #include + #include #elif defined (_WIN32) #include #elif defined (linux) @@ -995,9 +996,31 @@ void context_state_cb (pa_context *context, void *userdata) { } #endif +static bool deviceHasChanged = false; +#if defined (macintosh) +static int theCoreaudioPropertyListener (unsigned int, unsigned int, const AudioObjectPropertyAddress * _Nonnull, void * _Nullable) { + Melder_casual (U"coreaudio_property_listener"); + deviceHasChanged = true; + return 0; +} +#endif + void MelderAudio_play16 (int16 *buffer, integer sampleRate, integer numberOfSamples, integer numberOfChannels, bool (*playCallback) (void *playClosure, integer numberOfSamplesPlayed), void *playClosure) { + #if defined (macintosh) + {// scope + static bool inited; + if (! inited) { + OSStatus err = noErr; + AudioObjectPropertyAddress audioDevicesAddress = { kAudioHardwarePropertyDefaultOutputDevice, kAudioObjectPropertyScopeGlobal, kAudioObjectPropertyElementMaster }; + err = AudioObjectAddPropertyListener ( kAudioObjectSystemObject, & audioDevicesAddress, theCoreaudioPropertyListener, NULL); + if (err) Melder_casual (U"error on AudioObjectAddPropertyListener"); + inited = true; + } + } + #endif + struct MelderPlay *me = & thePlay; #ifdef _WIN32 bool wasPlaying = MelderAudio_isPlaying; @@ -1042,8 +1065,11 @@ void MelderAudio_play16 (int16 *buffer, integer sampleRate, integer numberOfSamp MelderAudio_isPlaying = true; if (my usePortAudio) { PaError err; - integer numberOfTries = 0; - restart_device: + if (deviceHasChanged) { + Pa_Terminate (); + Pa_Initialize (); + deviceHasChanged = false; + } if (! MelderAudio_hasBeenInitialized) { err = Pa_Initialize (); if (err) @@ -1054,6 +1080,7 @@ void MelderAudio_play16 (int16 *buffer, integer sampleRate, integer numberOfSamp PaStreamParameters outputParameters = { 0 }; outputParameters. device = Pa_GetDefaultOutputDevice (); const PaDeviceInfo *deviceInfo = Pa_GetDeviceInfo (outputParameters. device); + //Melder_casual (U"MelderAudio_play16: ", Melder_peek8to32 (deviceInfo -> name)); trace (U"the device can handle ", deviceInfo -> maxOutputChannels, U" channels"); if (my numberOfChannels > deviceInfo -> maxOutputChannels) { my numberOfChannels = deviceInfo -> maxOutputChannels; @@ -1091,18 +1118,8 @@ void MelderAudio_play16 (int16 *buffer, integer sampleRate, integer numberOfSamp outputParameters. hostApiSpecificStreamInfo = nullptr; err = Pa_OpenStream (& my stream, nullptr, & outputParameters, my sampleRate, paFramesPerBufferUnspecified, paDitherOff, thePaStreamCallback, me); - if (err) { - if (numberOfTries < 1) { - /* - Restart PortAudio and try again, once. - */ - numberOfTries += 1; - Pa_Terminate (); - MelderAudio_hasBeenInitialized = false; - goto restart_device; - } else - Melder_throw (U"PortAudio cannot open sound output: ", Melder_peek8to32 (Pa_GetErrorText (err)), U"."); - } + if (err) + Melder_throw (U"PortAudio cannot open sound output: ", Melder_peek8to32 (Pa_GetErrorText (err)), U"."); theStartingTime = Melder_clock (); err = Pa_StartStream (my stream); if (err) Melder_throw (U"PortAudio cannot start sound output: ", Melder_peek8to32 (Pa_GetErrorText (err)), U"."); diff --git a/melder/melder_debug.cpp b/melder/melder_debug.cpp index af24dadf..0153ba43 100644 --- a/melder/melder_debug.cpp +++ b/melder/melder_debug.cpp @@ -82,6 +82,8 @@ the behaviour of Praat will temporarily change in the following ways: 51: compute sum, mean, stdev with two cycles, as in R (80 bits) (other numbers than 48-51: compute sum, mean, stdev with simple pairwise algorithm, base case 64 [80 bits]) 52: debug Discriminant_TableOfReal_to_ClassificationTable +53: trace running cursor +54: ignore gdk_cairo_reset_clip 181: read and write native-endian real64 900: use DG Meta Serif Science instead of Palatino 1264: Mac: Sound_record_fixedTime uses microphone "FW Solo (1264)" diff --git a/melder/melder_int.h b/melder/melder_int.h index 16cb5e5c..39e37404 100644 --- a/melder/melder_int.h +++ b/melder/melder_int.h @@ -2,7 +2,7 @@ #define _melder_int_h_ /* melder_int.h * - * Copyright (C) 1992-2019 Paul Boersma + * Copyright (C) 1992-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -77,6 +77,10 @@ inline static integer uinteger_to_integer (uinteger n) { Melder_assert (n <= INTEGER_MAX); return (integer) n; } +inline static int32 integer_to_int32 (integer n) { + Melder_assert (n >= INT32_MIN && n <= INT32_MAX); + return (int32) n; +} inline static integer integer_abs (integer n) { Melder_assert (sizeof (integer) == sizeof (long) || sizeof (integer) == sizeof (long long)); @@ -89,37 +93,37 @@ inline static integer integer_abs (integer n) { struct MelderIntegerRange { integer first, last; bool isEmpty () { return ( last < first ); } - integer size () { + integer size () const { integer result = last - first + 1; return std::max (result, 0_integer); } }; template -void Melder_clipLeft (T minimum, T *var) { +void Melder_clipLeft (T minimum, T *var) { // no action if either undefined if (*var < minimum) *var = minimum; } template T Melder_clippedLeft (T minimum, T var) { - return std::max (minimum, var); + return var < minimum ? minimum : var; // if minimum undefined, then var } template -void Melder_clipRight (T *var, T maximum) { +void Melder_clipRight (T *var, T maximum) { // no action if either undefined if (*var > maximum) *var = maximum; } template T Melder_clippedRight (T var, T maximum) { - return std::min (var, maximum); + return var > maximum ? maximum : var; // if maximum undefined, then var } template void Melder_clip (T minimum, T *var, T maximum) { - Melder_assert (maximum >= minimum); + Melder_assert (! (maximum < minimum)); // NaN-safe if (*var < minimum) *var = minimum; else if (*var > maximum) @@ -128,16 +132,30 @@ void Melder_clip (T minimum, T *var, T maximum) { template T Melder_clipped (T minimum, T var, T maximum) { - Melder_assert (maximum >= minimum); - return std::max (minimum, std::min (var, maximum)); + Melder_assert (! (maximum < minimum)); // NaN-safe + return var < minimum ? minimum : var > maximum ? maximum : var; // if minimum and maximum undefined, then var +} + +template +void Melder_moveCloserToBy (T *x, T to, T by) { + if (*x < to) + *x = Melder_clippedRight (*x + by, to); + else if (*x > to) + *x = Melder_clippedLeft (to, *x - by); +} + +template +void Melder_sort (T *p1, T *p2) { + if (*p2 < *p1) + std::swap (*p1, *p2); } class kleenean { int _intValue; public: - static constexpr int UNKNOWN = -1; - static constexpr int NO_ = 0; - static constexpr int YES_ = 1; + constexpr static int UNKNOWN = -1; + constexpr static int NO_ = 0; + constexpr static int YES_ = 1; explicit constexpr kleenean (int initialValue): _intValue (initialValue) { } bool isTrue () const noexcept { return our _intValue > 0; diff --git a/melder/melder_progress.h b/melder/melder_progress.h index 9767430d..b3e0dc03 100644 --- a/melder/melder_progress.h +++ b/melder/melder_progress.h @@ -2,7 +2,7 @@ #define _melder_progress_h_ /* melder_progress.h * - * Copyright (C) 1992-2018,2020s Paul Boersma + * Copyright (C) 1992-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -73,9 +73,10 @@ Graphics graphics = Melder_monitor (0.0, U"Starting work..."); - at every turn of your loop, draw something in the Graphics: if (graphics) { // always check; might be batch - Graphics_clearWs (graphics); // only if you redraw all every time + Graphics_beginMovieFrame (graphics, & Melder_WHITE); // the colour only if you erase all every time Graphics_polyline (graphics, ...); Graphics_text (graphics, ...); + Graphics_endMovieFrame (graphics, 0.0); } - immediately after this in your loop, call with 'progress' between 0.0 and 1.0: Melder_monitor (i / (n + 1.0), U"Working on part ", i, U" out of ", n, U"..."); @@ -91,9 +92,10 @@ - showing and hiding can be automated by autoMelderMonitor: autoMelderMonitor monitor ("Starting work..."); if (monitor.graphics()) { // always check; might be batch - Graphics_clearWs (monitor.graphics()); // only if you redraw all every time + Graphics_beginMovieFrame (graphics, & Melder_WHITE); // the colour only if you erase all every time Graphics_polyline (monitor.graphics(), ...); Graphics_text (monitor.graphics(), ...); + Graphics_endMovieFrame (graphics, 0.0); } */ @@ -143,7 +145,7 @@ class autoMelderMonitor { Graphics _graphics; public: autoMelderMonitor (conststring32 message) { - _graphics = (Graphics) Melder_monitor (0.0, message); + our _graphics = (Graphics) Melder_monitor (0.0, message); } ~autoMelderMonitor () { Melder_monitor (1.0); diff --git a/melder/melder_real.h b/melder/melder_real.h index 86912cee..7074f376 100644 --- a/melder/melder_real.h +++ b/melder/melder_real.h @@ -23,6 +23,22 @@ */ using longdouble = long double; // typically 80 bits ("extended") precision, but stored in 96 or 128 bits; on some platforms only 64 bits +static const double undefined = (0.0/0.0); // NaN + +/* + isdefined() shall capture not only `undefined`, but all infinities and NaNs. + This can be done with a single test for the set bits in 0x7FF0'0000'0000'0000, + at least for 64-bit IEEE implementations. The correctness of this assumption is checked in sys/praat.cpp. + The portable version of isdefined() involves both isinf() and isnan(), or perhaps just isfinite(), + but that would be slower (as tested in fon/Praat_tests.cpp) + and it would also run into problems on some platforms when both and are included, + as in dwsys/NUMcomplex.cpp. +*/ +//inline bool isdefined (double x) { return ! isinf (x) && ! isnan (x); } /* portable */ +//inline bool isdefined (double x) { return isfinite (x); } /* portable */ +inline bool isdefined (double x) { return ((* (uint64 *) & x) & 0x7FF0'0000'0000'0000) != 0x7FF0'0000'0000'0000; } +inline bool isundef (double x) { return ((* (uint64 *) & x) & 0x7FF0'0000'0000'0000) == 0x7FF0'0000'0000'0000; } + template constexpr T sqr (T x) { return x * x; @@ -59,5 +75,26 @@ struct MelderGaussianStats { double mean, stdev; }; +struct MelderFraction { + double numerator = 0.0, denominator = 0.0; + double get () const { + return our denominator == 0.0 ? undefined : our numerator / our denominator; + } + bool isValid () const { + return our denominator != 0.0; + } +}; + +struct MelderCountAndFraction { + integer count = 0; + double numerator = 0.0, denominator = 0.0; + double getFraction () const { + return our denominator == 0.0 ? undefined : our numerator / our denominator; + } + bool isValid () const { + return our denominator != 0.0; + } +}; + /* End of file melder_real.h */ #endif diff --git a/melder/melder_search.cpp b/melder/melder_search.cpp index 76532eda..27785e7b 100644 --- a/melder/melder_search.cpp +++ b/melder/melder_search.cpp @@ -1,6 +1,6 @@ /* melder_search.cpp * - * Copyright (C) 1992-2018 Paul Boersma + * Copyright (C) 1992-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -34,7 +34,8 @@ inline static char32 * str32str_word_optionallyCaseSensitive (conststring32 stri bool ink, bool caseSensitive, bool startFree, bool endFree) noexcept { integer length = str32len (find); - if (length == 0) return (char32 *) string; + if (length == 0) + return (char32 *) string; conststring32 movingString = string; do { conststring32 movingFind = find; @@ -62,12 +63,10 @@ inline static char32 * str32str_word_optionallyCaseSensitive (conststring32 stri } bool Melder_stringMatchesCriterion (conststring32 value, kMelder_string which, conststring32 criterion, bool caseSensitive) { - if (! value) { + if (! value) value = U""; // regard null strings as empty strings, as is usual in Praat - } - if (! criterion) { + if (! criterion) criterion = U""; // regard null strings as empty strings, as is usual in Praat - } switch (which) { case kMelder_string::UNDEFINED: diff --git a/melder/melder_tensor.h b/melder/melder_tensor.h index f7a8ac52..3ee9d138 100644 --- a/melder/melder_tensor.h +++ b/melder/melder_tensor.h @@ -184,6 +184,15 @@ class constvector { : constvector (other.cells, other.size) { } //constvector (constvector const& other) = default; //constvector& operator= (constvector const& other) = default; + /* + Letting an autovector convert to a constvector would lead to errors such as in + constVEC vec = newVECzero (10); + where newVECzero produces a temporary that is deleted immediately + after the initialization of vec. + So we rule out this initialization. + */ + constvector (autovector const& other) + = delete; const T& operator[] (integer i) const { // it's still a reference, because we need to be able to take its address return our cells [i - 1]; } diff --git a/melder/regularExp.cpp b/melder/regularExp.cpp index 4290029a..df29582b 100644 --- a/melder/regularExp.cpp +++ b/melder/regularExp.cpp @@ -514,12 +514,11 @@ static char32 *shortcut_escape (char32 c, int *flag_param, int emit); * some of the structure of the compiled regexp. *----------------------------------------------------------------------*/ -regexp *CompileRE_throwable (conststring32 exp, int defaultFlags) { +regexp *CompileRE_throwable (conststring32 expression, int defaultFlags) { conststring32 compileMessage; - regexp *compiledRE = CompileRE (exp, & compileMessage, defaultFlags); - if (compiledRE == NULL) { - Melder_throw (U"Regular expression: ", compileMessage, U"."); - } + regexp *compiledRE = CompileRE (expression, & compileMessage, defaultFlags); + if (compiledRE == NULL) + Melder_throw (U"Regular expression: ", compileMessage, U" (", expression, U")."); return compiledRE; } diff --git a/stat/TableEditor.cpp b/stat/TableEditor.cpp index 338e2021..d0912e76 100644 --- a/stat/TableEditor.cpp +++ b/stat/TableEditor.cpp @@ -1,6 +1,6 @@ /* TableEditor.cpp * - * Copyright (C) 2006-2013,2015-2018 Paul Boersma + * Copyright (C) 2006-2013,2015-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -112,14 +112,12 @@ void structTableEditor :: v_draw () { double spacing = 2.0; // millimetres at both edges double columnWidth, cellWidth; /* - * We fit 200 rows in 40 inches, which is 14.4 points per row. - */ + We fit 200 rows in 40 inches, which is 14.4 points per row. + */ integer rowmin = topRow, rowmax = rowmin + 197; integer colmin = leftColumn, colmax = colmin + (kTableEditor_MAXNUM_VISIBLE_COLUMNS - 1); - if (rowmax > table -> rows.size) - rowmax = table -> rows.size; - if (colmax > table -> numberOfColumns) - colmax = table -> numberOfColumns; + Melder_clipRight (& rowmax, table -> rows.size); + Melder_clipRight (& colmax, table -> numberOfColumns); Graphics_clearWs (graphics.get()); Graphics_setTextAlignment (graphics.get(), Graphics_CENTRE, Graphics_HALF); Graphics_setWindow (graphics.get(), 0.0, 1.0, rowmin + 197.5, rowmin - 2.5); @@ -129,8 +127,8 @@ void structTableEditor :: v_draw () { Graphics_line (graphics.get(), 0.0, rowmin - 0.5, 1.0, rowmin - 0.5); Graphics_setWindow (graphics.get(), 0.0, Graphics_dxWCtoMM (graphics.get(), 1.0), rowmin + 197.5, rowmin - 2.5); /* - * Determine the width of the column with the row numbers. - */ + Determine the width of the column with the row numbers. + */ columnWidth = Graphics_textWidth (graphics.get(), U"row"); for (integer irow = rowmin; irow <= rowmax; irow ++) { cellWidth = Graphics_textWidth (graphics.get(), Melder_integer (irow)); @@ -143,8 +141,8 @@ void structTableEditor :: v_draw () { Graphics_setColour (graphics.get(), Melder_BLACK); Graphics_line (graphics.get(), columnLeft [0], rowmin - 0.5, columnLeft [0], rowmin + 197.5); /* - * Determine the width of the columns. - */ + Determine the widths of the columns. + */ for (integer icol = colmin; icol <= colmax; icol ++) { conststring32 columnLabel = table -> columnHeaders [icol]. label.get(); columnWidth = Graphics_textWidth (graphics.get(), Melder_integer (icol)); @@ -174,14 +172,14 @@ void structTableEditor :: v_draw () { Graphics_setCircumflexIsSuperscript (our graphics.get(), our p_useTextStyles); Graphics_setUnderscoreIsSubscript (our graphics.get(), our p_useTextStyles); /* - * Show the row numbers. - */ + Show the row numbers. + */ Graphics_text (graphics.get(), columnLeft [0] / 2, rowmin - 1, U"row"); for (integer irow = rowmin; irow <= rowmax; irow ++) Graphics_text (graphics.get(), columnLeft [0] / 2, irow, irow); /* - * Show the column labels. - */ + Show the column labels. + */ for (integer icol = colmin; icol <= colmax; icol ++) { const double mid = (columnLeft [icol - colmin] + columnRight [icol - colmin]) / 2; conststring32 columnLabel = table -> columnHeaders [icol]. label.get(); @@ -191,8 +189,8 @@ void structTableEditor :: v_draw () { Graphics_text (graphics.get(), mid, rowmin - 1, columnLabel); } /* - * Show the cell contents. - */ + Show the cell contents. + */ for (integer irow = rowmin; irow <= rowmax; irow ++) { for (integer icol = colmin; icol <= colmax; icol ++) { if (irow == selectedRow && icol == selectedColumn) { @@ -224,20 +222,21 @@ static void gui_text_cb_changed (TableEditor me, GuiTextEvent /* event */) { } static void gui_drawingarea_cb_expose (TableEditor me, GuiDrawingArea_ExposeEvent /* event */) { - if (! my graphics) return; + if (! my graphics) + return; my v_draw (); } -static void gui_drawingarea_cb_click (TableEditor me, GuiDrawingArea_ClickEvent event) { +static void gui_drawingarea_cb_mouse (TableEditor me, GuiDrawingArea_MouseEvent event) { Table table = static_cast (my data); if (! my graphics) return; // could be the case in the very beginning + if (! event -> isClick()) + return; integer rowmin = my topRow, rowmax = rowmin + 197; integer colmin = my leftColumn, colmax = colmin + (kTableEditor_MAXNUM_VISIBLE_COLUMNS - 1); - if (rowmax > table -> rows.size) - rowmax = table -> rows.size; - if (colmax > table -> numberOfColumns) - colmax = table -> numberOfColumns; + Melder_clipRight (& rowmax, table -> rows.size); + Melder_clipRight (& colmax, table -> numberOfColumns); double xWC, yWC; Graphics_DCtoWC (my graphics.get(), event -> x, event -> y, & xWC, & yWC); if (yWC < rowmin - 0.45 || yWC > rowmax + 0.55) @@ -263,12 +262,7 @@ static void gui_cb_scrollHorizontal (TableEditor me, GuiScrollBarEvent event) { const integer value = GuiScrollBar_getValue (event -> scrollBar); if (value != my leftColumn) { my leftColumn = value; - #if cocoa || gtk || motif || ! SUPPORT_DIRECT_DRAWING - Graphics_updateWs (my graphics.get()); // wait for expose event - #else - Graphics_clearWs (my graphics.get()); - my v_draw (); // do not wait for expose event - #endif + Graphics_updateWs (my graphics.get()); // wait for expose event } } @@ -276,12 +270,7 @@ static void gui_cb_scrollVertical (TableEditor me, GuiScrollBarEvent event) { const integer value = GuiScrollBar_getValue (event -> scrollBar); if (value != my topRow) { my topRow = value; - #if cocoa || gtk || motif || ! SUPPORT_DIRECT_DRAWING - Graphics_updateWs (my graphics.get()); // wait for expose event - #else - Graphics_clearWs (my graphics.get()); - my v_draw (); // do not wait for expose event - #endif + Graphics_updateWs (my graphics.get()); // wait for expose event } } @@ -294,13 +283,15 @@ void structTableEditor :: v_createChildren () { y += Machine_getTextHeight () + 4; our drawingArea = GuiDrawingArea_createShown (our windowForm, 0, - scrollWidth, y, - scrollWidth, - gui_drawingarea_cb_expose, gui_drawingarea_cb_click, NULL, gui_drawingarea_cb_resize, this, 0); + gui_drawingarea_cb_expose, gui_drawingarea_cb_mouse, + nullptr, gui_drawingarea_cb_resize, this, 0 + ); our verticalScrollBar = GuiScrollBar_createShown (our windowForm, - scrollWidth, 0, y, - scrollWidth, - 1, table -> rows.size + 1, 1, 1, 1, 10, gui_cb_scrollVertical, this, 0); + 1, table -> rows.size + 1, 1, 1, 1, 10, gui_cb_scrollVertical, this, 0); our horizontalScrollBar = GuiScrollBar_createShown (our windowForm, 0, - scrollWidth, - scrollWidth, 0, - 1, table -> numberOfColumns + 1, 1, 1, 1, 3, gui_cb_scrollHorizontal, this, GuiScrollBar_HORIZONTAL); + 1, table -> numberOfColumns + 1, 1, 1, 1, 3, gui_cb_scrollHorizontal, this, GuiScrollBar_HORIZONTAL); GuiDrawingArea_setSwipable (our drawingArea, our horizontalScrollBar, our verticalScrollBar); } diff --git a/stat/TableOfReal.cpp b/stat/TableOfReal.cpp index c8fdd511..c1879d37 100644 --- a/stat/TableOfReal.cpp +++ b/stat/TableOfReal.cpp @@ -753,10 +753,9 @@ void TableOfReal_drawAsNumbers (TableOfReal me, Graphics graphics, integer rowmi double maxTextHeight = getMaxColumnLabelHeight (me, graphics, 1, my numberOfColumns); Graphics_setTextAlignment (graphics, Graphics_CENTRE, Graphics_BOTTOM); - for (integer icol = 1; icol <= my numberOfColumns; icol ++) { + for (integer icol = 1; icol <= my numberOfColumns; icol ++) if (my columnLabels && my columnLabels [icol] && my columnLabels [icol] [0]) Graphics_text (graphics, icol, 1, my columnLabels [icol].get()); - } for (integer irow = rowmin; irow <= rowmax; irow ++) { double y = 1.0 - lineSpacing * (irow - rowmin + 0.6); Graphics_setTextAlignment (graphics, Graphics_RIGHT, Graphics_HALF); @@ -771,7 +770,8 @@ void TableOfReal_drawAsNumbers (TableOfReal me, Graphics graphics, integer rowmi } if (maxTextHeight != 0.0) { double left = 0.5; - if (maxTextWidth > 0.0) left -= maxTextWidth + 2 * leftMargin; + if (maxTextWidth > 0.0) + left -= maxTextWidth + 2 * leftMargin; Graphics_line (graphics, left, 1.0, my numberOfColumns + 0.5, 1.0); } Graphics_unsetInner (graphics); @@ -793,12 +793,11 @@ void TableOfReal_drawAsNumbers_if (TableOfReal me, Graphics graphics, integer ro Matrix_formula (original.get(), conditionFormula, interpreter, conditions.get()); Graphics_setTextAlignment (graphics, Graphics_CENTRE, Graphics_BOTTOM); - for (integer icol = 1; icol <= my numberOfColumns; icol ++) { + for (integer icol = 1; icol <= my numberOfColumns; icol ++) if (my columnLabels && my columnLabels [icol] && my columnLabels [icol] [0]) Graphics_text (graphics, icol, 1, my columnLabels [icol].get()); - } for (integer irow = rowmin; irow <= rowmax; irow ++) { - double y = 1.0 - lineSpacing * (irow - rowmin + 0.6); + const double y = 1.0 - lineSpacing * (irow - rowmin + 0.6); Graphics_setTextAlignment (graphics, Graphics_RIGHT, Graphics_HALF); if (my rowLabels && my rowLabels [irow] && my rowLabels [irow] [0]) Graphics_text (graphics, 0.5 - leftMargin, y, my rowLabels [irow].get()); @@ -811,7 +810,8 @@ void TableOfReal_drawAsNumbers_if (TableOfReal me, Graphics graphics, integer ro } if (maxTextHeight != 0.0) { double left = 0.5; - if (maxTextWidth > 0.0) left -= maxTextWidth + 2 * leftMargin; + if (maxTextWidth > 0.0) + left -= maxTextWidth + 2 * leftMargin; Graphics_line (graphics, left, 1.0, my numberOfColumns + 0.5, 1.0); } Graphics_unsetInner (graphics); @@ -897,18 +897,20 @@ void TableOfReal_drawTopAndBottomLines (TableOfReal me, Graphics graphics, integ void TableOfReal_drawAsSquares (TableOfReal me, Graphics graphics, integer rowmin, integer rowmax, integer colmin, integer colmax, bool garnish) { - double dx = 1.0, dy = 1.0; + const double dx = 1.0, dy = 1.0; MelderColour colour = Graphics_inqColour (graphics); fixRows (me, & rowmin, & rowmax); fixColumns (me, & colmin, & colmax); - + Graphics_setInner (graphics); Graphics_setWindow (graphics, colmin - 0.5, colmax + 0.5, rowmin - 0.5, rowmax + 0.5); + //const double datamax = NUMabsoluteExtremum (my data); TODO double datamax = my data [rowmin] [colmin]; for (integer irow = 1; irow <= my numberOfRows; irow ++) for (integer icol = 1; icol <= my numberOfColumns; icol ++) - if (fabs (my data [irow] [icol]) > datamax) datamax = fabs (my data [irow] [icol]); - + if (fabs (my data [irow] [icol]) > datamax) + datamax = fabs (my data [irow] [icol]); + for (integer irow = rowmin; irow <= rowmax; irow ++) { double y = rowmax + rowmin - irow; for (integer icol = colmin; icol <= colmax; icol ++) { @@ -917,7 +919,8 @@ void TableOfReal_drawAsSquares (TableOfReal me, Graphics graphics, integer rowmi double d = 0.95 * sqrt (fabs (my data [irow] [icol]) / datamax); double x1WC = x - d * dx / 2.0, x2WC = x + d * dx / 2.0; double y1WC = y - d * dy / 2.0, y2WC = y + d * dy / 2.0; - if (my data [irow] [icol] > 0) Graphics_setColour (graphics, Melder_WHITE); + if (my data [irow] [icol] > 0.0) + Graphics_setColour (graphics, Melder_WHITE); Graphics_fillRectangle (graphics, x1WC, x2WC, y1WC, y2WC); Graphics_setColour (graphics, colour); Graphics_rectangle (graphics, x1WC, x2WC , y1WC, y2WC); @@ -962,7 +965,8 @@ autoTableOfReal TablesOfReal_append (TableOfReal me, TableOfReal thee) { autoTableOfReal TablesOfReal_appendMany (OrderedOf* me) { try { - if (my size == 0) Melder_throw (U"Cannot add zero tables."); + if (my size == 0) + Melder_throw (U"Cannot add zero tables."); TableOfReal thee = my at [1]; integer totalNumberOfRows = thy numberOfRows; integer numberOfColumns = thy numberOfColumns; diff --git a/sys/ButtonEditor.cpp b/sys/ButtonEditor.cpp index a033f2b7..ca89dadc 100644 --- a/sys/ButtonEditor.cpp +++ b/sys/ButtonEditor.cpp @@ -1,6 +1,6 @@ /* ButtonEditor.cpp * - * Copyright (C) 1996-2019 Paul Boersma + * Copyright (C) 1996-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -127,7 +127,6 @@ static void drawAction (ButtonEditor me, Praat_Command cmd, integer i) { } void structButtonEditor :: v_draw () { - Graphics_clearWs (our graphics.get()); switch (show) { case 1: for (integer i = 1, n = praat_getNumberOfMenuCommands (); i <= n; i ++) { diff --git a/sys/DataEditor.cpp b/sys/DataEditor.cpp index c690d909..db4f7a42 100644 --- a/sys/DataEditor.cpp +++ b/sys/DataEditor.cpp @@ -100,18 +100,19 @@ static void gui_button_cb_change (DataSubEditor me, GuiButtonEvent /* event */) int irow = 1; for (; irow <= kDataSubEditor_MAXNUM_ROWS; irow ++) { #if motif - bool visible = XtIsManaged (my d_fieldData [irow]. text -> d_widget); + const bool visible = XtIsManaged (my d_fieldData [irow]. text -> d_widget); #elif gtk gboolean visible; - g_object_get (G_OBJECT (my d_fieldData [irow]. text), "visible", & visible, nullptr); + g_object_get (G_OBJECT (my d_fieldData [irow]. text -> d_widget), "visible", & visible, nullptr); #elif defined (macintosh) - bool visible = ! [(GuiCocoaTextField *) my d_fieldData [irow]. text -> d_widget isHidden]; + const bool visible = ! [(GuiCocoaTextField *) my d_fieldData [irow]. text -> d_widget isHidden]; #else - bool visible = false; + const bool visible = false; #endif if (visible) { int type = my d_fieldData [irow]. description -> type; - if (type > maxsingletypewa) continue; + if (type > maxsingletypewa) + continue; autostring32 text = GuiText_getString (my d_fieldData [irow]. text); switch (type) { case bytewa: { diff --git a/sys/DemoEditor.cpp b/sys/DemoEditor.cpp index aefab030..a7985064 100644 --- a/sys/DemoEditor.cpp +++ b/sys/DemoEditor.cpp @@ -1,6 +1,6 @@ /* DemoEditor.cpp * - * Copyright (C) 2009-2019 Paul Boersma + * Copyright (C) 2009-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -41,11 +41,10 @@ void structDemoEditor :: v_info () { } void structDemoEditor :: v_goAway () { - if (waitingForInput) { + if (waitingForInput) userWantsToClose = true; - } else { + else DemoEditor_Parent :: v_goAway (); - } } void structDemoEditor :: v_createMenus () { @@ -53,21 +52,19 @@ void structDemoEditor :: v_createMenus () { } static void gui_drawingarea_cb_expose (DemoEditor me, GuiDrawingArea_ExposeEvent /* event */) { - if (! my graphics) return; // could be the case in the very beginning - /* - * Erase the background. Don't record this erasure! - */ - Graphics_stopRecording (my graphics.get()); // the only place in Praat (the Picture window has a separate Graphics for erasing)? - Graphics_setColour (my graphics.get(), Melder_WHITE); - Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); - Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_startRecording (my graphics.get()); + if (! my graphics) + return; // could be the case in the very beginning +static integer count=0; +//Melder_casual(U"gui_drawingarea_cb_expose ", ++count); + //Graphics_clearWs (my foregroundGraphics.get()); Graphics_play (my graphics.get(), my graphics.get()); } -static void gui_drawingarea_cb_click (DemoEditor me, GuiDrawingArea_ClickEvent event) { - if (! my graphics) return; // could be the case in the very beginning +static void gui_drawingarea_cb_mouse (DemoEditor me, GuiDrawingArea_MouseEvent event) { + if (! my graphics) + return; // could be the case in the very beginning + if (! event -> isClick()) + return; my clicked = true; my keyPressed = false; my x = event -> x; @@ -76,11 +73,11 @@ static void gui_drawingarea_cb_click (DemoEditor me, GuiDrawingArea_ClickEvent e my shiftKeyPressed = event -> shiftKeyPressed; my commandKeyPressed = event -> commandKeyPressed; my optionKeyPressed = event -> optionKeyPressed; - my extraControlKeyPressed = event -> extraControlKeyPressed; } static void gui_drawingarea_cb_key (DemoEditor me, GuiDrawingArea_KeyEvent event) { - if (! my graphics) return; // could be the case in the very beginning + if (! my graphics) + return; // could be the case in the very beginning my clicked = false; my keyPressed = true; my x = 0; @@ -90,11 +87,11 @@ static void gui_drawingarea_cb_key (DemoEditor me, GuiDrawingArea_KeyEvent event my shiftKeyPressed = event -> shiftKeyPressed; my commandKeyPressed = event -> commandKeyPressed; my optionKeyPressed = event -> optionKeyPressed; - my extraControlKeyPressed = event -> extraControlKeyPressed; } static void gui_drawingarea_cb_resize (DemoEditor me, GuiDrawingArea_ResizeEvent event) { - if (! my graphics) return; // could be the case in the very beginning + if (! my graphics) + return; // could be the case in the very beginning trace (event -> width, U" ", event -> height); Graphics_setWsViewport (my graphics.get(), 0.0, event -> width, 0.0, event -> height); Graphics_setWsWindow (my graphics.get(), 0.0, 100.0, 0.0, 100.0); @@ -103,22 +100,27 @@ static void gui_drawingarea_cb_resize (DemoEditor me, GuiDrawingArea_ResizeEvent } void structDemoEditor :: v_createChildren () { - drawingArea = GuiDrawingArea_createShown (our windowForm, 0, 0, 0, 0, - gui_drawingarea_cb_expose, gui_drawingarea_cb_click, gui_drawingarea_cb_key, gui_drawingarea_cb_resize, this, 0); + our drawingArea = GuiDrawingArea_createShown (our windowForm, 0, 0, 0, 0, + gui_drawingarea_cb_expose, gui_drawingarea_cb_mouse, + gui_drawingarea_cb_key, gui_drawingarea_cb_resize, this, 0 + ); } void DemoEditor_init (DemoEditor me) { Editor_init (me, 0, 0, 1344, 756, U"", nullptr); // 70 percent of the standard 1920x1080 screen + my graphics = Graphics_create_xmdrawingarea (my drawingArea); + Graphics_setWsWindow (my graphics.get(), 0.0, 100.0, 0.0, 100.0); + Graphics_setWsViewport (my graphics.get(), + 0.0, GuiControl_getWidth (my drawingArea), + 0.0, GuiControl_getHeight (my drawingArea) + ); + Graphics_startRecording (my graphics.get()); + Graphics_setViewport (my graphics.get(), 0.0, 100.0, 0.0, 100.0); Graphics_setColour (my graphics.get(), Melder_WHITE); Graphics_setWindow (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_fillRectangle (my graphics.get(), 0.0, 1.0, 0.0, 1.0); Graphics_setColour (my graphics.get(), Melder_BLACK); - Graphics_startRecording (my graphics.get()); - Graphics_setWsViewport (my graphics.get(), 0.0, GuiControl_getWidth (my drawingArea), - 0.0, GuiControl_getHeight (my drawingArea)); - Graphics_setWsWindow (my graphics.get(), 0.0, 100.0, 0.0, 100.0); - Graphics_setViewport (my graphics.get(), 0.0, 100.0, 0.0, 100.0); Graphics_updateWs (my graphics.get()); } @@ -135,8 +137,8 @@ autoDemoEditor DemoEditor_create () { void Demo_open () { if (Melder_batch) { /* - * Batch scripts have to be able to run demos. - */ + Batch scripts have to be able to run demos. + */ //Melder_batch = false; } if (! theReferenceToTheOnlyDemoEditor) { @@ -168,6 +170,7 @@ void Demo_open () { void Demo_close () { theCurrentPraatPicture = & theForegroundPraatPicture; + Graphics_updateWs (theReferenceToTheOnlyDemoEditor -> graphics.get()); } int Demo_windowTitle (conststring32 title) { @@ -177,9 +180,11 @@ int Demo_windowTitle (conststring32 title) { } int Demo_show () { - if (! theReferenceToTheOnlyDemoEditor) return 0; + if (! theReferenceToTheOnlyDemoEditor) + return 0; autoDemoOpen demo; GuiThing_show (theReferenceToTheOnlyDemoEditor -> windowForm); + Graphics_updateWs (theReferenceToTheOnlyDemoEditor -> graphics.get()); GuiShell_drain (theReferenceToTheOnlyDemoEditor -> windowForm); return 1; } @@ -210,7 +215,8 @@ void Demo_timer (double duration) { } void Demo_waitForInput (Interpreter interpreter) { - if (! theReferenceToTheOnlyDemoEditor) return; + if (! theReferenceToTheOnlyDemoEditor) + return; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -222,7 +228,8 @@ void Demo_waitForInput (Interpreter interpreter) { {// scope autoMelderSaveDefaultDir saveDir; bool wasBackgrounding = Melder_backgrounding; - if (wasBackgrounding) praat_foreground (); + if (wasBackgrounding) + praat_foreground (); try { #if gtk do { @@ -260,7 +267,8 @@ void Demo_waitForInput (Interpreter interpreter) { } catch (MelderError) { Melder_flushError (U"An error made it to the outer level in the Demo window; should not occur! Please write to paul.boersma@uva.nl"); } - if (wasBackgrounding) praat_background (); + if (wasBackgrounding) + praat_background (); } theReferenceToTheOnlyDemoEditor -> waitingForInput = false; if (theReferenceToTheOnlyDemoEditor -> userWantsToClose) { @@ -285,7 +293,6 @@ void Demo_peekInput (Interpreter interpreter) { theReferenceToTheOnlyDemoEditor -> shiftKeyPressed = false; theReferenceToTheOnlyDemoEditor -> commandKeyPressed = false; theReferenceToTheOnlyDemoEditor -> optionKeyPressed = false; - theReferenceToTheOnlyDemoEditor -> extraControlKeyPressed = false; theReferenceToTheOnlyDemoEditor -> waitingForInput = true; {// scope autoMelderSaveDefaultDir saveDir; @@ -330,7 +337,8 @@ void Demo_peekInput (Interpreter interpreter) { } bool Demo_clicked () { - if (! theReferenceToTheOnlyDemoEditor) return false; + if (! theReferenceToTheOnlyDemoEditor) + return false; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -339,7 +347,8 @@ bool Demo_clicked () { } double Demo_x () { - if (! theReferenceToTheOnlyDemoEditor) return undefined; + if (! theReferenceToTheOnlyDemoEditor) + return undefined; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -356,7 +365,8 @@ double Demo_x () { } double Demo_y () { - if (! theReferenceToTheOnlyDemoEditor) return undefined; + if (! theReferenceToTheOnlyDemoEditor) + return undefined; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -369,7 +379,8 @@ double Demo_y () { } bool Demo_keyPressed () { - if (! theReferenceToTheOnlyDemoEditor) return false; + if (! theReferenceToTheOnlyDemoEditor) + return false; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -378,7 +389,8 @@ bool Demo_keyPressed () { } char32 Demo_key () { - if (! theReferenceToTheOnlyDemoEditor) return U'\0'; + if (! theReferenceToTheOnlyDemoEditor) + return U'\0'; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -387,7 +399,8 @@ char32 Demo_key () { } bool Demo_shiftKeyPressed () { - if (! theReferenceToTheOnlyDemoEditor) return false; + if (! theReferenceToTheOnlyDemoEditor) + return false; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -396,7 +409,8 @@ bool Demo_shiftKeyPressed () { } bool Demo_commandKeyPressed () { - if (! theReferenceToTheOnlyDemoEditor) return false; + if (! theReferenceToTheOnlyDemoEditor) + return false; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -405,7 +419,8 @@ bool Demo_commandKeyPressed () { } bool Demo_optionKeyPressed () { - if (! theReferenceToTheOnlyDemoEditor) return false; + if (! theReferenceToTheOnlyDemoEditor) + return false; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -413,17 +428,9 @@ bool Demo_optionKeyPressed () { return theReferenceToTheOnlyDemoEditor -> optionKeyPressed; } -bool Demo_extraControlKeyPressed () { - if (! theReferenceToTheOnlyDemoEditor) return false; - if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { - Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " - U"Please click or type into the Demo window or close it."); - } - return theReferenceToTheOnlyDemoEditor -> extraControlKeyPressed; -} - bool Demo_input (conststring32 keys) { - if (! theReferenceToTheOnlyDemoEditor) return false; + if (! theReferenceToTheOnlyDemoEditor) + return false; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); @@ -432,12 +439,14 @@ bool Demo_input (conststring32 keys) { } bool Demo_clickedIn (double left, double right, double bottom, double top) { - if (! theReferenceToTheOnlyDemoEditor || ! theReferenceToTheOnlyDemoEditor -> clicked) return false; + if (! theReferenceToTheOnlyDemoEditor || ! theReferenceToTheOnlyDemoEditor -> clicked) + return false; if (theReferenceToTheOnlyDemoEditor -> waitingForInput) { Melder_throw (U"You cannot work with the Demo window while it is waiting for input. " U"Please click or type into the Demo window or close it."); } - if (! theReferenceToTheOnlyDemoEditor -> clicked) return false; + if (! theReferenceToTheOnlyDemoEditor -> clicked) + return false; double xWC = Demo_x (), yWC = Demo_y (); return xWC >= left && xWC < right && yWC >= bottom && yWC < top; } diff --git a/sys/DemoEditor.h b/sys/DemoEditor.h index 17db123c..83e9c032 100644 --- a/sys/DemoEditor.h +++ b/sys/DemoEditor.h @@ -2,7 +2,7 @@ #define _DemoEditor_h_ /* DemoEditor.h * - * Copyright (C) 2009-2011,2012,2015,2017 Paul Boersma + * Copyright (C) 2009-2011,2012,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -24,7 +24,7 @@ Thing_define (DemoEditor, Editor) { GuiDrawingArea drawingArea; autoGraphics graphics; void *praatPicture; - bool clicked, keyPressed, shiftKeyPressed, commandKeyPressed, optionKeyPressed, extraControlKeyPressed; + bool clicked, keyPressed, shiftKeyPressed, commandKeyPressed, optionKeyPressed; integer x, y; char32 key; bool waitingForInput, userWantsToClose, fullScreen; @@ -69,7 +69,6 @@ char32 Demo_key (); bool Demo_shiftKeyPressed (); bool Demo_commandKeyPressed (); bool Demo_optionKeyPressed (); -bool Demo_extraControlKeyPressed (); /* Shortcuts: */ bool Demo_input (conststring32 keys); bool Demo_clickedIn (double left, double right, double bottom, double top); diff --git a/sys/Editor.cpp b/sys/Editor.cpp index af3f48db..bcdf99c9 100644 --- a/sys/Editor.cpp +++ b/sys/Editor.cpp @@ -1,6 +1,6 @@ /* Editor.cpp * - * Copyright (C) 1992-2018 Paul Boersma, 2008 Stefan de Konink, 2010 Franz Brausse + * Copyright (C) 1992-2020 Paul Boersma, 2008 Stefan de Konink, 2010 Franz Brausse * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -55,9 +55,8 @@ static void commonCallback (EditorCommand me, GuiMenuItemEvent /* event */) { try { my commandCallback (my d_editor, me, nullptr, 0, nullptr, nullptr, nullptr); } catch (MelderError) { - if (! Melder_hasError (U"Script exited.")) { + if (! Melder_hasError (U"Script exited.")) Melder_appendError (U"Menu command \"", my itemTitle.get(), U"\" not completed."); - } Melder_flushError (); } } @@ -69,9 +68,9 @@ GuiMenuItem EditorMenu_addCommand (EditorMenu me, conststring32 itemTitle /* cat thy menu = me; thy itemTitle = Melder_dup (itemTitle); thy itemWidget = - ! commandCallback ? GuiMenu_addSeparator (my menuWidget) : - flags & Editor_HIDDEN ? nullptr : - GuiMenu_addItem (my menuWidget, itemTitle, flags, commonCallback, thee.get()); // DANGLE BUG: me can be killed by Collection_addItem(), but EditorCommand::destroy doesn't remove the item + ! commandCallback ? GuiMenu_addSeparator (my menuWidget) : + flags & Editor_HIDDEN ? nullptr : + GuiMenu_addItem (my menuWidget, itemTitle, flags, commonCallback, thee.get()); // DANGLE BUG: me can be killed by Collection_addItem(), but EditorCommand::destroy doesn't remove the item thy commandCallback = commandCallback; GuiMenuItem result = thy itemWidget; my commands. addItem_move (thee.move()); @@ -141,7 +140,8 @@ GuiMenuItem Editor_addCommandScript (Editor me, conststring32 menuTitle, constst U"Menu \"", menuTitle, U"\" does not exist.\n" U"Command \"", itemTitle, U"\" not inserted in menu \"", menuTitle, U".\n" U"To fix this, go to Praat->Preferences->Buttons->Editors, and remove the script from this menu.\n" - U"You may want to install the script in a different menu."); + U"You may want to install the script in a different menu." + ); return nullptr; } @@ -194,9 +194,9 @@ void structEditor :: v_destroy () noexcept { trace (U"enter"); MelderAudio_stopPlaying (MelderAudio_IMPLICIT); /* - * The following command must be performed before the shell is destroyed. - * Otherwise, we would be forgetting dangling command dialogs here. - */ + The following command must be performed before the shell is destroyed. + Otherwise, we would be forgetting dangling command dialogs here. + */ our menus.removeAllItems(); Editor_broadcastDestruction (this); @@ -240,7 +240,8 @@ void structEditor :: v_nameChanged () { } void structEditor :: v_saveData () { - if (! our data) return; + if (! our data) + return; our previousData = Data_copy (our data); } @@ -278,12 +279,12 @@ static void menu_cb_undo (Editor me, EDITOR_ARGS_DIRECT) { [(GuiCocoaMenuItem *) my undoButton -> d_widget setTitle: (NSString *) Melder_peek32toCfstring (my undoText)]; #endif /* - * Send a message to myself (e.g., I will redraw myself). - */ + Send a message to myself (e.g., I will redraw myself). + */ my v_dataChanged (); /* - * Send a message to my boss (e.g., she will notify the others that depend on me). - */ + Send a message to my boss (e.g., she will notify the others that depend on me). + */ Editor_broadcastDataChanged (me); } @@ -325,9 +326,8 @@ void structEditor :: v_createMenuItems_query (EditorMenu menu) { void structEditor :: v_createMenuItems_query_info (EditorMenu menu) { EditorMenu_addCommand (menu, U"Editor info", 0, menu_cb_settingsReport); EditorMenu_addCommand (menu, U"Settings report", Editor_HIDDEN, menu_cb_settingsReport); - if (data) { + if (data) EditorMenu_addCommand (menu, Melder_cat (Thing_className (data), U" info"), 0, menu_cb_info); - } } void structEditor :: v_createMenus () { @@ -379,61 +379,63 @@ void Editor_init (Editor me, int x, int y, int width, int height, conststring32 double xmin, ymin, widthmax, heightmax; Gui_getWindowPositioningBounds (& xmin, & ymin, & widthmax, & heightmax); /* - * Negative widths are relative to the whole screen. - */ - if (width < 0) width += (int) widthmax; - if (height < 0) height += (int) heightmax; + Negative widths are relative to the whole screen. + */ + if (width < 0) + width += (int) widthmax; + if (height < 0) + height += (int) heightmax; /* - * Don't start with a maximized window, because then the user doesn't know what a click on the maximize button means. - */ - if (width > (int) widthmax - 100) width = (int) widthmax - 100; - if (height > (int) heightmax - 100) height = (int) heightmax - 100; + Don't start with a maximized window, because then the user doesn't know what a click on the maximize button means. + */ + Melder_clipRight (& width, (int) widthmax - 100); + Melder_clipRight (& height, (int) heightmax - 100); /* - * Make sure that the window has at least a sane size. - * Just in case the user made the previous window very small (Praat's FunctionEditor saves the last size), - * or the user edited the preferences file (which might save a window size). - */ - if (width < 200) width = 200; - if (height < 150) height = 150; + Make sure that the window has at least a sane size, + just in case the user made the previous window very small (Praat's FunctionEditor saves the last size), + or the user edited the preferences file (which might save a window size). + */ + Melder_clipLeft (200, & width); + Melder_clipLeft (150, & height); /* - * Now that the size is right, establish the position. - */ + Now that the size is right, establish the position. + */ int left, right, top, bottom; if (x > 0) { /* - * Positive x: relative to the left edge of the screen. - */ + Positive x: relative to the left edge of the screen. + */ left = (int) xmin + x; right = left + width; } else if (x < 0) { /* - * Negative x: relative to the right edge of the screen. - */ + Negative x: relative to the right edge of the screen. + */ right = (int) xmin + (int) widthmax + x; left = right - width; } else { /* - * Zero x: randomize between the left and right edge of the screen. - */ + Zero x: randomize between the left and right edge of the screen. + */ left = (int) NUMrandomInteger ((int) xmin + 4, (int) xmin + (int) widthmax - width - 4); right = left + width; } if (y > 0) { /* - * Positive y: relative to the top of the screen. - */ + Positive y: relative to the top of the screen. + */ top = (int) ymin + y; bottom = top + height; } else if (y < 0) { /* - * Negative y: relative to the bottom of the screen. - */ + Negative y: relative to the bottom of the screen. + */ bottom = (int) ymin + (int) heightmax + y; top = bottom - height; } else { /* - * Zero y: randomize between the top and bottom of the screen. - */ + Zero y: randomize between the top and bottom of the screen. + */ top = (int) NUMrandomInteger ((int) ymin + 4, (int) ymin + (int) heightmax - height - 4); //Melder_casual (ymin, U" ", heightmax, U" ", height, U" ", top); bottom = top + height; @@ -447,11 +449,12 @@ void Editor_init (Editor me, int x, int y, int width, int height, conststring32 my data = data; my v_copyPreferencesToInstance (); - /* Create menus. */ + /* + Create menus. + */ - if (my v_hasMenuBar ()) { + if (my v_hasMenuBar ()) GuiWindow_addMenuBar (my windowForm); - } my v_createChildren (); @@ -467,8 +470,8 @@ void Editor_init (Editor me, int x, int y, int width, int height, conststring32 Editor_addCommand (me, U"File", U"-- after script --", 0, 0); } /* - * Add the scripted commands. - */ + Add the scripted commands. + */ praat_addCommandsToEditor (me); if (my callbackSocket) Editor_addCommand (me, U"File", U"Send back to calling program", 0, menu_cb_sendBackToCallingProgram); @@ -479,7 +482,8 @@ void Editor_init (Editor me, int x, int y, int width, int height, conststring32 void Editor_save (Editor me, conststring32 text) { my v_saveData (); - if (! my undoButton) return; + if (! my undoButton) + return; GuiThing_setSensitive (my undoButton, true); Melder_sprint (my undoText,100, U"Undo ", text); #if gtk @@ -503,7 +507,8 @@ void Editor_closePraatPicture (Editor me) { Graphics_setUnderscoreIsSubscript (my pictureGraphics, false); Graphics_textTop (my pictureGraphics, my pref_picture_writeNameAtTop () == kEditor_writeNameAtTop::FAR_, - my data -> name.get()); + my data -> name.get() + ); Graphics_setNumberSignIsBold (my pictureGraphics, true); Graphics_setPercentSignIsItalic (my pictureGraphics, true); Graphics_setCircumflexIsSuperscript (my pictureGraphics, true); diff --git a/sys/EditorM.h b/sys/EditorM.h index 00d7716b..02b2ccc2 100644 --- a/sys/EditorM.h +++ b/sys/EditorM.h @@ -2,7 +2,7 @@ #define _EditorM_h_ /* EditorM.h * - * Copyright (C) 1992-2013,2015-2019 Paul Boersma + * Copyright (C) 1992-2013,2015-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -47,8 +47,11 @@ #undef SET_ENUM #define EDITOR_ARGS_FORM EditorCommand cmd, UiForm _sendingForm_, integer _narg_, Stackel _args_, conststring32 _sendingString_, Interpreter interpreter +#define EDITOR_ARGS_FORM_FORWARD cmd, _sendingForm_, _narg_, _args_, _sendingString_, interpreter #define EDITOR_ARGS_CMD EditorCommand cmd, UiForm, integer, Stackel, conststring32, Interpreter +#define EDITOR_ARGS_CMD_FORWARD cmd, nullptr, 0, nullptr, nullptr, nullptr #define EDITOR_ARGS_DIRECT EditorCommand, UiForm, integer, Stackel, conststring32, Interpreter +#define EDITOR_ARGS_DIRECT_FORWARD nullptr, nullptr, 0, nullptr, nullptr, nullptr #define EDITOR_FORM(title, helpTitle) \ UiField _radio_ = nullptr; \ diff --git a/sys/Formula.cpp b/sys/Formula.cpp index 467c590b..d4a6fcf2 100644 --- a/sys/Formula.cpp +++ b/sys/Formula.cpp @@ -148,7 +148,7 @@ enum { NO_SYMBOL_, CHOOSE_READ_FILESTR_, CHOOSE_WRITE_FILESTR_, CHOOSE_DIRECTORYSTR_, DEMO_WINDOW_TITLE_, DEMO_SHOW_, DEMO_WAIT_FOR_INPUT_, DEMO_PEEK_INPUT_, DEMO_INPUT_, DEMO_CLICKED_IN_, DEMO_CLICKED_, DEMO_X_, DEMO_Y_, DEMO_KEY_PRESSED_, DEMO_KEY_, - DEMO_SHIFT_KEY_PRESSED_, DEMO_COMMAND_KEY_PRESSED_, DEMO_OPTION_KEY_PRESSED_, DEMO_EXTRA_CONTROL_KEY_PRESSED_, + DEMO_SHIFT_KEY_PRESSED_, DEMO_COMMAND_KEY_PRESSED_, DEMO_OPTION_KEY_PRESSED_, VEC_ZERO_, MAT_ZERO_, VEC_LINEAR_, MAT_LINEAR_, VEC_TO_, VEC_FROM_TO_, VEC_FROM_TO_BY_, VEC_BETWEEN_BY_, VEC_RANDOM_UNIFORM_, MAT_RANDOM_UNIFORM_, @@ -159,8 +159,8 @@ enum { NO_SYMBOL_, MAT_PEAKS_, SIZE_, NUMBER_OF_ROWS_, NUMBER_OF_COLUMNS_, EDITOR_, RANDOM__INITIALIZE_WITH_SEED_UNSAFELY_BUT_PREDICTABLY_, RANDOM__INITIALIZE_SAFELY_AND_UNPREDICTABLY_, - HASH_, - #define HIGH_FUNCTION_N HASH_ + HASH_, HEXSTR_, UNHEXSTR_, + #define HIGH_FUNCTION_N UNHEXSTR_ /* String functions. */ #define LOW_STRING_FUNCTION LOW_FUNCTION_STR1 @@ -274,7 +274,7 @@ static const conststring32 Formula_instructionNames [1 + highestSymbol] = { U"", U"chooseReadFile$", U"chooseWriteFile$", U"chooseDirectory$", U"demoWindowTitle", U"demoShow", U"demoWaitForInput", U"demoPeekInput", U"demoInput", U"demoClickedIn", U"demoClicked", U"demoX", U"demoY", U"demoKeyPressed", U"demoKey$", - U"demoShiftKeyPressed", U"demoCommandKeyPressed", U"demoOptionKeyPressed", U"demoExtraControlKeyPressed", + U"demoShiftKeyPressed", U"demoCommandKeyPressed", U"demoOptionKeyPressed", U"zero#", U"zero##", U"linear#", U"linear##", U"to#", U"from_to#", U"from_to_by#", U"between_by#", U"randomUniform#", U"randomUniform##", @@ -284,7 +284,7 @@ static const conststring32 Formula_instructionNames [1 + highestSymbol] = { U"", U"peaks##", U"size", U"numberOfRows", U"numberOfColumns", U"editor", U"random_initializeWithSeedUnsafelyButPredictably", U"random_initializeSafelyAndUnpredictably", - U"hash", + U"hash", U"hex$", U"unhex$", U"length", U"number", U"fileReadable", U"deleteFile", U"createDirectory", U"variableExists", U"readFile", U"readFile$", U"unicodeToBackslashTrigraphs$", U"backslashTrigraphsToUnicode$", U"environment$", @@ -4562,6 +4562,54 @@ static void do_hash () { } } +static void do_hexStr () { + Stackel n = pop; + Melder_assert (n->which == Stackel_NUMBER); + if (n->number == 1) { + Stackel s = pop; + if (s->which == Stackel_STRING) { + autostring32 result = newSTRhex (s->getString()); + pushString (result.move()); + } else { + Melder_throw (U"The function \"hex$\" requires a string, not ", s->whichText(), U"."); + } + } else if (n->number == 2) { + Stackel k = pop, s = pop; + if (s->which == Stackel_STRING && k->which == Stackel_NUMBER) { + autostring32 result = newSTRhex (s->getString(), uint64 (round (k->number))); + pushString (result.move()); + } else { + Melder_throw (U"The function \"hex$\" requires a string and a number, not ", s->whichText(), U"."); + } + } else { + Melder_throw (U"The function \"hex$\" requires 1 or 2 arguments, not ", n->number, U"."); + } +} + +static void do_unhexStr () { + Stackel n = pop; + Melder_assert (n->which == Stackel_NUMBER); + if (n->number == 1) { + Stackel s = pop; + if (s->which == Stackel_STRING) { + autostring32 result = newSTRunhex (s->getString()); + pushString (result.move()); + } else { + Melder_throw (U"The function \"unhex$\" requires a string, not ", s->whichText(), U"."); + } + } else if (n->number == 2) { + Stackel k = pop, s = pop; + if (s->which == Stackel_STRING && k->which == Stackel_NUMBER) { + autostring32 result = newSTRunhex (s->getString(), uint64 (round (k->number))); + pushString (result.move()); + } else { + Melder_throw (U"The function \"unhex$\" requires a string and a number, not ", s->whichText(), U"."); + } + } else { + Melder_throw (U"The function \"unhex$\" requires 1 or 2 arguments, not ", n->number, U"."); + } +} + static void do_numericVectorElement () { InterpreterVariable vector = parse [programPointer]. content.variable; integer element = 1; // default @@ -5992,19 +6040,22 @@ static void do_pauseFormAddText () { if (theCurrentPraatObjects != & theForegroundPraatObjects) Melder_throw (U"The function \"text\" is not available inside manuals."); Stackel n = pop; - if (n->number == 2) { - Stackel defaultValue = pop; - Melder_require (defaultValue->which == Stackel_STRING, - U"The second argument of \"text\" (the default value) should be a string, not ", defaultValue->whichText(), U"."); - Stackel label = pop; - if (label->which == Stackel_STRING) { - UiPause_text (label->getString(), defaultValue->getString()); - } else { - Melder_throw (U"The first argument of \"text\" (the label) should be a string, not ", label->whichText(), U"."); - } - } else { - Melder_throw (U"The function \"text\" requires 2 arguments (a label and a default value), not ", n->number, U"."); - } + Melder_require (n->number >= 2 && n->number <= 3, + U"The function \"text\" requires 2 or 3 arguments (a label, a default value, and an optional number of lines), not ", n->number, U"."); + integer numberOfLines = 1; + if (n->number == 3) { + Stackel _numberOfLines = pop; + Melder_require (_numberOfLines->which == Stackel_NUMBER, + U"The third argument of \"text\" (the number of lines) should be a number, not ", _numberOfLines->whichText(), U"."); + numberOfLines = Melder_iround (_numberOfLines->number); + } + Stackel defaultValue = pop; + Melder_require (defaultValue->which == Stackel_STRING, + U"The second argument of \"text\" (the default value) should be a string, not ", defaultValue->whichText(), U"."); + Stackel label = pop; + Melder_require (label->which == Stackel_STRING, + U"The first argument of \"text\" (the label) should be a string, not ", label->whichText(), U"."); + UiPause_text (label->getString(), defaultValue->getString(), numberOfLines); pushNumber (1); } static void do_pauseFormAddBoolean () { @@ -6113,14 +6164,16 @@ static void do_endPauseForm () { if (ca->which == Stackel_NUMBER) { cancelContinueButton = defaultContinueButton; defaultContinueButton = Melder_iround (ca->number); - numberOfContinueButtons --; - if (cancelContinueButton < 1 || cancelContinueButton > numberOfContinueButtons) + numberOfContinueButtons -= 1; + if (cancelContinueButton < 0 || cancelContinueButton > numberOfContinueButtons) Melder_throw (U"Your last argument of \"endPause\" is the number of the cancel button; it cannot be ", cancelContinueButton, - U" but should lie between 1 and ", numberOfContinueButtons, U"."); + U" but should be 0 (no cancel or stop button) or lie between 1 and ", numberOfContinueButtons, U"."); + if (cancelContinueButton == 0) + cancelContinueButton = -1; } Stackel co [1+10] = { 0 }; for (integer i = numberOfContinueButtons; i >= 1; i --) { - co [i] = cancelContinueButton != 0 || i != numberOfContinueButtons ? pop : ca; + co [i] = ( cancelContinueButton != 0 || i != numberOfContinueButtons ? pop : ca ); if (co[i]->which != Stackel_STRING) Melder_throw (U"Each of the first ", numberOfContinueButtons, U" argument(s) of \"endPause\" should be a string (a button text), not ", co[i]->whichText(), U"."); @@ -6306,13 +6359,6 @@ static void do_demoOptionKeyPressed () { bool result = Demo_optionKeyPressed (); pushNumber (result); } -static void do_demoExtraControlKeyPressed () { - Stackel n = pop; - if (n->number != 0) - Melder_throw (U"The function \"demoControlKeyPressed\" requires 0 arguments, not ", n->number, U"."); - bool result = Demo_extraControlKeyPressed (); - pushNumber (result); -} static integer Stackel_getRowNumber (Stackel row, Daata thee) { integer result = 0; if (row->which == Stackel_NUMBER) { @@ -7055,6 +7101,8 @@ case NUMBER_: { pushNumber (f [programPointer]. content.number); } break; case RANDOM__INITIALIZE_WITH_SEED_UNSAFELY_BUT_PREDICTABLY_: { do_random_initializeWithSeedUnsafelyButPredictably (); } break; case RANDOM__INITIALIZE_SAFELY_AND_UNPREDICTABLY_: { do_random_initializeSafelyAndUnpredictably (); } break; case HASH_: { do_hash (); +} break; case HEXSTR_: { do_hexStr (); +} break; case UNHEXSTR_: { do_unhexStr (); /********** String functions: **********/ } break; case LENGTH_: { do_length (); } break; case STRING_TO_NUMBER_: { do_number (); @@ -7158,7 +7206,6 @@ case NUMBER_: { pushNumber (f [programPointer]. content.number); } break; case DEMO_SHIFT_KEY_PRESSED_: { do_demoShiftKeyPressed (); } break; case DEMO_COMMAND_KEY_PRESSED_: { do_demoCommandKeyPressed (); } break; case DEMO_OPTION_KEY_PRESSED_: { do_demoOptionKeyPressed (); -} break; case DEMO_EXTRA_CONTROL_KEY_PRESSED_: { do_demoExtraControlKeyPressed (); /********** **********/ } break; case TRUE_: { pushNumber (1.0); diff --git a/sys/Graphics.cpp b/sys/Graphics.cpp index 87ac5ca2..6806f362 100644 --- a/sys/Graphics.cpp +++ b/sys/Graphics.cpp @@ -1,6 +1,6 @@ /* Graphics.cpp * - * Copyright (C) 1992-2008,2010-2018 Paul Boersma + * Copyright (C) 1992-2008,2010-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -31,7 +31,7 @@ Thing_implement (Graphics, Thing, 0); -enum kGraphics_cjkFontStyle theGraphicsCjkFontStyle; +kGraphics_cjkFontStyle theGraphicsCjkFontStyle; void Graphics_prefs () { Preferences_addEnum (U"Graphics.cjkFontStyle", & theGraphicsCjkFontStyle, kGraphics_cjkFontStyle, (int) kGraphics_cjkFontStyle::DEFAULT); @@ -43,18 +43,17 @@ void structGraphics :: v_destroy () noexcept { } static void computeTrafo (Graphics me) { - double worldScaleX, worldScaleY, workScaleX, workScaleY; Melder_assert (my d_x2WC != my d_x1WC); - worldScaleX = (my d_x2NDC - my d_x1NDC) / (my d_x2WC - my d_x1WC); + const double worldScaleX = (my d_x2NDC - my d_x1NDC) / (my d_x2WC - my d_x1WC); Melder_assert (my d_y2WC != my d_y1WC); - worldScaleY = (my d_y2NDC - my d_y1NDC) / (my d_y2WC - my d_y1WC); + const double worldScaleY = (my d_y2NDC - my d_y1NDC) / (my d_y2WC - my d_y1WC); my deltaX = my d_x1NDC - my d_x1WC * worldScaleX; my deltaY = my d_y1NDC - my d_y1WC * worldScaleY; Melder_assert (my d_x2wNDC != my d_x1wNDC); - workScaleX = (my d_x2DC - my d_x1DC) / (my d_x2wNDC - my d_x1wNDC); + const double workScaleX = (my d_x2DC - my d_x1DC) / (my d_x2wNDC - my d_x1wNDC); my deltaX = my d_x1DC - (my d_x1wNDC - my deltaX) * workScaleX; - my scaleX = worldScaleX * workScaleX; Melder_assert (my d_y2wNDC != my d_y1wNDC); + double workScaleY; if (my yIsZeroAtTheTop) { workScaleY = ((int) my d_y1DC - (int) my d_y2DC) / (my d_y2wNDC - my d_y1wNDC); my deltaY = my d_y2DC - (my d_y1wNDC - my deltaY) * workScaleY; @@ -62,6 +61,7 @@ static void computeTrafo (Graphics me) { workScaleY = ((int) my d_y2DC - (int) my d_y1DC) / (my d_y2wNDC - my d_y1wNDC); my deltaY = my d_y1DC - (my d_y1wNDC - my deltaY) * workScaleY; } + my scaleX = worldScaleX * workScaleX; my scaleY = worldScaleY * workScaleY; } @@ -98,8 +98,10 @@ void Graphics_init (Graphics me, int resolution) { } else { Melder_fatal (U"Unsupported resolution ", resolution, U" dpi."); } - my d_x1DC = my d_x1DCmin = 0; my d_x2DC = my d_x2DCmax = 32767; - my d_y1DC = my d_y1DCmin = 0; my d_y2DC = my d_y2DCmax = 32767; + my d_x1DC = my d_x1DCmin = 0; + my d_x2DC = my d_x2DCmax = 32767; + my d_y1DC = my d_y1DCmin = 0; + my d_y2DC = my d_y2DCmax = 32767; my d_x1WC = my d_x1NDC = my d_x1wNDC = 0.0; my d_x2WC = my d_x2NDC = my d_x2wNDC = 1.0; my d_y1WC = my d_y1NDC = my d_y1wNDC = 0.0; @@ -113,12 +115,12 @@ void Graphics_init (Graphics me, int resolution) { my fontStyle = Graphics_NORMAL; my record = nullptr; my irecord = my nrecord = 0; - my percentSignIsItalic = 1; - my numberSignIsBold = 1; - my circumflexIsSuperscript = 1; - my underscoreIsSubscript = 1; - my dollarSignIsCode = 0; - my atSignIsLink = 0; + my percentSignIsItalic = true; + my numberSignIsBold = true; + my circumflexIsSuperscript = true; + my underscoreIsSubscript = true; + my dollarSignIsCode = false; + my atSignIsLink = false; } autoGraphics Graphics_create (int resolution) { @@ -154,12 +156,12 @@ void Graphics_setWsViewport (Graphics me, if (my screen && my printer) { GraphicsScreen mescreen = (GraphicsScreen) me; /* - * Map page coordinates to paper coordinates. - */ - mescreen -> d_x1DC -= GetDeviceCaps (mescreen -> d_gdiGraphicsContext, PHYSICALOFFSETX); - mescreen -> d_x2DC -= GetDeviceCaps (mescreen -> d_gdiGraphicsContext, PHYSICALOFFSETX); - mescreen -> d_y1DC -= GetDeviceCaps (mescreen -> d_gdiGraphicsContext, PHYSICALOFFSETY); - mescreen -> d_y2DC -= GetDeviceCaps (mescreen -> d_gdiGraphicsContext, PHYSICALOFFSETY); + Map page coordinates to paper coordinates. + */ + mescreen -> d_x1DC -= GetDeviceCaps (mescreen -> d_gdiGraphicsContext, PHYSICALOFFSETX); + mescreen -> d_x2DC -= GetDeviceCaps (mescreen -> d_gdiGraphicsContext, PHYSICALOFFSETX); + mescreen -> d_y1DC -= GetDeviceCaps (mescreen -> d_gdiGraphicsContext, PHYSICALOFFSETY); + mescreen -> d_y2DC -= GetDeviceCaps (mescreen -> d_gdiGraphicsContext, PHYSICALOFFSETY); } #endif computeTrafo (me); @@ -233,23 +235,25 @@ void Graphics_setViewport (Graphics me, double x1NDC, double x2NDC, double y1NDC } void Graphics_setInner (Graphics me) { - double margin = 2.8 * my fontSize * my resolution / 72.0; - double wDC = (my d_x2DC - my d_x1DC) / (my d_x2wNDC - my d_x1wNDC) * (my d_x2NDC - my d_x1NDC); - double hDC = integer_abs (my d_y2DC - my d_y1DC) / (my d_y2wNDC - my d_y1wNDC) * (my d_y2NDC - my d_y1NDC); + const double margin = 2.8 * my fontSize * my resolution / 72.0; + const double wDC = (my d_x2DC - my d_x1DC) / (my d_x2wNDC - my d_x1wNDC) * (my d_x2NDC - my d_x1NDC); + const double hDC = integer_abs (my d_y2DC - my d_y1DC) / (my d_y2wNDC - my d_y1wNDC) * (my d_y2NDC - my d_y1NDC); double dx = 1.5 * margin / wDC; double dy = margin / hDC; - my horTick = 0.06 * dx, my vertTick = 0.09 * dy; + my horTick = 0.06 * dx; + my vertTick = 0.09 * dy; if (dx > 0.4) dx = 0.4; if (dy > 0.4) dy = 0.4; - my horTick /= 1 - 2 * dx, my vertTick /= 1 - 2 * dy; + my horTick /= 1.0 - 2.0 * dx; + my vertTick /= 1.0 - 2.0 * dy; my outerViewport.x1NDC = my d_x1NDC; my outerViewport.x2NDC = my d_x2NDC; my outerViewport.y1NDC = my d_y1NDC; my outerViewport.y2NDC = my d_y2NDC; - my d_x1NDC = (1 - dx) * my outerViewport.x1NDC + dx * my outerViewport.x2NDC; - my d_x2NDC = (1 - dx) * my outerViewport.x2NDC + dx * my outerViewport.x1NDC; - my d_y1NDC = (1 - dy) * my outerViewport.y1NDC + dy * my outerViewport.y2NDC; - my d_y2NDC = (1 - dy) * my outerViewport.y2NDC + dy * my outerViewport.y1NDC; + my d_x1NDC = (1.0 - dx) * my outerViewport.x1NDC + dx * my outerViewport.x2NDC; + my d_x2NDC = (1.0 - dx) * my outerViewport.x2NDC + dx * my outerViewport.x1NDC; + my d_y1NDC = (1.0 - dy) * my outerViewport.y1NDC + dy * my outerViewport.y2NDC; + my d_y2NDC = (1.0 - dy) * my outerViewport.y2NDC + dy * my outerViewport.y1NDC; trace (U"done ", my d_x1NDC, U" ", my d_x2NDC, U" ", my d_y1NDC, U" ", my d_y2NDC); computeTrafo (me); if (my recording) { op (SET_INNER, 0); } diff --git a/sys/Graphics.h b/sys/Graphics.h index 8043388a..86fe8cea 100644 --- a/sys/Graphics.h +++ b/sys/Graphics.h @@ -2,7 +2,7 @@ #define _Graphics_h_ /* Graphics.h * - * Copyright (C) 1992-2005,2007-2019 Paul Boersma + * Copyright (C) 1992-2005,2007-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -104,8 +104,8 @@ Thing_define (Graphics, Thing) { kGraphics_font font; double fontSize; int fontStyle; - int percentSignIsItalic, numberSignIsBold, circumflexIsSuperscript, underscoreIsSubscript; - int dollarSignIsCode, atSignIsLink; + bool percentSignIsItalic, numberSignIsBold, circumflexIsSuperscript, underscoreIsSubscript; + bool dollarSignIsCode, atSignIsLink; bool recording, duringXor; integer irecord, nrecord; double *record; @@ -132,8 +132,6 @@ Thing_define (Graphics, Thing) { virtual void v_roundedRectangle (double x1DC, double x2DC, double y1DC, double y2DC, double r); virtual void v_fillRoundedRectangle (double x1DC, double x2DC, double y1DC, double y2DC, double r); virtual void v_arrowHead (double xDC, double yDC, double angle); - virtual bool v_mouseStillDown () { return false; } - virtual void v_getMouseLocation (double *xWC, double *yWC) { *xWC = *yWC = undefined; } virtual void v_flushWs () { } virtual void v_clearWs () { } virtual void v_updateWs () { } @@ -157,11 +155,6 @@ autoGraphics Graphics_create_xmdrawingarea (GuiDrawingArea drawingArea); int Graphics_getResolution (Graphics me); -#if defined (macintosh) - #define SUPPORT_DIRECT_DRAWING 1 -#else - #define SUPPORT_DIRECT_DRAWING 1 -#endif void Graphics_setWsViewport (Graphics me, integer x1DC, integer x2DC, integer y1DC, integer y2DC); void Graphics_resetWsViewport (Graphics me, integer x1DC, integer x2DC, integer y1DC, integer y2DC); void Graphics_setWsWindow (Graphics me, double x1NDC, double x2NDC, double y1NDC, double y2NDC); @@ -180,8 +173,8 @@ Graphics_Viewport Graphics_insetViewport (Graphics me, double x1rel, double x2re void Graphics_resetViewport (Graphics me, Graphics_Viewport viewport); void Graphics_setWindow (Graphics me, double x1, double x2, double y1, double y2); -void Graphics_polyline (Graphics me, integer numberOfPoints, double *x, double *y); -void Graphics_polyline_closed (Graphics me, integer numberOfPoints, double *x, double *y); +void Graphics_polyline (Graphics me, integer numberOfPoints, const double *x, const double *y); +void Graphics_polyline_closed (Graphics me, integer numberOfPoints, const double *x, const double *y); void Graphics_text (Graphics me, double xWC, double yWC, conststring32 txt); template @@ -238,11 +231,8 @@ void Graphics_setGrey (Graphics me, double grey); void Graphics_xorOn (Graphics me, MelderColour colour); void Graphics_xorOff (Graphics me); void Graphics_highlight (Graphics me, double x1, double x2, double y1, double y2); -void Graphics_unhighlight (Graphics me, double x1, double x2, double y1, double y2); void Graphics_highlight2 (Graphics me, double x1, double x2, double y1, double y2, double innerX1, double innerX2, double innerY1, double innerY2); -void Graphics_unhighlight2 (Graphics me, double x1, double x2, double y1, double y2, - double innerX1, double innerX2, double innerY1, double innerY2); #define Graphics_NOCHANGE -1 #define Graphics_LEFT kGraphics_horizontalAlignment::LEFT @@ -365,13 +355,14 @@ double Graphics_distanceWCtoMM (Graphics me, double x1WC, double y1WC, double x2 double Graphics_dxWCtoMM (Graphics me, double dxWC); double Graphics_dyWCtoMM (Graphics me, double dyWC); -bool Graphics_mouseStillDown (Graphics me); -void Graphics_waitMouseUp (Graphics me); -void Graphics_getMouseLocation (Graphics me, double *xWC, double *yWC); - void Graphics_nextSheetOfPaper (Graphics me); void Graphics_prefs (); +#ifdef macintosh + void GraphicsQuartz_initDraw (Graphics me); + void GraphicsQuartz_exitDraw (Graphics me); +#endif + /* End of file Graphics.h */ #endif diff --git a/sys/GraphicsP.h b/sys/GraphicsP.h index 5b940fd4..f437d68c 100644 --- a/sys/GraphicsP.h +++ b/sys/GraphicsP.h @@ -2,7 +2,7 @@ #define _GraphicsP_h_ /* GraphicsP.h * - * Copyright (C) 1992-2019 Paul Boersma, 2013 Tom Naughton + * Copyright (C) 1992-2020 Paul Boersma, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -83,7 +83,6 @@ Thing_define (GraphicsScreen, Graphics) { GdkDisplay *d_display; #if ALLOW_GDK_DRAWING GdkDrawable *d_window; - GdkGC *d_gdkGraphicsContext; #else GdkWindow *d_window; #endif @@ -104,7 +103,6 @@ Thing_define (GraphicsScreen, Graphics) { NSView *d_macView; int d_macFont, d_macStyle; int d_depth; - RGBColor d_macColour; uint8 *d_bits; CGContextRef d_macGraphicsContext; #endif @@ -135,10 +133,6 @@ Thing_define (GraphicsScreen, Graphics) { override; void v_arrowHead (double xDC, double yDC, double angle) override; - bool v_mouseStillDown () - override; - void v_getMouseLocation (double *xWC, double *yWC) - override; void v_flushWs () override; void v_clearWs () @@ -210,7 +204,7 @@ enum opcode { SET_VIEWPORT = 101, SET_INNER, UNSET_INNER, SET_WINDOW, /* 152 */ INNER_RECTANGLE, CELL_ARRAY8, IMAGE, HIGHLIGHT2, UNHIGHLIGHT2, /* 157 */ SET_ARROW_SIZE, DOUBLE_ARROW, SET_RGB_COLOUR, IMAGE_FROM_FILE, /* 161 */ POLYLINE_CLOSED, CELL_ARRAY_COLOUR, IMAGE_COLOUR, SET_COLOUR_SCALE, - /* 165 */ SET_SPECKLE_SIZE, SPECKLE + /* 165 */ SET_SPECKLE_SIZE, SPECKLE, CLEAR_WS }; void _GraphicsScreen_text_init (GraphicsScreen me); @@ -221,11 +215,6 @@ void _Graphics_colour_init (Graphics me); bool _GraphicsMac_tryToInitializeFonts (); bool _GraphicsLin_tryToInitializeFonts (); -#if quartz - void GraphicsQuartz_initDraw (GraphicsScreen me); - void GraphicsQuartz_exitDraw (GraphicsScreen me); -#endif - extern enum kGraphics_cjkFontStyle theGraphicsCjkFontStyle; /* End of file GraphicsP.h */ diff --git a/sys/GraphicsScreen.cpp b/sys/GraphicsScreen.cpp index 6a74033d..e944fbad 100644 --- a/sys/GraphicsScreen.cpp +++ b/sys/GraphicsScreen.cpp @@ -1,6 +1,6 @@ /* GraphicsScreen.cpp * - * Copyright (C) 1992-2012,2014,2015,2016,2017 Paul Boersma, 2013 Tom Naughton + * Copyright (C) 1992-2020 Paul Boersma, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -38,7 +38,6 @@ } #elif quartz #include "macport_on.h" - static RGBColor theBlackColour = { 0, 0, 0 }; static bool _GraphicsMacintosh_tryToInitializeQuartz () { return _GraphicsMac_tryToInitializeFonts (); } @@ -48,12 +47,6 @@ Thing_implement (GraphicsScreen, Graphics, 0); void structGraphicsScreen :: v_destroy () noexcept { #if cairo - #if ALLOW_GDK_DRAWING - if (d_gdkGraphicsContext) { - g_object_unref (d_gdkGraphicsContext); - d_gdkGraphicsContext = nullptr; - } - #endif if (d_cairoGraphicsContext) { cairo_destroy (d_cairoGraphicsContext); d_cairoGraphicsContext = nullptr; @@ -66,7 +59,7 @@ void structGraphicsScreen :: v_destroy () noexcept { #else unsigned char *bitmap = cairo_image_surface_get_data (my d_cairoSurface); // peeking into the internal bits // copy bitmap to PNG structure created with the PNG library - // save the PNG tructure to a file + // save the PNG structure to a file #endif } cairo_surface_destroy (d_cairoSurface); @@ -87,8 +80,8 @@ void structGraphicsScreen :: v_destroy () noexcept { if (d_isPng && d_gdiBitmap) { trace (U"saving the filled bitmap to a PNG file"); /* - * Deselect the bitmap from the device context (otherwise GetDIBits won't work). - */ + Deselect the bitmap from the device context (otherwise GetDIBits won't work). + */ //SelectBitmap (d_gdiGraphicsContext, nullptr); //SelectBitmap (d_gdiGraphicsContext, CreateCompatibleBitmap (nullptr, 1, 1)); @@ -99,8 +92,8 @@ void structGraphicsScreen :: v_destroy () noexcept { trace (U"width ", width, U", height ", height); /* - * Get the bits from the HBITMAP; - */ + Get the bits from the HBITMAP; + */ struct { BITMAPINFOHEADER header; } bitmapInfo; bitmapInfo. header.biSize = sizeof (BITMAPINFOHEADER); bitmapInfo. header.biWidth = width; @@ -162,9 +155,9 @@ void structGraphicsScreen :: v_destroy () noexcept { DeleteDC (d_gdiGraphicsContext); // this was a memory leak before 5.3.83 } /* - * No ReleaseDC here, because we have not created it ourselves, - * not even with GetDC. Is this a BUG? - */ + No ReleaseDC here, because we have not created it ourselves, + not even with GetDC. Is this a BUG? + */ d_gdiGraphicsContext = nullptr; #elif quartz if (! d_macView && ! d_isPng) { @@ -173,14 +166,14 @@ void structGraphicsScreen :: v_destroy () noexcept { } if (d_isPng && d_macGraphicsContext) { /* - * Turn the offscreen bitmap into an image. - */ + Turn the offscreen bitmap into an image. + */ CGImageRef image = CGBitmapContextCreateImage (d_macGraphicsContext); Melder_assert (image); //CGContextRelease (d_macGraphicsContext); /* - * Create a dictionary with resolution properties. - */ + Create a dictionary with resolution properties. + */ CFTypeRef keys [2], values [2]; keys [0] = kCGImagePropertyDPIWidth; keys [1] = kCGImagePropertyDPIHeight; @@ -190,8 +183,7 @@ void structGraphicsScreen :: v_destroy () noexcept { (const void **) keys, (const void **) values, 2, & kCFTypeDictionaryKeyCallBacks, & kCFTypeDictionaryValueCallBacks); Melder_assert (properties); - /* - */ + CFURLRef url = CFURLCreateWithFileSystemPath (nullptr, (CFStringRef) Melder_peek32toCfstring (d_file. path), kCFURLPOSIXPathStyle, false); CGImageDestinationRef imageDestination = CGImageDestinationCreateWithURL (url, kUTTypePNG, 1, nullptr); @@ -216,14 +208,47 @@ void structGraphicsScreen :: v_flushWs () { // Ik weet niet of dit is wat het zou moeten zijn ;) //gdk_window_process_updates (d_window, true); // this "works" but is incorrect because it's not the expose events that have to be carried out //gdk_window_flush (d_window); - gdk_flush (); + //gdk_flush (); // TODO: een aanroep die de eventuele grafische buffer ledigt, // zodat de gebruiker de grafica ziet ook al blijft Praat in hetzelfde event zitten + if (our d_drawingArea && our d_drawingArea -> d_exposeCallback) { + GdkRectangle rect; + if (our d_x1DC < our d_x2DC) { + rect.x = our d_x1DC; + rect.width = our d_x2DC - our d_x1DC; + } else { + rect.x = our d_x2DC; + rect.width = our d_x1DC - our d_x2DC; + } + if (our d_y1DC < our d_y2DC) { + rect.y = our d_y1DC; + rect.height = our d_y2DC - our d_y1DC; + } else { + rect.y = our d_y2DC; + rect.height = our d_y1DC - our d_y2DC; + } + structGuiDrawingArea_ExposeEvent event { our d_drawingArea, 0 }; + event. x = rect. x; + event. y = rect. y; + event. width = rect. width; + event. height = rect. height; + try { + //Melder_casual (U"_GuiGtkDrawingArea_exposeCallback: ", event. x, U" ", event. y, U" ", event. width, U" ", event. height); + trace (U"send the expose callback"); + trace (U"locale is ", Melder_peek8to32 (setlocale (LC_ALL, nullptr))); + our d_drawingArea -> d_exposeCallback (our d_drawingArea -> d_exposeBoss, & event); + trace (U"the expose callback finished"); + trace (U"locale is ", Melder_peek8to32 (setlocale (LC_ALL, nullptr))); + } catch (MelderError) { + Melder_flushError (U"Redrawing not completed"); + } + trace (U"the expose callback handled drawing"); + } #elif gdi /*GdiFlush ();*/ #elif quartz - if (d_drawingArea) { - GuiShell shell = d_drawingArea -> d_shell; + if (our d_drawingArea) { + GuiShell shell = our d_drawingArea -> d_shell; Melder_assert (shell); Melder_assert (shell -> d_cocoaShell); [shell -> d_cocoaShell flushWindow]; @@ -258,12 +283,7 @@ void structGraphicsScreen :: v_clearWs () { rect.y = our d_y2DC; rect.height = our d_y1DC - our d_y2DC; } - if (! d_cairoGraphicsContext) { - trace (U"clear and null"); - //gdk_window_clear (our window); - //gdk_window_invalidate_rect (our window, & rect, true); // BUG: it seems weird that this is necessary. - } else { - trace (U"clear and not null"); + if (d_cairoGraphicsContext) { cairo_set_source_rgb (d_cairoGraphicsContext, 1.0, 1.0, 1.0); cairo_rectangle (d_cairoGraphicsContext, rect.x, rect.y, rect.width, rect.height); cairo_fill (d_cairoGraphicsContext); @@ -277,66 +297,32 @@ void structGraphicsScreen :: v_clearWs () { FillRect (d_gdiGraphicsContext, & rect, GetStockBrush (WHITE_BRUSH)); /*if (d_winWindow) SendMessage (d_winWindow, WM_ERASEBKGND, (WPARAM) d_gdiGraphicsContext, 0);*/ #elif quartz - GuiCocoaDrawingArea *cocoaDrawingArea = (GuiCocoaDrawingArea *) d_drawingArea -> d_widget; - if (cocoaDrawingArea && ! [cocoaDrawingArea isHiddenOrHasHiddenAncestor]) { // can be called at destruction time - NSRect rect; - if (our d_x1DC < our d_x2DC) { - rect.origin.x = our d_x1DC; - rect.size.width = our d_x2DC - our d_x1DC; - } else { - rect.origin.x = our d_x2DC; - rect.size.width = our d_x1DC - our d_x2DC; - } - if (our d_y1DC < our d_y2DC) { - rect.origin.y = our d_y1DC; - rect.size.height = our d_y2DC - our d_y1DC; - } else { - rect.origin.y = our d_y2DC; - rect.size.height = our d_y1DC - our d_y2DC; - } - if (SUPPORT_DIRECT_DRAWING) { - [cocoaDrawingArea lockFocus]; - CGContextRef context = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; - Melder_assert (context); - CGContextSaveGState (context); - CGContextSetAlpha (context, 1.0); - CGContextSetBlendMode (context, kCGBlendModeNormal); - CGContextSetRGBFillColor (context, 1.0, 1.0, 1.0, 1.0); - //rect.origin.x -= 1000; - //rect.origin.y -= 1000; - //rect.size.width += 2000; - //rect.size.height += 2000; - trace (U"clearing ", rect.origin.x, U" ", rect.origin.y, U" ", rect.size.width, U" ", rect.size.height); - //CGContextTranslateCTM (context, 0, cocoaDrawingArea.bounds.size.height); - //CGContextScaleCTM (context, 1.0, -1.0); - CGContextFillRect (context, rect); - //CGContextSynchronize (context); - CGContextRestoreGState (context); - [cocoaDrawingArea unlockFocus]; - [cocoaDrawingArea setNeedsDisplay: YES]; - } else { - /* - Just redraw, and hope that the redraw method erases. - */ - [cocoaDrawingArea setNeedsDisplay: YES]; - } - //[cocoaDrawingArea display]; - } + GuiCocoaDrawingArea *cocoaDrawingArea = (GuiCocoaDrawingArea *) d_drawingArea -> d_widget; + if (cocoaDrawingArea && ! [cocoaDrawingArea isHiddenOrHasHiddenAncestor]) { // can be called at destruction time + Melder_assert (!! our d_macGraphicsContext); + CGContextSetAlpha (our d_macGraphicsContext, 1.0); + CGContextSetRGBFillColor (our d_macGraphicsContext, 1.0, 1.0, 1.0, 1.0); + CGContextFillRect (d_macGraphicsContext, CGRectMake (our d_x1DC, our d_y2DC, our d_x2DC - our d_x1DC, our d_y1DC - our d_y2DC)); + } #endif } void Graphics_clearWs (Graphics me) { - my v_clearWs (); + if (my recording) { + op (CLEAR_WS, 0); + } else + my v_clearWs (); } void structGraphicsScreen :: v_updateWs () { /* - * A function that invalidates the graphics. - * This function is typically called by the owner of the drawing area - * whenever the data to be displayed in the drawing area has changed; - * the idea is to generate an expose event to which the drawing area will - * respond by redrawing its contents from the (changed) data. - */ + A function that invalidates the graphics. + This function is typically called by the owner of the drawing area + whenever the data to be displayed in the drawing area has changed; + the idea is to generate an expose event to which the drawing area will + respond by redrawing its contents from the (changed) data. + (last checked 2020-07-12) + */ #if cairo && gtk //GdkWindow *window = gtk_widget_get_parent_window (GTK_WIDGET (our d_drawingArea -> d_widget)); GdkRectangle rect; @@ -357,42 +343,46 @@ void structGraphicsScreen :: v_updateWs () { rect.height = our d_y1DC - our d_y2DC; } - if (our d_cairoGraphicsContext && our d_drawingArea) { // update clipping rectangle to new graphics size - cairo_reset_clip (our d_cairoGraphicsContext); - cairo_rectangle (our d_cairoGraphicsContext, rect.x, rect.y, rect.width, rect.height); - cairo_clip (our d_cairoGraphicsContext); + if (Melder_debug == 54) { + // ignore gdk_cairo_reset_clip + } else { + if (our d_cairoGraphicsContext && our d_drawingArea) { // update clipping rectangle to new graphics size + cairo_reset_clip (our d_cairoGraphicsContext); + cairo_rectangle (our d_cairoGraphicsContext, rect.x, rect.y, rect.width, rect.height); + cairo_clip (our d_cairoGraphicsContext); + } } #if ALLOW_GDK_DRAWING - gdk_window_clear (our d_window); + //gdk_window_clear (our d_window); #endif - gdk_window_invalidate_rect (our d_window, & rect, true); + //gdk_window_invalidate_rect (our d_window, & rect, true); + gtk_widget_queue_draw_area (GTK_WIDGET (our d_drawingArea -> d_widget), rect.x, rect.y, rect.width, rect.height); + //gdk_window_invalidate_rect (our d_window, nullptr, true); //gdk_window_process_updates (our d_window, true); #elif gdi //clear (this); // lll - if (our d_winWindow) InvalidateRect (our d_winWindow, nullptr, true); + if (our d_winWindow) + InvalidateRect (our d_winWindow, nullptr, true); #elif quartz - NSView *view = our d_macView; + NSView *view = our d_macView; Melder_assert (!! view); - NSRect rect; - - if (our d_x1DC < our d_x2DC) { - rect.origin.x = our d_x1DC; - rect.size.width = our d_x2DC - our d_x1DC; - } else { - rect.origin.x = our d_x2DC; - rect.size.width = our d_x1DC - our d_x2DC; - } - - if (our d_y1DC < our d_y2DC) { - rect.origin.y = our d_y1DC; - rect.size.height = our d_y2DC - our d_y1DC; - } else { - rect.origin.y = our d_y2DC; - rect.size.height = our d_y1DC - our d_y2DC; - } - - //[view setNeedsDisplayInRect: rect]; - [view setNeedsDisplay: YES]; + NSRect rect; + if (our d_x1DC < our d_x2DC) { + rect.origin.x = our d_x1DC; + rect.size.width = our d_x2DC - our d_x1DC; + } else { + rect.origin.x = our d_x2DC; + rect.size.width = our d_x1DC - our d_x2DC; + } + if (our d_y1DC < our d_y2DC) { + rect.origin.y = our d_y1DC; + rect.size.height = our d_y2DC - our d_y1DC; + } else { + rect.origin.y = our d_y2DC; + rect.size.height = our d_y1DC - our d_y2DC; + } + //[view setNeedsDisplayInRect: rect]; + [view setNeedsDisplay: YES]; #endif } @@ -404,9 +394,9 @@ void Graphics_updateWs (Graphics me) { void Graphics_beginMovieFrame (Graphics any, MelderColour *p_colour) { if (any -> classInfo == classGraphicsScreen) { GraphicsScreen me = (GraphicsScreen) any; - Graphics_clearRecording (me); Graphics_startRecording (me); if (p_colour) { + Graphics_clearRecording (me); Graphics_setViewport (me, 0.0, 1.0, 0.0, 1.0); Graphics_setColour (me, *p_colour); Graphics_setWindow (me, 0.0, 1.0, 0.0, 1.0); @@ -420,12 +410,8 @@ void Graphics_endMovieFrame (Graphics any, double frameDuration) { if (any -> classInfo == classGraphicsScreen) { GraphicsScreen me = (GraphicsScreen) any; Graphics_stopRecording (me); - #if cairo || gdi - my v_flushWs (); - #elif quartz - my v_updateWs (); - GuiShell_drain (my d_drawingArea -> d_shell); - #endif + my v_updateWs (); + GuiShell_drain (my d_drawingArea -> d_shell); Melder_sleep (frameDuration); } } @@ -441,11 +427,10 @@ static int GraphicsScreen_init (GraphicsScreen me, void *voidDisplay, void *void trace (U"retrieving window"); my d_window = GDK_DRAWABLE (GTK_WIDGET (voidDisplay) -> window); trace (U"retrieved window"); - my d_gdkGraphicsContext = gdk_gc_new (my d_window); #else my d_window = gtk_widget_get_window (GTK_WIDGET (voidDisplay)); #endif - my d_cairoGraphicsContext = gdk_cairo_create (my d_window); + my d_cairoGraphicsContext = nullptr; // will be created and destroyed at expose time #elif gdi if (my printer) { my d_gdiGraphicsContext = (HDC) voidWindow; @@ -457,10 +442,10 @@ static int GraphicsScreen_init (GraphicsScreen me, void *voidDisplay, void *void my d_gdiGraphicsContext = GetDC (my d_winWindow); // window must have a constant display context; see XtInitialize () } Melder_assert (my d_gdiGraphicsContext); - SetBkMode (my d_gdiGraphicsContext, TRANSPARENT); // not the default! + SetBkMode (my d_gdiGraphicsContext, TRANSPARENT); // not the default! text should not be drawn against a white background /* - * Create pens and brushes. - */ + Create pens and brushes. + */ my d_winPen = CreatePen (PS_SOLID, 0, RGB (0, 0, 0)); my d_winBrush = CreateSolidBrush (RGB (0, 0, 0)); SelectBrush (my d_gdiGraphicsContext, GetStockBrush (NULL_BRUSH)); @@ -473,10 +458,18 @@ static int GraphicsScreen_init (GraphicsScreen me, void *voidDisplay, void *void //my d_macGraphicsContext = (CGContextRef) voidWindow; // in case we do context-based printing } else { my d_macView = (NSView *) voidWindow; - (void) my d_macGraphicsContext; // will be retrieved from Core Graphics with every drawing command! + my d_macGraphicsContext = nullptr; // will be retrieved and nullified at expose time } - my d_macColour = theBlackColour; - my d_depth = my resolution > 150 ? 1 : 8; /* BUG: replace by true depth (1=black/white) */ + /* + The following is what we would like to do. + However, if we do this outside of an expose event, d_macGraphicsContext will be null, + so we defer this to GraphicsQuartz_initDraw(). + (last checked 2020-07-26) + */ + //my d_macGraphicsContext = Melder_systemVersion < 101400 ? + // (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort] : + // [[NSGraphicsContext currentContext] CGContext]; + my d_depth = ( my resolution > 150 ? 1 : 8 ); // BUG: replace by true depth (1=black/white) _GraphicsScreen_text_init (me); #endif return 1; @@ -565,6 +558,9 @@ autoGraphics Graphics_create_xmdrawingarea (GuiDrawingArea w) { GraphicsScreen_init (me.get(), my d_drawingArea -> d_widget, my d_drawingArea -> d_widget); #endif + Melder_assert (w -> numberOfGraphicses < structGuiDrawingArea :: MAXIMUM_NUMBER_OF_GRAPHICSES); + w -> graphicses [++ w -> numberOfGraphicses] = me.get(); // refer back + #if cairo && gtk // fb: is really the request meant or rather the actual size, aka allocation? gtk_widget_size_request (GTK_WIDGET (my d_drawingArea -> d_widget), & realsize); @@ -576,7 +572,7 @@ autoGraphics Graphics_create_xmdrawingarea (GuiDrawingArea w) { XtVaGetValues (my d_drawingArea -> d_widget, XmNwidth, & width, XmNheight, & height, nullptr); Graphics_setWsViewport (me.get(), 0.0, width, 0.0, height); #elif quartz - NSView *view = (NSView *)my d_drawingArea -> d_widget; + NSView *view = (NSView *) my d_drawingArea -> d_widget; NSRect bounds = [view bounds]; Graphics_setWsViewport (me.get(), 0.0, bounds.size.width, 0.0, bounds.size.height); #endif @@ -610,8 +606,8 @@ autoGraphics Graphics_create_pngfile (MelderFile file, int resolution, my d_cairoGraphicsContext = cairo_create (my d_cairoSurface); //cairo_scale (my d_cairoGraphicsContext, 72.0 / resolution, 72.0 / resolution); /* - * Fill in the whole area with a white background. - */ + Fill in the whole area with a white background. + */ cairo_set_source_rgb (my d_cairoGraphicsContext, 1.0, 1.0, 1.0); cairo_rectangle (my d_cairoGraphicsContext, 0, 0, my d_x2DC, my d_y2DC); cairo_fill (my d_cairoGraphicsContext); @@ -634,8 +630,8 @@ autoGraphics Graphics_create_pngfile (MelderFile file, int resolution, my d_winBrush = CreateSolidBrush (RGB (0, 0, 0)); SetTextAlign (my d_gdiGraphicsContext, TA_LEFT | TA_BASELINE | TA_NOUPDATECP); /* - * Fill in the whole area with a white background. - */ + Fill in the whole area with a white background. + */ SelectPen (my d_gdiGraphicsContext, GetStockPen (NULL_PEN)); SelectBrush (my d_gdiGraphicsContext, GetStockBrush (WHITE_BRUSH)); Rectangle (my d_gdiGraphicsContext, 0, 0, my d_x2DC + 1, my d_y2DC + 1); // plus 1, in order to prevent two black edges @@ -693,7 +689,8 @@ autoGraphics Graphics_create_pdffile (MelderFile file, int resolution, my d_y2DC = my d_y2DCmax = ( isdefined (y1inches) ? 11.0 : y2inches ) * resolution; Graphics_setWsWindow (me.get(), isdefined (x1inches) ? 0.0 : 0.0, isdefined (x1inches) ? 7.5 : x2inches, - isdefined (y1inches) ? 1.0 : 0.0, isdefined (y1inches) ? 12.0 : y2inches); + isdefined (y1inches) ? 1.0 : 0.0, isdefined (y1inches) ? 12.0 : y2inches + ); cairo_scale (my d_cairoGraphicsContext, 72.0 / resolution, 72.0 / resolution); #elif quartz CFURLRef url = CFURLCreateWithFileSystemPath (nullptr, (CFStringRef) Melder_peek32toCfstring (file -> path), kCFURLPOSIXPathStyle, false); @@ -763,30 +760,19 @@ autoGraphics Graphics_create_pdf (void *context, int resolution, #endif #if quartz - void GraphicsQuartz_initDraw (GraphicsScreen me) { + void GraphicsQuartz_initDraw (Graphics me_generic) { + GraphicsScreen me = static_cast (me_generic); if (my d_macView) { - if (SUPPORT_DIRECT_DRAWING) - [my d_macView lockFocus]; - //if (! my printer) { my d_macGraphicsContext = Melder_systemVersion < 101400 ? (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort] : [[NSGraphicsContext currentContext] CGContext]; - //} - //Melder_assert (my d_macGraphicsContext); - //Melder_casual (U"GraphicsQuartz_initDraw: 1 ", Melder_pointer (my d_macGraphicsContext)); - //Melder_casual (U"GraphicsQuartz_initDraw: 2 ", Melder_pointer ([[NSGraphicsContext currentContext] graphicsPort])); - if (my printer) { - //CGContextTranslateCTM (my d_macGraphicsContext, 0, [my d_macView bounds]. size. height); - //CGContextScaleCTM (my d_macGraphicsContext, 1.0, -1.0); - } + Melder_assert (!! my d_macGraphicsContext); } } - void GraphicsQuartz_exitDraw (GraphicsScreen me) { - if (my d_macView) { - //CGContextSynchronize (my d_macGraphicsContext); // BUG: should not be needed - if (SUPPORT_DIRECT_DRAWING) - [my d_macView unlockFocus]; - } + void GraphicsQuartz_exitDraw (Graphics me_generic) { + GraphicsScreen me = static_cast (me_generic); + if (my d_macView) + my d_macGraphicsContext = nullptr; } #endif diff --git a/sys/Graphics_colour.cpp b/sys/Graphics_colour.cpp index ee82a408..1f2c2c66 100644 --- a/sys/Graphics_colour.cpp +++ b/sys/Graphics_colour.cpp @@ -1,6 +1,6 @@ /* Graphics_colour.cpp * - * Copyright (C) 1992-2005,2007-2019 Paul Boersma, 2013 Tom Naughton + * Copyright (C) 1992-2005,2007-2020 Paul Boersma, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -41,9 +41,6 @@ void _Graphics_setColour (Graphics graphics, MelderColour colour) { DeleteObject (my d_winBrush); my d_winBrush = CreateSolidBrush (my d_winForegroundColour); #elif quartz - my d_macColour. red = colour. red * 65535; - my d_macColour. green = colour. green * 65535; - my d_macColour. blue = colour. blue * 65535; // postpone till drawing #endif } else if (graphics -> postScript) { @@ -64,18 +61,15 @@ void Graphics_setColourScale (Graphics me, enum kGraphics_colourScale colourScal } void _Graphics_setGrey (Graphics graphics, double fgrey) { + Melder_clip (0.0, & fgrey, 1.0); if (graphics -> screen) { GraphicsScreen me = static_cast (graphics); #if cairo if (! my d_cairoGraphicsContext) return; - if (fgrey < 0.0) - fgrey = 0.0; - else if (fgrey > 1.0) - fgrey = 1.0; cairo_set_source_rgb (my d_cairoGraphicsContext, fgrey, fgrey, fgrey); #elif gdi - int lightness = ( fgrey <= 0.0 ? 0 : fgrey >= 1.0 ? 255 : fgrey * 255 ); + int lightness = fgrey * 255; my d_winForegroundColour = RGB (lightness, lightness, lightness); SelectPen (my d_gdiGraphicsContext, GetStockPen (BLACK_PEN)); DeleteObject (my d_winPen); @@ -84,18 +78,9 @@ void _Graphics_setGrey (Graphics graphics, double fgrey) { DeleteObject (my d_winBrush); my d_winBrush = CreateSolidBrush (my d_winForegroundColour); #elif quartz - if (fgrey < 0.0) - fgrey = 0.0; - else if (fgrey > 1.0) - fgrey = 1.0; - my d_macColour. red = my d_macColour. green = my d_macColour. blue = fgrey * 65535; #endif } else if (graphics -> postScript) { GraphicsPostscript me = static_cast (graphics); - if (fgrey < 0.0) - fgrey = 0.0; - else if (fgrey > 1.0) - fgrey = 1.0; my d_printf (my d_file, "%.6g setgray\n", fgrey); } } @@ -106,43 +91,20 @@ void Graphics_setGrey (Graphics me, double grey) { if (my recording) { op (SET_GREY, 1); put (grey); } } -#if quartz -static GuiDrawingArea_ExposeCallback saveExposeCallback; -static Thing saveExposeBoss; -static NSRect theRect; -static void highlightExposeCallback (Graphics me, GuiDrawingArea_ExposeEvent event) { - CGContextRef context = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; - Melder_assert (context); - CGContextSaveGState (context); - //CGContextSetBlendMode (context, kCGBlendModeDifference); - CGContextSetBlendMode (context, kCGBlendModeDarken); - CGContextSetShouldAntialias (context, false); - NSColor *colour = [[NSColor selectedTextBackgroundColor] colorUsingColorSpaceName: NSDeviceRGBColorSpace]; - double red = 0.5 + 0.5 * colour.redComponent, green = 0.5 + 0.5 * colour.greenComponent, blue = 0.5 + 0.5 * colour.blueComponent; - //CGContextSetRGBFillColor (context, 1.0 - red, 1.0 - green, 1.0 - blue, 1.0); - CGContextSetRGBFillColor (context, red, green, blue, 1.0); - CGContextFillRect (context, theRect); - CGContextRestoreGState (context); -} -#endif - -static void highlight (Graphics graphics, integer x1DC, integer x2DC, integer y1DC, integer y2DC, int direction) { +static void highlight (Graphics graphics, integer x1DC, integer x2DC, integer y1DC, integer y2DC) { if (graphics -> screen) { GraphicsScreen me = static_cast (graphics); #if cairo - if (! my d_cairoGraphicsContext) return; + if (! my d_cairoGraphicsContext) + return; int width = x2DC - x1DC, height = y1DC - y2DC; if (width <= 0 || height <= 0) return; - #if ALLOW_GDK_DRAWING - gdk_gc_set_function (my d_gdkGraphicsContext, GDK_XOR); - GdkColor pinkXorWhite = { 0, 0x0000, 0x4000, 0x4000 }, black = { 0, 0x0000, 0x0000, 0x0000 }; - gdk_gc_set_rgb_fg_color (my d_gdkGraphicsContext, & pinkXorWhite); - gdk_draw_rectangle (my d_window, my d_gdkGraphicsContext, true, x1DC, y2DC, width, height); - gdk_gc_set_rgb_fg_color (my d_gdkGraphicsContext, & black); - gdk_gc_set_function (my d_gdkGraphicsContext, GDK_COPY); - gdk_flush (); - #endif + if (! my d_cairoGraphicsContext) + return; + cairo_set_source_rgba (my d_cairoGraphicsContext, 1.0, 0.7, 0.7, 0.5); + cairo_rectangle (my d_cairoGraphicsContext, x1DC, y2DC, width, height); + cairo_fill (my d_cairoGraphicsContext); #elif gdi static HBRUSH highlightBrush; RECT rect; @@ -161,145 +123,53 @@ static void highlight (Graphics graphics, integer x1DC, integer x2DC, integer y1 if (width <= 0 || height <= 0) return; GuiCocoaDrawingArea *drawingArea = (GuiCocoaDrawingArea *) my d_drawingArea -> d_widget; - if (drawingArea) { - bool cacheImageInRectWillWork = ( Melder_systemVersion < 101100 || Melder_systemVersion > 101106 ); - if (cacheImageInRectWillWork) { - NSView *nsView = my d_macView; - if (direction == 1) { // forward - NSRect rect = NSMakeRect (x1DC, y2DC, width, height); - NSRect windowRect = [nsView convertRect: rect toView: nil]; - //NSRect windowRect = [nsView convertRectToBacking: rect]; - //NSRect windowRect = [nsView backingAlignedRect: rect options: NSAlignAllEdgesNearest]; - //windowRect.origin.x += 1; - //windowRect.size.width -= 2; - [[nsView window] cacheImageInRect: windowRect]; - if (SUPPORT_DIRECT_DRAWING) { - [drawingArea lockFocus]; - CGContextRef context = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; - if (context) { - CGContextSaveGState (context); - //CGContextSetBlendMode (context, kCGBlendModeDifference); - CGContextSetBlendMode (context, kCGBlendModeDarken); - CGContextSetShouldAntialias (context, false); - NSColor *colour = [[NSColor selectedTextBackgroundColor] colorUsingColorSpaceName: NSDeviceRGBColorSpace]; - double red = 0.5 + 0.5 * colour.redComponent, green = 0.5 + 0.5 * colour.greenComponent, blue = 0.5 + 0.5 * colour.blueComponent; - //CGContextSetRGBFillColor (context, 1.0 - red, 1.0 - green, 1.0 - blue, 1.0); - CGContextSetRGBFillColor (context, red, green, blue, 1.0); - CGContextFillRect (context, rect); - CGContextRestoreGState (context); - } - [drawingArea unlockFocus]; - //GuiShell_drain (nullptr); - } else { - CGContextRef context = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; - if (context) { - CGContextSaveGState (context); - //CGContextSetBlendMode (context, kCGBlendModeDifference); - CGContextSetBlendMode (context, kCGBlendModeDarken); - CGContextSetShouldAntialias (context, false); - NSColor *colour = [[NSColor selectedTextBackgroundColor] colorUsingColorSpaceName: NSDeviceRGBColorSpace]; - double red = 0.5 + 0.5 * colour.redComponent, green = 0.5 + 0.5 * colour.greenComponent, blue = 0.5 + 0.5 * colour.blueComponent; - //CGContextSetRGBFillColor (context, 1.0 - red, 1.0 - green, 1.0 - blue, 1.0); - CGContextSetRGBFillColor (context, red, green, blue, 1.0); - CGContextFillRect (context, rect); - CGContextRestoreGState (context); - } else { - theRect = rect; - saveExposeCallback = my d_drawingArea -> d_exposeCallback; - saveExposeBoss = my d_drawingArea -> d_exposeBoss; - //[drawingArea displayRect: rect]; - GuiDrawingArea_setExposeCallback (my d_drawingArea, highlightExposeCallback, graphics); - [drawingArea display]; - GuiDrawingArea_setExposeCallback (my d_drawingArea, saveExposeCallback, saveExposeBoss); - //[drawingArea setNeedsDisplayInRect: rect]; - Graphics_updateWs (graphics); - } - } - } else { // backward - //[drawingArea lockFocus]; - [[nsView window] restoreCachedImage]; - if (! SUPPORT_DIRECT_DRAWING) { - //CGContextFlush ((CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]); - //[[nsView window] flushWindow]; - } - //[[nsView window] discardCachedImage]; - //[drawingArea unlockFocus]; - //[[nsView window] flushWindow]; - //[[nsView window] flushWindowIfNeeded]; - } - } else { - if (SUPPORT_DIRECT_DRAWING) { - [drawingArea lockFocus]; - CGContextRef context = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; - CGContextSaveGState (context); - NSCAssert (context, @"nil context"); - //CGContextTranslateCTM (context, 0, drawingArea. bounds. size. height); - //CGContextScaleCTM (context, 1.0, -1.0); - NSRect rect = NSMakeRect (x1DC, y2DC, width, height); - CGContextSetBlendMode (context, kCGBlendModeDifference); - CGContextSetShouldAntialias (context, false); - NSColor *colour = [[NSColor selectedTextBackgroundColor] colorUsingColorSpaceName: NSCalibratedRGBColorSpace]; - double red = 0.5 + 0.5 * colour.redComponent, green = 0.5 + 0.5 * colour.greenComponent, blue = 0.5 + 0.5 * colour.blueComponent; - if (direction == 1) { // forward - CGContextSetRGBFillColor (context, 1.0 - red, 1.0 - green, 1.0 - blue, 1.0); - CGContextFillRect (context, rect); - } else { // backward - CGContextSetRGBFillColor (context, red, green, blue, 1.0); - CGContextFillRect (context, rect); - CGContextSetRGBFillColor (context, 1.0, 1.0, 1.0, 1.0); - CGContextFillRect (context, rect); - } - CGContextRestoreGState (context); - //CGContextSynchronize (context); - [drawingArea unlockFocus]; - } else { - } - } + if (! drawingArea) + return; + NSRect rect = NSMakeRect (x1DC, y2DC, width, height); + CGContextRef context = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; + if (context) { + CGContextSaveGState (context); + CGContextSetBlendMode (context, kCGBlendModeDarken); + CGContextSetShouldAntialias (context, false); + CGContextSetRGBFillColor (context, 1.0, 0.83, 0.83, 1.0); + CGContextFillRect (context, rect); + CGContextRestoreGState (context); } #endif } } void Graphics_highlight (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC) { - highlight (me, wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), 1); - if (my recording) - { op (HIGHLIGHT, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); } -} - -void Graphics_unhighlight (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC) { - highlight (me, wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), 2); - if (my recording) - { op (UNHIGHLIGHT, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); } + if (my recording) { + op (HIGHLIGHT, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); + } else + highlight (me, wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC)); } static void highlight2 (Graphics graphics, integer x1DC, integer x2DC, integer y1DC, integer y2DC, - integer x1DC_inner, integer x2DC_inner, integer y1DC_inner, integer y2DC_inner, int direction) + integer x1DC_inner, integer x2DC_inner, integer y1DC_inner, integer y2DC_inner) { if (graphics -> screen) { GraphicsScreen me = static_cast (graphics); #if cairo - if (! my d_cairoGraphicsContext) return; + if (! my d_cairoGraphicsContext) + return; int width = x2DC - x1DC, height = y1DC - y2DC; - if (width <= 0 || height <= 0) return; - #if ALLOW_GDK_DRAWING - gdk_gc_set_function (my d_gdkGraphicsContext, GDK_XOR); - GdkColor pinkXorWhite = { 0, 0x0000, 0x4000, 0x4000 }, black = { 0, 0x0000, 0x0000, 0x0000 }; - gdk_gc_set_rgb_fg_color (my d_gdkGraphicsContext, & pinkXorWhite); - gdk_draw_rectangle (my d_window, my d_gdkGraphicsContext, true, x1DC, y2DC, x2DC - x1DC, y2DC_inner - y2DC); // upper - gdk_draw_rectangle (my d_window, my d_gdkGraphicsContext, true, x1DC, y2DC_inner, x1DC_inner - x1DC, y1DC_inner - y2DC_inner); // left part - gdk_draw_rectangle (my d_window, my d_gdkGraphicsContext, true, x2DC_inner, y2DC_inner, x2DC - x2DC_inner, y1DC_inner - y2DC_inner); // right part - gdk_draw_rectangle (my d_window, my d_gdkGraphicsContext, true, x1DC, y1DC_inner, x2DC - x1DC, y1DC - y1DC_inner); // lower - gdk_gc_set_rgb_fg_color (my d_gdkGraphicsContext, & black); - gdk_gc_set_function (my d_gdkGraphicsContext, GDK_COPY); - gdk_flush (); - #endif + if (width <= 0 || height <= 0) + return; + cairo_set_source_rgba (my d_cairoGraphicsContext, 1.0, 0.7, 0.7, 0.5); + cairo_rectangle (my d_cairoGraphicsContext, x1DC, y2DC, x2DC - x1DC, y2DC_inner - y2DC); // upper + cairo_rectangle (my d_cairoGraphicsContext, x1DC, y2DC_inner, x1DC_inner - x1DC, y1DC_inner - y2DC_inner); // left part + cairo_rectangle (my d_cairoGraphicsContext, x2DC_inner, y2DC_inner, x2DC - x2DC_inner, y1DC_inner - y2DC_inner); // right part + cairo_rectangle (my d_cairoGraphicsContext, x1DC, y1DC_inner, x2DC - x1DC, y1DC - y1DC_inner); // lower + cairo_fill (my d_cairoGraphicsContext); #elif gdi static HBRUSH highlightBrush; if (! highlightBrush) highlightBrush = CreateSolidBrush (RGB (255, 210, 210)); SelectPen (my d_gdiGraphicsContext, GetStockPen (NULL_PEN)); SelectBrush (my d_gdiGraphicsContext, highlightBrush); - SetROP2 (my d_gdiGraphicsContext, R2_NOTXORPEN); + SetROP2 (my d_gdiGraphicsContext, R2_MASKPEN); Rectangle (my d_gdiGraphicsContext, x1DC, y2DC, x2DC + 1, y2DC_inner + 1); Rectangle (my d_gdiGraphicsContext, x1DC, y2DC_inner, x1DC_inner + 1, y1DC_inner + 1); Rectangle (my d_gdiGraphicsContext, x2DC_inner, y2DC_inner, x2DC + 1, y1DC_inner + 1); @@ -309,81 +179,23 @@ static void highlight2 (Graphics graphics, integer x1DC, integer x2DC, integer y SelectBrush (my d_gdiGraphicsContext, GetStockBrush (NULL_BRUSH)); // superfluous? #elif quartz GuiCocoaDrawingArea *drawingArea = (GuiCocoaDrawingArea *) my d_drawingArea -> d_widget; - if (drawingArea) { - bool cacheImageInRectWillWork = ( Melder_systemVersion < 101100 || Melder_systemVersion > 101106 ); - if (cacheImageInRectWillWork) { - NSView *nsView = my d_macView; - if (direction == 1) { - NSRect rect = Melder_systemVersion < 101100 &&0 ? - NSMakeRect (x1DC, y2DC, - x2DC - x1DC /*[nsView visibleRect].size.width*/, - y1DC - y2DC /*[nsView visibleRect].size.height*/) : - [nsView visibleRect]; - NSRect windowRect = [nsView convertRect: rect toView: nil]; - Melder_assert ([nsView window] != nil); - [[nsView window] cacheImageInRect: windowRect]; - } else { - [[nsView window] restoreCachedImage]; - //[[nsView window] flushWindow]; - return; - } - } - if (SUPPORT_DIRECT_DRAWING) { - [drawingArea lockFocus]; - my d_macGraphicsContext = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; - CGContextSaveGState (my d_macGraphicsContext); - NSRect upperRect = NSMakeRect (x1DC, y2DC, x2DC - x1DC, y2DC_inner - y2DC); - NSRect leftRect = NSMakeRect (x1DC, y2DC_inner, x1DC_inner - x1DC, y1DC_inner - y2DC_inner); - NSRect rightRect = NSMakeRect (x2DC_inner, y2DC_inner, x2DC - x2DC_inner, y1DC_inner - y2DC_inner); - NSRect lowerRect = NSMakeRect (x1DC, y1DC_inner, x2DC - x1DC, y1DC - y1DC_inner); - NSColor *colour = [[NSColor selectedTextBackgroundColor] colorUsingColorSpaceName: NSCalibratedRGBColorSpace]; - double red = 0.5 + 0.5 * colour.redComponent, green = 0.5 + 0.5 * colour.greenComponent, blue = 0.5 + 0.5 * colour.blueComponent; - if (cacheImageInRectWillWork) { - CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeDarken); - CGContextSetRGBFillColor (my d_macGraphicsContext, red, green, blue, 1.0); - CGContextFillRect (my d_macGraphicsContext, upperRect); - CGContextFillRect (my d_macGraphicsContext, leftRect); - CGContextFillRect (my d_macGraphicsContext, rightRect); - CGContextFillRect (my d_macGraphicsContext, lowerRect); - } else if (1) { - /* - An older, suboptimal method. - */ - CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeDifference); - if (direction == 1) { - CGContextSetRGBFillColor (my d_macGraphicsContext, 1.0 - red, 1.0 - green, 1.0 - blue, 1.0); - CGContextFillRect (my d_macGraphicsContext, upperRect); - CGContextFillRect (my d_macGraphicsContext, leftRect); - CGContextFillRect (my d_macGraphicsContext, rightRect); - CGContextFillRect (my d_macGraphicsContext, lowerRect); - } else { - CGContextSetRGBFillColor (my d_macGraphicsContext, red, green, blue, 1.0); - CGContextFillRect (my d_macGraphicsContext, upperRect); - CGContextFillRect (my d_macGraphicsContext, leftRect); - CGContextFillRect (my d_macGraphicsContext, rightRect); - CGContextFillRect (my d_macGraphicsContext, lowerRect); - CGContextSetRGBFillColor (my d_macGraphicsContext, 1.0, 1.0, 1.0, 1.0); - CGContextFillRect (my d_macGraphicsContext, upperRect); - CGContextFillRect (my d_macGraphicsContext, leftRect); - CGContextFillRect (my d_macGraphicsContext, rightRect); - CGContextFillRect (my d_macGraphicsContext, lowerRect); - } - } else if (1) { - /* - This is true XOR. - */ - CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeDifference); - CGContextSetRGBFillColor (my d_macGraphicsContext, 1.0, 1.0, 1.0, 1.0); - CGContextFillRect (my d_macGraphicsContext, upperRect); - CGContextFillRect (my d_macGraphicsContext, leftRect); - CGContextFillRect (my d_macGraphicsContext, rightRect); - CGContextFillRect (my d_macGraphicsContext, lowerRect); - } - CGContextRestoreGState (my d_macGraphicsContext); - [drawingArea unlockFocus]; - } else { - } - } + if (! drawingArea) + return; + my d_macGraphicsContext = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; + CGContextSaveGState (my d_macGraphicsContext); + NSRect upperRect = NSMakeRect (x1DC, y2DC, x2DC - x1DC, y2DC_inner - y2DC); + NSRect leftRect = NSMakeRect (x1DC, y2DC_inner, x1DC_inner - x1DC, y1DC_inner - y2DC_inner); + NSRect rightRect = NSMakeRect (x2DC_inner, y2DC_inner, x2DC - x2DC_inner, y1DC_inner - y2DC_inner); + NSRect lowerRect = NSMakeRect (x1DC, y1DC_inner, x2DC - x1DC, y1DC - y1DC_inner); + NSColor *colour = [[NSColor selectedTextBackgroundColor] colorUsingColorSpaceName: NSCalibratedRGBColorSpace]; + double red = 0.5 + 0.5 * colour.redComponent, green = 0.5 + 0.5 * colour.greenComponent, blue = 0.5 + 0.5 * colour.blueComponent; + CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeDarken); + CGContextSetRGBFillColor (my d_macGraphicsContext, 1.0, 0.83, 0.83, 1.0); + CGContextFillRect (my d_macGraphicsContext, upperRect); + CGContextFillRect (my d_macGraphicsContext, leftRect); + CGContextFillRect (my d_macGraphicsContext, rightRect); + CGContextFillRect (my d_macGraphicsContext, lowerRect); + CGContextRestoreGState (my d_macGraphicsContext); #endif } } @@ -391,69 +203,55 @@ static void highlight2 (Graphics graphics, integer x1DC, integer x2DC, integer y void Graphics_highlight2 (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC, double x1WC_inner, double x2WC_inner, double y1WC_inner, double y2WC_inner) { - highlight2 (me, wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), wdx (x1WC_inner), wdx (x2WC_inner), wdy (y1WC_inner), wdy (y2WC_inner), 1); - if (my recording) - { op (HIGHLIGHT2, 8); put (x1WC); put (x2WC); put (y1WC); put (y2WC); put (x1WC_inner); put (x2WC_inner); put (y1WC_inner); put (y2WC_inner); } + if (my recording) { + op (HIGHLIGHT2, 8); + put (x1WC); put (x2WC); put (y1WC); put (y2WC); + put (x1WC_inner); put (x2WC_inner); put (y1WC_inner); put (y2WC_inner); + } else + highlight2 (me, wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), wdx (x1WC_inner), wdx (x2WC_inner), wdy (y1WC_inner), wdy (y2WC_inner)); } -void Graphics_unhighlight2 (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC, - double x1WC_inner, double x2WC_inner, double y1WC_inner, double y2WC_inner) -{ - highlight2 (me, wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), wdx (x1WC_inner), wdx (x2WC_inner), wdy (y1WC_inner), wdy (y2WC_inner), 2); - if (my recording) - { op (UNHIGHLIGHT2, 8); put (x1WC); put (x2WC); put (y1WC); put (y2WC); put (x1WC_inner); put (x2WC_inner); put (y1WC_inner); put (y2WC_inner); } -} - -void Graphics_xorOn (Graphics graphics, MelderColour colour) { +void Graphics_xorOn (Graphics graphics, MelderColour colourOnWhiteBackground) { if (graphics -> screen) { GraphicsScreen me = static_cast (graphics); - #if cairo - #if ALLOW_GDK_DRAWING - GdkColor colourXorWhite { 0, - (uint16) ((uint16) (colour. red * 65535.0) ^ (uint16) 0xFFFF), - (uint16) ((uint16) (colour. green * 65535.0) ^ (uint16) 0xFFFF), - (uint16) ((uint16) (colour. blue * 65535.0) ^ (uint16) 0xFFFF) }; - gdk_gc_set_rgb_fg_color (my d_gdkGraphicsContext, & colourXorWhite); - gdk_gc_set_function (my d_gdkGraphicsContext, GDK_XOR); - gdk_flush (); - #else - cairo_set_source_rgba (my d_cairoGraphicsContext, 1.0, 0.8, 0.8, 0.5); - cairo_set_operator (my d_cairoGraphicsContext, CAIRO_OPERATOR_XOR); + if (graphics -> recording) { + op (XOR_ON, 3); + put (colourOnWhiteBackground. red); + put (colourOnWhiteBackground. green); + put (colourOnWhiteBackground. blue); + } else { + my colour. red = 1.0 - colourOnWhiteBackground. red; + my colour. green = 1.0 - colourOnWhiteBackground. green; + my colour. blue = 1.0 - colourOnWhiteBackground. blue; + #if cairo + cairo_set_operator (my d_cairoGraphicsContext, CAIRO_OPERATOR_DIFFERENCE); + #elif gdi + SetROP2 (my d_gdiGraphicsContext, R2_XORPEN); + #elif quartz + CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeDifference); #endif - #elif gdi - SetROP2 (my d_gdiGraphicsContext, R2_XORPEN); - colour. red = ((uint16) (colour. red * 65535.0) ^ 0xFFFF) / 65535.0; - colour. green = ((uint16) (colour. green * 65535.0) ^ 0xFFFF) / 65535.0; - colour. blue = ((uint16) (colour. blue * 65535.0) ^ 0xFFFF) / 65535.0; - _Graphics_setColour (me, colour); - #elif quartz - #endif - my duringXor = true; - if (graphics -> recording) { op (XOR_ON, 3); put (colour. red); put (colour. green); put (colour. blue); } + _Graphics_setColour (me, my colour); + my duringXor = true; + } } } void Graphics_xorOff (Graphics graphics) { if (graphics -> screen) { GraphicsScreen me = static_cast (graphics); - #if cairo - #if ALLOW_GDK_DRAWING - GdkColor black { 0, 0x0000, 0x0000, 0x0000 }; - gdk_gc_set_rgb_fg_color (my d_gdkGraphicsContext, & black); - gdk_gc_set_function (my d_gdkGraphicsContext, GDK_COPY); - gdk_flush (); // to undraw the last drawing - #else - cairo_set_source_rgba (my d_cairoGraphicsContext, 0.0, 0.0, 0.0, 1.0); + if (graphics -> recording) { + op (XOR_OFF, 0); + } else { + #if cairo cairo_set_operator (my d_cairoGraphicsContext, CAIRO_OPERATOR_OVER); + #elif gdi + SetROP2 (my d_gdiGraphicsContext, R2_COPYPEN); + #elif quartz + CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeNormal); #endif - #elif gdi - SetROP2 (my d_gdiGraphicsContext, R2_COPYPEN); _Graphics_setColour (me, my colour); - #elif quartz - //Graphics_flushWs (graphics); // to undraw the last drawing - #endif - my duringXor = false; - if (graphics -> recording) { op (XOR_OFF, 0); } + my duringXor = false; + } } } diff --git a/sys/Graphics_image.cpp b/sys/Graphics_image.cpp index 87fdbf3c..7130b0f4 100644 --- a/sys/Graphics_image.cpp +++ b/sys/Graphics_image.cpp @@ -80,7 +80,6 @@ static void _GraphicsScreen_cellArrayOrImage (GraphicsScreen me, for (int igrey = 0; igrey <= 255; igrey ++) greyBrush [igrey] = CreateSolidBrush (RGB (igrey, igrey, igrey)); // once #elif quartz - GraphicsQuartz_initDraw (me); CGContextSetAlpha (my d_macGraphicsContext, 1.0); CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeNormal); #endif @@ -145,7 +144,6 @@ static void _GraphicsScreen_cellArrayOrImage (GraphicsScreen me, cairo_pattern_destroy (grey [igrey]); #elif quartz CGContextSetRGBFillColor (my d_macGraphicsContext, 0.0, 0.0, 0.0, 1.0); - GraphicsQuartz_exitDraw (me); #endif } catch (MelderError) { } } else { @@ -439,9 +437,7 @@ static void _GraphicsScreen_cellArrayOrImage (GraphicsScreen me, // release bitmap? } Melder_assert (image != nullptr); - GraphicsQuartz_initDraw (me); CGContextDrawImage (my d_macGraphicsContext, CGRectMake (clipx1, clipy2, clipx2 - clipx1, clipy1 - clipy2), image); - GraphicsQuartz_exitDraw (me); //CGColorSpaceRelease (colourSpace); CGImageRelease (image); #endif @@ -664,10 +660,8 @@ static void _cellArrayOrImage (Graphics me, void Graphics_cellArray (Graphics me, constMATVU const& z, double x1WC, double x2WC, double y1WC, double y2WC, double minimum, double maximum) { - if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) return; - _cellArrayOrImage (me, z, constmatrixview(), constmatrixview(), - 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, - wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), false); + if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) + return; if (my recording) { op (CELL_ARRAY, 8 + z.nrow * z.ncol); put (x1WC); put (x2WC); put (y1WC); put (y2WC); @@ -676,16 +670,18 @@ void Graphics_cellArray (Graphics me, constMATVU const& z, for (integer irow = 1; irow <= z.nrow; irow ++) for (integer icol = 1; icol <= z.ncol; icol ++) put (z [irow] [icol]); - } + } else + _cellArrayOrImage (me, z, constmatrixview(), constmatrixview(), + 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, + wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), false + ); } void Graphics_cellArray_colour (Graphics me, constmatrixview const& z, double x1WC, double x2WC, double y1WC, double y2WC, double minimum, double maximum) { - if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) return; - _cellArrayOrImage (me, constMATVU(), z, constmatrixview(), - 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, - wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), false); + if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) + return; if (my recording) { op (CELL_ARRAY_COLOUR, 8 + z.nrow * z.ncol * 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); @@ -700,16 +696,18 @@ void Graphics_cellArray_colour (Graphics me, constmatrixview cons put (row [icol]. transparency); } } - } + } else + _cellArrayOrImage (me, constMATVU(), z, constmatrixview(), + 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, + wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), false + ); } void Graphics_cellArray8 (Graphics me, constmatrixview const& z, double x1WC, double x2WC, double y1WC, double y2WC, unsigned char minimum, unsigned char maximum) { - if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) return; - _cellArrayOrImage (me, constMATVU(), constmatrixview(), z, - 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, - wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), false); + if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) + return; if (my recording) { op (CELL_ARRAY8, 8 + z.nrow * z.ncol); put (x1WC); put (x2WC); put (y1WC); put (y2WC); @@ -718,16 +716,18 @@ void Graphics_cellArray8 (Graphics me, constmatrixview const& z, for (integer irow = 1; irow <= z.nrow; irow ++) for (integer icol = 1; icol <= z.ncol; icol ++) put (z [irow] [icol]); - } + } else + _cellArrayOrImage (me, constMATVU(), constmatrixview(), z, + 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, + wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), false + ); } void Graphics_image (Graphics me, constMATVU const& z, double x1WC, double x2WC, double y1WC, double y2WC, double minimum, double maximum) { - if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) return; - _cellArrayOrImage (me, z, constmatrixview(), constmatrixview(), - 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, - wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), true); + if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) + return; if (my recording) { op (IMAGE, 8 + z.nrow * z.ncol); put (x1WC); put (x2WC); put (y1WC); put (y2WC); @@ -736,16 +736,18 @@ void Graphics_image (Graphics me, constMATVU const& z, for (integer irow = 1; irow <= z.nrow; irow ++) for (integer icol = 1; icol <= z.ncol; icol ++) put (z [irow] [icol]); - } + } else + _cellArrayOrImage (me, z, constmatrixview(), constmatrixview(), + 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, + wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), true + ); } void Graphics_image_colour (Graphics me, constmatrixview const& z, double x1WC, double x2WC, double y1WC, double y2WC, double minimum, double maximum) { - if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) return; - _cellArrayOrImage (me, constMATVU(), z, constmatrixview(), - 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, - wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), true); + if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) + return; if (my recording) { op (IMAGE_COLOUR, 8 + z.nrow * z.ncol * 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); @@ -760,16 +762,18 @@ void Graphics_image_colour (Graphics me, constmatrixview const& z put (row [icol]. transparency); } } - } + } else + _cellArrayOrImage (me, constMATVU(), z, constmatrixview(), + 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, + wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), true + ); } void Graphics_image8 (Graphics me, constmatrixview const& z, double x1WC, double x2WC, double y1WC, double y2WC, uint8 minimum, uint8 maximum) { - if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) return; - _cellArrayOrImage (me, constMATVU(), constmatrixview(), z, - 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, - wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), true); + if (z.nrow < 1 || z.ncol < 1 || minimum == maximum) + return; if (my recording) { op (IMAGE8, 8 + z.nrow * z.ncol); put (x1WC); put (x2WC); put (y1WC); put (y2WC); @@ -778,7 +782,11 @@ void Graphics_image8 (Graphics me, constmatrixview const& z, for (integer irow = 1; irow <= z.nrow; irow ++) for (integer icol = 1; icol <= z.ncol; icol ++) put (z [irow] [icol]); - } + } else + _cellArrayOrImage (me, constMATVU(), constmatrixview(), z, + 1, z.ncol, wdx (x1WC), wdx (x2WC), 1, z.nrow, wdy (y1WC), wdy (y2WC), minimum, maximum, + wdx (my d_x1WC), wdx (my d_x2WC), wdy (my d_y1WC), wdy (my d_y2WC), true + ); } static void _GraphicsScreen_imageFromFile (GraphicsScreen me, conststring32 relativeFileName, double x1, double x2, double y1, double y2) { @@ -859,16 +867,14 @@ static void _GraphicsScreen_imageFromFile (GraphicsScreen me, conststring32 rela height = width * (double) CGImageGetHeight (image) / (double) CGImageGetWidth (image); y2DC -= height / 2, y1DC = y2DC + height; } - GraphicsQuartz_initDraw (me); CGContextSaveGState (my d_macGraphicsContext); - NSCAssert(my d_macGraphicsContext, @"nil context"); + //NSCAssert(my d_macGraphicsContext, @"nil context"); CGContextTranslateCTM (my d_macGraphicsContext, 0, y1DC); CGContextScaleCTM (my d_macGraphicsContext, 1.0, -1.0); CGContextDrawImage (my d_macGraphicsContext, CGRectMake (x1DC, 0, width, height), image); CGContextRestoreGState (my d_macGraphicsContext); - GraphicsQuartz_exitDraw (me); CGImageRelease (image); } } diff --git a/sys/Graphics_linesAndAreas.cpp b/sys/Graphics_linesAndAreas.cpp index 9ed26f7c..552a964e 100644 --- a/sys/Graphics_linesAndAreas.cpp +++ b/sys/Graphics_linesAndAreas.cpp @@ -1,6 +1,6 @@ /* Graphics_linesAndAreas.cpp * - * Copyright (C) 1992-2005,2007-2019 Paul Boersma, 2013 Tom Naughton + * Copyright (C) 1992-2005,2007-2020 Paul Boersma, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -46,17 +46,6 @@ static void psRevertLine (GraphicsPostscript me) { } #if cairo - #if ALLOW_GDK_DRAWING - static void gdkPrepareLine (GraphicsScreen me) { - gdk_gc_set_line_attributes (my d_gdkGraphicsContext, my lineWidth, - my lineType >= Graphics_DOTTED ? GDK_LINE_ON_OFF_DASH : GDK_LINE_SOLID, GDK_CAP_ROUND, GDK_JOIN_ROUND); - } - static void gdkRevertLine (GraphicsScreen me) { - if (my lineType >= Graphics_DOTTED) { - gdk_gc_set_line_attributes (my d_gdkGraphicsContext, my lineWidth, GDK_LINE_SOLID, GDK_CAP_ROUND, GDK_JOIN_ROUND); - } - } - #endif static void cairoPrepareLine (GraphicsScreen me) { if (! my d_cairoGraphicsContext) return; double dotted_line [] { 2.0, 2.0 }; @@ -77,10 +66,10 @@ static void psRevertLine (GraphicsPostscript me) { cairo_set_line_width (my d_cairoGraphicsContext, my lineWidth); } static void cairoRevertLine (GraphicsScreen me) { - if (! my d_cairoGraphicsContext) return; - if (my lineType >= Graphics_DOTTED) { + if (! my d_cairoGraphicsContext) + return; + if (my lineType >= Graphics_DOTTED) cairo_set_dash (my d_cairoGraphicsContext, nullptr, 0, 0); - } cairo_restore (my d_cairoGraphicsContext); } #elif gdi @@ -88,8 +77,7 @@ static void psRevertLine (GraphicsPostscript me) { #define DEFAULT SelectPen (d_gdiGraphicsContext, GetStockPen (BLACK_PEN)), SelectBrush (d_gdiGraphicsContext, GetStockBrush (NULL_BRUSH)); static void winPrepareLine (GraphicsScreen me) { HPEN newPen; - int lineWidth_pixels = LINE_WIDTH_IN_PIXELS (me) + 0.5; - if (! lineWidth_pixels) lineWidth_pixels = 1; + const int lineWidth_pixels = Melder_clippedLeft (1, int (LINE_WIDTH_IN_PIXELS (me) + 0.5)); my d_fatNonSolid = my lineType != Graphics_DRAWN && lineWidth_pixels > 1; if (Melder_debug == 10) { LOGBRUSH brush; @@ -120,13 +108,7 @@ static void psRevertLine (GraphicsPostscript me) { #elif quartz static void quartzPrepareLine (GraphicsScreen me) { CGContextSetLineJoin (my d_macGraphicsContext, kCGLineJoinBevel); // much faster than kCGLineJoinRound - if (my duringXor) { - CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeDifference); - CGContextSetAllowsAntialiasing (my d_macGraphicsContext, false); - CGContextSetRGBStrokeColor (my d_macGraphicsContext, 1.0, 1.0, 1.0, 1.0); - } else { - CGContextSetRGBStrokeColor (my d_macGraphicsContext, my d_macColour.red / 65536.0, my d_macColour.green / 65536.0, my d_macColour.blue / 65536.0, 1.0); - } + CGContextSetRGBStrokeColor (my d_macGraphicsContext, my colour.red, my colour.green, my colour.blue, 1.0); double lineWidth_pixels = LINE_WIDTH_IN_PIXELS (me); CGContextSetLineWidth (my d_macGraphicsContext, lineWidth_pixels); @@ -147,15 +129,10 @@ static void psRevertLine (GraphicsPostscript me) { my lineType == 0 ? 0 : my lineType == Graphics_DASHED_DOTTED ? 4 : 2); } static void quartzRevertLine (GraphicsScreen me) { - if (my duringXor) { - CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeNormal); - CGContextSetAllowsAntialiasing (my d_macGraphicsContext, true); - } } static void quartzPrepareFill (GraphicsScreen me) { CGContextSetAlpha (my d_macGraphicsContext, 1.0); - CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeNormal); - CGContextSetRGBFillColor (my d_macGraphicsContext, my d_macColour.red / 65536.0, my d_macColour.green / 65536.0, my d_macColour.blue / 65536.0, 1.0); + CGContextSetRGBFillColor (my d_macGraphicsContext, my colour.red, my colour.green, my colour.blue, 1.0); } #endif @@ -163,28 +140,17 @@ static void psRevertLine (GraphicsPostscript me) { void structGraphicsScreen :: v_polyline (integer numberOfPoints, double *xyDC, bool close) { #if cairo - if (duringXor) { - #if ALLOW_GDK_DRAWING - gdkPrepareLine (this); - for (integer i = 0; i < numberOfPoints - 1; i ++) { - gdk_draw_line (our d_window, our d_gdkGraphicsContext, - xyDC [i + i], xyDC [i + i + 1], xyDC [i + i + 2], xyDC [i + i + 3]); - } - gdkRevertLine (this); - gdk_flush (); - #endif - } else { - if (our d_cairoGraphicsContext == nullptr) return; - cairoPrepareLine (this); - // cairo_new_path (d_cairoGraphicsContext); // move_to() automatically creates a new path - cairo_move_to (our d_cairoGraphicsContext, xyDC [0], xyDC [1]); - for (integer i = 1; i < numberOfPoints; i ++) { - cairo_line_to (our d_cairoGraphicsContext, xyDC [i + i], xyDC [i + i + 1]); - } - if (close) cairo_close_path (our d_cairoGraphicsContext); - cairo_stroke (our d_cairoGraphicsContext); - cairoRevertLine (this); - } + if (our d_cairoGraphicsContext == nullptr) + return; + cairoPrepareLine (this); + // cairo_new_path (d_cairoGraphicsContext); // move_to() automatically creates a new path + cairo_move_to (our d_cairoGraphicsContext, xyDC [0], xyDC [1]); + for (integer i = 1; i < numberOfPoints; i ++) + cairo_line_to (our d_cairoGraphicsContext, xyDC [i + i], xyDC [i + i + 1]); + if (close) + cairo_close_path (our d_cairoGraphicsContext); + cairo_stroke (our d_cairoGraphicsContext); + cairoRevertLine (this); #elif gdi if (our d_useGdiplus && 0) { Gdiplus::Graphics dcplus (our d_gdiGraphicsContext); @@ -245,28 +211,25 @@ void structGraphicsScreen :: v_polyline (integer numberOfPoints, double *xyDC, b DEFAULT } #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareLine (this); CGContextBeginPath (our d_macGraphicsContext); trace (U"starting point ", xyDC [0], U" ", xyDC [1]); CGContextMoveToPoint (our d_macGraphicsContext, xyDC [0], xyDC [1]); // starts a new subpath - for (integer i = 1; i < numberOfPoints; i ++) { + for (integer i = 1; i < numberOfPoints; i ++) CGContextAddLineToPoint (our d_macGraphicsContext, xyDC [i + i], xyDC [i + i + 1]); - } if (close) CGContextClosePath (our d_macGraphicsContext); // closes only the subpath CGContextStrokePath (our d_macGraphicsContext); quartzRevertLine (this); - GraphicsQuartz_exitDraw (this); #endif } void structGraphicsPostscript :: v_polyline (integer numberOfPoints, double *xyDC, bool close) { - integer nn = 2 * numberOfPoints; + const integer nn = 2 * numberOfPoints; psPrepareLine (this); our d_printf (our d_file, "N %.7g %.7g moveto\n", xyDC [0], xyDC [1]); for (integer i = 2; i < nn; i += 2) { - double dx = xyDC [i] - xyDC [i - 2], dy = xyDC [i + 1] - xyDC [i - 1]; + const double dx = xyDC [i] - xyDC [i - 2], dy = xyDC [i + 1] - xyDC [i - 1]; our d_printf (our d_file, "%.7g %.7g L\n", dx, dy); } if (close) @@ -277,7 +240,8 @@ void structGraphicsPostscript :: v_polyline (integer numberOfPoints, double *xyD void structGraphicsScreen :: v_fillArea (integer numberOfPoints, double *xyDC) { #if cairo - if (our d_cairoGraphicsContext == nullptr) return; + if (our d_cairoGraphicsContext == nullptr) + return; // cairo_new_path (our d_cairoGraphicsContext); // move_to() automatically creates a new path cairo_move_to (our d_cairoGraphicsContext, xyDC [0], xyDC [1]); for (integer i = 1; i < numberOfPoints; i ++) @@ -294,24 +258,20 @@ void structGraphicsScreen :: v_fillArea (integer numberOfPoints, double *xyDC) { FillPath (our d_gdiGraphicsContext); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareFill (this); CGContextBeginPath (our d_macGraphicsContext); CGContextMoveToPoint (our d_macGraphicsContext, xyDC [0], xyDC [1]); - for (integer i = 1; i < numberOfPoints; i ++) { + for (integer i = 1; i < numberOfPoints; i ++) CGContextAddLineToPoint (our d_macGraphicsContext, xyDC [i + i], xyDC [i + i + 1]); - } CGContextFillPath (our d_macGraphicsContext); - GraphicsQuartz_exitDraw (this); #endif } void structGraphicsPostscript :: v_fillArea (integer numberOfPoints, double *xyDC) { integer nn = numberOfPoints + numberOfPoints; d_printf (d_file, "N %.7g %.7g M\n", xyDC [0], xyDC [1]); - for (integer i = 2; i < nn; i += 2) { + for (integer i = 2; i < nn; i += 2) d_printf (d_file, "%.7g %.7g L\n", xyDC [i] - xyDC [i - 2], xyDC [i + 1] - xyDC [i - 1]); - } d_printf (d_file, "closepath fill\n"); } @@ -320,9 +280,11 @@ void structGraphicsPostscript :: v_fillArea (integer numberOfPoints, double *xyD void structGraphicsScreen :: v_rectangle (double x1DC, double x2DC, double y1DC, double y2DC) { ORDER_DC #if cairo - if (! d_cairoGraphicsContext) return; - double width = x2DC - x1DC, height = y1DC - y2DC; - if (width <= 0.0 || height <= 0.0) return; + if (! d_cairoGraphicsContext) + return; + const double width = x2DC - x1DC, height = y1DC - y2DC; + if (width <= 0.0 || height <= 0.0) + return; cairoPrepareLine (this); cairo_rectangle (d_cairoGraphicsContext, x1DC, y2DC, width, height); cairo_stroke (d_cairoGraphicsContext); @@ -332,11 +294,9 @@ void structGraphicsScreen :: v_rectangle (double x1DC, double x2DC, double y1DC, Rectangle (our d_gdiGraphicsContext, x1DC, y2DC, x2DC + 1.0, y1DC + 1.0); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareLine (this); CGContextStrokeRect (d_macGraphicsContext, CGRectMake (x1DC, y2DC, x2DC - x1DC, y1DC - y2DC)); quartzRevertLine (this); - GraphicsQuartz_exitDraw (this); #else double xyDC [8]; xyDC [0] = x1DC; xyDC [1] = y1DC; @@ -350,16 +310,18 @@ void structGraphicsScreen :: v_rectangle (double x1DC, double x2DC, double y1DC, void structGraphicsPostscript :: v_rectangle (double x1DC, double x2DC, double y1DC, double y2DC) { psPrepareLine (this); d_printf (d_file, "N %.7g %.7g M %.7g %.7g lineto %.7g %.7g lineto %.7g %.7g lineto closepath stroke\n", - x1DC, y1DC, x2DC, y1DC, x2DC, y2DC, x1DC, y2DC); + x1DC, y1DC, x2DC, y1DC, x2DC, y2DC, x1DC, y2DC); psRevertLine (this); } void structGraphicsScreen :: v_fillRectangle (double x1DC, double x2DC, double y1DC, double y2DC) { ORDER_DC #if cairo - if (! d_cairoGraphicsContext) return; - double width = x2DC - x1DC + 1.0, height = y1DC - y2DC + 1.0; - if (width <= 0.0 || height <= 0.0) return; + if (! d_cairoGraphicsContext) + return; + const double width = x2DC - x1DC + 1.0, height = y1DC - y2DC + 1.0; + if (width <= 0.0 || height <= 0.0) + return; trace (U"x1DC ", x1DC, U", x2DC ", x2DC, U", y1DC ", y1DC, U", y2DC ", y2DC); cairo_rectangle (d_cairoGraphicsContext, round (x1DC), round (y2DC), round (width), round (height)); cairo_fill (d_cairoGraphicsContext); @@ -370,10 +332,8 @@ void structGraphicsScreen :: v_fillRectangle (double x1DC, double x2DC, double y Rectangle (d_gdiGraphicsContext, x1DC, y2DC, x2DC + 1.0, y1DC + 1.0); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareFill (this); CGContextFillRect (d_macGraphicsContext, CGRectMake (x1DC, y2DC, x2DC - x1DC, y1DC - y2DC)); - GraphicsQuartz_exitDraw (this); #else double xyDC [10]; xyDC [0] = x1DC; xyDC [1] = y1DC; @@ -393,33 +353,23 @@ void structGraphicsPostscript :: v_fillRectangle (double x1DC, double x2DC, doub void structGraphicsScreen :: v_circle (double xDC, double yDC, double rDC) { #if cairo - if (duringXor) { - #if ALLOW_GDK_DRAWING - gdkPrepareLine (this); - gdk_draw_arc (d_window, d_gdkGraphicsContext, false, xDC - rDC, yDC - rDC, rDC + rDC, rDC + rDC, 0, 360 * 64); - gdkRevertLine (this); - gdk_flush (); - #endif - } else { - if (! d_cairoGraphicsContext) return; - cairoPrepareLine (this); - cairo_new_path (d_cairoGraphicsContext); - cairo_arc (d_cairoGraphicsContext, xDC, yDC, rDC, 0.0, 2.0 * M_PI); - cairo_stroke (d_cairoGraphicsContext); - cairoRevertLine (this); - } + if (! d_cairoGraphicsContext) + return; + cairoPrepareLine (this); + cairo_new_path (d_cairoGraphicsContext); + cairo_arc (d_cairoGraphicsContext, xDC, yDC, rDC, 0.0, 2.0 * M_PI); + cairo_stroke (d_cairoGraphicsContext); + cairoRevertLine (this); #elif gdi winPrepareLine (this); Ellipse (d_gdiGraphicsContext, xDC - rDC, yDC - rDC, xDC + rDC + 1.0, yDC + rDC + 1.0); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareLine (this); CGContextBeginPath (d_macGraphicsContext); CGContextAddArc (d_macGraphicsContext, xDC, yDC, rDC, 0.0, NUM2pi, 0); CGContextStrokePath (d_macGraphicsContext); quartzRevertLine (this); - GraphicsQuartz_exitDraw (this); #endif } @@ -432,7 +382,8 @@ void structGraphicsPostscript :: v_circle (double xDC, double yDC, double rDC) { void structGraphicsScreen :: v_ellipse (double x1DC, double x2DC, double y1DC, double y2DC) { ORDER_DC #if cairo - if (! d_cairoGraphicsContext) return; + if (! d_cairoGraphicsContext) + return; cairoPrepareLine (this); cairo_new_path (d_cairoGraphicsContext); cairo_save (d_cairoGraphicsContext); @@ -447,9 +398,8 @@ void structGraphicsScreen :: v_ellipse (double x1DC, double x2DC, double y1DC, d Ellipse (d_gdiGraphicsContext, x1DC, y2DC, x2DC + 1, y1DC + 1); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareLine (this); - NSCAssert (d_macGraphicsContext, @"nil context"); + //NSCAssert (d_macGraphicsContext, @"nil context"); CGContextBeginPath (d_macGraphicsContext); CGContextSaveGState (d_macGraphicsContext); CGContextTranslateCTM (d_macGraphicsContext, 0.5 * (x2DC + x1DC), 0.5 * (y2DC + y1DC)); @@ -459,7 +409,6 @@ void structGraphicsScreen :: v_ellipse (double x1DC, double x2DC, double y1DC, d CGContextStrokePath (d_macGraphicsContext); CGContextRestoreGState (d_macGraphicsContext); quartzRevertLine (this); - GraphicsQuartz_exitDraw (this); #endif } @@ -473,14 +422,16 @@ void structGraphicsPostscript :: v_ellipse (double x1DC, double x2DC, double y1D d_printf (d_file, "gsave %.7g %.7g translate %.7g %.7g scale N 0 0 1 0 360 arc\n" " %.7g %.7g scale stroke grestore\n", 0.5 * (x2DC + x1DC), 0.5 * (y2DC + y1DC), 0.5 * (x2DC - x1DC), 0.5 * (y2DC - y1DC), - 2.0 / (x2DC - x1DC), 2.0 / (y2DC - y1DC)); + 2.0 / (x2DC - x1DC), 2.0 / (y2DC - y1DC) + ); psRevertLine (this); } } void structGraphicsScreen :: v_arc (double xDC, double yDC, double rDC, double fromAngle, double toAngle) { #if cairo - if (! d_cairoGraphicsContext) return; + if (! d_cairoGraphicsContext) + return; cairoPrepareLine (this); cairo_new_path (d_cairoGraphicsContext); cairo_arc (d_cairoGraphicsContext, xDC, yDC, rDC, -toAngle * (M_PI / 180.0), -fromAngle * (M_PI / 180.0)); @@ -489,19 +440,18 @@ void structGraphicsScreen :: v_arc (double xDC, double yDC, double rDC, double f #elif gdi int arcAngle = (int) toAngle - (int) fromAngle; POINT pt; - if (arcAngle < 0.0) arcAngle += 360; + if (arcAngle < 0.0) + arcAngle += 360; winPrepareLine (this); MoveToEx (d_gdiGraphicsContext, xDC + rDC * cos (NUMpi / 180 * fromAngle), yDC - rDC * sin (NUMpi / 180 * fromAngle), & pt); AngleArc (d_gdiGraphicsContext, xDC, yDC, rDC, fromAngle, arcAngle); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareLine (this); CGContextBeginPath (d_macGraphicsContext); CGContextAddArc (d_macGraphicsContext, xDC, yDC, rDC, NUM2pi - NUMpi / 180 * toAngle, NUM2pi - NUMpi / 180 * fromAngle, 0); CGContextStrokePath (d_macGraphicsContext); quartzRevertLine (this); - GraphicsQuartz_exitDraw (this); #endif } @@ -515,7 +465,8 @@ void structGraphicsPostscript :: v_arc (double xDC, double yDC, double rDC, doub void structGraphicsScreen :: v_fillCircle (double xDC, double yDC, double rDC) { #if cairo - if (! d_cairoGraphicsContext) return; + if (! d_cairoGraphicsContext) + return; cairo_new_path (d_cairoGraphicsContext); cairo_arc (d_cairoGraphicsContext, xDC, yDC, rDC, 0, 2 * M_PI); cairo_fill (d_cairoGraphicsContext); @@ -527,12 +478,10 @@ void structGraphicsScreen :: v_fillCircle (double xDC, double yDC, double rDC) { Ellipse (d_gdiGraphicsContext, xDC - rDC - 1.0, yDC - rDC - 1.0, xDC + rDC + 1.0, yDC + rDC + 1.0); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareFill (this); CGContextBeginPath (d_macGraphicsContext); CGContextAddArc (d_macGraphicsContext, xDC, yDC, rDC, 0.0, NUM2pi, 0); CGContextFillPath (d_macGraphicsContext); - GraphicsQuartz_exitDraw (this); #else v_circle (xDC, yDC, rDC); #endif @@ -545,7 +494,8 @@ void structGraphicsPostscript :: v_fillCircle (double xDC, double yDC, double rD void structGraphicsScreen :: v_fillEllipse (double x1DC, double x2DC, double y1DC, double y2DC) { ORDER_DC #if cairo - if (! d_cairoGraphicsContext) return; + if (! d_cairoGraphicsContext) + return; cairo_new_path (d_cairoGraphicsContext); cairo_save (d_cairoGraphicsContext); cairo_translate (d_cairoGraphicsContext, 0.5 * (x2DC + x1DC), 0.5 * (y2DC + y1DC)); @@ -558,9 +508,8 @@ void structGraphicsScreen :: v_fillEllipse (double x1DC, double x2DC, double y1D Ellipse (d_gdiGraphicsContext, x1DC, y2DC, x2DC + 1.0, y1DC + 1.0); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareFill (this); - NSCAssert (d_macGraphicsContext, @"nil context"); + //NSCAssert (d_macGraphicsContext, @"nil context"); CGContextBeginPath (d_macGraphicsContext); CGContextSaveGState (d_macGraphicsContext); CGContextTranslateCTM (d_macGraphicsContext, 0.5 * (x2DC + x1DC), 0.5 * (y2DC + y1DC)); @@ -569,7 +518,6 @@ void structGraphicsScreen :: v_fillEllipse (double x1DC, double x2DC, double y1D CGContextScaleCTM (d_macGraphicsContext, 2.0 / (x2DC - x1DC), 2.0 / (y2DC - y1DC)); CGContextFillPath (d_macGraphicsContext); CGContextRestoreGState (d_macGraphicsContext); - GraphicsQuartz_exitDraw (this); #else v_ellipse (x1DC, x2DC, y1DC, y2DC); #endif @@ -577,14 +525,14 @@ void structGraphicsScreen :: v_fillEllipse (double x1DC, double x2DC, double y1D void structGraphicsPostscript :: v_fillEllipse (double x1DC, double x2DC, double y1DC, double y2DC) { d_printf (d_file, "gsave %.7g %.7g translate %.7g %.7g scale N 0 0 1 FC grestore\n", - (x2DC + x1DC) / 2.0, (y2DC + y1DC) / 2.0, (x2DC - x1DC) / 2.0, (y2DC - y1DC) / 2.0); + (x2DC + x1DC) / 2.0, (y2DC + y1DC) / 2.0, (x2DC - x1DC) / 2.0, (y2DC - y1DC) / 2.0); } void structGraphicsScreen :: v_button (double x1DC, double x2DC, double y1DC, double y2DC) { ORDER_DC #if cairo - if (x2DC <= x1DC || y1DC <= y2DC) return; - + if (x2DC <= x1DC || y1DC <= y2DC) + return; cairo_save (d_cairoGraphicsContext); #if 0 if (d_drawingArea) { @@ -607,8 +555,13 @@ void structGraphicsScreen :: v_button (double x1DC, double x2DC, double y1DC, do cairo_rectangle (d_cairoGraphicsContext, left, top, width, height); cairo_stroke (d_cairoGraphicsContext); - left ++, right --, top ++, bottom --, width -= 2, height -= 2; - if (width > 0 && height > 0) { + left += 1.0; + right -= 1.0; + top += 1.0; + bottom -= 1.0; + width -= 2.0; + height -= 2.0; + if (width > 0.0 && height > 0.0) { cairo_set_source_rgb (d_cairoGraphicsContext, 0.3, 0.3, 0.3); cairo_move_to (d_cairoGraphicsContext, left + 1, bottom); cairo_line_to (d_cairoGraphicsContext, right, bottom); @@ -620,8 +573,13 @@ void structGraphicsScreen :: v_button (double x1DC, double x2DC, double y1DC, do cairo_line_to (d_cairoGraphicsContext, left, top); cairo_line_to (d_cairoGraphicsContext, right, top); cairo_stroke (d_cairoGraphicsContext); - left += 0.5, right -= 0.5, top += 0.5, bottom -= 0.5, width -= 1, height -= 1; - if (width > 0 && height > 0) { + left += 0.5; + right -= 0.5; + top += 0.5; + bottom -= 0.5; + width -= 1.0; + height -= 1.0; + if (width > 0.0 && height > 0.0) { cairo_set_source_rgb (d_cairoGraphicsContext, 0.65, 0.65, 0.65); cairo_rectangle (d_cairoGraphicsContext, left, top, width, height); cairo_fill (d_cairoGraphicsContext); @@ -630,29 +588,39 @@ void structGraphicsScreen :: v_button (double x1DC, double x2DC, double y1DC, do cairo_restore (d_cairoGraphicsContext); #elif quartz double width = x2DC - x1DC, height = y1DC - y2DC; - if (width <= 0 || height <= 0) return; + if (width <= 0.0 || height <= 0.0) + return; /* - * This is pixel-precise drawing, and may therefore be different on retina displays than on 100 dpi displays. - */ + This is pixel-precise drawing, and may therefore be different on retina displays than on 100 dpi displays. + */ #if 1 - bool isRetinaDisplay = [[d_macView window] backingScaleFactor] == 2.0; + const bool isRetinaDisplay = [[d_macView window] backingScaleFactor] == 2.0; #else - bool isRetinaDisplay = false; + const bool isRetinaDisplay = false; #endif - GraphicsQuartz_initDraw (this); CGContextSetLineWidth (d_macGraphicsContext, 1.0); CGContextSetAllowsAntialiasing (d_macGraphicsContext, false); // because we want to draw by pixel CGFloat red = 0.3, green = 0.3, blue = 0.2; CGContextSetRGBStrokeColor (d_macGraphicsContext, red, green, blue, 1.0); if (! isRetinaDisplay) - x1DC --; - x1DC += 0.5, x2DC -= 0.5, y1DC -= 0.5, y2DC += 0.5, width = x2DC - x1DC, height = y1DC - y2DC; + x1DC -= 1.0; + x1DC += 0.5; + x2DC -= 0.5; + y1DC -= 0.5; + y2DC += 0.5; + width = x2DC - x1DC; + height = y1DC - y2DC; CGRect rect = CGRectMake (x1DC, y2DC, width, height); CGContextAddRect (d_macGraphicsContext, rect); CGContextStrokePath (d_macGraphicsContext); - x1DC ++, x2DC --, y1DC --, y2DC ++, width = x2DC - x1DC, height = y1DC - y2DC; - if (width > 0 && height > 0) { + x1DC += 1.0; + x2DC -= 1.0; + y1DC -= 1.0; + y2DC += 1.0; + width = x2DC - x1DC; + height = y1DC - y2DC; + if (width > 0.0 && height > 0.0) { red = 0.5, green = 0.5, blue = 0.4; CGContextSetRGBStrokeColor (d_macGraphicsContext, red, green, blue, 1.0); CGContextMoveToPoint (d_macGraphicsContext, x1DC, y1DC); @@ -667,8 +635,12 @@ void structGraphicsScreen :: v_button (double x1DC, double x2DC, double y1DC, do CGContextMoveToPoint (d_macGraphicsContext, x1DC, y2DC); CGContextAddLineToPoint (d_macGraphicsContext, x2DC, y2DC); CGContextStrokePath (d_macGraphicsContext); - if (width > 2 && height > 2) { - if (! isRetinaDisplay) x1DC ++, width = x2DC - x1DC, height = y1DC - y2DC; + if (width > 2.0 && height > 2.0) { + if (! isRetinaDisplay) { + x1DC += 1.0; + width = x2DC - x1DC; + height = y1DC - y2DC; + } red = 0.75, green = 0.75, blue = 0.65; CGContextSetRGBFillColor (d_macGraphicsContext, red, green, blue, 1.0); rect = CGRectMake (x1DC, y2DC, width, height); @@ -677,7 +649,6 @@ void structGraphicsScreen :: v_button (double x1DC, double x2DC, double y1DC, do } CGContextSetAllowsAntialiasing (d_macGraphicsContext, true); CGContextSetLineDash (d_macGraphicsContext, 0, nullptr, 0); - GraphicsQuartz_exitDraw (this); #elif gdi RECT rect; rect. left = x1DC, rect. right = x2DC, rect. top = y2DC, rect. bottom = y1DC; @@ -691,7 +662,7 @@ void structGraphicsScreen :: v_button (double x1DC, double x2DC, double y1DC, do } void structGraphics :: v_roundedRectangle (double x1DC, double x2DC, double y1DC, double y2DC, double r) { - double dy = yIsZeroAtTheTop ? - r : r; + const double dy = ( yIsZeroAtTheTop ? - r : r ); double xyDC [4]; ORDER_DC xyDC [0] = x1DC + r; @@ -722,7 +693,8 @@ void structGraphics :: v_roundedRectangle (double x1DC, double x2DC, double y1DC void structGraphicsScreen :: v_roundedRectangle (double x1DC, double x2DC, double y1DC, double y2DC, double r) { #if gdi - double dy = yIsZeroAtTheTop ? - r : r, xyDC [4]; + const double dy = ( yIsZeroAtTheTop ? - r : r ); + double xyDC [4]; ORDER_DC winPrepareLine (this); RoundRect (d_gdiGraphicsContext, x1DC, y2DC, x2DC + 1.0, y1DC + 1.0, r + r, r + r); @@ -736,7 +708,7 @@ void structGraphicsScreen :: v_roundedRectangle (double x1DC, double x2DC, doubl /* Fourth level. */ void structGraphics :: v_fillRoundedRectangle (double x1DC, double x2DC, double y1DC, double y2DC, double r) { - double dy = yIsZeroAtTheTop ? - r : r; + const double dy = ( yIsZeroAtTheTop ? - r : r ); ORDER_DC v_fillCircle (x2DC - r, y1DC + dy, r); v_fillCircle (x2DC - r, y2DC - dy, r); @@ -751,102 +723,110 @@ void structGraphics :: v_fillRoundedRectangle (double x1DC, double x2DC, double #define wdx(x) ((x) * my scaleX + my deltaX) #define wdy(y) ((y) * my scaleY + my deltaY) -void Graphics_polyline (Graphics me, integer numberOfPoints, double *xWC, double *yWC) { // base 0 - if (numberOfPoints < 2) return; - double *xyDC; - try { - xyDC = Melder_malloc (double, 2 * numberOfPoints); - } catch (MelderError) { - /* - * Out of memory: silently refuse to draw. - */ - Melder_clearError (); - return; - } - for (integer i = 0; i < numberOfPoints; i ++) { - xyDC [i + i] = wdx (xWC [i]); - xyDC [i + i + 1] = wdy (yWC [i]); - } - my v_polyline (numberOfPoints, xyDC, false); - Melder_free (xyDC); +void Graphics_polyline (Graphics me, integer numberOfPoints, const double *xWC, const double *yWC) { // base 0 if (my recording) { op (POLYLINE, 1 + 2 * numberOfPoints); put (numberOfPoints); mput (numberOfPoints, & xWC [0]) mput (numberOfPoints, & yWC [0]) + } else { + if (numberOfPoints < 2) + return; + double *xyDC; + try { + xyDC = Melder_malloc (double, 2 * numberOfPoints); + } catch (MelderError) { + /* + Out of memory: silently refuse to draw. + */ + Melder_clearError (); + return; + } + for (integer i = 0; i < numberOfPoints; i ++) { + xyDC [i + i] = wdx (xWC [i]); + xyDC [i + i + 1] = wdy (yWC [i]); + } + my v_polyline (numberOfPoints, xyDC, false); + Melder_free (xyDC); } } -void Graphics_polyline_closed (Graphics me, integer numberOfPoints, double *xWC, double *yWC) { // base 0 - if (numberOfPoints < 1) return; - double *xyDC; - try { - xyDC = Melder_malloc (double, 2 * numberOfPoints); - } catch (MelderError) { - /* - * Out of memory: silently refuse to draw. - */ - Melder_clearError (); - return; - } - for (integer i = 0; i < numberOfPoints; i ++) { - xyDC [i + i] = wdx (xWC [i]); - xyDC [i + i + 1] = wdy (yWC [i]); - } - my v_polyline (numberOfPoints, xyDC, true); - Melder_free (xyDC); +void Graphics_polyline_closed (Graphics me, integer numberOfPoints, const double *xWC, const double *yWC) { // base 0 if (my recording) { op (POLYLINE_CLOSED, 1 + 2 * numberOfPoints); put (numberOfPoints); mput (numberOfPoints, & xWC [0]) mput (numberOfPoints, & yWC [0]) + } else { + if (numberOfPoints < 1) + return; + double *xyDC; + try { + xyDC = Melder_malloc (double, 2 * numberOfPoints); + } catch (MelderError) { + /* + Out of memory: silently refuse to draw. + */ + Melder_clearError (); + return; + } + for (integer i = 0; i < numberOfPoints; i ++) { + xyDC [i + i] = wdx (xWC [i]); + xyDC [i + i + 1] = wdy (yWC [i]); + } + my v_polyline (numberOfPoints, xyDC, true); + Melder_free (xyDC); } } void Graphics_line (Graphics me, double x1WC, double y1WC, double x2WC, double y2WC) { - double xyDC [4]; - trace (x1WC, U" ", y1WC, U" ", x2WC, U" ", y2WC); - xyDC [0] = wdx (x1WC); - xyDC [1] = wdy (y1WC); - xyDC [2] = wdx (x2WC); - xyDC [3] = wdy (y2WC); - my v_polyline (2, xyDC, false); - if (my recording) { op (LINE, 4); put (x1WC); put (y1WC); put (x2WC); put (y2WC); } + if (my recording) { + op (LINE, 4); put (x1WC); put (y1WC); put (x2WC); put (y2WC); + } else { + double xyDC [4]; + trace (x1WC, U" ", y1WC, U" ", x2WC, U" ", y2WC); + xyDC [0] = wdx (x1WC); + xyDC [1] = wdy (y1WC); + xyDC [2] = wdx (x2WC); + xyDC [3] = wdy (y2WC); + my v_polyline (2, xyDC, false); + } } void Graphics_fillArea (Graphics me, integer numberOfPoints, double const *xWC, double const *yWC) { - if (numberOfPoints < 3) return; - double *xyDC; - try { - xyDC = Melder_malloc (double, 2 * numberOfPoints); - } catch (MelderError) { - /* - * Out of memory: silently refuse to draw. - */ - Melder_clearError (); - return; - } - for (integer i = 0; i < numberOfPoints; i ++) { - xyDC [i + i] = wdx (xWC [i]); - xyDC [i + i + 1] = wdy (yWC [i]); - } - my v_fillArea (numberOfPoints, xyDC); - Melder_free (xyDC); if (my recording) { op (FILL_AREA, 1 + 2 * numberOfPoints); put (numberOfPoints); mput (numberOfPoints, & xWC [0]) mput (numberOfPoints, & yWC [0]) + } else { + if (numberOfPoints < 3) + return; + double *xyDC; + try { + xyDC = Melder_malloc (double, 2 * numberOfPoints); + } catch (MelderError) { + /* + Out of memory: silently refuse to draw. + */ + Melder_clearError (); + return; + } + for (integer i = 0; i < numberOfPoints; i ++) { + xyDC [i + i] = wdx (xWC [i]); + xyDC [i + i + 1] = wdy (yWC [i]); + } + my v_fillArea (numberOfPoints, xyDC); + Melder_free (xyDC); } } template -integer Graphics_function_ (Graphics me, const TYPE yWC [], integer stride, integer ix1, integer ix2, double x1WC, double x2WC) { +void Graphics_function_ (Graphics me, const TYPE yWC [], integer stride, integer ix1, integer ix2, double x1WC, double x2WC) { const integer clipy1 = wdy (my d_y1WC), clipy2 = wdy (my d_y2WC); const integer n = ix2 - ix1 + 1; - - if (n <= 1 || my scaleX == 0.0) return n; - + if (n <= 1 || my scaleX == 0.0) + return; const double dx = (x2WC - x1WC) / (n - 1); const double offsetX = x1WC - ix1 * dx; /* xDC = wdx (offsetX + i * dx) */ @@ -859,7 +839,8 @@ integer Graphics_function_ (Graphics me, const TYPE yWC [], integer stride, inte integer k = 0; const integer numberOfPointsActuallyDrawn = numberOfPixels * 2; TYPE lastMini; - if (numberOfPointsActuallyDrawn < 1) return n; + if (numberOfPointsActuallyDrawn < 1) + return; double *xyDC = Melder_malloc_f (double, 2 * numberOfPointsActuallyDrawn); for (integer i = 0; i < numberOfPixels; i ++) { integer jmin = ix1 + i / scale, jmax = ix1 + (i + 1) / scale; @@ -915,7 +896,8 @@ integer Graphics_function_ (Graphics me, const TYPE yWC [], integer stride, inte } lastMini = mini; } - if (k > 1) my v_polyline (k / 2, xyDC, false); + if (k > 1) + my v_polyline (k / 2, xyDC, false); Melder_free (xyDC); } else { // normal double *xyDC = Melder_malloc_f (double, 2 * n); @@ -935,116 +917,164 @@ integer Graphics_function_ (Graphics me, const TYPE yWC [], integer stride, inte my v_polyline (n, xyDC, false); Melder_free (xyDC); } - return n; } void Graphics_function (Graphics me, const double yWC [], integer ix1, integer ix2, double x1WC, double x2WC) { - integer n = Graphics_function_ (me, yWC, 1, ix1, ix2, x1WC, x2WC); - if (my recording && n >= 2) { op (FUNCTION, 3 + n); put (n); put (x1WC); put (x2WC); mput (n, & yWC [ix1]) } + if (my recording) { + const integer n = ix2 - ix1 + 1; + if (n >= 2) { + op (FUNCTION, 3 + n); + put (n); + put (x1WC); + put (x2WC); + mput (n, & yWC [ix1]) + } + } else + Graphics_function_ (me, yWC, 1, ix1, ix2, x1WC, x2WC); } void Graphics_function16 (Graphics me, const int16 yWC [], integer stride, integer ix1, integer ix2, double x1WC, double x2WC) { - (void) Graphics_function_ (me, yWC, stride, ix1, ix2, x1WC, x2WC); + if (my recording) { + Melder_fatal (U"Graphics_function16: cannot be used during graphics recording."); + } else + Graphics_function_ (me, yWC, stride, ix1, ix2, x1WC, x2WC); } void Graphics_rectangle (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC) { - my v_rectangle (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC)); - if (my recording) { op (RECTANGLE, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); } + if (my recording) { + op (RECTANGLE, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); + } else + my v_rectangle (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC)); } void Graphics_fillRectangle (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC) { - my v_fillRectangle (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC)); - if (my recording) { op (FILL_RECTANGLE, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); } + if (my recording) { + op (FILL_RECTANGLE, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); + } else + my v_fillRectangle (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC)); } void Graphics_roundedRectangle (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC, double r_mm) { - my v_roundedRectangle (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), Melder_iceiling (r_mm * my resolution / 25.4)); - if (my recording) { op (ROUNDED_RECTANGLE, 5); put (x1WC); put (x2WC); put (y1WC); put (y2WC); put (r_mm); } + if (my recording) { + op (ROUNDED_RECTANGLE, 5); put (x1WC); put (x2WC); put (y1WC); put (y2WC); put (r_mm); + } else + my v_roundedRectangle (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), r_mm * my resolution / 25.4); } void Graphics_fillRoundedRectangle (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC, double r_mm) { - my v_fillRoundedRectangle (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), Melder_iceiling (r_mm * my resolution / 25.4)); - if (my recording) { op (FILL_ROUNDED_RECTANGLE, 5); put (x1WC); put (x2WC); put (y1WC); put (y2WC); put (r_mm); } + if (my recording) { + op (FILL_ROUNDED_RECTANGLE, 5); put (x1WC); put (x2WC); put (y1WC); put (y2WC); put (r_mm); + } else + my v_fillRoundedRectangle (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC), r_mm * my resolution / 25.4); } void Graphics_button (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC) { - my v_button (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC)); - if (my recording) { op (BUTTON, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); } + if (my recording) { + op (BUTTON, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); + } else + my v_button (wdx (x1WC), wdx (x2WC), wdy (y1WC), wdy (y2WC)); } void Graphics_innerRectangle (Graphics me, double x1WC, double x2WC, double y1WC, double y2WC) { - int dy = my yIsZeroAtTheTop ? -1 : 1; - my v_rectangle (wdx (x1WC) + 1, wdx (x2WC) - 1, wdy (y1WC) + dy, wdy (y2WC) - dy); - if (my recording) { op (INNER_RECTANGLE, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); } + if (my recording) { + op (INNER_RECTANGLE, 4); put (x1WC); put (x2WC); put (y1WC); put (y2WC); + } else { + const double dy = ( my yIsZeroAtTheTop ? -1.0 : 1.0 ); + my v_rectangle (wdx (x1WC) + 1.0, wdx (x2WC) - 1.0, wdy (y1WC) + dy, wdy (y2WC) - dy); + } } void Graphics_circle (Graphics me, double xWC, double yWC, double rWC) { - my v_circle (wdx (xWC), wdy (yWC), my scaleX * rWC); - if (my recording) { op (CIRCLE, 3); put (xWC); put (yWC); put (rWC); } + if (my recording) { + op (CIRCLE, 3); put (xWC); put (yWC); put (rWC); + } else + my v_circle (wdx (xWC), wdy (yWC), my scaleX * rWC); } void Graphics_circle_mm (Graphics me, double xWC, double yWC, double diameter) { - my v_circle (wdx (xWC), wdy (yWC), 0.5 * diameter * my resolution / 25.4); - if (my recording) { op (CIRCLE_MM, 3); put (xWC); put (yWC); put (diameter); } + if (my recording) { + op (CIRCLE_MM, 3); put (xWC); put (yWC); put (diameter); + } else + my v_circle (wdx (xWC), wdy (yWC), 0.5 * diameter * my resolution / 25.4); } void Graphics_fillCircle (Graphics me, double xWC, double yWC, double rWC) { - my v_fillCircle (wdx (xWC), wdy (yWC), Melder_iceiling (my scaleX * rWC)); - if (my recording) { op (FILL_CIRCLE, 3); put (xWC); put (yWC); put (rWC); } + if (my recording) { + op (FILL_CIRCLE, 3); put (xWC); put (yWC); put (rWC); + } else + my v_fillCircle (wdx (xWC), wdy (yWC), my scaleX * rWC); } void Graphics_fillCircle_mm (Graphics me, double xWC, double yWC, double diameter) { - my v_fillCircle (wdx (xWC), wdy (yWC), Melder_iceiling (0.5 * diameter * my resolution / 25.4)); - if (my recording) { op (FILL_CIRCLE_MM, 3); put (xWC); put (yWC); put (diameter); } + if (my recording) { + op (FILL_CIRCLE_MM, 3); put (xWC); put (yWC); put (diameter); + } else + my v_fillCircle (wdx (xWC), wdy (yWC), 0.5 * diameter * my resolution / 25.4); } void Graphics_speckle (Graphics me, double xWC, double yWC) { - my v_fillCircle (wdx (xWC), wdy (yWC), Melder_iceiling (0.5 * my speckleSize * my resolution / 25.4)); - if (my recording) { op (SPECKLE, 2); put (xWC); put (yWC); } + if (my recording) { + op (SPECKLE, 2); put (xWC); put (yWC); + } else + my v_fillCircle (wdx (xWC), wdy (yWC), 0.5 * my speckleSize * my resolution / 25.4); } void Graphics_rectangle_mm (Graphics me, double xWC, double yWC, double horSide, double vertSide) { - integer xDC = wdx (xWC), yDC = wdy (yWC); - integer halfHorSide = Melder_iceiling (0.5 * horSide * my resolution / 25.4); - integer halfVertSide = Melder_iceiling (0.5 * vertSide * my resolution / 25.4); - if (my yIsZeroAtTheTop) { - my v_rectangle (xDC - halfHorSide, xDC + halfHorSide, yDC + halfVertSide, yDC - halfVertSide); + if (my recording) { + op (RECTANGLE_MM, 4); put (xWC); put (yWC); put (horSide); put (vertSide); } else { - my v_rectangle (xDC - halfHorSide, xDC + halfHorSide, yDC - halfVertSide, yDC + halfVertSide); + const double xDC = wdx (xWC), yDC = wdy (yWC); + const double halfHorSide = 0.5 * horSide * my resolution / 25.4; + const double halfVertSide = 0.5 * vertSide * my resolution / 25.4; + if (my yIsZeroAtTheTop) { + my v_rectangle (xDC - halfHorSide, xDC + halfHorSide, yDC + halfVertSide, yDC - halfVertSide); + } else { + my v_rectangle (xDC - halfHorSide, xDC + halfHorSide, yDC - halfVertSide, yDC + halfVertSide); + } } - if (my recording) { op (RECTANGLE_MM, 4); put (xWC); put (yWC); put (horSide); put (vertSide); } } void Graphics_fillRectangle_mm (Graphics me, double xWC, double yWC, double horSide, double vertSide) { - integer xDC = wdx (xWC), yDC = wdy (yWC); - integer halfHorSide = Melder_iceiling (0.5 * horSide * my resolution / 25.4); - integer halfVertSide = Melder_iceiling (0.5 * vertSide * my resolution / 25.4); - if (my yIsZeroAtTheTop) { - my v_fillRectangle (xDC - halfHorSide, xDC + halfHorSide, yDC + halfVertSide, yDC - halfVertSide); + if (my recording) { + op (FILL_RECTANGLE_MM, 4); put (xWC); put (yWC); put (horSide); put (vertSide); } else { - my v_fillRectangle (xDC - halfHorSide, xDC + halfHorSide, yDC - halfVertSide, yDC + halfVertSide); + const double xDC = wdx (xWC), yDC = wdy (yWC); + const double halfHorSide = 0.5 * horSide * my resolution / 25.4; + const double halfVertSide = 0.5 * vertSide * my resolution / 25.4; + if (my yIsZeroAtTheTop) { + my v_fillRectangle (xDC - halfHorSide, xDC + halfHorSide, yDC + halfVertSide, yDC - halfVertSide); + } else { + my v_fillRectangle (xDC - halfHorSide, xDC + halfHorSide, yDC - halfVertSide, yDC + halfVertSide); + } } - if (my recording) { op (FILL_RECTANGLE_MM, 4); put (xWC); put (yWC); put (horSide); put (vertSide); } } void Graphics_ellipse (Graphics me, double x1, double x2, double y1, double y2) { - my v_ellipse (wdx (x1), wdx (x2), wdy (y1), wdy (y2)); - if (my recording) { op (ELLIPSE, 4); put (x1); put (x2); put (y1); put (y2); } + if (my recording) { + op (ELLIPSE, 4); put (x1); put (x2); put (y1); put (y2); + } else + my v_ellipse (wdx (x1), wdx (x2), wdy (y1), wdy (y2)); } void Graphics_fillEllipse (Graphics me, double x1, double x2, double y1, double y2) { - my v_fillEllipse (wdx (x1), wdx (x2), wdy (y1), wdy (y2)); - if (my recording) { op (FILL_ELLIPSE, 4); put (x1); put (x2); put (y1); put (y2); } + if (my recording) { + op (FILL_ELLIPSE, 4); put (x1); put (x2); put (y1); put (y2); + } else + my v_fillEllipse (wdx (x1), wdx (x2), wdy (y1), wdy (y2)); } void Graphics_arc (Graphics me, double xWC, double yWC, double rWC, double fromAngle, double toAngle) { - my v_arc (wdx (xWC), wdy (yWC), my scaleX * rWC, fromAngle, toAngle); - if (my recording) { op (ARC, 5); put (xWC); put (yWC); put (rWC); put (fromAngle); put (toAngle); } + if (my recording) { + op (ARC, 5); put (xWC); put (yWC); put (rWC); put (fromAngle); put (toAngle); + } else + my v_arc (wdx (xWC), wdy (yWC), my scaleX * rWC, fromAngle, toAngle); } void Graphics_fillArc (Graphics me, double xWC, double yWC, double rWC, double fromAngle, double toAngle) { - my v_arc (wdx (xWC), wdy (yWC), my scaleX * rWC, fromAngle, toAngle); // NYI v_fillArc - if (my recording) { op (FILL_ARC, 5); put (xWC); put (yWC); put (rWC); put (fromAngle); put (toAngle); } + if (my recording) { + op (FILL_ARC, 5); put (xWC); put (yWC); put (rWC); put (fromAngle); put (toAngle); + } else + my v_arc (wdx (xWC), wdy (yWC), my scaleX * rWC, fromAngle, toAngle); // NYI v_fillArc } /* Arrows. */ @@ -1076,9 +1106,8 @@ void structGraphicsScreen :: v_arrowHead (double xDC, double yDC, double angle) FillPath (our d_gdiGraphicsContext); DEFAULT #elif quartz - GraphicsQuartz_initDraw (this); quartzPrepareFill (this); - NSCAssert (our d_macGraphicsContext, @"nil context"); + //NSCAssert (our d_macGraphicsContext, @"nil context"); CGContextSaveGState (our d_macGraphicsContext); CGContextBeginPath (our d_macGraphicsContext); CGContextTranslateCTM (our d_macGraphicsContext, xDC, yDC); @@ -1090,7 +1119,6 @@ void structGraphicsScreen :: v_arrowHead (double xDC, double yDC, double angle) CGContextAddLineToPoint (our d_macGraphicsContext, 0.0, 0.0); CGContextFillPath (our d_macGraphicsContext); CGContextRestoreGState (our d_macGraphicsContext); - GraphicsQuartz_exitDraw (this); #endif } @@ -1101,46 +1129,58 @@ void structGraphicsPostscript :: v_arrowHead (double xDC, double yDC, double ang } void Graphics_arrow (Graphics me, double x1WC, double y1WC, double x2WC, double y2WC) { - double angle = (180.0 / NUMpi) * atan2 ((wdy (y2WC) - wdy (y1WC)) * (my yIsZeroAtTheTop ? -1.0 : 1.0), wdx (x2WC) - wdx (x1WC)); - double size = my screen ? 10.0 * my resolution * my arrowSize / 72.0 : my resolution * my arrowSize / 10; - double xyDC [4]; - xyDC [0] = wdx (x1WC); - xyDC [1] = wdy (y1WC); - xyDC [2] = wdx (x2WC) + (my screen ? 0.7 : 0.6) * cos ((angle - 180.0) * NUMpi / 180.0) * size; - xyDC [3] = wdy (y2WC) + (my yIsZeroAtTheTop ? -1.0 : 1.0) * (my screen ? 0.7 : 0.6) * sin ((angle - 180.0) * NUMpi / 180.0) * size; - my v_polyline (2, xyDC, false); - my v_arrowHead (wdx (x2WC), wdy (y2WC), angle); - if (my recording) { op (ARROW, 4); put (x1WC); put (y1WC); put (x2WC); put (y2WC); } + if (my recording) { + op (ARROW, 4); put (x1WC); put (y1WC); put (x2WC); put (y2WC); + } else { + const double angle = (180.0 / NUMpi) * atan2 ((wdy (y2WC) - wdy (y1WC)) * (my yIsZeroAtTheTop ? -1.0 : 1.0), wdx (x2WC) - wdx (x1WC)); + const double size = my screen ? 10.0 * my resolution * my arrowSize / 72.0 : my resolution * my arrowSize / 10; + double xyDC [4]; + xyDC [0] = wdx (x1WC); + xyDC [1] = wdy (y1WC); + xyDC [2] = wdx (x2WC) + (my screen ? 0.7 : 0.6) * cos ((angle - 180.0) * NUMpi / 180.0) * size; + xyDC [3] = wdy (y2WC) + (my yIsZeroAtTheTop ? -1.0 : 1.0) * (my screen ? 0.7 : 0.6) * sin ((angle - 180.0) * NUMpi / 180.0) * size; + my v_polyline (2, xyDC, false); + my v_arrowHead (wdx (x2WC), wdy (y2WC), angle); + } } void Graphics_doubleArrow (Graphics me, double x1WC, double y1WC, double x2WC, double y2WC) { - double angle = (180.0 / NUMpi) * atan2 ((wdy (y2WC) - wdy (y1WC)) * (my yIsZeroAtTheTop ? -1.0 : 1.0), wdx (x2WC) - wdx (x1WC)); - double size = my screen ? 10.0 * my resolution * my arrowSize / 72.0 : my resolution * my arrowSize / 10.0; - double xyDC [4]; - xyDC [0] = wdx (x1WC) + (my screen ? 0.7 : 0.6) * cos (angle * NUMpi / 180.0) * size; - xyDC [1] = wdy (y1WC) + (my yIsZeroAtTheTop ? -1.0 : 1.0) * (my screen ? 0.7 : 0.6) * sin (angle * NUMpi / 180.0) * size; - xyDC [2] = wdx (x2WC) + (my screen ? 0.7 : 0.6) * cos ((angle - 180) * NUMpi / 180.0) * size; - xyDC [3] = wdy (y2WC) + (my yIsZeroAtTheTop ? -1.0 : 1.0) * (my screen ? 0.7 : 0.6) * sin ((angle - 180.0) * NUMpi / 180.0) * size; - my v_polyline (2, xyDC, false); - my v_arrowHead (wdx (x1WC), wdy (y1WC), angle + 180.0); - //my v_polyline (2, xyDC); - my v_arrowHead (wdx (x2WC), wdy (y2WC), angle); - if (my recording) { op (DOUBLE_ARROW, 4); put (x1WC); put (y1WC); put (x2WC); put (y2WC); } + if (my recording) { + op (DOUBLE_ARROW, 4); put (x1WC); put (y1WC); put (x2WC); put (y2WC); + } else { + const double angle = (180.0 / NUMpi) * atan2 ((wdy (y2WC) - wdy (y1WC)) * (my yIsZeroAtTheTop ? -1.0 : 1.0), wdx (x2WC) - wdx (x1WC)); + const double size = my screen ? 10.0 * my resolution * my arrowSize / 72.0 : my resolution * my arrowSize / 10.0; + double xyDC [4]; + xyDC [0] = wdx (x1WC) + (my screen ? 0.7 : 0.6) * cos (angle * NUMpi / 180.0) * size; + xyDC [1] = wdy (y1WC) + (my yIsZeroAtTheTop ? -1.0 : 1.0) * (my screen ? 0.7 : 0.6) * sin (angle * NUMpi / 180.0) * size; + xyDC [2] = wdx (x2WC) + (my screen ? 0.7 : 0.6) * cos ((angle - 180) * NUMpi / 180.0) * size; + xyDC [3] = wdy (y2WC) + (my yIsZeroAtTheTop ? -1.0 : 1.0) * (my screen ? 0.7 : 0.6) * sin ((angle - 180.0) * NUMpi / 180.0) * size; + my v_polyline (2, xyDC, false); + my v_arrowHead (wdx (x1WC), wdy (y1WC), angle + 180.0); + //my v_polyline (2, xyDC); + my v_arrowHead (wdx (x2WC), wdy (y2WC), angle); + } } void Graphics_arcArrow (Graphics me, double xWC, double yWC, double rWC, double fromAngle, double toAngle, int arrowAtStart, int arrowAtEnd) { - my v_arc (wdx (xWC), wdy (yWC), my scaleX * rWC, fromAngle, toAngle); - if (arrowAtStart) my v_arrowHead ( - wdx (xWC + rWC * cos (fromAngle * (NUMpi / 180.0))), - wdy (yWC + rWC * sin (fromAngle * (NUMpi / 180.0))), fromAngle - 90.0); - if (arrowAtEnd) my v_arrowHead ( - wdx (xWC + rWC * cos (toAngle * (NUMpi / 180.0))), - wdy (yWC + rWC * sin (toAngle * (NUMpi / 180.0))), toAngle + 90.0); - if (my recording) - { op (ARC_ARROW, 7); put (xWC); put (yWC); put (rWC); - put (fromAngle); put (toAngle); put (arrowAtStart); put (arrowAtEnd); } + if (my recording) { + op (ARC_ARROW, 7); put (xWC); put (yWC); put (rWC); + put (fromAngle); put (toAngle); put (arrowAtStart); put (arrowAtEnd); + } else { + my v_arc (wdx (xWC), wdy (yWC), my scaleX * rWC, fromAngle, toAngle); + if (arrowAtStart) + my v_arrowHead ( + wdx (xWC + rWC * cos (fromAngle * (NUMpi / 180.0))), + wdy (yWC + rWC * sin (fromAngle * (NUMpi / 180.0))), fromAngle - 90.0 + ); + if (arrowAtEnd) + my v_arrowHead ( + wdx (xWC + rWC * cos (toAngle * (NUMpi / 180.0))), + wdy (yWC + rWC * sin (toAngle * (NUMpi / 180.0))), toAngle + 90.0 + ); + } } /* Output attributes. */ diff --git a/sys/Graphics_mouse.cpp b/sys/Graphics_mouse.cpp deleted file mode 100644 index c5ac6677..00000000 --- a/sys/Graphics_mouse.cpp +++ /dev/null @@ -1,87 +0,0 @@ -/* Graphics_mouse.cpp - * - * Copyright (C) 1992-2011,2013,2016,2017 Paul Boersma, 2013 Tom Naughton - * - * This code is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or (at - * your option) any later version. - * - * This code is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - * See the GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this work. If not, see . - */ - -#include "GraphicsP.h" -#include "Gui.h" - -/* - * Graphics_mouseStillDown () can only be used in a loop - * if Graphics_getMouseLocation () is called in that same loop. - * This is because the Xwin version requires that. - */ - -bool structGraphicsScreen :: v_mouseStillDown () { - #if cairo && gtk - Graphics_flushWs (this); - GdkEvent *gevent = gdk_display_get_event (d_display); - if (! gevent) return true; - int gdkEventType = gevent -> type; - gdk_event_free (gevent); - return gdkEventType != GDK_BUTTON_RELEASE; - #elif gdi - return motif_win_mouseStillDown (); - #elif quartz - [[d_macView window] flushWindow]; - NSEvent *nsEvent = [[d_macView window] - nextEventMatchingMask: NSLeftMouseUpMask | NSLeftMouseDraggedMask | NSKeyDownMask - untilDate: [NSDate distantFuture] - inMode: NSEventTrackingRunLoopMode - dequeue: YES - ]; - NSUInteger nsEventType = [nsEvent type]; - if (nsEventType == NSKeyDown) NSBeep (); - return nsEventType != NSLeftMouseUp; - #else - return false; - #endif -} - -bool Graphics_mouseStillDown (Graphics me) { - return my v_mouseStillDown (); -} - -void structGraphicsScreen :: v_getMouseLocation (double *p_xWC, double *p_yWC) { - #if cairo && gtk - gint xDC, yDC; - gdk_window_get_pointer (d_window, & xDC, & yDC, nullptr); - Graphics_DCtoWC (this, xDC, yDC, p_xWC, p_yWC); - #elif gdi - POINT pos; - if (! GetCursorPos (& pos)) { Melder_warning (U"Cannot find the location of the mouse."); return; } - ScreenToClient (d_winWindow, & pos); - Graphics_DCtoWC (this, pos. x, pos. y, p_xWC, p_yWC); - #elif quartz - NSPoint mouseLoc = [[d_macView window] mouseLocationOutsideOfEventStream]; - mouseLoc = [d_macView convertPoint: mouseLoc fromView: nil]; - //mouseLoc. y = d_macView. bounds. size. height - mouseLoc. y; - Graphics_DCtoWC (this, mouseLoc. x, mouseLoc. y, p_xWC, p_yWC); - #endif -} - -void Graphics_getMouseLocation (Graphics me, double *p_xWC, double *p_yWC) { - my v_getMouseLocation (p_xWC, p_yWC); -} - -void Graphics_waitMouseUp (Graphics me) { - while (Graphics_mouseStillDown (me)) { - double xWC, yWC; - Graphics_getMouseLocation (me, & xWC, & yWC); - } -} - -/* End of file Graphics_mouse.cpp */ diff --git a/sys/Graphics_record.cpp b/sys/Graphics_record.cpp index 7c4d23ab..201d7aa3 100644 --- a/sys/Graphics_record.cpp +++ b/sys/Graphics_record.cpp @@ -1,6 +1,6 @@ /* Graphics_record.cpp * - * Copyright (C) 1992-2005,2007-2019 Paul Boersma + * Copyright (C) 1992-2005,2007-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -44,7 +44,8 @@ double * _Graphics_check (Graphics me, integer number) { my nrecord = nrecord; } if (nrecord < my irecord + RECORDING_HEADER_LENGTH + number) { - while (nrecord < my irecord + RECORDING_HEADER_LENGTH + number) nrecord *= 2; + while (nrecord < my irecord + RECORDING_HEADER_LENGTH + number) + nrecord *= 2; try { record = (double *) Melder_realloc (record, (1 + nrecord) * (integer) sizeof (double)); } catch (MelderError) { @@ -68,13 +69,13 @@ double * _Graphics_check (Graphics me, integer number) { /***** RECORD AND PLAY *****/ bool Graphics_startRecording (Graphics me) { - bool wasRecording = my recording; + const bool wasRecording = my recording; my recording = true; return wasRecording; } bool Graphics_stopRecording (Graphics me) { - bool wasRecording = my recording; + const bool wasRecording = my recording; my recording = false; return wasRecording; } @@ -88,9 +89,11 @@ void Graphics_clearRecording (Graphics me) { } void Graphics_play (Graphics me, Graphics thee) { - double *p = my record, *endp = p + my irecord; - bool wasRecording = my recording; - if (! p) return; + const double *p = my record; + const double * const endp = p + my irecord; + const bool wasRecording = my recording; + if (! p) + return; my recording = false; // temporarily, in case me == thee while (p < endp) { #define get (* ++ p) @@ -101,7 +104,7 @@ void Graphics_play (Graphics me, Graphics thee) { (void) (integer) get; // ignore number of arguments switch (opcode) { case SET_VIEWPORT: { - double x1NDC = get, x2NDC = get, y1NDC = get, y2NDC = get; + const double x1NDC = get, x2NDC = get, y1NDC = get, y2NDC = get; Graphics_setViewport (thee, x1NDC, x2NDC, y1NDC, y2NDC); } break; case SET_INNER: { @@ -111,75 +114,75 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_unsetInner (thee); } break; case SET_WINDOW: { - double x1 = get, x2 = get, y1 = get, y2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get; Graphics_setWindow (thee, x1, x2, y1, y2); } break; case TEXT: { - double x = get, y = get; - integer length = iget; - char *text_utf8 = sget (length); + const double x = get, y = get; + const integer length = iget; + const conststring8 text_utf8 = sget (length); Graphics_text (thee, x, y, Melder_peek8to32 (text_utf8)); } break; case POLYLINE: { - integer n = iget; - double *x = mget (n), *y = mget (n); + const integer n = iget; + const double *x = mget (n), *y = mget (n); Graphics_polyline (thee, n, & x [1], & y [1]); } break; case LINE: { - double x1 = get, y1 = get, x2 = get, y2 = get; + const double x1 = get, y1 = get, x2 = get, y2 = get; Graphics_line (thee, x1, y1, x2, y2); } break; case ARROW: { - double x1 = get, y1 = get, x2 = get, y2 = get; + const double x1 = get, y1 = get, x2 = get, y2 = get; Graphics_arrow (thee, x1, y1, x2, y2); } break; case FILL_AREA: { - integer n = iget; - double *x = mget (n), *y = mget (n); + const integer n = iget; + const double * const x = mget (n), * const y = mget (n); Graphics_fillArea (thee, n, & x [1], & y [1]); } break; case FUNCTION: { integer n = iget; - double x1 = get, x2 = get, *y = mget (n); + const double x1 = get, x2 = get, *y = mget (n); Graphics_function (thee, y, 1, n, x1, x2); } break; case RECTANGLE: { - double x1 = get, x2 = get, y1 = get, y2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get; Graphics_rectangle (thee, x1, x2, y1, y2); } break; case FILL_RECTANGLE: { - double x1 = get, x2 = get, y1 = get, y2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get; Graphics_fillRectangle (thee, x1, x2, y1, y2); } break; case CIRCLE: { - double x = get, y = get, r = get; + const double x = get, y = get, r = get; Graphics_circle (thee, x, y, r); } break; case FILL_CIRCLE: { - double x = get, y = get, r = get; + const double x = get, y = get, r = get; Graphics_fillCircle (thee, x, y, r); } break; case ARC: { - double x = get, y = get, r = get, fromAngle = get, toAngle = get; + const double x = get, y = get, r = get, fromAngle = get, toAngle = get; Graphics_arc (thee, x, y, r, fromAngle, toAngle); } break; case ARC_ARROW: { - double x = get, y = get, r = get, fromAngle = get, toAngle = get; - int arrowAtStart = (int) iget, arrowAtEnd = (int) iget; + const double x = get, y = get, r = get, fromAngle = get, toAngle = get; + const int arrowAtStart = (int) iget, arrowAtEnd = (int) iget; Graphics_arcArrow (thee, x, y, r, fromAngle, toAngle, arrowAtStart, arrowAtEnd); } break; case HIGHLIGHT: { - double x1 = get, x2 = get, y1 = get, y2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get; Graphics_highlight (thee, x1, x2, y1, y2); } break; case CELL_ARRAY: { - double x1 = get, x2 = get, y1 = get, y2 = get, minimum = get, maximum = get; - integer nrow = iget, ncol = iget; + const double x1 = get, x2 = get, y1 = get, y2 = get, minimum = get, maximum = get; + const integer nrow = iget, ncol = iget; /* - * We don't copy all the data into a new matrix. - * Instead, we create row pointers z [1..nrow] that point directly into the recorded data. - * This works because the data is a packed array of double, just as Graphics_cellArray expects. - */ + We don't copy all the data into a new matrix. + Instead, we create row pointers z [1..nrow] that point directly into the recorded data. + This works because the data is a packed array of double, just as Graphics_cellArray expects. + */ #if 0 autoMAT z = newMATraw (nrow, ncol); for (integer irow = 1; irow <= nrow; irow ++) @@ -202,7 +205,7 @@ void Graphics_play (Graphics me, Graphics thee) { } break; case SET_TEXT_ALIGNMENT: { kGraphics_horizontalAlignment hor = (kGraphics_horizontalAlignment) iget; - int vert = (int) iget; + const int vert = (int) iget; Graphics_setTextAlignment (thee, hor, vert); } break; case SET_TEXT_ROTATION: { @@ -215,7 +218,7 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_setLineWidth (thee, get); } break; case SET_STANDARD_COLOUR: { // only used in old Praat picture files - int standardColour = (int) get; + const int standardColour = (int) get; MelderColour colour = standardColour == 0 ? Melder_BLACK : standardColour == 1 ? Melder_WHITE : @@ -243,25 +246,25 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_markGroup (thee); } break; case ELLIPSE: { - double x1 = get, x2 = get, y1 = get, y2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get; Graphics_ellipse (thee, x1, x2, y1, y2); } break; case FILL_ELLIPSE: { - double x1 = get, x2 = get, y1 = get, y2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get; Graphics_fillEllipse (thee, x1, x2, y1, y2); } break; case CIRCLE_MM: { - double x = get, y = get, d = get; + const double x = get, y = get, d = get; Graphics_circle_mm (thee, x, y, d); } break; case FILL_CIRCLE_MM: { - double x = get, y = get, d = get; + const double x = get, y = get, d = get; Graphics_fillCircle_mm (thee, x, y, d); } break; case IMAGE8: { - double x1 = get, x2 = get, y1 = get, y2 = get; - uint8 minimum = (uint8) iget, maximum = (uint8) iget; - integer nrow = iget, ncol = iget; + const double x1 = get, x2 = get, y1 = get, y2 = get; + const uint8 minimum = (uint8) iget, maximum = (uint8) iget; + const integer nrow = iget, ncol = iget; automatrix z = newmatrixzero (nrow, ncol); for (integer irow = 1; irow <= nrow; irow ++) for (integer icol = 1; icol <= ncol; icol ++) @@ -269,10 +272,9 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_image8 (thee, z.all(), x1, x2, y1, y2, minimum, maximum); } break; case UNHIGHLIGHT: { - double x1 = get, x2 = get, y1 = get, y2 = get; - Graphics_unhighlight (thee, x1, x2, y1, y2); + (void) mget (4); // obsolete x1, x2, y1, y2 + // do nothing (this has become obsolete since the demise of XOR mode drawing) } break; -#if motif case XOR_ON: { MelderColour colour; colour. red = get, colour. green = get, colour. blue = get; Graphics_xorOn (thee, colour); @@ -280,17 +282,16 @@ void Graphics_play (Graphics me, Graphics thee) { case XOR_OFF: { Graphics_xorOff (thee); } break; -#endif case RECTANGLE_MM: { - double x = get, y = get, horSide = get, vertSide = get; + const double x = get, y = get, horSide = get, vertSide = get; Graphics_rectangle_mm (thee, x, y, horSide, vertSide); } break; case FILL_RECTANGLE_MM: { - double x = get, y = get, horSide = get, vertSide = get; + const double x = get, y = get, horSide = get, vertSide = get; Graphics_fillRectangle_mm (thee, x, y, horSide, vertSide); } break; case SET_WS_WINDOW: { - double x1NDC = get, x2NDC = get, y1NDC = get, y2NDC = get; + const double x1NDC = get, x2NDC = get, y1NDC = get, y2NDC = get; Graphics_setWsWindow (thee, x1NDC, x2NDC, y1NDC, y2NDC); } break; case SET_WRAP_WIDTH: { @@ -318,29 +319,29 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_setAtSignIsLink (thee, (bool) get); } break; case BUTTON: { - double x1 = get, x2 = get, y1 = get, y2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get; Graphics_button (thee, x1, x2, y1, y2); } break; case ROUNDED_RECTANGLE: { - double x1 = get, x2 = get, y1 = get, y2 = get, r = get; + const double x1 = get, x2 = get, y1 = get, y2 = get, r = get; Graphics_roundedRectangle (thee, x1, x2, y1, y2, r); } break; case FILL_ROUNDED_RECTANGLE: { - double x1 = get, x2 = get, y1 = get, y2 = get, r = get; + const double x1 = get, x2 = get, y1 = get, y2 = get, r = get; Graphics_fillRoundedRectangle (thee, x1, x2, y1, y2, r); } break; case FILL_ARC: { - double x = get, y = get, r = get, fromAngle = get, toAngle = get; + const double x = get, y = get, r = get, fromAngle = get, toAngle = get; Graphics_fillArc (thee, x, y, r, fromAngle, toAngle); } break; case INNER_RECTANGLE: { - double x1 = get, x2 = get, y1 = get, y2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get; Graphics_innerRectangle (thee, x1, x2, y1, y2); } break; case CELL_ARRAY8: { - double x1 = get, x2 = get, y1 = get, y2 = get; - uint8 minimum = (uint8) iget, maximum = (uint8) iget; - integer nrow = iget, ncol = iget; + const double x1 = get, x2 = get, y1 = get, y2 = get; + const uint8 minimum = (uint8) iget, maximum = (uint8) iget; + const integer nrow = iget, ncol = iget; automatrix z = newmatrixzero (nrow, ncol); for (integer irow = 1; irow <= nrow; irow ++) for (integer icol = 1; icol <= ncol; icol ++) @@ -348,8 +349,8 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_cellArray8 (thee, z.all(), x1, x2, y1, y2, minimum, maximum); } break; case IMAGE: { - double x1 = get, x2 = get, y1 = get, y2 = get, minimum = get, maximum = get; - integer nrow = iget, ncol = iget; + const double x1 = get, x2 = get, y1 = get, y2 = get, minimum = get, maximum = get; + const integer nrow = iget, ncol = iget; autoMAT z = newMATraw (nrow, ncol); for (integer irow = 1; irow <= nrow; irow ++) for (integer icol = 1; icol <= ncol; icol ++) @@ -357,18 +358,18 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_image (thee, z.all(), x1, x2, y1, y2, minimum, maximum); // or with constMATVU construction } break; case HIGHLIGHT2: { - double x1 = get, x2 = get, y1 = get, y2 = get, innerX1 = get, innerX2 = get, innerY1 = get, innerY2 = get; + const double x1 = get, x2 = get, y1 = get, y2 = get, innerX1 = get, innerX2 = get, innerY1 = get, innerY2 = get; Graphics_highlight2 (thee, x1, x2, y1, y2, innerX1, innerX2, innerY1, innerY2); } break; case UNHIGHLIGHT2: { - double x1 = get, x2 = get, y1 = get, y2 = get, innerX1 = get, innerX2 = get, innerY1 = get, innerY2 = get; - Graphics_unhighlight2 (thee, x1, x2, y1, y2, innerX1, innerX2, innerY1, innerY2); + (void) mget (8); // obsolete x1, x2, y1, y2, innerX1, innerX2, innerY1, innerY2 + // do nothing (this has become obsolete since the demise of XOR mode drawing) } break; case SET_ARROW_SIZE: { Graphics_setArrowSize (thee, get); } break; case DOUBLE_ARROW: { - double x1 = get, y1 = get, x2 = get, y2 = get; + const double x1 = get, y1 = get, x2 = get, y2 = get; Graphics_doubleArrow (thee, x1, y1, x2, y2); } break; case SET_RGB_COLOUR: { @@ -377,19 +378,19 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_setColour (thee, colour); } break; case IMAGE_FROM_FILE: { - double x1 = get, x2 = get, y1 = get, y2 = get; - integer length = iget; - char *text_utf8 = sget (length); + const double x1 = get, x2 = get, y1 = get, y2 = get; + const integer length = iget; + const conststring8 text_utf8 = sget (length); Graphics_imageFromFile (thee, Melder_peek8to32 (text_utf8), x1, x2, y1, y2); } break; case POLYLINE_CLOSED: { - integer n = iget; - double *x = mget (n), *y = mget (n); + const integer n = iget; + const double *x = mget (n), *y = mget (n); Graphics_polyline_closed (thee, n, & x [1], & y [1]); } break; case CELL_ARRAY_COLOUR: { - double x1 = get, x2 = get, y1 = get, y2 = get, minimum = get, maximum = get; - integer nrow = iget, ncol = iget; + const double x1 = get, x2 = get, y1 = get, y2 = get, minimum = get, maximum = get; + const integer nrow = iget, ncol = iget; automatrix z = newmatrixzero (nrow, ncol); for (integer irow = 1; irow <= nrow; irow ++) for (integer icol = 1; icol <= ncol; icol ++) { @@ -401,8 +402,8 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_cellArray_colour (thee, z.all(), x1, x2, y1, y2, minimum, maximum); } break; case IMAGE_COLOUR: { - double x1 = get, x2 = get, y1 = get, y2 = get, minimum = get, maximum = get; - integer nrow = iget, ncol = iget; + const double x1 = get, x2 = get, y1 = get, y2 = get, minimum = get, maximum = get; + const integer nrow = iget, ncol = iget; automatrix z = newmatrixzero (nrow, ncol); for (integer irow = 1; irow <= nrow; irow ++) for (integer icol = 1; icol <= ncol; icol ++) { @@ -420,9 +421,12 @@ void Graphics_play (Graphics me, Graphics thee) { Graphics_setSpeckleSize (thee, get); } break; case SPECKLE: { - double x = get, y = get; + const double x = get, y = get; Graphics_speckle (thee, x, y); } break; + case CLEAR_WS: { + Graphics_clearWs (thee); + } break; default: my recording = wasRecording; Melder_flushError (U"Graphics_play: unknown opcode (", opcode, U").\n", p [-1], U" ", p [1]); @@ -433,18 +437,20 @@ void Graphics_play (Graphics me, Graphics thee) { } void Graphics_writeRecordings (Graphics me, FILE *f) { - double *p = my record, *endp = p + my irecord; - if (! p) return; - binputi32 (my irecord, f); + const double * p = my record; + const double * const endp = p + my irecord; + if (! p) + return; + binputi32 (integer_to_int32 (my irecord), f); while (p < endp) { #define get (* ++ p) - int opcode = (int) get; + const int opcode = (int) get; binputr32 ((float) opcode, f); integer numberOfArguments = (integer) get; const integer largestIntegerRepresentableAs32BitFloat = 0x00FFFFFF; if (numberOfArguments > largestIntegerRepresentableAs32BitFloat) { binputr32 (-1.0, f); - binputi32 (numberOfArguments, f); + binputi32 (integer_to_int32 (numberOfArguments), f); //Melder_warning ("This picture is very large!"); } else { binputr32 ((float) numberOfArguments, f); @@ -454,7 +460,7 @@ void Graphics_writeRecordings (Graphics me, FILE *f) { binputr32 (get, f); // y binputr32 (get, f); // length Melder_assert (sizeof (double) == 8); - if ((integer) fwrite (++ p, 8, numberOfArguments - 3, f) < numberOfArguments - 3) // text + if (uinteger_to_integer (fwrite (++ p, 8, integer_to_uinteger (numberOfArguments - 3), f)) < numberOfArguments - 3) // text Melder_throw (U"Error writing graphics recordings."); p += numberOfArguments - 4; } else if (opcode == IMAGE_FROM_FILE) { @@ -464,11 +470,12 @@ void Graphics_writeRecordings (Graphics me, FILE *f) { binputr32 (get, f); // y2 binputr32 (get, f); // length Melder_assert (sizeof (double) == 8); - if ((integer) fwrite (++ p, 8, numberOfArguments - 5, f) < numberOfArguments - 5) // text + if (uinteger_to_integer (fwrite (++ p, 8, integer_to_uinteger (numberOfArguments - 5), f)) < numberOfArguments - 5) // text Melder_throw (U"Error writing graphics recordings."); p += numberOfArguments - 6; } else { - for (integer i = numberOfArguments; i > 0; i --) binputr32 (get, f); + for (integer i = numberOfArguments; i > 0; i --) + binputr32 (get, f); } } } @@ -479,11 +486,12 @@ void Graphics_readRecordings (Graphics me, FILE *f) { double* p = nullptr; double* endp = nullptr; integer numberOfArguments = 0; - int opcode = 0; + int opcode = 0; // large scope on behalf of message try { added_irecord = bingeti32 (f); p = _Graphics_check (me, added_irecord - RECORDING_HEADER_LENGTH); - if (! p) return; + if (! p) + return; Melder_assert (my irecord == old_irecord + added_irecord); endp = p + added_irecord; while (p < endp) { @@ -497,7 +505,7 @@ void Graphics_readRecordings (Graphics me, FILE *f) { put (bingetr32 (f)); // x put (bingetr32 (f)); // y put (bingetr32 (f)); // length - if (fread (++ p, 8, (size_t) numberOfArguments - 3, f) < (size_t) numberOfArguments - 3) // text + if (uinteger_to_integer (fread (++ p, 8, integer_to_uinteger (numberOfArguments - 3), f)) < numberOfArguments - 3) // text Melder_throw (U"Error reading graphics recordings."); p += numberOfArguments - 4; } else if (opcode == IMAGE_FROM_FILE) { @@ -506,7 +514,7 @@ void Graphics_readRecordings (Graphics me, FILE *f) { put (bingetr32 (f)); // y1 put (bingetr32 (f)); // y2 put (bingetr32 (f)); // length - if (fread (++ p, 8, (size_t) numberOfArguments - 5, f) < (size_t) numberOfArguments - 5) // text + if (uinteger_to_integer (fread (++ p, 8, integer_to_uinteger (numberOfArguments - 5), f)) < numberOfArguments - 5) // text Melder_throw (U"Error reading graphics recordings."); p += numberOfArguments - 6; } else { @@ -529,12 +537,14 @@ void Graphics_undoGroup (Graphics me) { integer lastMark = 0; // not yet found integer jrecord = 0; while (jrecord < my irecord) { // keep looking for marks until the end - int opcode = (int) my record [++ jrecord]; + const int opcode = (int) my record [++ jrecord]; integer number = (integer) my record [++ jrecord]; - if (opcode == MARK_GROUP) lastMark = jrecord - 1; // found a mark + if (opcode == MARK_GROUP) + lastMark = jrecord - 1; // found a mark jrecord += number; } - if (jrecord != my irecord) Melder_flushError (U"jrecord != my irecord: ", jrecord, U", ", my irecord); + if (jrecord != my irecord) + Melder_flushError (U"jrecord != my irecord: ", jrecord, U", ", my irecord); if (lastMark > 0) // found? my irecord = lastMark - 1; // forget all graphics from and including the last mark } diff --git a/sys/Graphics_text.cpp b/sys/Graphics_text.cpp index c622c40a..6185b1c4 100644 --- a/sys/Graphics_text.cpp +++ b/sys/Graphics_text.cpp @@ -47,7 +47,6 @@ extern const char * ipaSerifRegularPS []; static bool hasTimes, hasHelvetica, hasCourier, hasSymbol, hasPalatino, hasDoulos, hasCharis, hasIpaSerif; #define mac_MAXIMUM_FONT_SIZE 500 static CTFontRef theScreenFonts [1 + kGraphics_font_DINGBATS] [1+mac_MAXIMUM_FONT_SIZE] [1 + Graphics_BOLD_ITALIC]; - static RGBColor theWhiteColour = { 0xFFFF, 0xFFFF, 0xFFFF }, theBlueColour = { 0, 0, 0xFFFF }; #endif #if gdi @@ -522,8 +521,8 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, iam (GraphicsPostscript); bool onlyRegular = lc -> font.string [0] == 'S' || (lc -> font.string [0] == 'T' && lc -> font.string [1] == 'e'); // Symbol & SILDoulos ! - int slant = (lc -> style & Graphics_ITALIC) && onlyRegular; - int thick = (lc -> style & Graphics_BOLD) && onlyRegular; + bool slant = (lc -> style & Graphics_ITALIC) && onlyRegular; + bool thick = (lc -> style & Graphics_BOLD) && onlyRegular; if (lc -> font.string != my lastFid || lc -> size != my lastSize) my d_printf (my d_file, my languageLevel == 1 ? "/%s %d FONT\n" : "/%s %d selectfont\n", my lastFid = lc -> font.string, my lastSize = lc -> size); @@ -559,25 +558,11 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, } else if (my screen) { iam (GraphicsScreen); #if cairo - if (my duringXor) { - #if ALLOW_GDK_DRAWING - static GdkFont *font = nullptr; - if (! font) { - font = gdk_font_load ("-*-courier-medium-r-normal--*-120-*-*-*-*-iso8859-1"); - if (! font) { - font = gdk_font_load ("-*-courier 10 pitch-medium-r-normal--*-120-*-*-*-*-iso8859-1"); - } - } - if (font) { - gdk_draw_text_wc (my d_window, font, my d_gdkGraphicsContext, xDC, yDC, (const GdkWChar *) codes, nchars); - } - gdk_flush (); - #endif + if (! my d_cairoGraphicsContext) return; - } - if (! my d_cairoGraphicsContext) return; // TODO! - if (lc -> link) _Graphics_setColour (me, Melder_BLUE); + if (lc -> link) + _Graphics_setColour (me, Melder_BLUE); int font = lc -> font.integer_; cairo_save (my d_cairoGraphicsContext); cairo_translate (my d_cairoGraphicsContext, xDC, yDC); @@ -594,12 +579,18 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, pango_cairo_show_layout_line (my d_cairoGraphicsContext, pango_layout_get_line_readonly (layout, 0)); g_object_unref (layout); cairo_restore (my d_cairoGraphicsContext); - if (lc -> link) _Graphics_setColour (me, my colour); + if (lc -> link) + _Graphics_setColour (me, my colour); return; #elif gdi int font = lc -> font.integer_; conststringW codesW = Melder_peek32toW (codes); if (my duringXor) { + /* + On GDI, SetROP2 does not influence text drawing, + so we have to create a bitmap in the background + and use BitBlt with SRCINVERT as its ROP. + */ int descent = (1.0/216) * my fontSize * my resolution; int ascent = (1.0/72) * my fontSize * my resolution; int maxWidth = 800, maxHeight = 200; @@ -625,8 +616,12 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, BitBlt (my d_gdiGraphicsContext, xDC, yDC - ascent, width, bottom - top, dc, 0, top, SRCINVERT); return; } - SelectPen (my d_gdiGraphicsContext, my d_winPen), SelectBrush (my d_gdiGraphicsContext, my d_winBrush); - if (lc -> link) SetTextColor (my d_gdiGraphicsContext, RGB (0, 0, 255)); else SetTextColor (my d_gdiGraphicsContext, my d_winForegroundColour); + SelectPen (my d_gdiGraphicsContext, my d_winPen); + SelectBrush (my d_gdiGraphicsContext, my d_winBrush); + if (lc -> link) + SetTextColor (my d_gdiGraphicsContext, RGB (0, 0, 255)); + else + SetTextColor (my d_gdiGraphicsContext, my d_winForegroundColour); SelectFont (my d_gdiGraphicsContext, fonts [(int) my resolutionNumber] [font] [lc -> size] [lc -> style]); if (my textRotation == 0.0) { TextOutW (my d_gdiGraphicsContext, xDC, yDC, codesW, str16len ((const char16 *) codesW)); @@ -641,23 +636,24 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, TextOutW (my d_gdiGraphicsContext, 0, 0, codesW, str16len ((const char16 *) codesW)); RestoreDC (my d_gdiGraphicsContext, restore); } - if (lc -> link) SetTextColor (my d_gdiGraphicsContext, my d_winForegroundColour); + if (lc -> link) + SetTextColor (my d_gdiGraphicsContext, my d_winForegroundColour); SelectPen (my d_gdiGraphicsContext, GetStockPen (BLACK_PEN)), SelectBrush (my d_gdiGraphicsContext, GetStockBrush (NULL_BRUSH)); return; #elif quartz /* - * Determine the font family. - */ + Determine the font family. + */ int font = lc -> font.integer_; // the font of the first character /* - * Determine the style. - */ + Determine the style. + */ int style = lc -> style; // the style of the first character /* - * Determine the font-style combination. - */ + Determine the font-style combination. + */ CTFontRef ctFont = theScreenFonts [font] [lc -> size] [style]; if (! ctFont) { CTFontSymbolicTraits ctStyle = ( style & Graphics_BOLD ? kCTFontBoldTrait : 0 ) | ( lc -> style & Graphics_ITALIC ? kCTFontItalicTrait : 0 ); @@ -725,10 +721,10 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, CFStringRef s = CFStringCreateWithBytes (nullptr, (const UInt8 *) codes16, str16len (codes16) * 2, kCFStringEncodingUTF16LE, false); - int length = CFStringGetLength (s); + integer length = CFStringGetLength (s); #else NSString *s = [[NSString alloc] initWithBytes: codes16 length: str16len (codes16) * 2 encoding: NSUTF16LittleEndianStringEncoding]; - int length = [s length]; + integer length = [s length]; #endif CGFloat descent = CTFontGetDescent (ctFont); @@ -740,7 +736,7 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, static CFNumberRef cfKerning; if (! cfKerning) { - double kerning = 0.0; + const double kerning = 0.0; cfKerning = CFNumberCreate (kCFAllocatorDefault, kCFNumberDoubleType, & kerning); } CFAttributedStringSetAttribute (string, textRange, kCTKernAttributeName, cfKerning); @@ -754,40 +750,26 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, } CFAttributedStringSetAttribute (string, textRange, kCTParagraphStyleAttributeName, paragraphStyle); - RGBColor *macColor = lc -> link ? & theBlueColour : my duringXor ? & theWhiteColour : & my d_macColour; - CGColorRef color = CGColorCreateGenericRGB (macColor->red / 65536.0, macColor->green / 65536.0, macColor->blue / 65536.0, 1.0); + MelderColour colour = lc -> link ? Melder_BLUE : my colour; + CGColorRef color = CGColorCreateGenericRGB (colour.red, colour.green, colour.blue, 1.0); Melder_assert (color != nullptr); CFAttributedStringSetAttribute (string, textRange, kCTForegroundColorAttributeName, color); /* - * Draw. - */ + Draw. + */ CGContextSetTextMatrix (my d_macGraphicsContext, CGAffineTransformIdentity); // this could set the "current context" for CoreText CFRelease (color); - if (my d_macView) { - if (SUPPORT_DIRECT_DRAWING) { - [my d_macView lockFocus]; - my d_macGraphicsContext = (CGContextRef) [[NSGraphicsContext currentContext] graphicsPort]; - } - } CGContextSaveGState (my d_macGraphicsContext); CGContextTranslateCTM (my d_macGraphicsContext, xDC, yDC); - if (my yIsZeroAtTheTop) CGContextScaleCTM (my d_macGraphicsContext, 1.0, -1.0); + if (my yIsZeroAtTheTop) + CGContextScaleCTM (my d_macGraphicsContext, 1.0, -1.0); CGContextRotateCTM (my d_macGraphicsContext, my textRotation * NUMpi / 180.0); CTLineRef line = CTLineCreateWithAttributedString (string); - if (my duringXor) { - CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeDifference); - CGContextSetAllowsAntialiasing (my d_macGraphicsContext, false); - CTLineDraw (line, my d_macGraphicsContext); - CGContextSetBlendMode (my d_macGraphicsContext, kCGBlendModeNormal); - CGContextSetAllowsAntialiasing (my d_macGraphicsContext, true); - } else { - CTLineDraw (line, my d_macGraphicsContext); - } - //CGContextFlush (my d_macGraphicsContext); + CTLineDraw (line, my d_macGraphicsContext); CFRelease (line); CGContextRestoreGState (my d_macGraphicsContext); @@ -795,34 +777,11 @@ static void charDraw (void *void_me, int xDC, int yDC, _Graphics_widechar *lc, CFRelease (string); CFRelease (s); //CFRelease (ctFont); - if (my d_macView) { - if (SUPPORT_DIRECT_DRAWING) - [my d_macView unlockFocus]; - if (! my duringXor) { - //[my d_macView setNeedsDisplay: YES]; // otherwise, CoreText text may not be drawn - } - } return; #endif } } -static void initText (void *void_me) { - iam (Graphics); - if (my screen) { - iam (GraphicsScreen); - (void) me; - } -} - -static void exitText (void *void_me) { - iam (Graphics); - if (my screen) { - iam (GraphicsScreen); - (void) me; - } -} - #define MAX_LINK_LENGTH 300 static integer bufferSize; @@ -851,13 +810,22 @@ static int numberOfLinks = 0; static Graphics_Link links [100]; // a maximum of 100 links per string static void charSizes (Graphics me, _Graphics_widechar string [], bool measureEachCharacterSeparately) { - if (my postScript || (cairo && my duringXor) || (cairo && ! my screen)) { // TODO: use Pango measurements even without Cairo context (if no screen) + /* + Ideally, this function should work even in cases where there is no screen. + Example: a Praat script wants to draw a text inside a rectangle + and determines the witth of the rectangle by means of the "Text width (mm)" command. + Ideally, this script should run correctly from the command line. + On the Mac, `CTFramesetterSuggestFrameSizeWithConstraints` works correctly from thecommand line, + but on Linux, `pango_layout_get_extents` does not work if there is no d_cairoGraphicsContext. + (last checked 2020-07-17) + */ + if (my postScript || (cairo && ! my screen)) { // TODO: use Pango measurements even without Cairo context (if no screen) for (_Graphics_widechar *character = string; character -> kar > U'\t'; character ++) charSize (me, character); } else { /* - * Measure the size of each character. - */ + Measure the size of each character. + */ _Graphics_widechar *character; #if quartz || cairo #if cairo @@ -866,23 +834,23 @@ static void charSizes (Graphics me, _Graphics_widechar string [], bool measureEa int numberOfDiacritics = 0; for (_Graphics_widechar *lc = string; lc -> kar > U'\t'; lc ++) { /* - * Determine the font family. - */ + Determine the font family. + */ Longchar_Info info = lc -> karInfo; Melder_assert (info); int font = chooseFont (me, lc); lc -> font.string = nullptr; // this erases font.integer_! /* - * Determine the style. - */ + Determine the style. + */ int style = lc -> style; Melder_assert (style >= 0 && style <= Graphics_BOLD_ITALIC); #if quartz /* - * Determine and store the font-style combination. - */ + Determine and store the font-style combination. + */ CTFontRef ctFont = theScreenFonts [font] [100] [style]; if (! ctFont) { CTFontSymbolicTraits ctStyle = ( style & Graphics_BOLD ? kCTFontBoldTrait : 0 ) | ( lc -> style & Graphics_ITALIC ? kCTFontItalicTrait : 0 ); @@ -1075,11 +1043,6 @@ static void drawOneCell (Graphics me, int xDC, int yDC, _Graphics_widechar lc [] case Graphics_BASELINE: dy = 0; break; default: dy = 0; break; } - #if quartz - if (my screen) { - GraphicsQuartz_initDraw ((GraphicsScreen) me); - } - #endif if (my textRotation != 0.0) { double xbegin = dx, x = xbegin, cosa, sina; if (my textRotation == 90.0f) { cosa = 0.0; sina = 1.0; } @@ -1195,11 +1158,6 @@ static void drawOneCell (Graphics me, int xDC, int yDC, _Graphics_widechar lc [] my textX = (x - my deltaX) / my scaleX; my textY = (( my yIsZeroAtTheTop ? y + dy : y - dy ) - my deltaY) / my scaleY; } - #if quartz - if (my screen) { - GraphicsQuartz_exitDraw ((GraphicsScreen) me); - } - #endif } static struct { double width; kGraphics_horizontalAlignment alignment; } tabs [1 + 20] = { { 0, Graphics_CENTRE }, @@ -1440,12 +1398,11 @@ static void parseTextIntoCellsLinesRuns (Graphics me, conststring32 txt /* catta } double Graphics_textWidth (Graphics me, conststring32 txt) { - if (! initBuffer (txt)) return 0.0; - initText (me); + if (! initBuffer (txt)) + return 0.0; parseTextIntoCellsLinesRuns (me, txt, theWidechar); charSizes (me, theWidechar, false); double width = textWidth (theWidechar); - exitText (me); return width / my scaleX; } @@ -1456,16 +1413,19 @@ void Graphics_textRect (Graphics me, double x1, double x2, double y1, double y2, integer y1DC = y1 * my scaleY + my deltaY, y2DC = y2 * my scaleY + my deltaY; int availableHeight = my yIsZeroAtTheTop ? y1DC - y2DC : y2DC - y1DC, availableWidth = x2DC - x1DC; int linesAvailable = availableHeight / lineHeight, linesNeeded = 1, lines, iline; - if (linesAvailable <= 0) linesAvailable = 1; - if (availableWidth <= 0) return; - if (! initBuffer (txt)) return; - initText (me); + if (linesAvailable <= 0) + linesAvailable = 1; + if (availableWidth <= 0) + return; + if (! initBuffer (txt)) + return; parseTextIntoCellsLinesRuns (me, txt, theWidechar); charSizes (me, theWidechar, true); for (plc = theWidechar; plc -> kar > U'\t'; plc ++) { width += plc -> width; if (width > availableWidth) { - if (++ linesNeeded > linesAvailable) break; + if (++ linesNeeded > linesAvailable) + break; width = 0.0; } } @@ -1478,8 +1438,8 @@ void Graphics_textRect (Graphics me, double x1, double x2, double y1, double y2, width += plc -> width; if (width > availableWidth) flush = true; /* - * Trick for incorporating end-of-text. - */ + Trick for incorporating end-of-text. + */ if (! flush && plc [1]. kar <= U'\t') { Melder_assert (iline == lines); plc ++; // brr @@ -1504,46 +1464,44 @@ void Graphics_textRect (Graphics me, double x1, double x2, double y1, double y2, } } } - exitText (me); } void Graphics_text (Graphics me, double xWC, double yWC, conststring32 txt) { - if (my wrapWidth == 0.0 && str32chr (txt, U'\n') && my textRotation == 0.0) { - double lineSpacingWC = (1.2/72.0) * my fontSize * my resolution / fabs (my scaleY); - integer numberOfLines = 1; - for (const char32 *p = & txt [0]; *p != U'\0'; p ++) { - if (*p == U'\n') { - numberOfLines ++; - } - } - yWC += - my verticalTextAlignment == Graphics_TOP ? 0.0 : - my verticalTextAlignment == Graphics_HALF ? 0.5 * (numberOfLines - 1) * lineSpacingWC: - (numberOfLines - 1) * lineSpacingWC; - autostring32 linesToDraw = Melder_dup_f (txt); - char32 *p = & linesToDraw [0]; - for (;;) { - char32 *newline = str32chr (p, U'\n'); - if (newline) *newline = U'\0'; - Graphics_text (me, xWC, yWC, p); - yWC -= lineSpacingWC; - if (newline) { - p = newline + 1; - } else { - break; - } - } - return; - } - if (! initBuffer (txt)) return; - initText (me); - parseTextIntoCellsLinesRuns (me, txt, theWidechar); - drawCells (me, xWC, yWC, theWidechar); - exitText (me); if (my recording) { conststring8 txt_utf8 = Melder_peek32to8 (txt); int length = strlen (txt_utf8) / sizeof (double) + 1; op (TEXT, 3 + length); put (xWC); put (yWC); sput (txt_utf8, length) + } else { + if (my wrapWidth == 0.0 && str32chr (txt, U'\n') && my textRotation == 0.0) { + double lineSpacingWC = (1.2/72.0) * my fontSize * my resolution / fabs (my scaleY); + integer numberOfLines = 1; + for (const char32 *p = & txt [0]; *p != U'\0'; p ++) { + if (*p == U'\n') + numberOfLines ++; + } + yWC += + my verticalTextAlignment == Graphics_TOP ? 0.0 : + my verticalTextAlignment == Graphics_HALF ? 0.5 * (numberOfLines - 1) * lineSpacingWC: + (numberOfLines - 1) * lineSpacingWC; + autostring32 linesToDraw = Melder_dup_f (txt); + char32 *p = & linesToDraw [0]; + for (;;) { + char32 *newline = str32chr (p, U'\n'); + if (newline) *newline = U'\0'; + Graphics_text (me, xWC, yWC, p); + yWC -= lineSpacingWC; + if (newline) { + p = newline + 1; + } else { + break; + } + } + return; + } + if (! initBuffer (txt)) + return; + parseTextIntoCellsLinesRuns (me, txt, theWidechar); + drawCells (me, xWC, yWC, theWidechar); } } @@ -1554,8 +1512,8 @@ int Graphics_getLinks (Graphics_Link **plinks) { *plinks = & links [0]; return n static double psTextWidth (_Graphics_widechar string [], bool useSilipaPS) { /* - * The following has to be kept IN SYNC with GraphicsPostscript::charSize. - */ + The following has to be kept IN SYNC with GraphicsPostscript::charSize. + */ double textWidth = 0; for (_Graphics_widechar *character = & string [0]; character -> kar > U'\t'; character ++) { Longchar_Info info = character -> karInfo; @@ -1631,17 +1589,22 @@ double Graphics_textWidth_ps (Graphics me, conststring32 txt, bool useSilipaPS) #if quartz bool _GraphicsMac_tryToInitializeFonts () { static bool inited = false; - if (inited) return true; + if (inited) + return true; NSArray *fontNames = [[NSFontManager sharedFontManager] availableFontFamilies]; hasTimes = [fontNames containsObject: @"Times"]; - if (! hasTimes) hasTimes = [fontNames containsObject: @"Times New Roman"]; + if (! hasTimes) + hasTimes = [fontNames containsObject: @"Times New Roman"]; hasHelvetica = [fontNames containsObject: @"Helvetica"]; - if (! hasHelvetica) hasHelvetica = [fontNames containsObject: @"Arial"]; + if (! hasHelvetica) + hasHelvetica = [fontNames containsObject: @"Arial"]; hasCourier = [fontNames containsObject: @"Courier"]; - if (! hasCourier) hasCourier = [fontNames containsObject: @"Courier New"]; + if (! hasCourier) + hasCourier = [fontNames containsObject: @"Courier New"]; hasSymbol = [fontNames containsObject: @"Symbol"]; hasPalatino = [fontNames containsObject: @"Palatino"]; - if (! hasPalatino) hasPalatino = [fontNames containsObject: @"Book Antiqua"]; + if (! hasPalatino) + hasPalatino = [fontNames containsObject: @"Book Antiqua"]; hasDoulos = [fontNames containsObject: @"Doulos SIL"]; hasCharis = [fontNames containsObject: @"Charis SIL"]; hasIpaSerif = hasDoulos || hasCharis; @@ -1652,16 +1615,15 @@ double Graphics_textWidth_ps (Graphics me, conststring32 txt, bool useSilipaPS) #if cairo static const char *testFont (const char *fontName) { - PangoFontDescription *pangoFontDescription, *pangoFontDescription2; - PangoFont *pangoFont; - pangoFontDescription = pango_font_description_from_string (fontName); - pangoFont = pango_font_map_load_font (thePangoFontMap, thePangoContext, pangoFontDescription); - pangoFontDescription2 = pango_font_describe (pangoFont); + PangoFontDescription *pangoFontDescription = pango_font_description_from_string (fontName); + PangoFont *pangoFont = pango_font_map_load_font (thePangoFontMap, thePangoContext, pangoFontDescription); + PangoFontDescription *pangoFontDescription2 = pango_font_describe (pangoFont); return pango_font_description_get_family (pangoFontDescription2); } bool _GraphicsLin_tryToInitializeFonts () { static bool inited = false; - if (inited) return true; + if (inited) + return true; thePangoFontMap = pango_cairo_font_map_get_default (); thePangoContext = pango_font_map_create_context (thePangoFontMap); #if 0 /* For debugging: list all fonts. */ @@ -1742,15 +1704,15 @@ void Graphics_setFontStyle (Graphics me, int style) { } void Graphics_setItalic (Graphics me, bool onoff) { - if (onoff) my fontStyle |= Graphics_ITALIC; else my fontStyle &= ~ Graphics_ITALIC; + Graphics_setFontStyle (me, ( onoff ? my fontStyle | Graphics_ITALIC : my fontStyle & ~ Graphics_ITALIC )); } void Graphics_setBold (Graphics me, bool onoff) { - if (onoff) my fontStyle |= Graphics_BOLD; else my fontStyle &= ~ Graphics_BOLD; + Graphics_setFontStyle (me, ( onoff ? my fontStyle | Graphics_BOLD : my fontStyle & ~ Graphics_BOLD )); } void Graphics_setCode (Graphics me, bool onoff) { - if (onoff) my fontStyle |= Graphics_CODE; else my fontStyle &= ~ Graphics_CODE; + Graphics_setFontStyle (me, ( onoff ? my fontStyle | Graphics_CODE : my fontStyle & ~ Graphics_CODE )); } void Graphics_setTextRotation (Graphics me, double angle) { diff --git a/sys/Graphics_utils.cpp b/sys/Graphics_utils.cpp index ddf5d757..d35225b4 100644 --- a/sys/Graphics_utils.cpp +++ b/sys/Graphics_utils.cpp @@ -28,27 +28,30 @@ /********** Drawing into margins. **********/ void Graphics_drawInnerBox (Graphics me) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + const int original_lineType = my lineType; + const double original_lineWidth = my lineWidth; + const MelderColour original_colour = my colour; + Graphics_setInner (me); Graphics_setWindow (me, 0.0, 1.0, 0.0, 1.0); Graphics_setLineType (me, Graphics_DRAWN); - Graphics_setLineWidth (me, 2.0 * lineWidth); + Graphics_setLineWidth (me, 2.0 * original_lineWidth); Graphics_setColour (me, Melder_BLACK); Graphics_rectangle (me, 0.0, 1.0, 0.0, 1.0); Graphics_unsetInner (me); - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setLineType (me, lineType); - Graphics_setLineWidth (me, lineWidth); - Graphics_setColour (me, colour); + + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setLineType (me, original_lineType); + Graphics_setLineWidth (me, original_lineWidth); + Graphics_setColour (me, original_colour); } void Graphics_textLeft (Graphics me, bool farr, conststring32 text) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int vert = ( farr ? Graphics_TOP : Graphics_BOTTOM ); - MelderColour colour = my colour; + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + const int vert = ( farr ? Graphics_TOP : Graphics_BOTTOM ); + const MelderColour original_colour = my colour; + Graphics_setColour (me, Melder_BLACK); Graphics_setWindow (me, 0.0, 1.0, 0.0, 1.0); Graphics_setTextRotation (me, 90.0); @@ -58,34 +61,38 @@ void Graphics_textLeft (Graphics me, bool farr, conststring32 text) { Graphics_text (me, 0.0, 0.5, text); if (! farr) Graphics_unsetInner (me); + Graphics_setTextRotation (me, 0.0); - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setColour (me, colour); + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setColour (me, original_colour); } void Graphics_textRight (Graphics me, bool farr, conststring32 text) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int vert = ( farr ? Graphics_TOP : Graphics_BOTTOM ); - MelderColour colour = my colour; + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + const int vert = ( farr ? Graphics_TOP : Graphics_BOTTOM ); + const MelderColour original_colour = my colour; + + Graphics_setWindow (me, 0.0, 1.0, 0.0, 1.0); Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, vert); - Graphics_setWindow (me, 0.0, 1.0, 0.0, 1.0); Graphics_setTextRotation (me, 270.0); if (! farr) Graphics_setInner (me); Graphics_text (me, 1.0, 0.5, text); if (! farr) Graphics_unsetInner (me); + Graphics_setTextRotation (me, 0.0); - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setColour (me, colour); + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setColour (me, original_colour); } void Graphics_textBottom (Graphics me, bool farr, conststring32 text) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - MelderColour colour = my colour; - Graphics_setColour (me, Melder_BLACK); + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + const MelderColour original_colour = my colour; + Graphics_setWindow (me, 0.0, 1.0, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); if (farr) { Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_BOTTOM); Graphics_text (me, 0.5, 0.0, text); @@ -95,15 +102,17 @@ void Graphics_textBottom (Graphics me, bool farr, conststring32 text) { Graphics_text (me, 0.5, - my vertTick, text); Graphics_unsetInner (me); } - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setColour (me, colour); + + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setColour (me, original_colour); } void Graphics_textTop (Graphics me, bool farr, conststring32 text) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - MelderColour colour = my colour; - Graphics_setColour (me, Melder_BLACK); + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + const MelderColour original_colour = my colour; + Graphics_setWindow (me, 0.0, 1.0, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); if (farr) { Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_TOP); Graphics_text (me, 0.5, 1.0, text); @@ -113,163 +122,181 @@ void Graphics_textTop (Graphics me, bool farr, conststring32 text) { Graphics_text (me, 0.5, 1.0 + my vertTick, text); Graphics_unsetInner (me); } - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setColour (me, colour); + + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setColour (me, original_colour); } void Graphics_marksLeft (Graphics me, int numberOfMarks, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + const int original_lineType = my lineType; + const double original_lineWidth = my lineWidth; + const MelderColour original_colour = my colour; if (numberOfMarks < 2) return; + + Graphics_setWindow (me, 0.0, 1.0, original_y1WC, original_y2WC); Graphics_setColour (me, Melder_BLACK); - Graphics_setWindow (me, 0.0, 1.0, y1WC, y2WC); Graphics_setTextAlignment (me, Graphics_RIGHT, Graphics_HALF); Graphics_setInner (me); if (haveTicks) { Graphics_setLineType (me, Graphics_DRAWN); - Graphics_setLineWidth (me, 2.0 * lineWidth); + Graphics_setLineWidth (me, 2.0 * original_lineWidth); } for (int i = 1; i <= numberOfMarks; i ++) { - double f = (i - 1.0) / (numberOfMarks - 1), yWC = y1WC + (y2WC - y1WC) * f; + const double f = (i - 1.0) / (numberOfMarks - 1); + const double yWC = original_y1WC + (original_y2WC - original_y1WC) * f; if (haveNumbers) Graphics_text (me, - my horTick, yWC, Melder_float (Melder_half (yWC))); if (haveTicks) Graphics_line (me, - my horTick, yWC, 0, yWC); } if (haveTicks) - Graphics_setLineWidth (me, lineWidth); + Graphics_setLineWidth (me, original_lineWidth); if (haveDottedLines && numberOfMarks > 2) { Graphics_setLineType (me, Graphics_DOTTED); - Graphics_setLineWidth (me, 0.67 * lineWidth); + Graphics_setLineWidth (me, 0.67 * original_lineWidth); for (int i = 2; i < numberOfMarks; i ++) { - double f = (i - 1.0) / (numberOfMarks - 1), yWC = y1WC + (y2WC - y1WC) * f; + const double f = (i - 1.0) / (numberOfMarks - 1); + const double yWC = original_y1WC + (original_y2WC - original_y1WC) * f; Graphics_line (me, 0.0, yWC, 1.0, yWC); } - Graphics_setLineWidth (me, lineWidth); + Graphics_setLineWidth (me, original_lineWidth); } Graphics_unsetInner (me); - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setLineType (me, lineType); - Graphics_setColour (me, colour); + + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setLineType (me, original_lineType); + Graphics_setColour (me, original_colour); } void Graphics_marksRight (Graphics me, int numberOfMarks, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + const int original_lineType = my lineType; + const double original_lineWidth = my lineWidth; + const MelderColour original_colour = my colour; if (numberOfMarks < 2) return; + + Graphics_setWindow (me, 0.0, 1.0, original_y1WC, original_y2WC); Graphics_setColour (me, Melder_BLACK); - Graphics_setWindow (me, 0.0, 1.0, y1WC, y2WC); Graphics_setTextAlignment (me, Graphics_LEFT, Graphics_HALF); Graphics_setInner (me); if (haveTicks) { Graphics_setLineType (me, Graphics_DRAWN); - Graphics_setLineWidth (me, 2.0 * lineWidth); + Graphics_setLineWidth (me, 2.0 * original_lineWidth); } for (int i = 1; i <= numberOfMarks; i ++) { - double f = (i - 1.0) / (numberOfMarks - 1), yWC = y1WC + (y2WC - y1WC) * f; + const double f = (i - 1.0) / (numberOfMarks - 1); + const double yWC = original_y1WC + (original_y2WC - original_y1WC) * f; if (haveNumbers) Graphics_text (me, 1.0 + my horTick, yWC, Melder_float (Melder_half (yWC))); if (haveTicks) Graphics_line (me, 1.0, yWC, 1.0 + my horTick, yWC); } if (haveTicks) - Graphics_setLineWidth (me, lineWidth); + Graphics_setLineWidth (me, original_lineWidth); if (haveDottedLines && numberOfMarks > 2) { Graphics_setLineType (me, Graphics_DOTTED); - Graphics_setLineWidth (me, 0.67 * lineWidth); + Graphics_setLineWidth (me, 0.67 * original_lineWidth); for (int i = 2; i < numberOfMarks; i ++) { - double f = (i - 1.0) / (numberOfMarks - 1), yWC = y1WC + (y2WC - y1WC) * f; + const double f = (i - 1.0) / (numberOfMarks - 1); + const double yWC = original_y1WC + (original_y2WC - original_y1WC) * f; Graphics_line (me, 0.0, yWC, 1.0, yWC); } - Graphics_setLineWidth (me, lineWidth); + Graphics_setLineWidth (me, original_lineWidth); } Graphics_unsetInner (me); - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setLineType (me, lineType); - Graphics_setColour (me, colour); + + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setLineType (me, original_lineType); + Graphics_setColour (me, original_colour); } void Graphics_marksBottom (Graphics me, int numberOfMarks, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + int original_lineType = my lineType; + const double original_lineWidth = my lineWidth; + const MelderColour original_colour = my colour; if (numberOfMarks < 2) return; + + Graphics_setWindow (me, original_x1WC, original_x2WC, 0.0, 1.0); Graphics_setColour (me, Melder_BLACK); - Graphics_setWindow (me, x1WC, x2WC, 0.0, 1.0); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_TOP); Graphics_setInner (me); if (haveTicks) { Graphics_setLineType (me, Graphics_DRAWN); - Graphics_setLineWidth (me, 2.0 * lineWidth); + Graphics_setLineWidth (me, 2.0 * original_lineWidth); } for (int i = 1; i <= numberOfMarks; i ++) { - double f = (i - 1.0) / (numberOfMarks - 1), xWC = x1WC + (x2WC - x1WC) * f; + const double f = (i - 1.0) / (numberOfMarks - 1); + const double xWC = original_x1WC + (original_x2WC - original_x1WC) * f; if (haveNumbers) Graphics_text (me, xWC, - my vertTick, Melder_float (Melder_half (xWC))); if (haveTicks) Graphics_line (me, xWC, - my vertTick, xWC, 0); } if (haveTicks) - Graphics_setLineWidth (me, lineWidth); + Graphics_setLineWidth (me, original_lineWidth); if (haveDottedLines && numberOfMarks > 2) { Graphics_setLineType (me, Graphics_DOTTED); - Graphics_setLineWidth (me, 0.67 * lineWidth); + Graphics_setLineWidth (me, 0.67 * original_lineWidth); for (int i = 2; i < numberOfMarks; i ++) { - double f = (i - 1.0) / (numberOfMarks - 1), xWC = x1WC + (x2WC - x1WC) * f; + const double f = (i - 1.0) / (numberOfMarks - 1); + const double xWC = original_x1WC + (original_x2WC - original_x1WC) * f; Graphics_line (me, xWC, 0.0, xWC, 1.0); } - Graphics_setLineWidth (me, lineWidth); + Graphics_setLineWidth (me, original_lineWidth); } Graphics_unsetInner (me); - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setLineType (me, lineType); - Graphics_setColour (me, colour); + + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setLineType (me, original_lineType); + Graphics_setColour (me, original_colour); } void Graphics_marksTop (Graphics me, int numberOfMarks, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double original_x1WC = my d_x1WC, original_x2WC = my d_x2WC, original_y1WC = my d_y1WC, original_y2WC = my d_y2WC; + const int original_lineType = my lineType; + const double original_lineWidth = my lineWidth; + const MelderColour original_colour = my colour; if (numberOfMarks < 2) return; + + Graphics_setWindow (me, original_x1WC, original_x2WC, 0.0, 1.0); Graphics_setColour (me, Melder_BLACK); - Graphics_setWindow (me, x1WC, x2WC, 0.0, 1.0); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_BOTTOM); Graphics_setInner (me); if (haveTicks) { Graphics_setLineType (me, Graphics_DRAWN); - Graphics_setLineWidth (me, 2.0 * lineWidth); + Graphics_setLineWidth (me, 2.0 * original_lineWidth); } for (int i = 1; i <= numberOfMarks; i ++) { - double f = (i - 1.0) / (numberOfMarks - 1), xWC = x1WC + (x2WC - x1WC) * f; + const double f = (i - 1.0) / (numberOfMarks - 1); + const double xWC = original_x1WC + (original_x2WC - original_x1WC) * f; if (haveNumbers) Graphics_text (me, xWC, 1.0 + my vertTick, Melder_float (Melder_half (xWC))); if (haveTicks) Graphics_line (me, xWC, 1.0, xWC, 1.0 + my vertTick); } - if (haveTicks) Graphics_setLineWidth (me, lineWidth); + if (haveTicks) + Graphics_setLineWidth (me, original_lineWidth); if (haveDottedLines && numberOfMarks > 2) { Graphics_setLineType (me, Graphics_DOTTED); - Graphics_setLineWidth (me, 0.67 * lineWidth); + Graphics_setLineWidth (me, 0.67 * original_lineWidth); for (int i = 2; i < numberOfMarks; i ++) { - double f = (i - 1.0) / (numberOfMarks - 1), xWC = x1WC + (x2WC - x1WC) * f; + const double f = (i - 1.0) / (numberOfMarks - 1); + const double xWC = original_x1WC + (original_x2WC - original_x1WC) * f; Graphics_line (me, xWC, 0.0, xWC, 1.0); } - Graphics_setLineWidth (me, lineWidth); + Graphics_setLineWidth (me, original_lineWidth); } Graphics_unsetInner (me); - Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); - Graphics_setLineType (me, lineType); - Graphics_setColour (me, colour); + + Graphics_setWindow (me, original_x1WC, original_x2WC, original_y1WC, original_y2WC); + Graphics_setLineType (me, original_lineType); + Graphics_setColour (me, original_colour); } #define MAXNUM_MARKS_PER_DECADE 7 @@ -285,20 +312,18 @@ static double decade_y [1 + MAXNUM_MARKS_PER_DECADE] [1 + MAXNUM_MARKS_PER_DECAD }; void Graphics_marksLeftLogarithmic (Graphics me, int numberOfMarksPerDecade, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1 = my d_x1WC, x2 = my d_x2WC, y1 = my d_y1WC, y2 = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; - if (numberOfMarksPerDecade < 1) - numberOfMarksPerDecade = 1; - if (numberOfMarksPerDecade > MAXNUM_MARKS_PER_DECADE) - numberOfMarksPerDecade = MAXNUM_MARKS_PER_DECADE; - if (y1 > 300 || y2 > 300) + const double x1 = my d_x1WC, x2 = my d_x2WC, y1 = my d_y1WC, y2 = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + Melder_clip (1, & numberOfMarksPerDecade, MAXNUM_MARKS_PER_DECADE); + if (y1 > 300.0 || y2 > 300.0) return; - double py1 = pow (10, y1 + ( y1 < y2 ? -1e-6 : 1e-6 )); - double py2 = pow (10, y2 + ( y1 < y2 ? 1e-6 : -1e-6 )); - Graphics_setColour (me, Melder_BLACK); + + const double py1 = pow (10.0, y1 + ( y1 < y2 ? -1e-6 : 1e-6 )); + const double py2 = pow (10.0, y2 + ( y1 < y2 ? 1e-6 : -1e-6 )); Graphics_setWindow (me, 0, 1, y1, y2); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_RIGHT, Graphics_HALF); Graphics_setInner (me); for (int i = 1; i <= numberOfMarksPerDecade; i ++) { @@ -326,24 +351,24 @@ void Graphics_marksLeftLogarithmic (Graphics me, int numberOfMarksPerDecade, boo } } Graphics_unsetInner (me); + Graphics_setWindow (me, x1, x2, y1, y2); Graphics_setColour (me, colour); } void Graphics_marksRightLogarithmic (Graphics me, int numberOfMarksPerDecade, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1 = my d_x1WC, x2 = my d_x2WC, y1 = my d_y1WC, y2 = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; - if (numberOfMarksPerDecade < 1) - numberOfMarksPerDecade = 1; - if (numberOfMarksPerDecade > MAXNUM_MARKS_PER_DECADE) - numberOfMarksPerDecade = MAXNUM_MARKS_PER_DECADE; - if (y1 > 300.0 || y2 > 300.0) return; - double py1 = pow (10.0, y1 + ( y1 < y2 ? -1e-6 : 1e-6 )); - double py2 = pow (10.0, y2 + ( y1 < y2 ? 1e-6 : -1e-6 )); - Graphics_setColour (me, Melder_BLACK); + const double x1 = my d_x1WC, x2 = my d_x2WC, y1 = my d_y1WC, y2 = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + Melder_clip (1, & numberOfMarksPerDecade, MAXNUM_MARKS_PER_DECADE); + if (y1 > 300.0 || y2 > 300.0) + return; + + const double py1 = pow (10.0, y1 + ( y1 < y2 ? -1e-6 : 1e-6 )); + const double py2 = pow (10.0, y2 + ( y1 < y2 ? 1e-6 : -1e-6 )); Graphics_setWindow (me, 0.0, 1.0, y1, y2); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_LEFT, Graphics_HALF); Graphics_setInner (me); for (int i = 1; i <= numberOfMarksPerDecade; i ++) { @@ -353,7 +378,8 @@ void Graphics_marksRightLogarithmic (Graphics me, int numberOfMarksPerDecade, bo while (y >= (y1 MAXNUM_MARKS_PER_DECADE) - numberOfMarksPerDecade = MAXNUM_MARKS_PER_DECADE; + const double x1 = my d_x1WC, x2 = my d_x2WC, y1 = my d_y1WC, y2 = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + Melder_clip (1, & numberOfMarksPerDecade, MAXNUM_MARKS_PER_DECADE); if (x1 > 300.0 || x2 > 300.0) return; - double px1 = pow (10.0, x1 + ( x1 < x2 ? -1e-6 : 1e-6 )); - double px2 = pow (10.0, x2 + ( x1 < x2 ? 1e-6 : -1e-6 )); - Graphics_setColour (me, Melder_BLACK); + + const double px1 = pow (10.0, x1 + ( x1 < x2 ? -1e-6 : 1e-6 )); + const double px2 = pow (10.0, x2 + ( x1 < x2 ? 1e-6 : -1e-6 )); Graphics_setWindow (me, x1, x2, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_BOTTOM); Graphics_setInner (me); for (int i = 1; i <= numberOfMarksPerDecade; i ++) { @@ -398,7 +423,8 @@ void Graphics_marksTopLogarithmic (Graphics me, int numberOfMarksPerDecade, bool while (x >= (x1 MAXNUM_MARKS_PER_DECADE) - numberOfMarksPerDecade = MAXNUM_MARKS_PER_DECADE; + const double x1 = my d_x1WC, x2 = my d_x2WC, y1 = my d_y1WC, y2 = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + Melder_clip (1, & numberOfMarksPerDecade, MAXNUM_MARKS_PER_DECADE); if (x1 > 300.0 || x2 > 300.0) return; - double px1 = pow (10.0, x1 + ( x1 < x2 ? -1e-6 : 1e-6 )); - double px2 = pow (10.0, x2 + ( x1 < x2 ? 1e-6 : -1e-6 )); - Graphics_setColour (me, Melder_BLACK); + + const double px1 = pow (10.0, x1 + ( x1 < x2 ? -1e-6 : 1e-6 )); + const double px2 = pow (10.0, x2 + ( x1 < x2 ? 1e-6 : -1e-6 )); Graphics_setWindow (me, x1, x2, 0, 1); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_TOP); Graphics_setInner (me); for (int i = 1; i <= numberOfMarksPerDecade; i ++) { @@ -461,17 +486,19 @@ void Graphics_marksBottomLogarithmic (Graphics me, int numberOfMarksPerDecade, b } } Graphics_unsetInner (me); + Graphics_setWindow (me, x1, x2, y1, y2); Graphics_setColour (me, colour); } void Graphics_markLeft (Graphics me, double position, bool hasNumber, bool hasTick, bool hasDottedLine, conststring32 text /* cattable */) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; - Graphics_setColour (me, Melder_BLACK); + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + Graphics_setWindow (me, 0.0, 1.0, y1WC, y2WC); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_RIGHT, Graphics_HALF); Graphics_setInner (me); if (hasNumber) @@ -491,18 +518,20 @@ void Graphics_markLeft (Graphics me, double position, bool hasNumber, bool hasTi if (text && text [0]) Graphics_text (me, - my horTick, position, text); // 'text' has to stay valid until here; no Graphics is allowed to use the cat buffer! Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_markRight (Graphics me, double position, bool hasNumber, bool hasTick, bool hasDottedLine, conststring32 text /* cattable */) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; - Graphics_setColour (me, Melder_BLACK); + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + Graphics_setWindow (me, 0.0, 1.0, y1WC, y2WC); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_LEFT, Graphics_HALF); Graphics_setInner (me); if (hasNumber) @@ -522,18 +551,20 @@ void Graphics_markRight (Graphics me, double position, bool hasNumber, bool hasT if (text && text [0]) Graphics_text (me, 1.0 + my horTick, position, text); Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_markTop (Graphics me, double position, bool hasNumber, bool hasTick, bool hasDottedLine, conststring32 text /* cattable */) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; - Graphics_setColour (me, Melder_BLACK); + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + Graphics_setWindow (me, x1WC, x2WC, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_BOTTOM); Graphics_setInner (me); if (hasNumber) @@ -553,18 +584,20 @@ void Graphics_markTop (Graphics me, double position, bool hasNumber, bool hasTic if (text && text [0]) Graphics_text (me, position, 1.0 + my vertTick, text); Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_markBottom (Graphics me, double position, bool hasNumber, bool hasTick, bool hasDottedLine, conststring32 text /* cattable */) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; - Graphics_setColour (me, Melder_BLACK); + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + Graphics_setWindow (me, x1WC, x2WC, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_TOP); Graphics_setInner (me); if (hasNumber) @@ -584,20 +617,22 @@ void Graphics_markBottom (Graphics me, double position, bool hasNumber, bool has if (text && text [0]) Graphics_text (me, position, - my vertTick, text); Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_markLeftLogarithmic (Graphics me, double position, bool hasNumber, bool hasTick, bool hasDottedLine, conststring32 text /* cattable */) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; if (position <= 0.0) return; + + Graphics_setWindow (me, 0.0, 1.0, y1WC, y2WC); Graphics_setColour (me, Melder_BLACK); - Graphics_setWindow (me, 0, 1, y1WC, y2WC); Graphics_setTextAlignment (me, Graphics_RIGHT, Graphics_HALF); Graphics_setInner (me); if (hasNumber) @@ -617,19 +652,22 @@ void Graphics_markLeftLogarithmic (Graphics me, double position, bool hasNumber, if (text && text [0]) Graphics_text (me, - my horTick, log10 (position), text); Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_markRightLogarithmic (Graphics me, double position, bool hasNumber, bool hasTick, bool hasDottedLine, conststring32 text /* cattable */) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; - if (position <= 0.0) return; - Graphics_setColour (me, Melder_BLACK); + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; + if (position <= 0.0) + return; + Graphics_setWindow (me, 0.0, 1.0, y1WC, y2WC); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_LEFT, Graphics_HALF); Graphics_setInner (me); if (hasNumber) @@ -649,20 +687,22 @@ void Graphics_markRightLogarithmic (Graphics me, double position, bool hasNumber if (text && text [0]) Graphics_text (me, 1.0 + my horTick, log10 (position), text); Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_markTopLogarithmic (Graphics me, double position, bool hasNumber, bool hasTick, bool hasDottedLine, conststring32 text /* cattable */) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; if (position <= 0.0) return; - Graphics_setColour (me, Melder_BLACK); + Graphics_setWindow (me, x1WC, x2WC, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_BOTTOM); Graphics_setInner (me); if (hasNumber) @@ -682,20 +722,22 @@ void Graphics_markTopLogarithmic (Graphics me, double position, bool hasNumber, if (text && text [0]) Graphics_text (me, log10 (position), 1.0 + my vertTick, text); Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_markBottomLogarithmic (Graphics me, double position, bool hasNumber, bool hasTick, bool hasDottedLine, conststring32 text /* cattable */) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; if (position <= 0.0) return; - Graphics_setColour (me, Melder_BLACK); + Graphics_setWindow (me, x1WC, x2WC, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_TOP); Graphics_setInner (me); if (hasNumber) @@ -715,22 +757,23 @@ void Graphics_markBottomLogarithmic (Graphics me, double position, bool hasNumbe if (text && text [0]) Graphics_text (me, log10 (position), - my vertTick, text); Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_marksLeftEvery (Graphics me, double units, double distance, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - integer first, last; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; distance *= units; - first = Melder_iceiling (( y1WC < y2WC ? y1WC : y2WC ) / distance - 1e-5); - last = Melder_ifloor (( y1WC < y2WC ? y2WC : y1WC ) / distance + 1e-5); + + const integer first = Melder_iceiling (( y1WC < y2WC ? y1WC : y2WC ) / distance - 1e-5); + const integer last = Melder_ifloor (( y1WC < y2WC ? y2WC : y1WC ) / distance + 1e-5); + Graphics_setWindow (me, 0.0, 1.0, y1WC, y2WC); Graphics_setColour (me, Melder_BLACK); - Graphics_setWindow (me, 0, 1, y1WC, y2WC); Graphics_setTextAlignment (me, Graphics_RIGHT, Graphics_HALF); Graphics_setInner (me); if (haveTicks) { @@ -738,7 +781,7 @@ void Graphics_marksLeftEvery (Graphics me, double units, double distance, bool h Graphics_setLineWidth (me, 2.0 * lineWidth); } for (integer i = first; i <= last; i ++) { - double yWC = i * distance; + const double yWC = i * distance; if (haveNumbers) Graphics_text (me, - my horTick, yWC, Melder_float (Melder_half (yWC / units))); if (haveTicks) @@ -750,30 +793,31 @@ void Graphics_marksLeftEvery (Graphics me, double units, double distance, bool h Graphics_setLineType (me, Graphics_DOTTED); Graphics_setLineWidth (me, 0.67 * lineWidth); for (integer i = first; i <= last; i ++) { - double yWC = i * distance; + const double yWC = i * distance; Graphics_line (me, 0.0, yWC, 1.0, yWC); } Graphics_setLineWidth (me, lineWidth); } Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_marksRightEvery (Graphics me, double units, double distance, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - integer first, last; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; distance *= units; - first = Melder_iceiling (( y1WC < y2WC ? y1WC : y2WC ) / distance - 1e-5); - last = Melder_ifloor (( y1WC < y2WC ? y2WC : y1WC ) / distance + 1e-5); + + const integer first = Melder_iceiling (( y1WC < y2WC ? y1WC : y2WC ) / distance - 1e-5); + const integer last = Melder_ifloor (( y1WC < y2WC ? y2WC : y1WC ) / distance + 1e-5); if (first > last) - return; + return; // TODO: describe why this is. ppgb 2020-10-01 + Graphics_setWindow (me, 0.0, 1.0, y1WC, y2WC); Graphics_setColour (me, Melder_BLACK); - Graphics_setWindow (me, 0, 1, y1WC, y2WC); Graphics_setTextAlignment (me, Graphics_LEFT, Graphics_HALF); Graphics_setInner (me); if (haveTicks) { @@ -781,7 +825,7 @@ void Graphics_marksRightEvery (Graphics me, double units, double distance, bool Graphics_setLineWidth (me, 2.0 * lineWidth); } for (integer i = first; i <= last; i ++) { - double yWC = i * distance; + const double yWC = i * distance; if (haveNumbers) Graphics_text (me, 1.0 + my horTick, yWC, Melder_float (Melder_half (yWC / units))); if (haveTicks) @@ -793,28 +837,29 @@ void Graphics_marksRightEvery (Graphics me, double units, double distance, bool Graphics_setLineType (me, Graphics_DOTTED); Graphics_setLineWidth (me, 0.67 * lineWidth); for (integer i = first; i <= last; i ++) { - double yWC = i * distance; + const double yWC = i * distance; Graphics_line (me, 0.0, yWC, 1.0, yWC); } Graphics_setLineWidth (me, lineWidth); } Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_marksBottomEvery (Graphics me, double units, double distance, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - integer first, last; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; distance *= units; - first = Melder_iceiling (( x1WC < x2WC ? x1WC : x2WC ) / distance - 1e-5); - last = Melder_ifloor (( x1WC < x2WC ? x2WC : x1WC ) / distance + 1e-5); - Graphics_setColour (me, Melder_BLACK); + + const integer first = Melder_iceiling (( x1WC < x2WC ? x1WC : x2WC ) / distance - 1e-5); + const integer last = Melder_ifloor (( x1WC < x2WC ? x2WC : x1WC ) / distance + 1e-5); Graphics_setWindow (me, x1WC, x2WC, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_TOP); Graphics_setInner (me); if (haveTicks) { @@ -822,9 +867,11 @@ void Graphics_marksBottomEvery (Graphics me, double units, double distance, bool Graphics_setLineWidth (me, 2.0 * lineWidth); } for (integer i = first; i <= last; i ++) { - double xWC = i * distance; - if (haveNumbers) Graphics_text (me, xWC, - my vertTick, Melder_float (Melder_half (xWC / units))); - if (haveTicks) Graphics_line (me, xWC, - my vertTick, xWC, 0.0); + const double xWC = i * distance; + if (haveNumbers) + Graphics_text (me, xWC, - my vertTick, Melder_float (Melder_half (xWC / units))); + if (haveTicks) + Graphics_line (me, xWC, - my vertTick, xWC, 0.0); } if (haveTicks) Graphics_setLineWidth (me, lineWidth); @@ -832,28 +879,29 @@ void Graphics_marksBottomEvery (Graphics me, double units, double distance, bool Graphics_setLineType (me, Graphics_DOTTED); Graphics_setLineWidth (me, 0.67 * lineWidth); for (integer i = first; i <= last; i ++) { - double xWC = i * distance; + const double xWC = i * distance; Graphics_line (me, xWC, 0.0, xWC, 1.0); } Graphics_setLineWidth (me, lineWidth); } Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); } void Graphics_marksTopEvery (Graphics me, double units, double distance, bool haveNumbers, bool haveTicks, bool haveDottedLines) { - double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; - int lineType = my lineType; - integer first, last; - double lineWidth = my lineWidth; - MelderColour colour = my colour; + const double x1WC = my d_x1WC, x2WC = my d_x2WC, y1WC = my d_y1WC, y2WC = my d_y2WC; + const int lineType = my lineType; + const double lineWidth = my lineWidth; + const MelderColour colour = my colour; distance *= units; - first = Melder_iceiling (( x1WC < x2WC ? x1WC : x2WC ) / distance - 1e-5); - last = Melder_ifloor (( x1WC < x2WC ? x2WC : x1WC ) / distance + 1e-5); - Graphics_setColour (me, Melder_BLACK); + + const integer first = Melder_iceiling (( x1WC < x2WC ? x1WC : x2WC ) / distance - 1e-5); + const integer last = Melder_ifloor (( x1WC < x2WC ? x2WC : x1WC ) / distance + 1e-5); Graphics_setWindow (me, x1WC, x2WC, 0.0, 1.0); + Graphics_setColour (me, Melder_BLACK); Graphics_setTextAlignment (me, Graphics_CENTRE, Graphics_BOTTOM); Graphics_setInner (me); if (haveTicks) { @@ -879,6 +927,7 @@ void Graphics_marksTopEvery (Graphics me, double units, double distance, bool ha Graphics_setLineWidth (me, lineWidth); } Graphics_unsetInner (me); + Graphics_setWindow (me, x1WC, x2WC, y1WC, y2WC); Graphics_setLineType (me, lineType); Graphics_setColour (me, colour); @@ -886,14 +935,21 @@ void Graphics_marksTopEvery (Graphics me, double units, double distance, bool ha void Graphics_mark (Graphics me, double x, double y, double size_mm, conststring32 markString /* cattable */) { int mark; - if (! markString || ! markString [0]) mark = 0; + if (! markString || ! markString [0]) + mark = 0; else if (! markString [1]) { - if (markString [0] == '+') mark = 1; - else if (markString [0] == 'x') mark = 2; - else if (markString [0] == 'o') mark = 3; - else if (markString [0] == '.') mark = 0; - else mark = -1; - } else mark = -1; + if (markString [0] == '+') + mark = 1; + else if (markString [0] == 'x') + mark = 2; + else if (markString [0] == 'o') + mark = 3; + else if (markString [0] == '.') + mark = 0; + else + mark = -1; + } else + mark = -1; if (mark == -1) { const double oldSize = my fontSize; const int oldHorizontalAlignment = my horizontalTextAlignment; @@ -923,11 +979,12 @@ void Graphics_mark (Graphics me, double x, double y, double size_mm, conststring void Graphics_setTextRotation_vector (Graphics me, double dx, double dy) { double angle; if (dy == 0.0) { - angle = dx >= 0.0 ? 0.0 : 180.0; + angle = ( dx >= 0.0 ? 0.0 : 180.0 ); } else if (dx == 0.0) { - angle = dy > 0.0 ? 90.0 : 270.0; + angle = ( dy > 0.0 ? 90.0 : 270.0 ); } else { - double dxDC = dx * my scaleX, dyDC = my yIsZeroAtTheTop ? -dy * my scaleY : dy * my scaleY; + const double dxDC = dx * my scaleX; + const double dyDC = ( my yIsZeroAtTheTop ? -dy * my scaleY : dy * my scaleY ); angle = atan2 (dyDC, dxDC) * (180.0 / NUMpi); } Graphics_setTextRotation (me, angle); diff --git a/sys/Gui.h b/sys/Gui.h index a170b254..bf555711 100644 --- a/sys/Gui.h +++ b/sys/Gui.h @@ -2,7 +2,7 @@ #define _Gui_h_ /* Gui.h * - * Copyright (C) 1993-2019 Paul Boersma, 2013 Tom Naughton + * Copyright (C) 1993-2020 Paul Boersma, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -50,6 +50,13 @@ #define cocoa 0 #endif +constexpr bool theCommandKeyIsToTheLeftOfTheOptionKey = + #if defined (macintosh) + false; + #else + true; + #endif + #include "Collection.h" #if defined (UNIX) @@ -289,7 +296,6 @@ void XmToggleButtonGadgetSetState (GuiObject widget, Boolean value, Boolean notify); #define XmToggleButtonSetState XmToggleButtonGadgetSetState - bool motif_win_mouseStillDown (); void motif_win_setUserMessageCallback (int (*userMessageCallback) (void)); #else typedef void *GuiObject; @@ -298,6 +304,7 @@ int Gui_getResolution (GuiObject widget); void Gui_getWindowPositioningBounds (double *x, double *y, double *width, double *height); +Thing_declare (GuiDrawingArea); Thing_declare (GuiForm); Thing_declare (GuiMenu); Thing_declare (GuiScrolledWindow); @@ -352,6 +359,7 @@ Thing_define (GuiShell, GuiForm) { #endif GuiShell_GoAwayCallback d_goAwayCallback; Thing d_goAwayBoss; + GuiDrawingArea drawingArea; void v_destroy () noexcept override; @@ -360,7 +368,7 @@ Thing_define (GuiShell, GuiForm) { int GuiShell_getShellWidth (GuiShell me); // needed because GuiControl_getWidth yields the width of the inner form int GuiShell_getShellHeight (GuiShell me); void GuiShell_setTitle (GuiShell me, conststring32 title /* cattable */); -void GuiShell_drain (GuiShell me); // drain the double graphics buffer +void GuiShell_drain (GuiShell me); // force display of update regions (forces the handling of an expose event) /********** GuiButton **********/ @@ -368,7 +376,7 @@ Thing_declare (GuiButton); typedef struct structGuiButtonEvent { GuiButton button; - bool shiftKeyPressed, commandKeyPressed, optionKeyPressed, extraControlKeyPressed; + bool shiftKeyPressed, commandKeyPressed, optionKeyPressed; } *GuiButtonEvent; typedef MelderCallback GuiButton_ActivateCallback; @@ -384,7 +392,7 @@ Thing_define (GuiButton, GuiControl) { #define GuiButton_CANCEL 2 #define GuiButton_INSENSITIVE 4 #define GuiButton_ATTRACTIVE 8 -GuiButton GuiButton_create (GuiForm parent, +GuiButton GuiButton_create (GuiForm parent, int left, int right, int top, int bottom, conststring32 text, GuiButton_ActivateCallback activateCallback, Thing boss, @@ -417,7 +425,7 @@ Thing_define (GuiCheckButton, GuiControl) { /* GuiCheckButton creation flags: */ #define GuiCheckButton_SET 1 #define GuiCheckButton_INSENSITIVE 2 -GuiCheckButton GuiCheckButton_create (GuiForm parent, +GuiCheckButton GuiCheckButton_create (GuiForm parent, int left, int right, int top, int bottom, conststring32 text, GuiCheckButton_ValueChangedCallback valueChangedCallback, Thing boss, @@ -456,24 +464,36 @@ typedef struct structGuiDrawingArea_ExposeEvent { GuiDrawingArea widget; int x, y, width, height; } *GuiDrawingArea_ExposeEvent; -typedef struct structGuiDrawingArea_ClickEvent { + +typedef struct structGuiDrawingArea_MouseEvent { GuiDrawingArea widget; int x, y; - bool shiftKeyPressed, commandKeyPressed, optionKeyPressed, extraControlKeyPressed; - int button; -} *GuiDrawingArea_ClickEvent; + enum class Phase { CLICK, DRAG, DROP } phase; + bool isClick() const { return our phase == Phase::CLICK; } + bool isDrag() const { return our phase == Phase::DRAG; } + bool isDrop() const { return our phase == Phase::DROP; } + bool shiftKeyPressed, commandKeyPressed, optionKeyPressed; + bool isLeftBottomFunctionKeyPressed () const { + return theCommandKeyIsToTheLeftOfTheOptionKey ? our commandKeyPressed : our optionKeyPressed; + } + bool isRightBottomFunctionKeyPressed () const { + return theCommandKeyIsToTheLeftOfTheOptionKey ? our optionKeyPressed : our commandKeyPressed; + } +} *GuiDrawingArea_MouseEvent; + typedef struct structGuiDrawingArea_KeyEvent { GuiDrawingArea widget; char32 key; - bool shiftKeyPressed, commandKeyPressed, optionKeyPressed, extraControlKeyPressed; + bool shiftKeyPressed, commandKeyPressed, optionKeyPressed; } *GuiDrawingArea_KeyEvent; + typedef struct structGuiDrawingArea_ResizeEvent { GuiDrawingArea widget; int width, height; } *GuiDrawingArea_ResizeEvent; typedef MelderCallback GuiDrawingArea_ExposeCallback; -typedef MelderCallback GuiDrawingArea_ClickCallback; +typedef MelderCallback GuiDrawingArea_MouseCallback; typedef MelderCallback GuiDrawingArea_KeyCallback; typedef MelderCallback GuiDrawingArea_ResizeCallback; @@ -481,44 +501,47 @@ Thing_define (GuiDrawingArea, GuiControl) { GuiScrollBar d_horizontalScrollBar, d_verticalScrollBar; // for swiping GuiDrawingArea_ExposeCallback d_exposeCallback; Thing d_exposeBoss; - GuiDrawingArea_ClickCallback d_clickCallback; - Thing d_clickBoss; + GuiDrawingArea_MouseCallback mouseCallback; + Thing mouseBoss; GuiDrawingArea_KeyCallback d_keyCallback; Thing d_keyBoss; GuiDrawingArea_ResizeCallback d_resizeCallback; Thing d_resizeBoss; + integer numberOfGraphicses; + constexpr static integer MAXIMUM_NUMBER_OF_GRAPHICSES = 10; + Graphics graphicses [1+MAXIMUM_NUMBER_OF_GRAPHICSES]; }; /* GuiDrawingArea creation flags: */ #define GuiDrawingArea_BORDER 1 GuiDrawingArea GuiDrawingArea_create (GuiForm parent, int left, int right, int top, int bottom, GuiDrawingArea_ExposeCallback exposeCallback, - GuiDrawingArea_ClickCallback clickCallback, + GuiDrawingArea_MouseCallback mouseCallback, GuiDrawingArea_KeyCallback keyCallback, GuiDrawingArea_ResizeCallback resizeCallback, Thing boss, uint32 flags); GuiDrawingArea GuiDrawingArea_createShown (GuiForm parent, int left, int right, int top, int bottom, GuiDrawingArea_ExposeCallback exposeCallback, - GuiDrawingArea_ClickCallback clickCallback, + GuiDrawingArea_MouseCallback mouseCallback, GuiDrawingArea_KeyCallback keyCallback, GuiDrawingArea_ResizeCallback resizeCallback, Thing boss, uint32 flags); GuiDrawingArea GuiDrawingArea_create (GuiScrolledWindow parent, int width, int height, GuiDrawingArea_ExposeCallback exposeCallback, - GuiDrawingArea_ClickCallback clickCallback, + GuiDrawingArea_MouseCallback mouseCallback, GuiDrawingArea_KeyCallback keyCallback, GuiDrawingArea_ResizeCallback resizeCallback, Thing boss, uint32 flags); GuiDrawingArea GuiDrawingArea_createShown (GuiScrolledWindow parent, int width, int height, GuiDrawingArea_ExposeCallback exposeCallback, - GuiDrawingArea_ClickCallback clickCallback, + GuiDrawingArea_MouseCallback mouseCallback, GuiDrawingArea_KeyCallback keyCallback, GuiDrawingArea_ResizeCallback resizeCallback, Thing boss, uint32 flags); void GuiDrawingArea_setSwipable (GuiDrawingArea me, GuiScrollBar horizontalScrollBar, GuiScrollBar verticalScrollBar); void GuiDrawingArea_setExposeCallback (GuiDrawingArea me, GuiDrawingArea_ExposeCallback callback, Thing boss); -void GuiDrawingArea_setClickCallback (GuiDrawingArea me, GuiDrawingArea_ClickCallback callback, Thing boss); +void GuiDrawingArea_setMouseCallback (GuiDrawingArea me, GuiDrawingArea_MouseCallback callback, Thing boss); void GuiDrawingArea_setResizeCallback (GuiDrawingArea me, GuiDrawingArea_ResizeCallback callback, Thing boss); /********** GuiFileSelect **********/ @@ -653,7 +676,7 @@ Thing_declare (GuiMenuItem); typedef struct structGuiMenuItemEvent { GuiMenuItem menuItem; - bool shiftKeyPressed, commandKeyPressed, optionKeyPressed, extraControlKeyPressed; + bool shiftKeyPressed, commandKeyPressed, optionKeyPressed; } *GuiMenuItemEvent; typedef MelderCallback GuiMenuItemCallback; diff --git a/sys/GuiButton.cpp b/sys/GuiButton.cpp index 5cffbcaa..dbdeb6ee 100644 --- a/sys/GuiButton.cpp +++ b/sys/GuiButton.cpp @@ -1,6 +1,6 @@ /* GuiButton.cpp * - * Copyright (C) 1993-2008,2010-2018 Paul Boersma, + * Copyright (C) 1993-2008,2010-2020 Paul Boersma, * 2007-2008 Stefan de Konink, 2010 Franz Brausse, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify @@ -37,12 +37,12 @@ Thing_implement (GuiButton, GuiControl, 0); } static void _GuiGtkButton_activateCallback (GuiObject widget, gpointer userData) { GuiButton me = (GuiButton) userData; - struct structGuiButtonEvent event { me, false, false, false, false }; + structGuiButtonEvent event { me, false, false, false }; if (my d_activateCallback) { try { my d_activateCallback (my d_activateBoss, & event); } catch (MelderError) { - Melder_flushError (U"Your click on button \"", Melder_peek8to32 (GTK_WIDGET (widget) -> name), U"\" was not completely handled."); + Melder_flushError (U"Your click on button \"", Melder_peek8to32 (gtk_widget_get_name (GTK_WIDGET (widget))), U"\" was not completely handled."); } } } @@ -59,7 +59,7 @@ Thing_implement (GuiButton, GuiControl, 0); void _GuiWinButton_handleClick (GuiObject widget) { iam_button; if (my d_activateCallback) { - struct structGuiButtonEvent event { me, false, false, false, false }; + structGuiButtonEvent event { me, false, false, false }; try { my d_activateCallback (my d_activateBoss, & event); } catch (MelderError) { @@ -70,7 +70,7 @@ Thing_implement (GuiButton, GuiControl, 0); bool _GuiWinButton_tryToHandleShortcutKey (GuiObject widget) { iam_button; if (my d_activateCallback) { - struct structGuiButtonEvent event { me, false, false, false, false }; + structGuiButtonEvent event { me, false, false, false }; try { my d_activateCallback (my d_activateBoss, & event); } catch (MelderError) { @@ -101,7 +101,7 @@ Thing_implement (GuiButton, GuiControl, 0); Melder_assert (self == widget); // sender (widget) and receiver (self) happen to be the same object GuiButton me = d_userData; if (my d_activateCallback) { - struct structGuiButtonEvent event { me, false, false, false, false }; + structGuiButtonEvent event { me, false, false, false }; try { my d_activateCallback (my d_activateBoss, & event); } catch (MelderError) { @@ -122,17 +122,29 @@ GuiButton GuiButton_create (GuiForm parent, int left, int right, int top, int bo my d_activateBoss = activateBoss; #if gtk my d_widget = gtk_button_new_with_label (Melder_peek32to8 (buttonText)); - gtk_button_set_relief (GTK_BUTTON (my d_widget), GTK_RELIEF_HALF); + #if ALLOW_GDK_DRAWING + gtk_button_set_relief (GTK_BUTTON (my d_widget), GTK_RELIEF_HALF); + #else + gtk_button_set_relief (GTK_BUTTON (my d_widget), GTK_RELIEF_NORMAL); + #endif _GuiObject_setUserData (my d_widget, me.get()); my v_positionInForm (my d_widget, left, right, top, bottom, parent); if (flags & GuiButton_DEFAULT || flags & GuiButton_ATTRACTIVE) { - GTK_WIDGET_SET_FLAGS (my d_widget, GTK_CAN_DEFAULT); + #if ALLOW_GDK_DRAWING + GTK_WIDGET_SET_FLAGS (my d_widget, GTK_CAN_DEFAULT); + #else + gtk_widget_set_can_default (GTK_WIDGET (my d_widget), TRUE); + #endif GtkWidget *shell = gtk_widget_get_toplevel (GTK_WIDGET (my d_widget)); Melder_assert (shell); gtk_window_set_default (GTK_WINDOW (shell), GTK_WIDGET (my d_widget)); } else if (1) { gtk_button_set_focus_on_click (GTK_BUTTON (my d_widget), false); - GTK_WIDGET_UNSET_FLAGS (my d_widget, GTK_CAN_DEFAULT); + #if ALLOW_GDK_DRAWING + GTK_WIDGET_UNSET_FLAGS (my d_widget, GTK_CAN_DEFAULT); + #else + gtk_widget_set_can_default (GTK_WIDGET (my d_widget), FALSE); + #endif } g_signal_connect (G_OBJECT (my d_widget), "destroy", G_CALLBACK (_GuiGtkButton_destroyCallback), me.get()); g_signal_connect (GTK_BUTTON (my d_widget), "clicked", G_CALLBACK (_GuiGtkButton_activateCallback), me.get()); diff --git a/sys/GuiControl.cpp b/sys/GuiControl.cpp index babf3fa8..b4ac379c 100644 --- a/sys/GuiControl.cpp +++ b/sys/GuiControl.cpp @@ -143,7 +143,10 @@ void structGuiControl :: v_positionInScrolledWindow (GuiObject widget, int width int GuiControl_getX (GuiControl me) { #if gtk - return GTK_WIDGET (my d_widget) -> allocation.x; + //return GTK_WIDGET (my d_widget) -> allocation.x; + GtkAllocation allocation; + gtk_widget_get_allocation (GTK_WIDGET (my d_widget), & allocation); + return allocation.x; #elif motif return my d_widget -> x; #elif cocoa @@ -155,7 +158,10 @@ int GuiControl_getX (GuiControl me) { int GuiControl_getY (GuiControl me) { #if gtk - return GTK_WIDGET (my d_widget) -> allocation.y; + //return GTK_WIDGET (my d_widget) -> allocation.y; + GtkAllocation allocation; + gtk_widget_get_allocation (GTK_WIDGET (my d_widget), & allocation); + return allocation.y; #elif motif return my d_widget -> y; #elif cocoa @@ -167,7 +173,10 @@ int GuiControl_getY (GuiControl me) { int GuiControl_getWidth (GuiControl me) { #if gtk - return GTK_WIDGET (my d_widget) -> allocation.width; + //return GTK_WIDGET (my d_widget) -> allocation.width; + GtkAllocation allocation; + gtk_widget_get_allocation (GTK_WIDGET (my d_widget), & allocation); + return allocation.width; #elif motif return my d_widget -> width; #elif cocoa @@ -179,7 +188,10 @@ int GuiControl_getWidth (GuiControl me) { int GuiControl_getHeight (GuiControl me) { #if gtk - return GTK_WIDGET (my d_widget) -> allocation.height; + //return GTK_WIDGET (my d_widget) -> allocation.height; + GtkAllocation allocation; + gtk_widget_get_allocation (GTK_WIDGET (my d_widget), & allocation); + return allocation.height; #elif motif return my d_widget -> height; #elif cocoa diff --git a/sys/GuiDialog.cpp b/sys/GuiDialog.cpp index af6811d6..93cab925 100644 --- a/sys/GuiDialog.cpp +++ b/sys/GuiDialog.cpp @@ -72,7 +72,8 @@ GuiDialog GuiDialog_create (GuiWindow parent, int x, int y, int width, int heigh gtk_window_set_default_size (GTK_WINDOW (my d_gtkWindow), width, height); gtk_window_set_modal (GTK_WINDOW (my d_gtkWindow), flags & GuiDialog_MODAL); GuiShell_setTitle (me.get(), title); - GuiObject vbox = GTK_DIALOG (my d_gtkWindow) -> vbox; + //GuiObject vbox = GTK_DIALOG (my d_gtkWindow) -> vbox; + GuiObject vbox = gtk_dialog_get_content_area (GTK_DIALOG (my d_gtkWindow)); my d_widget = gtk_fixed_new (); _GuiObject_setUserData (my d_widget, me.get()); gtk_widget_set_size_request (GTK_WIDGET (my d_widget), width, height); diff --git a/sys/GuiDrawingArea.cpp b/sys/GuiDrawingArea.cpp index 5d558944..94bad7a0 100644 --- a/sys/GuiDrawingArea.cpp +++ b/sys/GuiDrawingArea.cpp @@ -1,6 +1,6 @@ /* GuiDrawingArea.cpp * - * Copyright (C) 1993-2012,2013,2015,2016,2017 Paul Boersma, + * Copyright (C) 1993-2018,2020 Paul Boersma, * 2008 Stefan de Konink, 2010 Franz Brausse, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify @@ -22,6 +22,7 @@ #include "gdk/gdkkeysyms.h" #include #endif +#include "GraphicsP.h" Thing_implement (GuiDrawingArea, GuiControl, 0); @@ -44,27 +45,21 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); trace (U"begin"); iam (GuiDrawingArea); Melder_assert (me); - // TODO: that helps against the damaged regions outside the rect where the - // Graphics drawing is done, but where does that margin come from in the - // first place?? Additionally this causes even more flickering - //gdk_window_clear_area ((GTK_WIDGET (widget)) -> window, expose->area.x, expose->area.y, expose->area.width, expose->area.height); if (my d_exposeCallback) { - struct structGuiDrawingArea_ExposeEvent event { me, 0 }; + structGuiDrawingArea_ExposeEvent event { me, 0 }; event. x = expose -> area. x; event. y = expose -> area. y; event. width = expose -> area. width; event. height = expose -> area. height; try { - //GdkRectangle rect = { event. x, event. y, event. width, event. height }; - //gdk_window_begin_paint_rect ((GTK_WIDGET (widget)) -> window, & rect); - trace (U"send the expose callback"); - trace (U"locale is ", Melder_peek8to32 (setlocale (LC_ALL, nullptr))); + GdkRectangle rect = { event. x, event. y, event. width, event. height }; + cairo_t *cairoGraphicsContext = gdk_cairo_create (gtk_widget_get_window (GTK_WIDGET (widget))); + for (int igraphics = 1; igraphics <= my numberOfGraphicses; igraphics ++) + ((GraphicsScreen) my graphicses [igraphics]) -> d_cairoGraphicsContext = cairoGraphicsContext; my d_exposeCallback (my d_exposeBoss, & event); - trace (U"the expose callback finished"); - trace (U"locale is ", Melder_peek8to32 (setlocale (LC_ALL, nullptr))); - //gdk_window_end_paint ((GTK_WIDGET (widget)) -> window); - //gdk_window_flush ((GTK_WIDGET (widget)) -> window); - //gdk_flush (); + cairo_destroy (cairoGraphicsContext); + for (int igraphics = 1; igraphics <= my numberOfGraphicses; igraphics ++) + ((GraphicsScreen) my graphicses [igraphics]) -> d_cairoGraphicsContext = nullptr; } catch (MelderError) { Melder_flushError (U"Redrawing not completed"); } @@ -74,19 +69,32 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); trace (U"GTK will handle redrawing"); return false; } - static gboolean _GuiGtkDrawingArea_clickCallback (GuiObject widget, GdkEvent *e, gpointer void_me) { + static structGuiDrawingArea_MouseEvent::Phase previousPhase = structGuiDrawingArea_MouseEvent::Phase::DROP; + static gboolean _GuiGtkDrawingArea_mouseDownCallback (GuiObject widget, GdkEvent *e, gpointer void_me) { iam (GuiDrawingArea); - if (e -> type != GDK_BUTTON_PRESS) return false; - if (my d_clickCallback) { - struct structGuiDrawingArea_ClickEvent event { me, 0 }; - event. button = ((GdkEventButton *) e) -> button; + if (my mouseCallback) { + structGuiDrawingArea_MouseEvent event { me, 0 }; event. x = ((GdkEventButton *) e) -> x; event. y = ((GdkEventButton *) e) -> y; event. shiftKeyPressed = (((GdkEventButton *) e) -> state & GDK_SHIFT_MASK) != 0; event. commandKeyPressed = (((GdkEventButton *) e) -> state & GDK_CONTROL_MASK) != 0; event. optionKeyPressed = (((GdkEventButton *) e) -> state & GDK_MOD1_MASK) != 0; + if (previousPhase == structGuiDrawingArea_MouseEvent::Phase::CLICK) { + /* + Apparently a double-click. + On other platforms, a mouse-up event is always generated, even within a double-click. + On Linux, we generate it ourselves. + */ + try { + previousPhase = event. phase = structGuiDrawingArea_MouseEvent::Phase::DROP; + my mouseCallback (my mouseBoss, & event); + } catch (MelderError) { + Melder_flushError (U"Mouse drop not completely handled."); + } + } try { - my d_clickCallback (my d_clickBoss, & event); + previousPhase = event. phase = structGuiDrawingArea_MouseEvent::Phase::CLICK; + my mouseCallback (my mouseBoss, & event); } catch (MelderError) { Melder_flushError (U"Mouse click not completely handled."); } @@ -94,11 +102,49 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); } return false; } + static gboolean _GuiGtkDrawingArea_mouseDraggedCallback (GuiObject widget, GdkEvent *e, gpointer void_me) { + iam (GuiDrawingArea); + if (my mouseCallback) { + structGuiDrawingArea_MouseEvent event { me, 0 }; + event. x = ((GdkEventButton *) e) -> x; + event. y = ((GdkEventButton *) e) -> y; + event. shiftKeyPressed = (((GdkEventButton *) e) -> state & GDK_SHIFT_MASK) != 0; + event. commandKeyPressed = (((GdkEventButton *) e) -> state & GDK_CONTROL_MASK) != 0; + event. optionKeyPressed = (((GdkEventButton *) e) -> state & GDK_MOD1_MASK) != 0; + try { + previousPhase = event. phase = structGuiDrawingArea_MouseEvent::Phase::DRAG; + my mouseCallback (my mouseBoss, & event); + } catch (MelderError) { + Melder_flushError (U"Mouse drag not completely handled."); + } + return true; + } + return false; + } + static gboolean _GuiGtkDrawingArea_mouseUpCallback (GuiObject widget, GdkEvent *e, gpointer void_me) { + iam (GuiDrawingArea); + if (my mouseCallback) { + structGuiDrawingArea_MouseEvent event { me, 0 }; + event. x = ((GdkEventButton *) e) -> x; + event. y = ((GdkEventButton *) e) -> y; + event. shiftKeyPressed = (((GdkEventButton *) e) -> state & GDK_SHIFT_MASK) != 0; + event. commandKeyPressed = (((GdkEventButton *) e) -> state & GDK_CONTROL_MASK) != 0; + event. optionKeyPressed = (((GdkEventButton *) e) -> state & GDK_MOD1_MASK) != 0; + try { + previousPhase = event. phase = structGuiDrawingArea_MouseEvent::Phase::DROP; + my mouseCallback (my mouseBoss, & event); + } catch (MelderError) { + Melder_flushError (U"Mouse drop not completely handled."); + } + return true; + } + return false; + } static gboolean _GuiGtkDrawingArea_keyCallback (GuiObject widget, GdkEvent *gevent, gpointer void_me) { iam (GuiDrawingArea); trace (U"begin"); if (my d_keyCallback && gevent -> type == GDK_KEY_PRESS) { - struct structGuiDrawingArea_KeyEvent event { me, 0 }; + structGuiDrawingArea_KeyEvent event { me, 0 }; GdkEventKey *gkeyEvent = (GdkEventKey *) gevent; event. key = gkeyEvent -> keyval; /* @@ -112,7 +158,6 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); event. shiftKeyPressed = (gkeyEvent -> state & GDK_SHIFT_MASK) != 0; event. commandKeyPressed = (gkeyEvent -> state & GDK_CONTROL_MASK) != 0; event. optionKeyPressed = (gkeyEvent -> state & GDK_MOD1_MASK) != 0; - event. extraControlKeyPressed = false; try { my d_keyCallback (my d_keyBoss, & event); } catch (MelderError) { @@ -128,7 +173,7 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); static gboolean _GuiGtkDrawingArea_resizeCallback (GuiObject widget, GtkAllocation *allocation, gpointer void_me) { iam (GuiDrawingArea); if (my d_resizeCallback) { - struct structGuiDrawingArea_ResizeEvent event { me, 0 }; + structGuiDrawingArea_ResizeEvent event { me, 0 }; trace (U"drawingArea resized to ", allocation -> width, U" x ", allocation -> height, U"."); event. width = allocation -> width; event. height = allocation -> height; @@ -150,38 +195,62 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); } void _GuiWinDrawingArea_update (GuiObject widget) { iam_drawingarea; - PAINTSTRUCT paintStruct; - BeginPaint (widget -> window, & paintStruct); + GraphicsScreen graphics = (GraphicsScreen) my graphicses [1]; + Melder_assert (Thing_isa (graphics, classGraphicsScreen)); + HDC memoryDC = CreateCompatibleDC (graphics -> d_gdiGraphicsContext); + HBITMAP memoryBitmap = CreateCompatibleBitmap (graphics -> d_gdiGraphicsContext, widget -> width, widget -> height); + SelectObject (memoryDC, memoryBitmap); + SetBkMode (memoryDC, TRANSPARENT); // not the default! + SelectPen (memoryDC, GetStockPen (BLACK_PEN)); + SelectBrush (memoryDC, GetStockBrush (BLACK_BRUSH)); + SetTextAlign (memoryDC, TA_LEFT | TA_BASELINE | TA_NOUPDATECP); // baseline is not the default! + HDC saveContext = graphics -> d_gdiGraphicsContext; + for (int igraphics = 1; igraphics <= my numberOfGraphicses; igraphics ++) + ((GraphicsScreen) my graphicses [igraphics]) -> d_gdiGraphicsContext = memoryDC; if (my d_exposeCallback) { - struct structGuiDrawingArea_ExposeEvent event { me }; + structGuiDrawingArea_ExposeEvent event { me }; try { my d_exposeCallback (my d_exposeBoss, & event); } catch (MelderError) { Melder_flushError (U"Redrawing not completed"); } } - EndPaint (widget -> window, & paintStruct); + for (int igraphics = 1; igraphics <= my numberOfGraphicses; igraphics ++) + ((GraphicsScreen) my graphicses [igraphics]) -> d_gdiGraphicsContext = saveContext; + BitBlt (graphics -> d_gdiGraphicsContext, 0, 0, widget -> width, widget -> height, memoryDC, 0, 0, SRCCOPY); + DeleteObject (memoryBitmap); + DeleteDC (memoryDC); + ValidateRect (widget -> window, nullptr); } - void _GuiWinDrawingArea_handleClick (GuiObject widget, int x, int y) { + void _GuiWinDrawingArea_handleMouse (GuiObject widget, structGuiDrawingArea_MouseEvent::Phase phase, int x, int y) { iam_drawingarea; - if (my d_clickCallback) { - struct structGuiDrawingArea_ClickEvent event { me, 0 }; + if (my mouseCallback) { + structGuiDrawingArea_MouseEvent event { me, 0 }; event. x = x; event. y = y; + event. phase = phase; event. shiftKeyPressed = GetKeyState (VK_SHIFT) < 0; event. optionKeyPressed = GetKeyState (VK_MENU) < 0; event. commandKeyPressed = GetKeyState (VK_CONTROL) < 0; try { - my d_clickCallback (my d_clickBoss, & event); + my mouseCallback (my mouseBoss, & event); } catch (MelderError) { - Melder_flushError (U"Mouse click not completely handled."); + switch (phase) { + case structGuiDrawingArea_MouseEvent::Phase::CLICK: + Melder_flushError (U"Mouse click not completely handled."); + break; case structGuiDrawingArea_MouseEvent::Phase::DRAG: + Melder_flushError (U"Mouse drag not completely handled."); + break; case structGuiDrawingArea_MouseEvent::Phase::DROP: + Melder_flushError (U"Mouse drop not completely handled."); + break; + } } } } void _GuiWinDrawingArea_handleKey (GuiObject widget, TCHAR kar) { // TODO: event? iam_drawingarea; if (my d_keyCallback) { - struct structGuiDrawingArea_KeyEvent event { me, 0 }; + structGuiDrawingArea_KeyEvent event { me, 0 }; event. key = kar; if (event. key == VK_RETURN) event. key = 10; if (event. key == VK_LEFT) event. key = 0x2190; @@ -201,7 +270,7 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); void _GuiWinDrawingArea_shellResize (GuiObject widget) { iam_drawingarea; if (my d_resizeCallback) { - struct structGuiDrawingArea_ResizeEvent event { me }; + structGuiDrawingArea_ResizeEvent event { me }; event. width = widget -> width; event. height = widget -> height; try { @@ -248,7 +317,7 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); - (void) resizeCallback: (NSRect) rect { GuiDrawingArea me = (GuiDrawingArea) d_userData; if (me && my d_resizeCallback) { - struct structGuiDrawingArea_ResizeEvent event = { me, 0, 0 }; + structGuiDrawingArea_ResizeEvent event = { me, 0, 0 }; event. width = rect. size. width; event. height = rect. size. height; try { @@ -267,9 +336,14 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); _inited = YES; } if (my d_exposeCallback) { - struct structGuiDrawingArea_ExposeEvent event = { me, 0, 0, 0, 0 }; + structGuiDrawingArea_ExposeEvent event = { me, 0, 0, 0, 0 }; try { + Melder_assert (my numberOfGraphicses > 0); + for (integer igraphics = 1; igraphics <= my numberOfGraphicses; igraphics ++) + GraphicsQuartz_initDraw (my graphicses [igraphics]); my d_exposeCallback (my d_exposeBoss, & event); + for (integer igraphics = 1; igraphics <= my numberOfGraphicses; igraphics ++) + GraphicsQuartz_exitDraw (my graphicses [igraphics]); } catch (MelderError) { Melder_flushError (U"Redrawing not completed"); } @@ -298,30 +372,45 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); (void) nsEvent; [[NSCursor crosshairCursor] push]; } - - (void) mouseExited: (NSEvent *) nsEvent{ + - (void) mouseExited: (NSEvent *) nsEvent { (void) nsEvent; [[NSCursor currentCursor] pop]; } - - (void) mouseDown: (NSEvent *) nsEvent { - // [self becomeFirstResponder]; + - (void) mouse: (NSEvent *) nsEvent inPhase: (structGuiDrawingArea_MouseEvent::Phase) phase { GuiDrawingArea me = (GuiDrawingArea) d_userData; - if (my d_clickCallback) { - struct structGuiDrawingArea_ClickEvent event = { me, 0, 0, false, false, false, false, 0 }; + if (my mouseCallback) { + structGuiDrawingArea_MouseEvent event = { me, 0, 0, phase, false, false, false }; NSPoint local_point = [self convertPoint: [nsEvent locationInWindow] fromView: nil]; event. x = local_point. x; - //event. y = [self frame]. size. height - local_point. y; event. y = local_point. y; NSUInteger modifiers = [nsEvent modifierFlags]; event. shiftKeyPressed = modifiers & NSShiftKeyMask; event. optionKeyPressed = modifiers & NSAlternateKeyMask; event. commandKeyPressed = modifiers & NSCommandKeyMask; try { - my d_clickCallback (my d_clickBoss, & event); + my mouseCallback (my mouseBoss, & event); } catch (MelderError) { - Melder_flushError (U"Mouse click not completely handled."); + switch (phase) { + case structGuiDrawingArea_MouseEvent::Phase::CLICK: + Melder_flushError (U"Mouse click not completely handled."); + break; case structGuiDrawingArea_MouseEvent::Phase::DRAG: + Melder_flushError (U"Mouse drag not completely handled."); + break; case structGuiDrawingArea_MouseEvent::Phase::DROP: + Melder_flushError (U"Mouse drop not completely handled."); + break; + } } } } + - (void) mouseDown: (NSEvent *) nsEvent { + [self mouse: nsEvent inPhase: structGuiDrawingArea_MouseEvent::Phase::CLICK]; + } + - (void) mouseDragged: (NSEvent *) nsEvent { + [self mouse: nsEvent inPhase: structGuiDrawingArea_MouseEvent::Phase::DRAG]; + } + - (void) mouseUp: (NSEvent *) nsEvent { + [self mouse: nsEvent inPhase: structGuiDrawingArea_MouseEvent::Phase::DROP]; + } - (void) scrollWheel: (NSEvent *) nsEvent { GuiDrawingArea me = (GuiDrawingArea) d_userData; if (my d_horizontalScrollBar || my d_verticalScrollBar) { @@ -358,7 +447,7 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); - (void) keyDown: (NSEvent *) nsEvent { GuiDrawingArea me = (GuiDrawingArea) d_userData; if (my d_keyCallback) { - struct structGuiDrawingArea_KeyEvent event = { me, U'\0', false, false, false, false }; + structGuiDrawingArea_KeyEvent event = { me, U'\0', false, false, false }; event. key = [[nsEvent charactersIgnoringModifiers] characterAtIndex: 0]; if (event. key == NSLeftArrowFunctionKey) event. key = 0x2190; if (event. key == NSRightArrowFunctionKey) event. key = 0x2192; @@ -416,18 +505,19 @@ Thing_implement (GuiDrawingArea, GuiControl, 0); GuiDrawingArea GuiDrawingArea_create (GuiForm parent, int left, int right, int top, int bottom, GuiDrawingArea_ExposeCallback exposeCallback, - GuiDrawingArea_ClickCallback clickCallback, + GuiDrawingArea_MouseCallback mouseCallback, GuiDrawingArea_KeyCallback keyCallback, GuiDrawingArea_ResizeCallback resizeCallback, Thing boss, uint32 /* flags */) { autoGuiDrawingArea me = Thing_new (GuiDrawingArea); my d_shell = parent -> d_shell; + my d_shell -> drawingArea = me.get(); my d_parent = parent; my d_exposeCallback = exposeCallback; my d_exposeBoss = boss; - my d_clickCallback = clickCallback; - my d_clickBoss = boss; + my mouseCallback = mouseCallback; + my mouseBoss = boss; my d_keyCallback = keyCallback; my d_keyBoss = boss; my d_resizeCallback = resizeCallback; @@ -440,11 +530,16 @@ GuiDrawingArea GuiDrawingArea_create (GuiForm parent, int left, int right, int t | GDK_KEY_PRESS_MASK | GDK_KEY_RELEASE_MASK | GDK_POINTER_MOTION_HINT_MASK); // receive fewer motion notify events (the cb might take time) gtk_widget_set_events (GTK_WIDGET (my d_widget), mask); - g_signal_connect (G_OBJECT (my d_widget), "expose-event", G_CALLBACK (_GuiGtkDrawingArea_exposeCallback), me.get()); - g_signal_connect (G_OBJECT (my d_widget), "destroy", G_CALLBACK (_GuiGtkDrawingArea_destroyCallback), me.get()); - g_signal_connect (G_OBJECT (my d_widget), "button-press-event", G_CALLBACK (_GuiGtkDrawingArea_clickCallback), me.get()); - g_signal_connect (G_OBJECT (my d_widget), "button-release-event", G_CALLBACK (_GuiGtkDrawingArea_clickCallback), me.get()); - g_signal_connect (G_OBJECT (my d_widget), "motion-notify-event", G_CALLBACK (_GuiGtkDrawingArea_clickCallback), me.get()); + #if ALLOW_GDK_DRAWING + g_signal_connect (G_OBJECT (my d_widget), "expose-event", G_CALLBACK (_GuiGtkDrawingArea_exposeCallback), me.get()); + #else + g_signal_connect (G_OBJECT (my d_widget), "draw", G_CALLBACK (_GuiGtkDrawingArea_exposeCallback), me.get()); + #endif + g_signal_connect (G_OBJECT (my d_widget), "destroy", G_CALLBACK (_GuiGtkDrawingArea_destroyCallback), me.get()); + g_signal_connect (G_OBJECT (my d_widget), "button-press-event", G_CALLBACK (_GuiGtkDrawingArea_mouseDownCallback), me.get()); + g_signal_connect (G_OBJECT (my d_widget), "button-release-event", G_CALLBACK (_GuiGtkDrawingArea_mouseUpCallback), me.get()); + //g_signal_connect (G_OBJECT (my d_widget), "drag-motion-event", G_CALLBACK (_GuiGtkDrawingArea_mouseUpCallback), me.get()); + g_signal_connect (G_OBJECT (my d_widget), "motion-notify-event", G_CALLBACK (_GuiGtkDrawingArea_mouseDraggedCallback), me.get()); if (parent) { Melder_assert (parent -> d_widget); g_signal_connect (G_OBJECT (gtk_widget_get_toplevel (GTK_WIDGET (parent -> d_widget))), "key-press-event", @@ -454,7 +549,6 @@ GuiDrawingArea GuiDrawingArea_create (GuiForm parent, int left, int right, int t _GuiObject_setUserData (my d_widget, me.get()); my v_positionInForm (my d_widget, left, right, top, bottom, parent); - gtk_widget_set_double_buffered (GTK_WIDGET (my d_widget), false); #elif motif my d_widget = _Gui_initializeWidget (xmDrawingAreaWidgetClass, parent -> d_widget, U"drawingArea"); _GuiObject_setUserData (my d_widget, me.get()); @@ -477,30 +571,34 @@ GuiDrawingArea GuiDrawingArea_create (GuiForm parent, int left, int right, int t GuiDrawingArea GuiDrawingArea_createShown (GuiForm parent, int left, int right, int top, int bottom, GuiDrawingArea_ExposeCallback exposeCallback, - GuiDrawingArea_ClickCallback clickCallback, + GuiDrawingArea_MouseCallback mouseCallback, GuiDrawingArea_KeyCallback keyCallback, GuiDrawingArea_ResizeCallback resizeCallback, Thing boss, uint32 flags) { - GuiDrawingArea me = GuiDrawingArea_create (parent, left, right, top, bottom, exposeCallback, clickCallback, keyCallback, resizeCallback, boss, flags); + GuiDrawingArea me = GuiDrawingArea_create (parent, left, right, top, bottom, + exposeCallback, mouseCallback, + keyCallback, resizeCallback, boss, flags + ); GuiThing_show (me); return me; } GuiDrawingArea GuiDrawingArea_create (GuiScrolledWindow parent, int width, int height, GuiDrawingArea_ExposeCallback exposeCallback, - GuiDrawingArea_ClickCallback clickCallback, + GuiDrawingArea_MouseCallback mouseCallback, GuiDrawingArea_KeyCallback keyCallback, GuiDrawingArea_ResizeCallback resizeCallback, Thing boss, uint32 /* flags */) { autoGuiDrawingArea me = Thing_new (GuiDrawingArea); my d_shell = parent -> d_shell; + my d_shell -> drawingArea = me.get(); my d_parent = parent; my d_exposeCallback = exposeCallback; my d_exposeBoss = boss; - my d_clickCallback = clickCallback; - my d_clickBoss = boss; + my mouseCallback = mouseCallback; + my mouseBoss = boss; my d_keyCallback = keyCallback; my d_keyBoss = boss; my d_resizeCallback = resizeCallback; @@ -513,11 +611,15 @@ GuiDrawingArea GuiDrawingArea_create (GuiScrolledWindow parent, int width, int h | GDK_KEY_PRESS_MASK | GDK_KEY_RELEASE_MASK | GDK_POINTER_MOTION_HINT_MASK); // receive fewer motion notify events (the cb might take time) gtk_widget_set_events (GTK_WIDGET (my d_widget), mask); - g_signal_connect (G_OBJECT (my d_widget), "expose-event", G_CALLBACK (_GuiGtkDrawingArea_exposeCallback), me.get()); - g_signal_connect (G_OBJECT (my d_widget), "destroy", G_CALLBACK (_GuiGtkDrawingArea_destroyCallback), me.get()); - g_signal_connect (G_OBJECT (my d_widget), "button-press-event", G_CALLBACK (_GuiGtkDrawingArea_clickCallback), me.get()); - g_signal_connect (G_OBJECT (my d_widget), "button-release-event", G_CALLBACK (_GuiGtkDrawingArea_clickCallback), me.get()); - g_signal_connect (G_OBJECT (my d_widget), "motion-notify-event", G_CALLBACK (_GuiGtkDrawingArea_clickCallback), me.get()); + #if ALLOW_GDK_DRAWING + g_signal_connect (G_OBJECT (my d_widget), "expose-event", G_CALLBACK (_GuiGtkDrawingArea_exposeCallback), me.get()); + #else + g_signal_connect (G_OBJECT (my d_widget), "draw", G_CALLBACK (_GuiGtkDrawingArea_exposeCallback), me.get()); + #endif + g_signal_connect (G_OBJECT (my d_widget), "destroy", G_CALLBACK (_GuiGtkDrawingArea_destroyCallback), me.get()); + g_signal_connect (G_OBJECT (my d_widget), "button-press-event", G_CALLBACK (_GuiGtkDrawingArea_mouseDownCallback), me.get()); + g_signal_connect (G_OBJECT (my d_widget), "button-release-event", G_CALLBACK (_GuiGtkDrawingArea_mouseUpCallback), me.get()); + g_signal_connect (G_OBJECT (my d_widget), "motion-notify-event", G_CALLBACK (_GuiGtkDrawingArea_mouseDraggedCallback), me.get()); if (parent) { g_signal_connect (G_OBJECT (gtk_widget_get_toplevel (GTK_WIDGET (parent -> d_widget))), "key-press-event", G_CALLBACK (_GuiGtkDrawingArea_keyCallback), me.get()); @@ -525,7 +627,6 @@ GuiDrawingArea GuiDrawingArea_create (GuiScrolledWindow parent, int width, int h g_signal_connect (G_OBJECT (my d_widget), "size-allocate", G_CALLBACK (_GuiGtkDrawingArea_resizeCallback), me.get()); _GuiObject_setUserData (my d_widget, me.get()); my v_positionInScrolledWindow (my d_widget, width, height, parent); - gtk_widget_set_double_buffered (GTK_WIDGET (my d_widget), false); #elif motif my d_widget = _Gui_initializeWidget (xmDrawingAreaWidgetClass, parent -> d_widget, U"drawingArea"); _GuiObject_setUserData (my d_widget, me.get()); @@ -545,12 +646,15 @@ GuiDrawingArea GuiDrawingArea_create (GuiScrolledWindow parent, int width, int h GuiDrawingArea GuiDrawingArea_createShown (GuiScrolledWindow parent, int width, int height, GuiDrawingArea_ExposeCallback exposeCallback, - GuiDrawingArea_ClickCallback clickCallback, + GuiDrawingArea_MouseCallback mouseCallback, GuiDrawingArea_KeyCallback keyCallback, GuiDrawingArea_ResizeCallback resizeCallback, Thing boss, uint32 flags) { - GuiDrawingArea me = GuiDrawingArea_create (parent, width, height, exposeCallback, clickCallback, keyCallback, resizeCallback, boss, flags); + GuiDrawingArea me = GuiDrawingArea_create (parent, width, height, + exposeCallback, mouseCallback, + keyCallback, resizeCallback, boss, flags + ); GuiThing_show (me); return me; } @@ -568,9 +672,9 @@ void GuiDrawingArea_setExposeCallback (GuiDrawingArea me, GuiDrawingArea_ExposeC my d_exposeBoss = boss; } -void GuiDrawingArea_setClickCallback (GuiDrawingArea me, GuiDrawingArea_ClickCallback callback, Thing boss) { - my d_clickCallback = callback; - my d_clickBoss = boss; +void GuiDrawingArea_setMouseCallback (GuiDrawingArea me, GuiDrawingArea_MouseCallback callback, Thing boss) { + my mouseCallback = callback; + my mouseBoss = boss; } void GuiDrawingArea_setResizeCallback (GuiDrawingArea me, GuiDrawingArea_ResizeCallback callback, Thing boss) { diff --git a/sys/GuiLabel.cpp b/sys/GuiLabel.cpp index de8a60f9..3e237b89 100644 --- a/sys/GuiLabel.cpp +++ b/sys/GuiLabel.cpp @@ -71,7 +71,12 @@ GuiLabel GuiLabel_create (GuiForm parent, int left, int right, int top, int bott _GuiObject_setUserData (my d_widget, me.get()); my v_positionInForm (my d_widget, left, right, top, bottom, parent); g_signal_connect (G_OBJECT (my d_widget), "destroy", G_CALLBACK (_GuiGtkLabel_destroyCallback), me.get()); - gtk_misc_set_alignment (GTK_MISC (my d_widget), flags & GuiLabel_RIGHT ? 1.0 : flags & GuiLabel_CENTRE ? 0.5 : 0.0, 0.5); + #if ALLOW_GDK_DRAWING + gtk_misc_set_alignment (GTK_MISC (my d_widget), flags & GuiLabel_RIGHT ? 1.0 : flags & GuiLabel_CENTRE ? 0.5 : 0.0, 0.5); + #else + gtk_widget_set_halign (GTK_WIDGET (my d_widget), (flags & GuiLabel_RIGHT ? GTK_ALIGN_END : (flags & GuiLabel_CENTRE ? GTK_ALIGN_CENTER : GTK_ALIGN_START))); + gtk_widget_set_valign (GTK_WIDGET (my d_widget), GTK_ALIGN_BASELINE); + #endif #elif motif my d_widget = _Gui_initializeWidget (xmLabelWidgetClass, parent -> d_widget, labelText); _GuiObject_setUserData (my d_widget, me.get()); diff --git a/sys/GuiMenu.cpp b/sys/GuiMenu.cpp index 32a2bdfa..f433dbe7 100644 --- a/sys/GuiMenu.cpp +++ b/sys/GuiMenu.cpp @@ -1,6 +1,6 @@ /* GuiMenu.cpp * - * Copyright (C) 1992-2005,2007-2019 Paul Boersma, + * Copyright (C) 1992-2005,2007-2020 Paul Boersma, * 2008 Stefan de Konink, 2010 Franz Brausse, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify @@ -104,7 +104,7 @@ void structGuiMenu :: v_destroy () noexcept { GuiWindow window = (GuiWindow) shell; if (window -> d_tabCallback) { try { - struct structGuiMenuItemEvent event { nullptr, false, false, false, false }; + structGuiMenuItemEvent event { nullptr, false, false, false }; window -> d_tabCallback (window -> d_tabBoss, & event); } catch (MelderError) { Melder_flushError (U"Tab key not completely handled."); @@ -136,7 +136,7 @@ void structGuiMenu :: v_destroy () noexcept { */ if (window -> d_shiftTabCallback) { try { - struct structGuiMenuItemEvent event { nullptr, false, false, false, false }; + structGuiMenuItemEvent event { nullptr, false, false, false }; window -> d_shiftTabCallback (window -> d_shiftTabBoss, & event); } catch (MelderError) { Melder_flushError (U"Tab key not completely handled."); @@ -167,7 +167,7 @@ void structGuiMenu :: v_destroy () noexcept { GuiWindow window = (GuiWindow) shell; if (([nsEvent modifierFlags] & NSAlternateKeyMask) && window -> d_optionBackspaceCallback) { try { - struct structGuiMenuItemEvent event { nullptr, false, false, false, false }; + structGuiMenuItemEvent event { nullptr, false, false, false }; window -> d_optionBackspaceCallback (window -> d_optionBackspaceBoss, & event); } catch (MelderError) { Melder_flushError (U"Option-Backspace not completely handled."); @@ -357,10 +357,10 @@ GuiMenu GuiMenu_createInWindow (GuiWindow window, conststring32 title, uint32 fl [my d_cocoaMenu setAutoenablesItems: NO]; if (! window) { /* - * Install the menu in the main OS X menu bar along the top of the screen. - * This is done by creating a menu item for the main menu bar, - * and during applicationWillFinishLaunching installing that item. - */ + Install the menu in the main OS X menu bar along the top of the screen. + This is done by creating a menu item for the main menu bar, + and during applicationWillFinishLaunching installing that item. + */ NSString *itemTitle = (NSString *) Melder_peek32toCfstring (title); my d_cocoaMenuItem = [[GuiCocoaMenuItem alloc] initWithTitle: itemTitle action: nullptr keyEquivalent: @""]; @@ -370,15 +370,15 @@ GuiMenu GuiMenu_createInWindow (GuiWindow window, conststring32 title, uint32 fl theMenuBarItems [++ theNumberOfMenuBarItems] = my d_cocoaMenuItem; } else if ([(NSView *) window -> d_widget isKindOfClass: [NSView class]]) { /* - * Install the menu at the top of a window. - * Menu title positioning information is maintained in that GuiWindow. - */ + Install the menu at the top of a window. + Menu title positioning information is maintained in that GuiWindow. + */ NSRect parentRect = [(NSView *) window -> d_widget frame]; // this is the window's top form - int parentWidth = parentRect.size.width, parentHeight = parentRect.size.height; + integer parentWidth = parentRect.size.width, parentHeight = parentRect.size.height; if (window -> d_menuBarWidth == 0) window -> d_menuBarWidth = -1; - int width = 18 + 7 * str32len (title), height = 35 /*25*/; - int x = window -> d_menuBarWidth, y = parentHeight + 1 - height; + integer width = 18 + 7 * str32len (title), height = 35 /*25*/; + integer x = window -> d_menuBarWidth, y = parentHeight + 1 - height; NSUInteger resizingMask = NSViewMinYMargin; if (Melder_equ (title, U"Help")) { x = parentWidth + 1 - width; @@ -400,24 +400,23 @@ GuiMenu GuiMenu_createInWindow (GuiWindow window, conststring32 title, uint32 fl [[my d_cocoaMenuButton cell] setArrowPosition: NSPopUpNoArrow /*NSPopUpArrowAtBottom*/]; [[my d_cocoaMenuButton cell] setPreferredEdge: NSMaxYEdge]; /* - * Apparently, Cocoa swallows title setting only if there is already a menu with a dummy item. - */ + Apparently, Cocoa swallows title setting only if there is already a menu with a dummy item. + */ GuiCocoaMenuItem *item = [[GuiCocoaMenuItem alloc] initWithTitle: @"-you should never get to see this-" action: nullptr keyEquivalent: @""]; [my d_cocoaMenu addItem: item]; // the menu will retain the item... [item release]; // ... so we can release the item already /* - * Install the menu button in the form. - */ + Install the menu button in the form. + */ [(NSView *) window -> d_widget addSubview: my d_cocoaMenuButton]; // parent will retain the button... [my d_cocoaMenuButton release]; // ... so we can release the button already /* - * Attach the menu to the button. - */ + Attach the menu to the button. + */ [my d_cocoaMenuButton setMenu: my d_cocoaMenu]; // the button will retain the menu... [my d_cocoaMenu release]; // ... so we can release the menu already (before even returning it!) [my d_cocoaMenuButton setTitle: (NSString *) Melder_peek32toCfstring (title)]; - } #endif @@ -493,23 +492,26 @@ GuiMenu GuiMenu_createInMenu (GuiMenu supermenu, conststring32 title, uint32 fla #if gtk static void set_position (GtkMenu *menu, gint *px, gint *py, gpointer data) { - gint w, h; + //gint w, h; GtkWidget *button = (GtkWidget *) g_object_get_data (G_OBJECT (menu), "button"); + GtkAllocation button_allocation; + gtk_widget_get_allocation (GTK_WIDGET (button), & button_allocation); + GtkRequisition menu_requisition; + gtk_widget_get_child_requisition (GTK_WIDGET (menu), & menu_requisition); + //if (GTK_WIDGET (menu) -> requisition. width < button_allocation.width) + if (menu_requisition. width < button_allocation.width) + gtk_widget_set_size_request (GTK_WIDGET (menu), button_allocation.width, -1); - if (GTK_WIDGET (menu) -> requisition. width < button->allocation.width) - gtk_widget_set_size_request (GTK_WIDGET (menu), button->allocation.width, -1); - - gdk_window_get_origin (button->window, px, py); - *px += button->allocation.x; - *py += button->allocation.y + button->allocation.height; /* Dit is vreemd */ + gdk_window_get_origin (gtk_widget_get_window (button), px, py); + *px += button_allocation.x; + *py += button_allocation.y + button_allocation.height; /* Dit is vreemd */ } static gint button_press (GtkWidget *widget, GdkEvent *event) { + /* GtkWidget *button = (GtkWidget *) g_object_get_data (G_OBJECT (widget), "button"); gint w, h; - GtkWidget *button = (GtkWidget *) g_object_get_data (G_OBJECT (widget), "button"); - - /* gdk_window_get_size (button->window, &w, &h); + gdk_window_get_size (button->window, &w, &h); gtk_widget_set_usize (widget, w, 0);*/ if (event->type == GDK_BUTTON_PRESS) { @@ -539,10 +541,17 @@ GuiMenu GuiMenu_createInForm (GuiForm form, int left, int right, int top, int bo gtk_widget_set_sensitive (GTK_WIDGET (my d_widget), false); g_signal_connect_object (G_OBJECT (my d_cascadeButton -> d_widget), "event", + #if ALLOW_GDK_DRAWING GTK_SIGNAL_FUNC (button_press), G_OBJECT (my d_widget), G_CONNECT_SWAPPED); + #else + G_CALLBACK (button_press), G_OBJECT (my d_widget), G_CONNECT_SWAPPED); + #endif g_object_set_data (G_OBJECT (my d_widget), "button", my d_cascadeButton -> d_widget); gtk_menu_attach_to_widget (GTK_MENU (my d_widget), GTK_WIDGET (my d_cascadeButton -> d_widget), nullptr); - gtk_button_set_alignment (GTK_BUTTON (my d_cascadeButton -> d_widget), 0.0f, 0.5f); + #if ALLOW_GDK_DRAWING + gtk_button_set_alignment (GTK_BUTTON (my d_cascadeButton -> d_widget), 0.0f, 0.5f); + #else + #endif _GuiObject_setUserData (my d_widget, me.get()); _GuiObject_setUserData (my d_cascadeButton -> d_widget, me.get()); #elif motif @@ -571,14 +580,14 @@ GuiMenu GuiMenu_createInForm (GuiForm form, int left, int right, int top, int bo my d_widget = my d_cocoaMenu = [[GuiCocoaMenu alloc] initWithTitle:menuTitle]; [my d_cocoaMenu setAutoenablesItems: NO]; /* - * Apparently, Cocoa swallows title setting only if there is already a menu with a dummy item. - */ + Apparently, Cocoa swallows title setting only if there is already a menu with a dummy item. + */ NSMenuItem *item = [[NSMenuItem alloc] initWithTitle: @"-you should never get to see this-" action: nullptr keyEquivalent: @""]; [my d_cocoaMenu addItem: item]; // the menu will retain the item... [item release]; // ... so we can release the item already /* - * Attach the menu to the button. - */ + Attach the menu to the button. + */ [my d_cocoaMenuButton setMenu: my d_cocoaMenu]; // the button will retain the menu... [my d_cocoaMenu release]; // ... so we can release the menu already (before even returning it!) [my d_cocoaMenuButton setTitle: (NSString *) Melder_peek32toCfstring (title)]; diff --git a/sys/GuiMenuItem.cpp b/sys/GuiMenuItem.cpp index a9c66283..51f79fcf 100644 --- a/sys/GuiMenuItem.cpp +++ b/sys/GuiMenuItem.cpp @@ -1,6 +1,6 @@ /* GuiMenuItem.cpp * - * Copyright (C) 1992-2018 Paul Boersma, 2013 Tom Naughton + * Copyright (C) 1992-2018,2020 Paul Boersma, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -80,12 +80,12 @@ Thing_implement (GuiMenuItem, GuiThing, 0); iam (GuiMenuItem); if (my d_callbackBlocked) return; if (G_OBJECT_TYPE (widget) == GTK_TYPE_RADIO_MENU_ITEM && ! gtk_check_menu_item_get_active (GTK_CHECK_MENU_ITEM (widget))) return; - struct structGuiMenuItemEvent event { me, false, false, false, false }; + structGuiMenuItemEvent event { me, false, false, false }; if (my d_callback) { try { my d_callback (my d_boss, & event); } catch (MelderError) { - Melder_flushError (U"Your choice of menu item \"", Melder_peek8to32 (GTK_WIDGET (widget) -> name), U"\" was not completely handled."); + Melder_flushError (U"Your choice of menu item \"", Melder_peek8to32 (gtk_widget_get_name (GTK_WIDGET (widget))), U"\" was not completely handled."); } } } @@ -98,7 +98,7 @@ Thing_implement (GuiMenuItem, GuiThing, 0); static void _guiMotifMenuItem_activateCallback (GuiObject widget, XtPointer void_me, XtPointer call) { iam (GuiMenuItem); if (my d_callback) { - struct structGuiMenuItemEvent event { me, false, false, false, false }; + structGuiMenuItemEvent event { me, false, false, false }; try { my d_callback (my d_boss, & event); } catch (MelderError) { @@ -127,7 +127,7 @@ Thing_implement (GuiMenuItem, GuiThing, 0); Melder_assert (self == widget); // sender (widget) and receiver (self) happen to be the same object GuiMenuItem me = d_userData; if (my d_callback) { - struct structGuiMenuItemEvent event { me, false, false, false, false }; + structGuiMenuItemEvent event { me, false, false, false }; try { my d_callback (my d_boss, & event); } catch (MelderError) { @@ -223,9 +223,15 @@ GuiMenuItem GuiMenu_addItem (GuiMenu menu, conststring32 title, uint32 flags, #if gtk static const guint acceleratorKeys [] = { 0, + #if ALLOW_GDK_DRAWING GDK_Left, GDK_Right, GDK_Up, GDK_Down, GDK_Pause, GDK_Delete, GDK_Insert, GDK_BackSpace, GDK_Tab, GDK_Return, GDK_Home, GDK_End, GDK_Return, GDK_Page_Up, GDK_Page_Down, GDK_Escape, GDK_F1, GDK_F2, GDK_F3, GDK_F4, GDK_F5, GDK_F6, GDK_F7, GDK_F8, GDK_F9, GDK_F10, GDK_F11, GDK_F12, + #else + GDK_KEY_Left, GDK_KEY_Right, GDK_KEY_Up, GDK_KEY_Down, GDK_KEY_Pause, GDK_KEY_Delete, GDK_KEY_Insert, GDK_KEY_BackSpace, + GDK_KEY_Tab, GDK_KEY_Return, GDK_KEY_Home, GDK_KEY_End, GDK_KEY_Return, GDK_KEY_Page_Up, GDK_KEY_Page_Down, GDK_KEY_Escape, + GDK_KEY_F1, GDK_KEY_F2, GDK_KEY_F3, GDK_KEY_F4, GDK_KEY_F5, GDK_KEY_F6, GDK_KEY_F7, GDK_KEY_F8, GDK_KEY_F9, GDK_KEY_F10, GDK_KEY_F11, GDK_KEY_F12, + #endif 0, 0, 0 }; GdkModifierType modifiers = (GdkModifierType) 0; if (flags & GuiMenu_COMMAND) modifiers = (GdkModifierType) (modifiers | GDK_CONTROL_MASK); diff --git a/sys/GuiOptionMenu.cpp b/sys/GuiOptionMenu.cpp index dfe0c3d7..d04ec8c0 100644 --- a/sys/GuiOptionMenu.cpp +++ b/sys/GuiOptionMenu.cpp @@ -67,11 +67,20 @@ void GuiOptionMenu_init (GuiOptionMenu me, GuiForm parent, int left, int right, my d_shell = parent -> d_shell; my d_parent = parent; #if gtk - my d_widget = gtk_combo_box_new_text (); + #if ALLOW_GDK_DRAWING + my d_widget = gtk_combo_box_new_text (); + #else + my d_widget = gtk_combo_box_text_new (); + #endif gtk_widget_set_size_request (GTK_WIDGET (my d_widget), right - left, bottom - top + 8); gtk_fixed_put (GTK_FIXED (parent -> d_widget), GTK_WIDGET (my d_widget), left, top - 6); - gtk_combo_box_set_focus_on_click (GTK_COMBO_BOX (my d_widget), false); - GTK_WIDGET_UNSET_FLAGS (my d_widget, GTK_CAN_DEFAULT); + #if ALLOW_GDK_DRAWING + gtk_combo_box_set_focus_on_click (GTK_COMBO_BOX (my d_widget), false); + GTK_WIDGET_UNSET_FLAGS (my d_widget, GTK_CAN_DEFAULT); + #else + gtk_widget_set_focus_on_click (GTK_WIDGET (my d_widget), false); + gtk_widget_set_can_default (GTK_WIDGET (my d_widget), FALSE); + #endif #elif motif my d_xmMenuBar = XmCreateMenuBar (parent -> d_widget, "UiOptionMenu", nullptr, 0); XtVaSetValues (my d_xmMenuBar, XmNx, left - 4, XmNy, top - 4, @@ -134,7 +143,11 @@ GuiOptionMenu GuiOptionMenu_createShown (GuiForm parent, int left, int right, in void GuiOptionMenu_addOption (GuiOptionMenu me, conststring32 text) { #if gtk - gtk_combo_box_append_text (GTK_COMBO_BOX (my d_widget), Melder_peek32to8 (text)); + #if ALLOW_GDK_DRAWING + gtk_combo_box_append_text (GTK_COMBO_BOX (my d_widget), Melder_peek32to8 (text)); + #else + gtk_combo_box_text_append_text (GTK_COMBO_BOX_TEXT (my d_widget), Melder_peek32to8 (text)); + #endif #elif motif autoGuiMenuItem menuItem = Thing_new (GuiMenuItem); menuItem -> d_widget = XtVaCreateManagedWidget (Melder_peek32to8 (text), xmToggleButtonWidgetClass, my d_widget, nullptr); diff --git a/sys/GuiP.h b/sys/GuiP.h index 34825262..355af97e 100644 --- a/sys/GuiP.h +++ b/sys/GuiP.h @@ -2,7 +2,7 @@ #define _GuiP_h_ /* GuiP.h * - * Copyright (C) 1993-2013,2015-2017 Paul Boersma + * Copyright (C) 1993-2013,2015-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -148,7 +148,7 @@ class GuiControlBlockValueChangedCallbacks { /********** GuiDrawingArea.cpp **********/ void _GuiWinDrawingArea_destroy (GuiObject widget); void _GuiWinDrawingArea_update (GuiObject widget); - void _GuiWinDrawingArea_handleClick (GuiObject widget, int x, int y); + void _GuiWinDrawingArea_handleMouse (GuiObject widget, structGuiDrawingArea_MouseEvent::Phase phase, int x, int y); void _GuiWinDrawingArea_handleKey (GuiObject widget, TCHAR kar); void _GuiWinDrawingArea_shellResize (GuiObject widget); diff --git a/sys/GuiScale.cpp b/sys/GuiScale.cpp index 68f4f27b..c664c26a 100644 --- a/sys/GuiScale.cpp +++ b/sys/GuiScale.cpp @@ -72,7 +72,8 @@ GuiScale GuiScale_create (GuiForm parent, int left, int right, int top, int bott my d_widget = gtk_hscrollbar_new (nullptr); gtk_range_set_range (GTK_RANGE (my d_widget), 0, 1000); GtkAdjustment *adj = gtk_range_get_adjustment (GTK_RANGE (my d_widget)); - adj -> page_size = 150; + //adj -> page_size = 150; + gtk_adjustment_set_page_size (adj, 150.0); gtk_adjustment_changed (adj); _GuiObject_setUserData (my d_widget, me.get()); my v_positionInForm (my d_widget, left, right, top, bottom, parent); diff --git a/sys/GuiScrollBar.cpp b/sys/GuiScrollBar.cpp index adaebbf0..da85fd64 100644 --- a/sys/GuiScrollBar.cpp +++ b/sys/GuiScrollBar.cpp @@ -208,8 +208,14 @@ GuiScrollBar GuiScrollBar_create (GuiForm parent, int left, int right, int top, my d_valueChangedCallback = valueChangedCallback; my d_valueChangedBoss = valueChangedBoss; #if gtk - GtkObject *adj = gtk_adjustment_new (value, minimum, maximum, increment, pageIncrement, sliderSize); - my d_widget = flags & GuiScrollBar_HORIZONTAL ? gtk_hscrollbar_new (GTK_ADJUSTMENT (adj)) : gtk_vscrollbar_new (GTK_ADJUSTMENT (adj)); + #if ALLOW_GDK_DRAWING + GtkObject *adj = gtk_adjustment_new (value, minimum, maximum, increment, pageIncrement, sliderSize); + my d_widget = flags & GuiScrollBar_HORIZONTAL ? gtk_hscrollbar_new (GTK_ADJUSTMENT (adj)) : gtk_vscrollbar_new (GTK_ADJUSTMENT (adj)); + #else + GtkAdjustment *adjustment = gtk_adjustment_new (value, minimum, maximum, increment, pageIncrement, sliderSize); + GtkOrientation orientation = ( flags & GuiScrollBar_HORIZONTAL ? GTK_ORIENTATION_HORIZONTAL : GTK_ORIENTATION_VERTICAL ); + my d_widget = gtk_scrollbar_new (orientation, adjustment); + #endif _GuiObject_setUserData (my d_widget, me.get()); my v_positionInForm (my d_widget, left, right, top, bottom, parent); g_signal_connect (G_OBJECT (my d_widget), "value-changed", G_CALLBACK (_GuiGtkScrollBar_valueChangedCallback), me.get()); diff --git a/sys/GuiShell.cpp b/sys/GuiShell.cpp index 1892db3c..66dc91c4 100644 --- a/sys/GuiShell.cpp +++ b/sys/GuiShell.cpp @@ -1,6 +1,6 @@ /* GuiShell.cpp * - * Copyright (C) 1993-2012,2015,2016,2017 Paul Boersma, 2013 Tom Naughton + * Copyright (C) 1993-2018,2020 Paul Boersma, 2013 Tom Naughton * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -62,7 +62,7 @@ void structGuiShell :: v_destroy () noexcept { #if cocoa if (our d_cocoaShell) { [our d_cocoaShell setUserData: nullptr]; // undangle reference to this - Melder_fatal (U"ordering out?"); + Melder_fatal (U"ordering out?"); // TODO: how can this never be reached? [our d_cocoaShell orderOut: nil]; [our d_cocoaShell close]; [our d_cocoaShell release]; @@ -75,11 +75,13 @@ void structGuiShell :: v_destroy () noexcept { int GuiShell_getShellWidth (GuiShell me) { int width = 0; #if gtk - width = GTK_WIDGET (my d_gtkWindow) -> allocation.width; + GtkAllocation allocation; + gtk_widget_get_allocation (GTK_WIDGET (my d_gtkWindow), & allocation); + width = allocation.width; #elif motif width = my d_xmShell -> width; #elif cocoa - return [my d_cocoaShell frame].size.width; + width = [my d_cocoaShell frame].size.width; #endif return width; } @@ -87,11 +89,13 @@ int GuiShell_getShellWidth (GuiShell me) { int GuiShell_getShellHeight (GuiShell me) { int height = 0; #if gtk - height = GTK_WIDGET (my d_gtkWindow) -> allocation.height; + GtkAllocation allocation; + gtk_widget_get_allocation (GTK_WIDGET (my d_gtkWindow), & allocation); + height = allocation.height; #elif motif height = my d_xmShell -> height; #elif cocoa - return [my d_cocoaShell frame].size.height; + height = [my d_cocoaShell frame].size.height; #endif return height; } @@ -108,21 +112,21 @@ void GuiShell_setTitle (GuiShell me, conststring32 title /* cattable */) { void GuiShell_drain (GuiShell me) { #if gtk - //gdk_window_flush (gtk_widget_get_window (my d_gtkWindow)); - gdk_flush (); + gdk_window_process_all_updates (); #elif motif - /* - On Windows Motif, there is no graphics buffering. - */ + UpdateWindow (my d_xmShell -> window); #elif cocoa Melder_assert (my d_cocoaShell); [my d_cocoaShell display]; // not just flushWindow - [NSApp - nextEventMatchingMask: NSAnyEventMask + NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init]; + NSEvent *nsEvent = [NSApp + nextEventMatchingMask: NSAppKitDefinedMask // NSAnyEventMask untilDate: [NSDate distantPast] inMode: NSDefaultRunLoopMode - dequeue: NO + dequeue: YES ]; + [NSApp sendEvent: nsEvent]; + [pool release]; #endif } diff --git a/sys/GuiText.cpp b/sys/GuiText.cpp index 222ef960..9e99cac4 100644 --- a/sys/GuiText.cpp +++ b/sys/GuiText.cpp @@ -561,7 +561,7 @@ GuiText GuiText_create (GuiForm parent, int left, int right, int top, int bottom g_signal_connect (G_OBJECT (my d_widget), "delete-text", G_CALLBACK (_GuiGtkEntry_history_delete_cb), me.get()); g_signal_connect (G_OBJECT (my d_widget), "insert-text", G_CALLBACK (_GuiGtkEntry_history_insert_cb), me.get()); g_signal_connect (GTK_EDITABLE (my d_widget), "changed", G_CALLBACK (_GuiGtkText_valueChangedCallback), me.get()); - //GTK_WIDGET_UNSET_FLAGS (my d_widget, GTK_CAN_DEFAULT); + //GTK_WIDGET_UNSET_FLAGS (my d_widget, GTK_CAN_DEFAULT); gtk_widget_set_can_default (my d_widget, FALSE); _GuiObject_setUserData (my d_widget, me.get()); my v_positionInForm (my d_widget, left, right, top, bottom, parent); gtk_entry_set_activates_default (GTK_ENTRY (my d_widget), true); diff --git a/sys/Gui_messages.cpp b/sys/Gui_messages.cpp index 2ad581a7..5ec02217 100644 --- a/sys/Gui_messages.cpp +++ b/sys/Gui_messages.cpp @@ -201,7 +201,8 @@ static void gui_progress (double progress, conststring32 message) { static autoGraphics graphics; static void gui_drawingarea_cb_expose (Thing /* boss */, GuiDrawingArea_ExposeEvent /* event */) { - if (! graphics) return; + if (! graphics) + return; Graphics_play (graphics.get(), graphics.get()); } @@ -218,12 +219,18 @@ static void * gui_monitor (double progress, conststring32 message) { { if (! dia) { _Melder_dia_init (& dia, & scale, & label1, & label2, & cancelButton, true); - drawingArea = GuiDrawingArea_createShown (dia, 0, 400, 230, 430, gui_drawingarea_cb_expose, nullptr, nullptr, nullptr, nullptr, 0); + drawingArea = GuiDrawingArea_createShown (dia, 0, 400, 230, 430, + gui_drawingarea_cb_expose, nullptr, nullptr, nullptr, nullptr, 0); GuiThing_show (dia); graphics = Graphics_create_xmdrawingarea (drawingArea); } - if (graphics) - Graphics_flushWs (graphics.get()); + if (progress <= 0.0 && graphics) { + Graphics_clearRecording (graphics.get()); + Graphics_startRecording (graphics.get()); + Graphics_clearWs (graphics.get()); + } + //if (graphics) + // Graphics_flushWs (graphics.get()); if (! waitWhileProgress (progress, message, dia, scale, label1, label2, cancelButton)) Melder_throw (U"Interrupted!"); lastTime = now; @@ -236,7 +243,7 @@ static void * gui_monitor (double progress, conststring32 message) { #if cocoa static void mac_message (NSAlertStyle macAlertType, conststring32 message32) { static char16 message16 [4000]; - int messageLength = str32len (message32); + integer messageLength = str32len (message32); uinteger j = 0; for (int i = 0; i < messageLength && j <= 4000 - 3; i ++) { char32 kar = message32 [i]; @@ -251,10 +258,10 @@ static void * gui_monitor (double progress, conststring32 message) { message16 [j] = u'\0'; // append null byte because we are going to search this string /* - * Split up the message between header (will appear in bold) and rest. - * The split is done at the first line break, except if the first line ends in a colon, - * in which case the split is done at the second line break. - */ + Split up the message between header (will appear in bold) and rest. + The split is done at the first line break, except if the first line ends in a colon, + in which case the split is done at the second line break. + */ const char16 *lineBreak = & message16 [0]; for (; *lineBreak != u'\0'; lineBreak ++) { if (*lineBreak == u'\n') { @@ -270,21 +277,21 @@ static void * gui_monitor (double progress, conststring32 message) { } uinteger lengthOfFirstSentence = (uinteger) (lineBreak - message16); /* - * Create an alert dialog with an icon that is appropriate for the level. - */ + Create an alert dialog with an icon that is appropriate for the level. + */ NSAlert *alert = [[NSAlert alloc] init]; [alert setAlertStyle: macAlertType]; /* - * Add the header in bold. - */ + Add the header in bold. + */ NSString *header = [[NSString alloc] initWithCharacters: (const unichar *) & message16 [0] length: lengthOfFirstSentence]; // note: init can change the object pointer! if (header) { // make this very safe, because we can be at error time or at fatal time [alert setMessageText: header]; [header release]; } /* - * Add the rest of the message in small type. - */ + Add the rest of the message in small type. + */ if (lengthOfFirstSentence < j) { NSString *rest = [[NSString alloc] initWithCharacters: (const unichar *) & lineBreak [1] length: j - 1 - lengthOfFirstSentence]; if (rest) { // make this very safe, because we can be at error time or at fatal time @@ -293,8 +300,12 @@ static void * gui_monitor (double progress, conststring32 message) { } } /* - * Display the alert dialog and synchronously wait for the user to click OK. - */ + Display the alert dialog and synchronously wait for the user to click OK. + But: it is not impossible that the program crashes during `runModal`, + especially if `runModal` is called at expose time. + Write the message to stdout just in case. + */ + Melder_casual (message32); [alert runModal]; [alert release]; } @@ -320,9 +331,8 @@ static void gui_fatal (conststring32 message) { static void gui_error (conststring32 message) { bool memoryIsLow = str32str (message, U"Out of memory"); - if (memoryIsLow) { + if (memoryIsLow) free (theMessageFund); - } #if gtk trace (U"create dialog"); GuiObject dialog = gtk_message_dialog_new (GTK_WINDOW (Melder_topShell -> d_gtkWindow), GTK_DIALOG_DESTROY_WITH_PARENT, diff --git a/sys/HyperPage.cpp b/sys/HyperPage.cpp index 7a85e674..8e1806ab 100644 --- a/sys/HyperPage.cpp +++ b/sys/HyperPage.cpp @@ -591,7 +591,8 @@ void structHyperPage :: v_destroy () noexcept { } static void gui_drawingarea_cb_expose (HyperPage me, GuiDrawingArea_ExposeEvent /* event */) { - if (! my graphics) return; // could be the case in the very beginning + if (! my graphics) + return; // could be the case in the very beginning Graphics_clearWs (my graphics.get()); initScreen (me); trace (U"going to draw"); @@ -599,7 +600,8 @@ static void gui_drawingarea_cb_expose (HyperPage me, GuiDrawingArea_ExposeEvent if (my entryHint && my entryPosition != 0.0) { my entryHint. reset(); my top = (int) floor (5.0 * (PAGE_HEIGHT - my entryPosition)); - if (my top < 0) my top = 0; + if (my top < 0) + my top = 0; Graphics_clearWs (my graphics.get()); initScreen (me); my v_draw (); @@ -607,8 +609,11 @@ static void gui_drawingarea_cb_expose (HyperPage me, GuiDrawingArea_ExposeEvent } } -static void gui_drawingarea_cb_click (HyperPage me, GuiDrawingArea_ClickEvent event) { - if (! my graphics) return; // could be the case in the very beginning +static void gui_drawingarea_cb_mouse (HyperPage me, GuiDrawingArea_MouseEvent event) { + if (! event -> isClick()) + return; + if (! my graphics) + return; // could be the case in the very beginning for (integer ilink = 1; ilink <= my links.size; ilink ++) { HyperLink link = my links.at [ilink]; if (! link) @@ -746,7 +751,8 @@ static void createVerticalScrollBar (HyperPage me, GuiForm parent) { - Machine_getScrollBarWidth (), 0, Machine_getMenuBarHeight () + (my d_hasExtraRowOfTools ? 2 * height + 19 : height + 12), - Machine_getScrollBarWidth (), 0, PAGE_HEIGHT * 5, 0, 25, 1, 24, - gui_cb_verticalScroll, me, 0); + gui_cb_verticalScroll, me, 0 + ); } static void updateVerticalScrollBar (HyperPage me) @@ -759,9 +765,10 @@ static void updateVerticalScrollBar (HyperPage me) } static void menu_cb_pageUp (HyperPage me, EDITOR_ARGS_DIRECT) { - if (! my verticalScrollBar) return; + if (! my verticalScrollBar) + return; int value = GuiScrollBar_getValue (my verticalScrollBar) - 24; - if (value < 0) value = 0; + Melder_clipLeft (0, & value); if (value != my top) { my top = value; Graphics_clearWs (my graphics.get()); @@ -772,9 +779,10 @@ static void menu_cb_pageUp (HyperPage me, EDITOR_ARGS_DIRECT) { } static void menu_cb_pageDown (HyperPage me, EDITOR_ARGS_DIRECT) { - if (! my verticalScrollBar) return; + if (! my verticalScrollBar) + return; int value = GuiScrollBar_getValue (my verticalScrollBar) + 24; - if (value > (int) (PAGE_HEIGHT * 5) - 25) value = (int) (PAGE_HEIGHT * 5) - 25; + Melder_clipRight (& value, (int) (PAGE_HEIGHT * 5) - 25); if (value != my top) { my top = value; Graphics_clearWs (my graphics.get()); @@ -806,7 +814,8 @@ static void gui_button_cb_back (HyperPage me, GuiButtonEvent /* event */) { } static void do_forth (HyperPage me) { - if (my historyPointer >= 19 || ! my history [my historyPointer + 1]. page) return; + if (my historyPointer >= 19 || ! my history [my historyPointer + 1]. page) + return; autostring32 page = Melder_dup_f (my history [++ my historyPointer]. page.get()); int top = my history [my historyPointer]. top; if (my v_goToPage (page.get())) { @@ -858,17 +867,18 @@ void structHyperPage :: v_createMenus () { /********** **********/ static void gui_drawingarea_cb_resize (HyperPage me, GuiDrawingArea_ResizeEvent event) { - if (! my graphics) return; + if (! my graphics) + return; Graphics_setWsViewport (my graphics.get(), 0.0, event -> width, 0.0, event -> height); Graphics_setWsWindow (my graphics.get(), 0.0, my rightMargin = event -> width / resolution, - PAGE_HEIGHT - event -> height / resolution, PAGE_HEIGHT); + PAGE_HEIGHT - event -> height / resolution, PAGE_HEIGHT); Graphics_updateWs (my graphics.get()); updateVerticalScrollBar (me); } static void gui_button_cb_previousPage (HyperPage me, GuiButtonEvent /* event */) { HyperPage_goToPage_number (me, my v_getCurrentPageNumber () > 1 ? - my v_getCurrentPageNumber () - 1 : my v_getNumberOfPages ()); + my v_getCurrentPageNumber () - 1 : my v_getNumberOfPages ()); } static void gui_button_cb_nextPage (HyperPage me, GuiButtonEvent /* event */) { @@ -884,15 +894,15 @@ void structHyperPage :: v_createChildren () { if (our v_hasHistory ()) { GuiButton_createShown (our windowForm, 4, 48, y, y + height, - U"<", gui_button_cb_back, this, 0); + U"<", gui_button_cb_back, this, 0); GuiButton_createShown (our windowForm, 54, 98, y, y + height, - U">", gui_button_cb_forth, this, 0); + U">", gui_button_cb_forth, this, 0); } if (our v_isOrdered ()) { GuiButton_createShown (our windowForm, 174, 218, y, y + height, - U"< 1", gui_button_cb_previousPage, this, 0); + U"< 1", gui_button_cb_previousPage, this, 0); GuiButton_createShown (our windowForm, 224, 268, y, y + height, - U"1 >", gui_button_cb_nextPage, this, 0); + U"1 >", gui_button_cb_nextPage, this, 0); } /***** Create scroll bar. *****/ @@ -904,7 +914,9 @@ void structHyperPage :: v_createChildren () { drawingArea = GuiDrawingArea_createShown (our windowForm, 0, - Machine_getScrollBarWidth (), y + ( our d_hasExtraRowOfTools ? 2 * height + 16 : height + 9 ), - Machine_getScrollBarWidth (), - gui_drawingarea_cb_expose, gui_drawingarea_cb_click, nullptr, gui_drawingarea_cb_resize, this, GuiDrawingArea_BORDER); + gui_drawingarea_cb_expose, gui_drawingarea_cb_mouse, + nullptr, gui_drawingarea_cb_resize, this, GuiDrawingArea_BORDER + ); GuiDrawingArea_setSwipable (drawingArea, nullptr, our verticalScrollBar); } diff --git a/sys/InfoEditor.cpp b/sys/InfoEditor.cpp index 2e1bff28..a9c87372 100644 --- a/sys/InfoEditor.cpp +++ b/sys/InfoEditor.cpp @@ -109,6 +109,7 @@ static void gui_information (conststring32 message) { //Melder_casual (U"cocoaTextView retain count after: ", [editor -> textWidget -> d_cocoaTextView retainCount]); [pool release]; #elif defined (macintosh) + // TODO: call [view invalidate] here? GuiShell_drain (editor -> windowForm); #endif } diff --git a/sys/Interpreter.cpp b/sys/Interpreter.cpp index 1215be7f..3d24b1a3 100644 --- a/sys/Interpreter.cpp +++ b/sys/Interpreter.cpp @@ -2656,33 +2656,33 @@ void Interpreter_voidExpression (Interpreter me, conststring32 expression) { Formula_run (0, 0, & result); } -void Interpreter_numericExpression (Interpreter me, conststring32 expression, double *p_value) { - Melder_assert (p_value); +void Interpreter_numericExpression (Interpreter me, conststring32 expression, double *out_value) { + Melder_assert (out_value); if (str32str (expression, U"(=")) { - *p_value = Melder_atof (expression); + *out_value = Melder_atof (expression); } else { Formula_compile (me, nullptr, expression, kFormula_EXPRESSION_TYPE_NUMERIC, false); Formula_Result result; Formula_run (0, 0, & result); - *p_value = result. numericResult; + *out_value = result. numericResult; } } -void Interpreter_numericVectorExpression (Interpreter me, conststring32 expression, VEC *p_value, bool *p_owned) { +void Interpreter_numericVectorExpression (Interpreter me, conststring32 expression, VEC *out_value, bool *out_owned) { Formula_compile (me, nullptr, expression, kFormula_EXPRESSION_TYPE_NUMERIC_VECTOR, false); Formula_Result result; Formula_run (0, 0, & result); - *p_value = result. numericVectorResult; - *p_owned = result. owned; + *out_value = result. numericVectorResult; + *out_owned = result. owned; result. owned = false; } -void Interpreter_numericMatrixExpression (Interpreter me, conststring32 expression, MAT *p_value, bool *p_owned) { +void Interpreter_numericMatrixExpression (Interpreter me, conststring32 expression, MAT *out_value, bool *out_owned) { Formula_compile (me, nullptr, expression, kFormula_EXPRESSION_TYPE_NUMERIC_MATRIX, false); Formula_Result result; Formula_run (0, 0, & result); - *p_value = result. numericMatrixResult; - *p_owned = result. owned; + *out_value = result. numericMatrixResult; + *out_owned = result. owned; result. owned = false; } @@ -2693,9 +2693,9 @@ autostring32 Interpreter_stringExpression (Interpreter me, conststring32 express return result. stringResult.move(); } -void Interpreter_anyExpression (Interpreter me, conststring32 expression, Formula_Result *p_result) { +void Interpreter_anyExpression (Interpreter me, conststring32 expression, Formula_Result *out_result) { Formula_compile (me, nullptr, expression, kFormula_EXPRESSION_TYPE_UNKNOWN, false); - Formula_run (0, 0, p_result); + Formula_run (0, 0, out_result); } /* End of file Interpreter.cpp */ diff --git a/sys/Makefile b/sys/Makefile index 88712621..c7de43ae 100644 --- a/sys/Makefile +++ b/sys/Makefile @@ -1,14 +1,14 @@ # Makefile of the library "sys" -# Paul Boersma, 11 August 2018 +# Paul Boersma, 4 October 2020 include ../makefile.defs - + # -I ../sys is there because e.g. Graphics.cpp include fon/Function.h, which again includes something from sys CPPFLAGS = -I ../melder -I ../sys OBJECTS = Thing.o Data.o Simple.o Collection.o Strings.o \ Graphics.o Graphics_linesAndAreas.o Graphics_text.o Graphics_colour.o \ - Graphics_image.o Graphics_mouse.o Graphics_record.o \ + Graphics_image.o Graphics_record.o \ Graphics_utils.o Graphics_grey.o Graphics_altitude.o \ GraphicsPostscript.o Graphics_surface.o \ ManPage.o ManPages.o Script.o machine.o \ diff --git a/sys/Manual.cpp b/sys/Manual.cpp index 24bb7e39..25538e33 100644 --- a/sys/Manual.cpp +++ b/sys/Manual.cpp @@ -78,9 +78,6 @@ static void menu_cb_searchForPageList (Manual me, EDITOR_ARGS_FORM) { void structManual :: v_draw () { ManPages manPages = (ManPages) our data; - #if motif - Graphics_clearWs (our graphics.get()); - #endif if (our visiblePageNumber == SEARCH_PAGE) { HyperPage_pageTitle (this, U"Best matches"); HyperPage_intro (this, U"The best matches to your query seem to be:"); diff --git a/sys/Picture.cpp b/sys/Picture.cpp index d51dd3cf..60c0a84b 100644 --- a/sys/Picture.cpp +++ b/sys/Picture.cpp @@ -1,6 +1,6 @@ /* Picture.cpp * - * Copyright (C) 1992-2019 Paul Boersma, 2008 Stefan de Konink, 2010 Franz Brauße + * Copyright (C) 1992-2020 Paul Boersma, 2008 Stefan de Konink, 2010 Franz Brauße * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -29,161 +29,149 @@ Thing_implement (Picture, Thing, 0); static void drawMarkers (Picture me) /* - * The drawing area is a square measuring 12x12 inches. - */ + The drawing area is a square measuring 12x12 inches. +*/ #define SIDE 12 /* - * The selection grid has a resolution of 1/2 inch. - */ -#define SQUARES 24 + The selection grid has a resolution of 1/2 inch. +*/ +#define SQUARES 24_integer /* - * Vertical and horizontal lines every 3 inches. - */ + Vertical and horizontal lines every 3 inches. +*/ #define YELLOW_GRID 3 { - /* Fill the entire canvas with GC's background. */ - + /* + Fill the entire canvas with GC's background. + */ Graphics_setColour (my selectionGraphics.get(), Melder_WHITE); Graphics_fillRectangle (my selectionGraphics.get(), 0, SIDE, 0, SIDE); - /* Draw yellow grid lines for coarse navigation. */ - + /* + Draw yellow grid lines for coarse navigation. + */ Graphics_setColour (my selectionGraphics.get(), Melder_YELLOW); for (int i = YELLOW_GRID; i < SIDE; i += YELLOW_GRID) { Graphics_line (my selectionGraphics.get(), 0, i, SIDE, i); Graphics_line (my selectionGraphics.get(), i, 0, i, SIDE); } - /* Draw red ticks and numbers for feedback on viewport measurement. */ - + /* + Draw red ticks and numbers for feedback on viewport measurement. + */ Graphics_setColour (my selectionGraphics.get(), Melder_RED); for (int i = 1; i < SIDE; i ++) { - double x = i; + const double x = i; Graphics_setTextAlignment (my selectionGraphics.get(), Graphics_CENTRE, Graphics_TOP); Graphics_text (my selectionGraphics.get(), x, SIDE, i); Graphics_setTextAlignment (my selectionGraphics.get(), Graphics_CENTRE, Graphics_BOTTOM); Graphics_text (my selectionGraphics.get(), x, 0, i); } for (int i = 1; i < SQUARES ; i ++) { // vertical ticks - double x = 0.5 * i; + const double x = 0.5 * i; Graphics_line (my selectionGraphics.get(), x, SIDE - 0.04, x, SIDE); Graphics_line (my selectionGraphics.get(), x, 0, x, 0.04); } for (int i = 1; i < SIDE; i ++) { - double y = SIDE - i; + const double y = SIDE - i; Graphics_setTextAlignment (my selectionGraphics.get(), Graphics_LEFT, Graphics_HALF); Graphics_text (my selectionGraphics.get(), 0.04, y, i); Graphics_setTextAlignment (my selectionGraphics.get(), Graphics_RIGHT, Graphics_HALF); Graphics_text (my selectionGraphics.get(), SIDE - 0.03, y, i); } for (int i = 1; i < SQUARES; i ++) { // horizontal ticks - double y = SIDE - 0.5 * i; + const double y = SIDE - 0.5 * i; Graphics_line (my selectionGraphics.get(), SIDE - 0.04, y, SIDE, y); Graphics_line (my selectionGraphics.get(), 0, y, 0.04, y); } - Graphics_setColour (my selectionGraphics.get(), Melder_BLACK); } -static void drawSelection (Picture me, int high) { - if (my backgrounding) return; - double dy = 2.8 * Graphics_inqFontSize (my graphics.get()) / 72.0; - double dx = 1.5 * dy; - if (dy > 0.4 * (my sely2 - my sely1)) dy = 0.4 * (my sely2 - my sely1); - if (dx > 0.4 * (my selx2 - my selx1)) dx = 0.4 * (my selx2 - my selx1); - if (high) { - Graphics_highlight2 (my selectionGraphics.get(), my selx1, my selx2, my sely1, my sely2, - my selx1 + dx, my selx2 - dx, my sely1 + dy, my sely2 - dy); - } else { - Graphics_unhighlight2 (my selectionGraphics.get(), my selx1, my selx2, my sely1, my sely2, - my selx1 + dx, my selx2 - dx, my sely1 + dy, my sely2 - dy); - } +static void drawSelection (Picture me) { + const double dy = Melder_clippedRight (2.8 * Graphics_inqFontSize (my graphics.get()) / 72.0, + 0.4 * (my sely2 - my sely1)); + const double dx = Melder_clippedRight (1.5 * dy, + 0.4 * (my selx2 - my selx1)); + Graphics_highlight2 (my selectionGraphics.get(), + my selx1, my selx2, my sely1, my sely2, + my selx1 + dx, my selx2 - dx, my sely1 + dy, my sely2 - dy + ); } -//static double test = 0.0; - static void gui_drawingarea_cb_expose (Picture me, GuiDrawingArea_ExposeEvent event) { #if gtk /* - * The size of the viewable part of the drawing area may have changed. - */ + The size of the viewable part of the drawing area may have changed. + */ Melder_assert (event -> widget); #if ALLOW_GDK_DRAWING - gdk_cairo_reset_clip ((cairo_t *) Graphics_x_getCR (my graphics.get()), GDK_DRAWABLE (GTK_WIDGET (event -> widget -> d_widget) -> window)); - gdk_cairo_reset_clip ((cairo_t *) Graphics_x_getCR (my selectionGraphics.get()), GDK_DRAWABLE (GTK_WIDGET (event -> widget -> d_widget) -> window)); + if (Melder_debug == 54) { + // ignore gdk_cairo_reset_clip + } else { + gdk_cairo_reset_clip ((cairo_t *) Graphics_x_getCR (my graphics.get()), GDK_DRAWABLE (GTK_WIDGET (event -> widget -> d_widget) -> window)); + gdk_cairo_reset_clip ((cairo_t *) Graphics_x_getCR (my selectionGraphics.get()), GDK_DRAWABLE (GTK_WIDGET (event -> widget -> d_widget) -> window)); + } #endif #else (void) event; #endif drawMarkers (me); Graphics_play (my graphics.get(), my graphics.get()); - drawSelection (me, 1); + drawSelection (me); } -// TODO: Paul, als praat nu 100dpi zou zijn waarom zie ik hier dan nog 72.0 onder? -// Stefan, die 72.0 is het aantal font-punten per inch, -// gewoon een vaste verhouding die niks met pixels te maken heeft. -// TODO: Paul, deze code is bagger :) En dient door event-model-extremisten te worden veroordeeld. -// Stefan, zoals gezegd, er zijn goede redenen waarom sommige platforms dit synchroon oplossen; -// misschien maar splitsen tussen die platforms en platforms die met events kunnen werken. - -// (Tom:) On Cocoa this leads to flashing, it definitely needs to be event based. - -// (Paul:) No, running this through the normal event loop with mouse-down-drag-up events and generating exposes -// redrew the entire picture window on every change of the selection during dragging. Much too slow! - -static void gui_drawingarea_cb_click (Picture me, GuiDrawingArea_ClickEvent event) { - int xstart = event -> x; - int ystart = event -> y; +static void gui_drawingarea_cb_mouse (Picture me, GuiDrawingArea_MouseEvent event) { + /* + Dragging the mouse selects an integer number of "blocks". + */ + struct Block { + integer ix, iy; + }; + static Block anchorBlock, previousBlock; double xWC, yWC; - int ixstart, iystart, ix, iy, oldix = 0, oldiy = 0; - - Graphics_DCtoWC (my selectionGraphics.get(), xstart, ystart, & xWC, & yWC); - ix = ixstart = 1 + (int) floor (xWC * SQUARES / SIDE); - iy = iystart = SQUARES - (int) floor (yWC * SQUARES / SIDE); - if (ixstart < 1 || ixstart > SQUARES || iystart < 1 || iystart > SQUARES) return; - if (event -> shiftKeyPressed) { - int ix1 = 1 + (int) floor (my selx1 * SQUARES / SIDE); - int ix2 = (int) floor (my selx2 * SQUARES / SIDE); - int iy1 = SQUARES + 1 - (int) floor (my sely2 * SQUARES / SIDE); - int iy2 = SQUARES - (int) floor (my sely1 * SQUARES / SIDE); - ixstart = ix < (ix1 + ix2) / 2 ? ix2 : ix1; - iystart = iy < (iy1 + iy2) / 2 ? iy2 : iy1; + Graphics_DCtoWC (my selectionGraphics.get(), event -> x, event -> y, & xWC, & yWC); + const Block currentBlock { + Melder_clipped (1_integer, 1 + (integer) floor (xWC * SQUARES / SIDE), SQUARES), + Melder_clipped (1_integer, SQUARES - (integer) floor (yWC * SQUARES / SIDE), SQUARES) + }; + bool didBlockChange = false; // optimization: don't redraw if we stay in the same block + if (event -> isClick()) { + constexpr int INVALID_BLOCK_NUMBER = 0; + previousBlock = { INVALID_BLOCK_NUMBER, INVALID_BLOCK_NUMBER }; + if (event -> shiftKeyPressed) { + const integer ix1 = Melder_clipped (1_integer, 1 + (integer) floor (my selx1 * SQUARES / SIDE), SQUARES); // BUG not compatible with mouseSelectsInnerViewport + const integer ix2 = Melder_clipped (1_integer, (integer) floor (my selx2 * SQUARES / SIDE), SQUARES); + const integer iy1 = Melder_clipped (1_integer, SQUARES + 1 - (integer) floor (my sely2 * SQUARES / SIDE), SQUARES); + const integer iy2 = Melder_clipped (1_integer, SQUARES - (integer) floor (my sely1 * SQUARES / SIDE), SQUARES); + anchorBlock = { currentBlock. ix < (ix1 + ix2) / 2 ? ix2 : ix1, currentBlock. iy < (iy1 + iy2) / 2 ? iy2 : iy1 }; + } else { + anchorBlock = currentBlock; + } + didBlockChange = true; + } else if (event -> isDrag() || event -> isDrop()) { + didBlockChange = ( currentBlock. ix != previousBlock. ix || currentBlock. iy != previousBlock. iy ); } - //while (Graphics_mouseStillDown (my selectionGraphics)) { - do { - Graphics_getMouseLocation (my selectionGraphics.get(), & xWC, & yWC); - ix = 1 + (int) floor (xWC * SQUARES / SIDE); - iy = SQUARES - (int) floor (yWC * SQUARES / SIDE); - if (ix >= 1 && ix <= SQUARES && iy >= 1 && iy <= SQUARES && (ix != oldix || iy != oldiy)) { - int ix1, ix2, iy1, iy2; - if (ix < ixstart) { ix1 = ix; ix2 = ixstart; } - else { ix1 = ixstart; ix2 = ix; } - if (iy < iystart) { iy1 = iy; iy2 = iystart; } - else { iy1 = iystart; iy2 = iy; } - if (my mouseSelectsInnerViewport) { - const double fontSize = Graphics_inqFontSize (my graphics.get()); - double xmargin = fontSize * 4.2 / 72.0, ymargin = fontSize * 2.8 / 72.0; - if (xmargin > ix2 - ix1 + 1) xmargin = ix2 - ix1 + 1; - if (ymargin > iy2 - iy1 + 1) ymargin = iy2 - iy1 + 1; - Picture_setSelection (me, 0.5 * (ix1 - 1) - xmargin, 0.5 * ix2 + xmargin, - 0.5 * (SQUARES - iy2) - ymargin, 0.5 * (SQUARES + 1 - iy1) + ymargin, false); - } else { - Picture_setSelection (me, 0.5 * (ix1 - 1), 0.5 * ix2, - 0.5 * (SQUARES - iy2), 0.5 * (SQUARES + 1 - iy1), false); - } - oldix = ix; oldiy = iy; + if (didBlockChange) { + previousBlock = currentBlock; + const auto ix12 = std::minmax (currentBlock. ix, anchorBlock. ix); + const integer ix1 = ix12. first, ix2 = ix12. second; + const auto iy12 = std::minmax (currentBlock. iy, anchorBlock. iy); + const integer iy1 = iy12. first, iy2 = iy12. second; + double xmargin = 0.0, ymargin = 0.0; + if (my mouseSelectsInnerViewport) { + const double fontSize = Graphics_inqFontSize (my graphics.get()); + xmargin = std::min (fontSize * 4.2 / 72.0, double (ix2 - ix1 + 1)); + ymargin = std::min (fontSize * 2.8 / 72.0, double (iy2 - iy1 + 1)); } - } while (Graphics_mouseStillDown (my selectionGraphics.get())); - // } - #if cocoa - Graphics_updateWs (my selectionGraphics.get()); // to change the dark red back into black - #endif - if (my selectionChangedCallback) { - //Melder_casual (U"selectionChangedCallback from gui_drawingarea_cb_click"); + Picture_setSelection (me, + 0.5 * (ix1 - 1) - xmargin, 0.5 * ix2 + xmargin, + 0.5 * (SQUARES - iy2) - ymargin, 0.5 * (SQUARES + 1 - iy1) + ymargin + ); + Graphics_updateWs (my selectionGraphics.get()); + } + if (event -> isDrop() && my selectionChangedCallback) my selectionChangedCallback (me, my selectionChangedClosure, my selx1, my selx2, my sely1, my sely2); - } } autoPicture Picture_create (GuiDrawingArea drawingArea, bool sensitive) { @@ -191,29 +179,32 @@ autoPicture Picture_create (GuiDrawingArea drawingArea, bool sensitive) { autoPicture me = Thing_new (Picture); my drawingArea = drawingArea; /* - * The initial viewport is a rectangle 6 inches wide and 4 inches high. - */ + The initial viewport is a rectangle 6 inches wide and 4 inches high. + */ my selx1 = 0.0; my selx2 = 6.0; my sely1 = 8.0; my sely2 = 12.0; my sensitive = sensitive && drawingArea; + /* + Create a Graphics to directly draw in. + */ if (drawingArea) { - /* The drawing area must have been realized; see manual at XtWindow. */ + // the drawing area must have been realized; see manual at XtWindow my graphics = Graphics_create_xmdrawingarea (my drawingArea); GuiDrawingArea_setExposeCallback (my drawingArea, gui_drawingarea_cb_expose, me.get()); } else { /* - * Create a dummy Graphics. - */ + Create a dummy Graphics. + */ my graphics = Graphics_create (600); } Graphics_setWsWindow (my graphics.get(), 0.0, 12.0, 0.0, 12.0); Graphics_setViewport (my graphics.get(), my selx1, my selx2, my sely1, my sely2); if (my sensitive) { my selectionGraphics = Graphics_create_xmdrawingarea (my drawingArea); - Graphics_setWindow (my selectionGraphics.get(), 0, 12, 0, 12); - GuiDrawingArea_setClickCallback (my drawingArea, gui_drawingarea_cb_click, me.get()); + Graphics_setWindow (my selectionGraphics.get(), 0.0, 12.0, 0.0, 12.0); + GuiDrawingArea_setMouseCallback (my drawingArea, gui_drawingarea_cb_mouse, me.get()); } Graphics_startRecording (my graphics.get()); return me; @@ -241,27 +232,16 @@ void structPicture :: v_destroy () noexcept { Graphics Picture_peekGraphics (Picture me) { return my graphics.get(); } -void Picture_unhighlight (Picture me) { - if (my drawingArea) drawSelection (me, 0); // unselect -} - -void Picture_highlight (Picture me) { - if (my drawingArea) drawSelection (me, 1); // select -} - void Picture_erase (Picture me) { Graphics_clearRecording (my graphics.get()); - Graphics_clearWs (my graphics.get()); - if (my drawingArea) { - drawMarkers (me); - drawSelection (me, 1); - } + Graphics_updateWs (my graphics.get()); } void Picture_writeToPraatPictureFile (Picture me, MelderFile file) { try { autofile f = Melder_fopen (file, "wb"); - if (fprintf (f, "PraatPictureFile") < 0) Melder_throw (U"Write error."); + if (fprintf (f, "PraatPictureFile") < 0) + Melder_throw (U"Write error."); Graphics_writeRecordings (my graphics.get(), f); f.close (file); } catch (MelderError) { @@ -273,14 +253,15 @@ void Picture_readFromPraatPictureFile (Picture me, MelderFile file) { try { autofile f = Melder_fopen (file, "rb"); char line [200]; - int n = fread (line, 1, 199, f); + integer n = uinteger_to_integer (fread (line, 1, 199, f)); line [n] = '\0'; const char *tag = "PraatPictureFile"; char *end = strstr (line, tag); - if (! end) Melder_throw (U"This is not a Praat picture file."); + if (! end) + Melder_throw (U"This is not a Praat picture file."); *end = '\0'; rewind (f); - fread (line, 1, end - line + strlen (tag), f); + fread (line, 1, integer_to_uinteger (end - line + uinteger_to_integer (strlen (tag))), f); Graphics_readRecordings (my graphics.get(), f); Graphics_updateWs (my graphics.get()); f.close (file); @@ -291,19 +272,19 @@ void Picture_readFromPraatPictureFile (Picture me, MelderFile file) { #ifdef macintosh static size_t appendBytes (void *info, const void *buffer, size_t count) { - CFDataAppendBytes ((CFMutableDataRef) info, (const UInt8 *) buffer, count); + CFDataAppendBytes ((CFMutableDataRef) info, (const UInt8 *) buffer, uinteger_to_integer (count)); return count; } void Picture_copyToClipboard (Picture me) { /* - * Find the clipboard and clear it. - */ + Find the clipboard and clear it. + */ PasteboardRef clipboard = nullptr; PasteboardCreate (kPasteboardClipboard, & clipboard); PasteboardClear (clipboard); /* - * Add a PDF flavour to the clipboard. - */ + Add a PDF flavour to the clipboard. + */ static CGDataConsumerCallbacks callbacks = { appendBytes, nullptr }; CFDataRef data = CFDataCreateMutable (kCFAllocatorDefault, 0); CGDataConsumerRef consumer = CGDataConsumerCreate ((void *) data, & callbacks); @@ -312,14 +293,14 @@ void Picture_copyToClipboard (Picture me) { CGContextRef context = CGPDFContextCreate (consumer, & rect, nullptr); //my selx1 * RES, (12 - my sely2) * RES, my selx2 * RES, (12 - my sely1) * RES) {// scope - autoGraphics graphics = Graphics_create_pdf (context, resolution, my selx1, my selx2, my sely1, my sely2); - Graphics_play (my graphics.get(), graphics.get()); + autoGraphics pdfGraphics = Graphics_create_pdf (context, resolution, my selx1, my selx2, my sely1, my sely2); + Graphics_play (my graphics.get(), pdfGraphics.get()); } PasteboardPutItemFlavor (clipboard, (PasteboardItemID) 1, kUTTypePDF, data, kPasteboardFlavorNoFlags); CFRelease (data); /* - * Forget the clipboard. - */ + Forget the clipboard. + */ CFRelease (clipboard); } #endif @@ -330,18 +311,17 @@ void Picture_copyToClipboard (Picture me) { #define WIN_WIDTH 7.5 #define WIN_HEIGHT 11 static HENHMETAFILE copyToMetafile (Picture me) { - RECT rect; - HDC dc; PRINTDLG defaultPrinter; - int resolution; memset (& defaultPrinter, 0, sizeof (PRINTDLG)); defaultPrinter. lStructSize = sizeof (PRINTDLG); defaultPrinter. Flags = PD_RETURNDEFAULT | PD_RETURNDC; PrintDlg (& defaultPrinter); + RECT rect; SetRect (& rect, my selx1 * 2540, (12 - my sely2) * 2540, my selx2 * 2540, (12 - my sely1) * 2540); - dc = CreateEnhMetaFile (defaultPrinter. hDC, nullptr, & rect, L"Praat\0"); - if (! dc) Melder_throw (U"Cannot create Windows metafile."); - resolution = GetDeviceCaps (dc, LOGPIXELSX); // Virtual PC: 360; Parallels Desktop: 600 + const HDC dc = CreateEnhMetaFile (defaultPrinter. hDC, nullptr, & rect, L"Praat\0"); + if (! dc) + Melder_throw (U"Cannot create Windows metafile."); + const int resolution = GetDeviceCaps (dc, LOGPIXELSX); // Virtual PC: 360; Parallels Desktop: 600 //Melder_fatal (U"resolution ", resolution); if (Melder_debug == 6) { DEVMODE *devMode = * (DEVMODE **) defaultPrinter. hDevMode; @@ -388,9 +368,9 @@ void Picture_copyToClipboard (Picture me) { SetClipboardData (CF_ENHMETAFILE, metafile); CloseClipboard (); /* - * We should NOT call DeleteEnhMetaFile, - * because the clipboard becomes the owner of this global memory object. - */ + We should NOT call DeleteEnhMetaFile, + because the clipboard becomes the owner of this global memory object. + */ } catch (MelderError) { Melder_throw (U"Picture not copied to clipboard."); } @@ -410,12 +390,12 @@ void Picture_writeToWindowsMetafile (Picture me, MelderFile file) { void Picture_writeToEpsFile (Picture me, MelderFile file, bool includeFonts, bool useSilipaPS) { try { MelderFile_delete (file); // to kill resources as well (fopen only kills data fork) - /* BUG: no message if file cannot be deleted (e.g. because still open by Microsoft Word 2001 after reading). */ + // BUG: no message if file cannot be deleted (e.g. because still open by Microsoft Word 2001 after reading) {// scope - autoGraphics ps = Graphics_create_epsfile (file, 600, thePrinter. spots, - my selx1, my selx2, my sely1, my sely2, includeFonts, useSilipaPS); - Graphics_play (my graphics.get(), ps.get()); + autoGraphics postscriptGraphics = Graphics_create_epsfile (file, 600, thePrinter. spots, + my selx1, my selx2, my sely1, my sely2, includeFonts, useSilipaPS); + Graphics_play (my graphics.get(), postscriptGraphics.get()); } } catch (MelderError) { Melder_throw (U"Picture not written to EPS file ", file); @@ -424,8 +404,8 @@ void Picture_writeToEpsFile (Picture me, MelderFile file, bool includeFonts, boo void Picture_writeToPdfFile (Picture me, MelderFile file) { try { - autoGraphics graphics = Graphics_create_pdffile (file, 300, my selx1, my selx2, my sely1, my sely2); - Graphics_play (my graphics.get(), graphics.get()); + autoGraphics pdfGraphics = Graphics_create_pdffile (file, 300, my selx1, my selx2, my sely1, my sely2); + Graphics_play (my graphics.get(), pdfGraphics.get()); } catch (MelderError) { Melder_throw (U"Picture not written to PDF file ", file, U"."); } @@ -433,8 +413,8 @@ void Picture_writeToPdfFile (Picture me, MelderFile file) { void Picture_writeToPngFile_300 (Picture me, MelderFile file) { try { - autoGraphics graphics = Graphics_create_pngfile (file, 300, my selx1, my selx2, my sely1, my sely2); - Graphics_play (my graphics.get(), graphics.get()); + autoGraphics pngGraphics = Graphics_create_pngfile (file, 300, my selx1, my selx2, my sely1, my sely2); + Graphics_play (my graphics.get(), pngGraphics.get()); } catch (MelderError) { Melder_throw (U"Picture not written to PNG file ", file, U"."); } @@ -442,8 +422,8 @@ void Picture_writeToPngFile_300 (Picture me, MelderFile file) { void Picture_writeToPngFile_600 (Picture me, MelderFile file) { try { - autoGraphics graphics = Graphics_create_pngfile (file, 600, my selx1, my selx2, my sely1, my sely2); - Graphics_play (my graphics.get(), graphics.get()); + autoGraphics pngGraphics = Graphics_create_pngfile (file, 600, my selx1, my selx2, my sely1, my sely2); + Graphics_play (my graphics.get(), pngGraphics.get()); } catch (MelderError) { Melder_throw (U"Picture not written to PNG file ", file, U"."); } @@ -463,28 +443,14 @@ void Picture_print (Picture me) { } void Picture_setSelection - (Picture me, double x1NDC, double x2NDC, double y1NDC, double y2NDC, bool notify) + (Picture me, double x1NDC, double x2NDC, double y1NDC, double y2NDC) { - if (my drawingArea) { + if (my drawingArea) Melder_assert (my drawingArea -> d_widget); - drawSelection (me, 0); // unselect - } my selx1 = x1NDC; my selx2 = x2NDC; my sely1 = y1NDC; my sely2 = y2NDC; - if (my drawingArea) { - drawSelection (me, 1); // select - } - - if (notify && my selectionChangedCallback) { - //Melder_casual (U"selectionChangedCallback from Picture_setSelection"); - my selectionChangedCallback (me, my selectionChangedClosure, - my selx1, my selx2, my sely1, my sely2); - } } -void Picture_background (Picture me) { my backgrounding = true; } -void Picture_foreground (Picture me) { my backgrounding = false; } - /* End of file Picture.cpp */ diff --git a/sys/Picture.h b/sys/Picture.h index ca46bcfb..d70748e4 100644 --- a/sys/Picture.h +++ b/sys/Picture.h @@ -2,7 +2,7 @@ #define _Picture_h_ /* Picture.h * - * Copyright (C) 1992-2005,2007-2016,2018 Paul Boersma + * Copyright (C) 1992-2005,2007-2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -24,25 +24,17 @@ the user can select the viewport by dragging the mouse across the drawing area. If the viewport is smaller than the entire drawing area, it is highlighted. Usage: - You should put highlighting off during drawing. Do not use the workstation Graphics routines, like clearWs, flushWs, closeWs, updateWs, setWsViewport. Example: - Picture p = Picture_create (myDrawingArea); - Graphics g = Picture_peekGraphics (p); - Picture_unhighlight (p); + autoPicture p = Picture_create (myDrawingArea); + Graphics g = Picture_peekGraphics (p.get()); Graphics_setTextAlignment (g, Graphics_CENTRE, Graphics_HALF); Graphics_text (g, 0.5, 0.7, U"Hello"); Graphics_text (g, 0.5, 0.6, U"there"); - Picture_highlight (p); - ... (event handling) - Picture_unhighlight (p); Graphics_text (g, 0.5, 0.3, U"Goodbye"); - Picture_highlight (p); - ... (event handling) - Picture_writeToEpsFile (p, U"HelloGoodbye.eps", false, false); - Picture_print (p, GraphicsPostscript_FINE); - Picture_remove (& p); + Picture_writeToPngFile_300 (p, U"HelloGoodbye.png"); + Picture_print (p.get()); */ #include "Gui.h" @@ -54,7 +46,7 @@ Thing_define (Picture, Thing) { double selx1, selx2, sely1, sely2; // selection in NDC co-ordinates void (*selectionChangedCallback) (Picture, void *, double, double, double, double); void *selectionChangedClosure; - bool backgrounding, mouseSelectsInnerViewport; + bool mouseSelectsInnerViewport; void v_destroy () noexcept override; @@ -81,22 +73,6 @@ Graphics Picture_peekGraphics (Picture me); bracketed by calls to Picture_startRecording and Picture_stopRecording. */ -void Picture_unhighlight (Picture me); -/* - Function: - hide the viewport. - Usage: - call just before sending graphics output. -*/ - -void Picture_highlight (Picture me); -/* - Function: - visualize the viewport. - Usage: - call just after sending graphics output. -*/ - void Picture_setSelectionChangedCallback (Picture me, void (*selectionChangedCallback) (Picture, void *closure, double x1NDC, double x2NDC, double y1NDC, double y2NDC), @@ -125,15 +101,12 @@ void Picture_printToPostScriptPrinter (Picture me, int spots, int paperSize, int #endif void Picture_setSelection - (Picture me, double x1NDC, double x2NDC, double y1NDC, double y2NDC, bool notify); + (Picture me, double x1NDC, double x2NDC, double y1NDC, double y2NDC); /* Preconditions: 0.0 <= x1NDC < x2NDC <= 1.0; 0.0 <= y1NDC < y2NDC <= 1.0; */ -void Picture_background (Picture me); -void Picture_foreground (Picture me); - /* End of file Picture.h */ #endif diff --git a/sys/Script.cpp b/sys/Script.cpp index feceeaff..5381d548 100644 --- a/sys/Script.cpp +++ b/sys/Script.cpp @@ -1,6 +1,6 @@ /* Script.cpp * - * Copyright (C) 1997-2011,2015 Paul Boersma + * Copyright (C) 1997-2005,2009,2011,2015,2016,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by diff --git a/sys/Script.h b/sys/Script.h index 8c4195a0..6663e561 100644 --- a/sys/Script.h +++ b/sys/Script.h @@ -2,7 +2,7 @@ #define _Script_h_ /* Script.h * - * Copyright (C) 1997-2011,2015 Paul Boersma + * Copyright (C) 1997-2005,2007,2011,2015,2016,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by diff --git a/sys/ScriptEditor.cpp b/sys/ScriptEditor.cpp index e3ac7831..cf58e6c5 100644 --- a/sys/ScriptEditor.cpp +++ b/sys/ScriptEditor.cpp @@ -1,6 +1,6 @@ /* ScriptEditor.cpp * - * Copyright (C) 1997-2005,2007-2018 Paul Boersma + * Copyright (C) 1997-2005,2007-2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -28,7 +28,8 @@ static CollectionOf theReferencesToAllOpenScriptEditors; bool ScriptEditors_dirty () { for (integer i = 1; i <= theReferencesToAllOpenScriptEditors.size; i ++) { ScriptEditor me = theReferencesToAllOpenScriptEditors.at [i]; - if (my dirty) return true; + if (my dirty) + return true; } return false; } @@ -75,7 +76,8 @@ static void args_ok (UiForm sendingForm, integer /* narg */, Stackel /* args */, Interpreter_getArgumentsFromDialog (my interpreter.get(), sendingForm); autoPraatBackground background; - if (my name [0]) MelderFile_setDefaultDir (& file); + if (my name [0]) + MelderFile_setDefaultDir (& file); Interpreter_run (my interpreter.get(), text.get()); } @@ -101,6 +103,7 @@ static void args_ok_selectionOnly (UiForm sendingForm, integer /* narg */, Stack } static void menu_cb_run (ScriptEditor me, EDITOR_ARGS_DIRECT) { + bool isObscured = false; if (my interpreter -> running) Melder_throw (U"The script is already running (paused). Please close or continue the pause or demo window."); autostring32 text = GuiText_getString (my textWidget); @@ -110,19 +113,53 @@ static void menu_cb_run (ScriptEditor me, EDITOR_ARGS_DIRECT) { Melder_pathToFile (my name.get(), & file); MelderFile_setDefaultDir (& file); } + const conststring32 obscuredLabel = U"#!praatObscured"; + if (Melder_stringMatchesCriterion (text.get(), kMelder_string::STARTS_WITH, obscuredLabel, true)) { + const integer obscuredLabelLength = str32len (obscuredLabel); + const double fileKey_real = Melder_atof (MelderFile_name (& file)); + const uint64 fileKey = ( isdefined (fileKey_real) ? uint64 (fileKey_real) : 0 ); + char32 *restOfText = & text [obscuredLabelLength]; + uint64 passwordHash = 0; + if (*restOfText == U'\n') { + restOfText += 1; // skip newline + } else if (*restOfText == U' ') { + restOfText ++; + char32 *endOfFirstLine = str32chr (restOfText, U'\n'); + if (! endOfFirstLine) + Melder_throw (U"Incomplete script."); + *endOfFirstLine = U'\0'; + passwordHash = NUMhashString (restOfText); + restOfText = endOfFirstLine + 1; + } else { + Melder_throw (U"Unexpected nonspace after #!praatObscured."); + } + static uint64 nonsecret = UINT64_C (529857089); + text = newSTRunhex (restOfText, fileKey + nonsecret + passwordHash); + isObscured = true; + } Melder_includeIncludeFiles (& text); - integer npar = Interpreter_readParameters (my interpreter.get(), text.get()); - if (npar) { - /* - * Pop up a dialog box for querying the arguments. - */ - my argsDialog = Interpreter_createForm (my interpreter.get(), my windowForm, nullptr, args_ok, me, false); - UiForm_do (my argsDialog.get(), false); - } else { - autoPraatBackground background; - if (my name [0]) MelderFile_setDefaultDir (& file); - trace (U"Running the following script (2):\n", text.get()); - Interpreter_run (my interpreter.get(), text.get()); + const integer npar = Interpreter_readParameters (my interpreter.get(), text.get()); + try { + if (npar) { + /* + Pop up a dialog box for querying the arguments. + */ + my argsDialog = Interpreter_createForm (my interpreter.get(), my windowForm, nullptr, args_ok, me, false); + UiForm_do (my argsDialog.get(), false); + } else { + autoPraatBackground background; + if (my name [0]) + MelderFile_setDefaultDir (& file); + trace (U"Running the following script (2):\n", text.get()); + Interpreter_run (my interpreter.get(), text.get()); + } + } catch (MelderError) { + if (isObscured) { + Melder_clearError (); + Melder_throw (U"Undisclosed error in obscured Praat script."); + } else { + throw; + } } } @@ -141,13 +178,14 @@ static void menu_cb_runSelection (ScriptEditor me, EDITOR_ARGS_DIRECT) { integer npar = Interpreter_readParameters (my interpreter.get(), text.get()); if (npar) { /* - * Pop up a dialog box for querying the arguments. - */ + Pop up a dialog box for querying the arguments. + */ my argsDialog = Interpreter_createForm (my interpreter.get(), my windowForm, nullptr, args_ok_selectionOnly, me, true); UiForm_do (my argsDialog.get(), false); } else { autoPraatBackground background; - if (my name [0]) MelderFile_setDefaultDir (& file); + if (my name [0]) + MelderFile_setDefaultDir (& file); Interpreter_run (my interpreter.get(), text.get()); } } @@ -161,7 +199,8 @@ static void menu_cb_addToMenu (ScriptEditor me, EDITOR_ARGS_FORM) { INTEGER (depth, U"Depth", U"0") TEXTFIELD (scriptFile, U"Script file:", U"") EDITOR_OK - if (my editorClass) SET_STRING (window, my editorClass -> className) + if (my editorClass) + SET_STRING (window, my editorClass -> className) if (my name [0]) SET_STRING (scriptFile, my name.get()) else diff --git a/sys/Ui.cpp b/sys/Ui.cpp index 4a15f7f5..1611639d 100644 --- a/sys/Ui.cpp +++ b/sys/Ui.cpp @@ -666,11 +666,12 @@ UiField UiForm_addBoolean (UiForm me, bool *variable, conststring32 variableName return thee; } -UiField UiForm_addText (UiForm me, conststring32 *variable, conststring32 variableName, conststring32 name, conststring32 defaultValue) { +UiField UiForm_addText (UiForm me, conststring32 *variable, conststring32 variableName, conststring32 name, conststring32 defaultValue, integer numberOfLines) { UiField thee = UiForm_addField (me, _kUiField_type::TEXT_, name); thy stringDefaultValue = Melder_dup (defaultValue); thy stringVariable = variable; thy variableName = variableName; + thy numberOfLines = Melder_clipped (1_integer, numberOfLines, 33_integer); return thee; } @@ -679,6 +680,7 @@ UiField UiForm_addNumvec (UiForm me, constVEC *variable, conststring32 variableN thy stringDefaultValue = Melder_dup (defaultValue); thy numericVectorVariable = variable; thy variableName = variableName; + thy numberOfLines = 1; return thee; } @@ -687,6 +689,7 @@ UiField UiForm_addNummat (UiForm me, constMAT *variable, conststring32 variableN thy stringDefaultValue = Melder_dup (defaultValue); thy numericMatrixVariable = variable; thy variableName = variableName; + thy numberOfLines = 1; return thee; } @@ -755,8 +758,23 @@ static void appendColon () { MelderString_appendCharacter (& theFinishBuffer, U':'); } +static int multiLineTextHeight (integer numberOfLines) { + if (numberOfLines <= 1) + return Gui_TEXTFIELD_HEIGHT; + #if defined (macintosh) + return numberOfLines * (Gui_TEXTFIELD_HEIGHT - 9) + 21; // 15 is the minimum, but 21 gives some feedback about what is outside (2020-10-19) + #elif defined (_WIN32) + return numberOfLines * (Gui_TEXTFIELD_HEIGHT - 4) + 21; // 21 is the mininum (2020-10-19) + #elif defined (linux) + return numberOfLines * (Gui_TEXTFIELD_HEIGHT - 8) + 15; // 13 is the minimum, but if there is no horizontal scrollbar, there is a line more (2020-10-19) + #else + return numberOfLines * Gui_TEXTFIELD_HEIGHT; + #endif +} + void UiForm_finish (UiForm me) { - if (! my d_dialogParent && ! my isPauseForm) return; + if (! my d_dialogParent && ! my isPauseForm) + return; int size = my numberOfFields; int dialogHeight = 0, x = Gui_LEFT_DIALOG_SPACING, y; @@ -765,6 +783,7 @@ void UiForm_finish (UiForm me) { int labelWidth = fieldX - Gui_LABEL_SPACING - x, fieldWidth = labelWidth, halfFieldWidth = fieldWidth / 2 - 6; GuiForm form; + bool okButtonIsDefault = true; /* Compute height. Cannot leave this to the default geometry management system. @@ -791,7 +810,9 @@ void UiForm_finish (UiForm me) { #else - 10 : #endif + thy type == _kUiField_type::TEXT_ ? multiLineTextHeight (thy numberOfLines) : textFieldHeight; + okButtonIsDefault &= ( thy numberOfLines <= 1 ); // because otherwise, the Enter key would be ambiguous } dialogHeight += 2 * Gui_BOTTOM_DIALOG_SPACING + Gui_PUSHBUTTON_HEIGHT; my d_dialogForm = GuiDialog_create (my d_dialogParent, DIALOG_X, DIALOG_Y, dialogWidth, dialogHeight, my name.get(), gui_dialog_cb_close, me, 0); @@ -799,9 +820,9 @@ void UiForm_finish (UiForm me) { form = my d_dialogForm; for (integer ifield = 1; ifield <= size; ifield ++) { - UiField field = my field [ifield].get(); - y = field -> y; - switch (field -> type) + UiField thee = my field [ifield].get(); + y = thy y; + switch (thy type) { case _kUiField_type::REAL_: case _kUiField_type::REAL_OR_UNDEFINED_: @@ -817,22 +838,22 @@ void UiForm_finish (UiForm me) { #if defined (macintosh) ylabel += 3; #endif - if (str32nequ (field -> name.get(), U"left ", 5)) { - MelderString_copy (& theFinishBuffer, field -> formLabel.get() + 5); + if (str32nequ (thy name.get(), U"left ", 5)) { + MelderString_copy (& theFinishBuffer, thy formLabel.get() + 5); appendColon (); - field -> label = GuiLabel_createShown (form, 0, x + labelWidth, ylabel, ylabel + textFieldHeight, + thy label = GuiLabel_createShown (form, 0, x + labelWidth, ylabel, ylabel + textFieldHeight, theFinishBuffer.string, GuiLabel_RIGHT); - field -> text = GuiText_createShown (form, fieldX, fieldX + halfFieldWidth, y, y + Gui_TEXTFIELD_HEIGHT, 0); - } else if (str32nequ (field -> name.get(), U"right ", 6)) { - field -> text = GuiText_createShown (form, fieldX + halfFieldWidth + 12, fieldX + fieldWidth, + thy text = GuiText_createShown (form, fieldX, fieldX + halfFieldWidth, y, y + Gui_TEXTFIELD_HEIGHT, 0); + } else if (str32nequ (thy name.get(), U"right ", 6)) { + thy text = GuiText_createShown (form, fieldX + halfFieldWidth + 12, fieldX + fieldWidth, y, y + Gui_TEXTFIELD_HEIGHT, 0); } else { - MelderString_copy (& theFinishBuffer, field -> formLabel.get()); + MelderString_copy (& theFinishBuffer, thy formLabel.get()); appendColon (); - field -> label = GuiLabel_createShown (form, 0, x + labelWidth, + thy label = GuiLabel_createShown (form, 0, x + labelWidth, ylabel, ylabel + textFieldHeight, theFinishBuffer.string, GuiLabel_RIGHT); - field -> text = GuiText_createShown (form, fieldX, fieldX + fieldWidth, // or once the dialog is a Form: - Gui_RIGHT_DIALOG_SPACING, + thy text = GuiText_createShown (form, fieldX, fieldX + fieldWidth, // or once the dialog is a Form: - Gui_RIGHT_DIALOG_SPACING, y, y + Gui_TEXTFIELD_HEIGHT, 0); } } @@ -841,14 +862,14 @@ void UiForm_finish (UiForm me) { case _kUiField_type::NUMVEC_: case _kUiField_type::NUMMAT_: { - field -> text = GuiText_createShown (form, x, x + dialogWidth - Gui_LEFT_DIALOG_SPACING - Gui_RIGHT_DIALOG_SPACING, - y, y + Gui_TEXTFIELD_HEIGHT, 0); + thy text = GuiText_createShown (form, x, x + dialogWidth - Gui_LEFT_DIALOG_SPACING - Gui_RIGHT_DIALOG_SPACING, + y, y + multiLineTextHeight (thy numberOfLines), thy numberOfLines > 1 ? GuiText_SCROLLED : 0); } break; case _kUiField_type::LABEL_: { - MelderString_copy (& theFinishBuffer, field -> stringValue.get()); - field -> label = GuiLabel_createShown (form, + MelderString_copy (& theFinishBuffer, thy stringValue.get()); + thy label = GuiLabel_createShown (form, x, dialogWidth /* allow to extend into the margin */, y + 5, y + 5 + textFieldHeight, theFinishBuffer.string, 0); } @@ -859,13 +880,13 @@ void UiForm_finish (UiForm me) { #if defined (macintosh) ylabel += 1; #endif - MelderString_copy (& theFinishBuffer, field -> formLabel.get()); + MelderString_copy (& theFinishBuffer, thy formLabel.get()); appendColon (); - field -> label = GuiLabel_createShown (form, x, x + labelWidth, ylabel, ylabel + Gui_RADIOBUTTON_HEIGHT, + thy label = GuiLabel_createShown (form, x, x + labelWidth, ylabel, ylabel + Gui_RADIOBUTTON_HEIGHT, theFinishBuffer.string, GuiLabel_RIGHT); GuiRadioGroup_begin (); - for (integer ibutton = 1; ibutton <= field -> options.size; ibutton ++) { - UiOption button = field -> options.at [ibutton]; + for (integer ibutton = 1; ibutton <= thy options.size; ibutton ++) { + UiOption button = thy options.at [ibutton]; MelderString_copy (& theFinishBuffer, button -> name.get()); button -> radioButton = GuiRadioButton_createShown (form, fieldX, dialogWidth /* allow to extend into the margin */, @@ -882,24 +903,24 @@ void UiForm_finish (UiForm me) { #if defined (macintosh) ylabel += 2; #endif - MelderString_copy (& theFinishBuffer, field -> formLabel.get()); + MelderString_copy (& theFinishBuffer, thy formLabel.get()); appendColon (); - field -> label = GuiLabel_createShown (form, x, x + labelWidth, ylabel, ylabel + Gui_OPTIONMENU_HEIGHT, + thy label = GuiLabel_createShown (form, x, x + labelWidth, ylabel, ylabel + Gui_OPTIONMENU_HEIGHT, theFinishBuffer.string, GuiLabel_RIGHT); - field -> optionMenu = GuiOptionMenu_createShown (form, fieldX, fieldX + fieldWidth, y, y + Gui_OPTIONMENU_HEIGHT, 0); - for (integer ibutton = 1; ibutton <= field -> options.size; ibutton ++) { - UiOption button = field -> options.at [ibutton]; + thy optionMenu = GuiOptionMenu_createShown (form, fieldX, fieldX + fieldWidth, y, y + Gui_OPTIONMENU_HEIGHT, 0); + for (integer ibutton = 1; ibutton <= thy options.size; ibutton ++) { + UiOption button = thy options.at [ibutton]; MelderString_copy (& theFinishBuffer, button -> name.get()); - GuiOptionMenu_addOption (field -> optionMenu, theFinishBuffer.string); + GuiOptionMenu_addOption (thy optionMenu, theFinishBuffer.string); } } break; case _kUiField_type::BOOLEAN_: { - MelderString_copy (& theFinishBuffer, field -> formLabel.get()); + MelderString_copy (& theFinishBuffer, thy formLabel.get()); /*field -> label = GuiLabel_createShown (form, x, x + labelWidth, y, y + Gui_CHECKBUTTON_HEIGHT, theFinishBuffer.string, GuiLabel_RIGHT); */ - field -> checkButton = GuiCheckButton_createShown (form, + thy checkButton = GuiCheckButton_createShown (form, fieldX, dialogWidth /* allow to extend into the margin */, y, y + Gui_CHECKBUTTON_HEIGHT, theFinishBuffer.string, nullptr, nullptr, 0); } @@ -907,15 +928,15 @@ void UiForm_finish (UiForm me) { case _kUiField_type::LIST_: { int listWidth = my numberOfFields == 1 ? dialogWidth - fieldX : fieldWidth; - MelderString_copy (& theFinishBuffer, field -> formLabel.get()); + MelderString_copy (& theFinishBuffer, thy formLabel.get()); appendColon (); - field -> label = GuiLabel_createShown (form, x, x + labelWidth, y + 1, y + 21, + thy label = GuiLabel_createShown (form, x, x + labelWidth, y + 1, y + 21, theFinishBuffer.string, GuiLabel_RIGHT); - field -> list = GuiList_create (form, fieldX, fieldX + listWidth, y, y + LIST_HEIGHT, false, theFinishBuffer.string); - for (integer i = 1; i <= field -> strings.size; i ++) { - GuiList_insertItem (field -> list, field -> strings [i], 0); + thy list = GuiList_create (form, fieldX, fieldX + listWidth, y, y + LIST_HEIGHT, false, theFinishBuffer.string); + for (integer i = 1; i <= thy strings.size; i ++) { + GuiList_insertItem (thy list, thy strings [i], 0); } - GuiThing_show (field -> list); + GuiThing_show (thy list); } break; } @@ -939,7 +960,7 @@ void UiForm_finish (UiForm me) { if (my isPauseForm) { my revertButton = GuiButton_createShown (form, HELP_BUTTON_X, HELP_BUTTON_X + REVERT_BUTTON_WIDTH, - y, y + Gui_PUSHBUTTON_HEIGHT, U"Revert", gui_button_cb_revert, me, 0); + y, y + Gui_PUSHBUTTON_HEIGHT, U"Undo", gui_button_cb_revert, me, 0); } else { my revertButton = GuiButton_createShown (form, HELP_BUTTON_X + HELP_BUTTON_WIDTH + Gui_HORIZONTAL_DIALOG_SPACING, @@ -958,12 +979,17 @@ void UiForm_finish (UiForm me) { } int room = dialogWidth - Gui_RIGHT_DIALOG_SPACING - x; int roomPerContinueButton = room / my numberOfContinueButtons; - int horizontalSpacing = my numberOfContinueButtons > 7 ? Gui_HORIZONTAL_DIALOG_SPACING - 2 * (my numberOfContinueButtons - 7) : Gui_HORIZONTAL_DIALOG_SPACING; + int horizontalSpacing = ( + my numberOfContinueButtons > 7 ? + Gui_HORIZONTAL_DIALOG_SPACING - 2 * (my numberOfContinueButtons - 7) + : + Gui_HORIZONTAL_DIALOG_SPACING + ); int continueButtonWidth = roomPerContinueButton - horizontalSpacing; for (int i = 1; i <= my numberOfContinueButtons; i ++) { x = dialogWidth - Gui_RIGHT_DIALOG_SPACING - roomPerContinueButton * (my numberOfContinueButtons - i + 1) + horizontalSpacing; my continueButtons [i] = GuiButton_createShown (form, x, x + continueButtonWidth, y, y + Gui_PUSHBUTTON_HEIGHT, - my continueTexts [i], gui_button_cb_ok, me, i == my defaultContinueButton ? GuiButton_DEFAULT : 0); + my continueTexts [i], gui_button_cb_ok, me, i == my defaultContinueButton && okButtonIsDefault ? GuiButton_DEFAULT : 0); } } else { x = dialogWidth - Gui_RIGHT_DIALOG_SPACING - Gui_OK_BUTTON_WIDTH - 2 * Gui_HORIZONTAL_DIALOG_SPACING @@ -977,7 +1003,7 @@ void UiForm_finish (UiForm me) { } x = dialogWidth - Gui_RIGHT_DIALOG_SPACING - Gui_OK_BUTTON_WIDTH; my okButton = GuiButton_createShown (form, x, x + Gui_OK_BUTTON_WIDTH, y, y + Gui_PUSHBUTTON_HEIGHT, - my isPauseForm ? U"Continue" : U"OK", gui_button_cb_ok, me, GuiButton_DEFAULT); + my isPauseForm ? U"Continue" : U"OK", gui_button_cb_ok, me, okButtonIsDefault ? GuiButton_DEFAULT : 0); } /*GuiObject_show (separator);*/ } diff --git a/sys/Ui.h b/sys/Ui.h index c9b92f39..67e52ae3 100644 --- a/sys/Ui.h +++ b/sys/Ui.h @@ -2,7 +2,7 @@ #define _Ui_h_ /* Ui.h * - * Copyright (C) 1992-2011,2012,2013,2015,2017,2018 Paul Boersma + * Copyright (C) 1992-2005,2007-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -132,13 +132,14 @@ Thing_define (UiField, Thing) { constMAT *numericMatrixVariable; int subtract; + integer numberOfLines; void v_destroy () noexcept override; }; #define UiCallback_ARGS \ - UiForm _sendingForm, integer _narg, Stackel _args, conststring32 _sendingString, Interpreter interpreter, conststring32 _invokingButtonTitle, bool _modified, void *_closure + UiForm _sendingForm, integer _narg, Stackel _args, conststring32 _sendingString, Interpreter interpreter, conststring32 _invokingButtonTitle, bool _isModified, void *_closure typedef void (*UiCallback) (UiCallback_ARGS); #define MAXIMUM_NUMBER_OF_FIELDS 50 @@ -194,7 +195,7 @@ UiField UiForm_addWord (UiForm me, conststring32 *variable, conststring32 variab UiField UiForm_addSentence (UiForm me, conststring32 *variable, conststring32 variableName, conststring32 label, conststring32 defaultValue); UiField UiForm_addLabel (UiForm me, conststring32 *variable, conststring32 label); UiField UiForm_addBoolean (UiForm me, bool *variable, conststring32 variableName, conststring32 label, bool defaultValue); -UiField UiForm_addText (UiForm me, conststring32 *variable, conststring32 variableName, conststring32 name, conststring32 defaultValue); +UiField UiForm_addText (UiForm me, conststring32 *variable, conststring32 variableName, conststring32 name, conststring32 defaultValue, integer numberOfLines = 1); UiField UiForm_addNumvec (UiForm me, constVEC *variable, conststring32 variableName, conststring32 name, conststring32 defaultValue); UiField UiForm_addNummat (UiForm me, constMAT *variable, conststring32 variableName, conststring32 name, conststring32 defaultValue); UiField UiForm_addRadio (UiForm me, int *intVariable, conststring32 *stringVariable, conststring32 variableName, conststring32 label, int defaultValue, int base); diff --git a/sys/UiPause.cpp b/sys/UiPause.cpp index fc3d2aac..ca71f61f 100644 --- a/sys/UiPause.cpp +++ b/sys/UiPause.cpp @@ -1,6 +1,6 @@ /* UiPause.cpp * - * Copyright (C) 2009-2019 Paul Boersma + * Copyright (C) 2009-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -80,10 +80,10 @@ void UiPause_sentence (conststring32 label, conststring32 defaultValue) { Melder_throw (U"The function \"sentence\" should be between a \"beginPause\" and an \"endPause\"."); UiForm_addSentence (thePauseForm.get(), nullptr, nullptr, label, defaultValue); } -void UiPause_text (conststring32 label, conststring32 defaultValue) { +void UiPause_text (conststring32 label, conststring32 defaultValue, integer numberOfLines) { if (! thePauseForm) Melder_throw (U"The function \"text\" should be between a \"beginPause\" and an \"endPause\"."); - UiForm_addText (thePauseForm.get(), nullptr, nullptr, label, defaultValue); + UiForm_addText (thePauseForm.get(), nullptr, nullptr, label, defaultValue, numberOfLines); } void UiPause_boolean (conststring32 label, bool defaultValue) { if (! thePauseForm) diff --git a/sys/UiPause.h b/sys/UiPause.h index f9e62ffa..fe9d8fc8 100644 --- a/sys/UiPause.h +++ b/sys/UiPause.h @@ -2,7 +2,7 @@ #define _UiPause_h_ /* UiPause.h * - * Copyright (C) 2009-2012,2015,2016,2018 Paul Boersma + * Copyright (C) 2009-2012,2015,2016,2018,2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -29,7 +29,7 @@ void UiPause_integer (conststring32 label, conststring32 defaultValue); void UiPause_natural (conststring32 label, conststring32 defaultValue); void UiPause_word (conststring32 label, conststring32 defaultValue); void UiPause_sentence (conststring32 label, conststring32 defaultValue); -void UiPause_text (conststring32 label, conststring32 defaultValue); +void UiPause_text (conststring32 label, conststring32 defaultValue, integer numberOfLines); void UiPause_boolean (conststring32 label, bool defaultValue); void UiPause_choice (conststring32 label, int defaultValue); void UiPause_optionMenu (conststring32 label, int defaultValue); diff --git a/sys/motifEmulator.cpp b/sys/motifEmulator.cpp index 1cad60d9..ab037286 100644 --- a/sys/motifEmulator.cpp +++ b/sys/motifEmulator.cpp @@ -505,17 +505,19 @@ static void NativeMenuItem_setText (GuiObject me) { /* * We now create the native objects associated with this widget, * but do not show them on the screen yet (ideally). - * A reference must be made from widget to native object and back. - * On Mac, we normally use the RefCon fields of the windows and controls. - * On Win, we use SetWindowLongPtr (window, GWLP_USERDATA, (LONG_PTR) widget). + * A reference must be made from widget to native object and back, + * with SetWindowLongPtr (window, GWLP_USERDATA, (LONG_PTR) widget). */ static void _GuiNativizeWidget (GuiObject me) { - if (my nativized) return; + if (my nativized) + return; if (my inMenu) { if (MEMBER (me, PulldownMenu)) { int id; - for (id = 1; id <= MAXIMUM_NUMBER_OF_MENUS; id ++) if (! theMenus [id]) break; + for (id = 1; id <= MAXIMUM_NUMBER_OF_MENUS; id ++) + if (! theMenus [id]) + break; my nat.menu.id = id; theMenus [my nat.menu.id] = me; // instead of UserData fields /* @@ -536,7 +538,9 @@ static void _GuiNativizeWidget (GuiObject me) { * In our implementation, item IDs are application-unique. */ int id; - for (id = MINIMUM_MENU_ITEM_ID; id <= MAXIMUM_MENU_ITEM_ID; id ++) if (! theMenuItems [id]) break; + for (id = MINIMUM_MENU_ITEM_ID; id <= MAXIMUM_MENU_ITEM_ID; id ++) + if (! theMenuItems [id]) + break; my nat.entry.id = id; // install unique ID theMenuItems [id] = true; } @@ -2105,7 +2109,8 @@ static GuiObject _motif_getNextTextWidget (GuiObject shell, GuiObject text, bool } static void on_scroll (GuiObject me, UINT part, int pos) { - if (my maximum == my minimum) return; + if (my maximum == my minimum) + return; switch (part) { case SB_LINEUP: my value -= my increment; break; case SB_LINEDOWN: my value += my increment; break; @@ -2119,8 +2124,7 @@ static void on_scroll (GuiObject me, UINT part, int pos) { #endif default: break; } - if (my value < my minimum) my value = my minimum; - if (my value > my maximum - my sliderSize) my value = my maximum - my sliderSize; + Melder_clip (my minimum, & my value, my maximum - my sliderSize); NativeScrollBar_set (me); if (part == SB_THUMBTRACK || part == SB_THUMBPOSITION) _Gui_callCallbacks (me, & my motiff.scrollBar.dragCallbacks, (XtPointer) (ULONG_PTR) part); @@ -2133,14 +2137,12 @@ void XtNextEvent (XEvent *xevent) { } static void processWorkProcsAndTimeOuts () { - if (theNumberOfWorkProcs) { - for (integer i = 9; i >= 1; i --) { - if (theWorkProcs [i]) { - if (theWorkProcs [i] (theWorkProcClosures [i])) XtRemoveWorkProc (i); - } - } - } - if (theNumberOfTimeOuts) { + if (theNumberOfWorkProcs != 0) + for (integer i = 9; i >= 1; i --) + if (theWorkProcs [i]) + if (theWorkProcs [i] (theWorkProcClosures [i])) + XtRemoveWorkProc (i); + if (theNumberOfTimeOuts != 0) { clock_t now = clock (); for (integer i = 1; i < 10; i ++) if (theTimeOutProcs [i]) { static volatile clock_t timeElapsed; // careful: use 32-bit integers circularly; prevent optimization @@ -2508,10 +2510,28 @@ static void on_lbuttonDown (HWND window, BOOL doubleClick, int x, int y, UINT fl GuiObject me = (GuiObject) GetWindowLongPtr (window, GWLP_USERDATA); if (me) { if (MEMBER (me, DrawingArea)) { - _GuiWinDrawingArea_handleClick (me, x, y); + SetCapture (window); + _GuiWinDrawingArea_handleMouse (me, structGuiDrawingArea_MouseEvent::Phase::CLICK, x, y); } else FORWARD_WM_LBUTTONDOWN (window, doubleClick, x, y, flags, DefWindowProc); } else FORWARD_WM_LBUTTONDOWN (window, doubleClick, x, y, flags, DefWindowProc); } +static void on_mouseMove (HWND window, int x, int y, UINT flags) { + GuiObject me = (GuiObject) GetWindowLongPtr (window, GWLP_USERDATA); + if (me) { + if (MEMBER (me, DrawingArea) && (flags & MK_LBUTTON)) { + _GuiWinDrawingArea_handleMouse (me, structGuiDrawingArea_MouseEvent::Phase::DRAG, x, y); + } else FORWARD_WM_MOUSEMOVE (window, x, y, flags, DefWindowProc); + } else FORWARD_WM_MOUSEMOVE (window, x, y, flags, DefWindowProc); +} +static void on_lbuttonUp (HWND window, int x, int y, UINT flags) { + GuiObject me = (GuiObject) GetWindowLongPtr (window, GWLP_USERDATA); + if (me) { + if (MEMBER (me, DrawingArea)) { + ReleaseCapture (); + _GuiWinDrawingArea_handleMouse (me, structGuiDrawingArea_MouseEvent::Phase::DROP, x, y); + } else FORWARD_WM_LBUTTONUP (window, x, y, flags, DefWindowProc); + } else FORWARD_WM_LBUTTONUP (window, x, y, flags, DefWindowProc); +} static void on_paint (HWND window) { GuiObject me = (GuiObject) GetWindowLongPtr (window, GWLP_USERDATA); if (me) { @@ -2538,6 +2558,24 @@ static void on_vscroll (HWND window, HWND controlWindow, UINT code, int pos) { } else FORWARD_WM_VSCROLL (window, controlWindow, code, pos, DefWindowProc); } else FORWARD_WM_VSCROLL (window, controlWindow, code, pos, DefWindowProc); } +#undef FORWARD_WM_MOUSEWHEEL // bug in our windowsx.h +#define FORWARD_WM_MOUSEWHEEL(hwnd,xPos,yPos,zDelta,fwKeys,fn) \ + (void)(fn)((hwnd),WM_MOUSEWHEEL,MAKEWPARAM((fwKeys),(zDelta)),MAKELPARAM((xPos),(yPos))) +//#define HANDLE_WM_MOUSEWHEEL(hwnd,wParam,lParam,fn) \ + ((fn)((hwnd),(int)(short)LOWORD(lParam),(int)(short)HIWORD(lParam),(int)(short)HIWORD(wParam),(UINT)(short)LOWORD(wParam)),(LRESULT)0) +static void on_verticalWheel (HWND window, int xPos, int yPos, int zDelta, int fwKeys) { + GuiObject me = (GuiObject) GetWindowLongPtr (window, GWLP_USERDATA); + if (me) { + if (my widgetClass == xmDrawingAreaWidgetClass) { + if (my parent -> widgetClass == xmScrolledWindowWidgetClass) + on_scroll (my parent -> motiff.scrolledWindow.verticalBar, zDelta < 0 ? SB_LINEDOWN : SB_LINEUP, 0); + else + for (GuiObject child = my parent -> firstChild; child; child = child -> nextSibling) + if (child -> widgetClass == xmScrollBarWidgetClass && child -> orientation == XmVERTICAL) + on_scroll (child, zDelta < 0 ? SB_LINEDOWN : SB_LINEUP, 0); + } else FORWARD_WM_MOUSEWHEEL (window, xPos, yPos, zDelta, fwKeys, DefWindowProc); + } else FORWARD_WM_MOUSEWHEEL (window, xPos, yPos, zDelta, fwKeys, DefWindowProc); +} static void on_size (HWND window, UINT state, int cx, int cy) { GuiObject me = (GuiObject) GetWindowLongPtr (window, GWLP_USERDATA); if (me && MEMBER (me, Shell) && (state == SIZE_RESTORED || state == SIZE_MAXIMIZED)) { @@ -2640,9 +2678,13 @@ static LRESULT CALLBACK windowProc (HWND window, UINT message, WPARAM wParam, LP HANDLE_MSG (window, WM_COMMAND, on_command); HANDLE_MSG (window, WM_DESTROY, on_destroy); HANDLE_MSG (window, WM_LBUTTONDOWN, on_lbuttonDown); + HANDLE_MSG (window, WM_LBUTTONUP, on_lbuttonUp); + HANDLE_MSG (window, WM_MOUSEMOVE, on_mouseMove); HANDLE_MSG (window, WM_PAINT, on_paint); HANDLE_MSG (window, WM_HSCROLL, on_hscroll); HANDLE_MSG (window, WM_VSCROLL, on_vscroll); + HANDLE_MSG (window, WM_MOUSEWHEEL, on_verticalWheel); + //HANDLE_MSG (window, WM_MOUSEHWHEEL, on_horizontalWheel); HANDLE_MSG (window, WM_SIZE, on_size); HANDLE_MSG (window, WM_KEYDOWN, on_key); HANDLE_MSG (window, WM_CHAR, on_char); @@ -2658,18 +2700,6 @@ static LRESULT CALLBACK windowProc (HWND window, UINT message, WPARAM wParam, LP default: return DefWindowProc (window, message, wParam, lParam); } } -bool motif_win_mouseStillDown () { - XEvent event; - if (! GetCapture ()) SetCapture (theApplicationShell -> window); - if (PeekMessage (& event, 0, 0, 0, PM_REMOVE)) { - if (event. message == WM_LBUTTONUP) { - DispatchMessage (& event); - ReleaseCapture (); - return false; - } - } - return true; -} void motif_win_setUserMessageCallback (int (*userMessageCallback) (void)) { theUserMessageCallback = userMessageCallback; } diff --git a/sys/praat.cpp b/sys/praat.cpp index 4c359e01..a79a6b1d 100644 --- a/sys/praat.cpp +++ b/sys/praat.cpp @@ -1078,6 +1078,7 @@ void praat_init (conststring32 title, int argc, char **argv) while (praatP.argumentNumber < argc && argv [praatP.argumentNumber] [0] == '-') { if (strequ (argv [praatP.argumentNumber], "-")) { praatP.hasCommandLineInput = true; + praatP.argumentNumber += 1; } else if (strequ (argv [praatP.argumentNumber], "--open")) { foundTheOpenOption = true; praatP.argumentNumber += 1; @@ -1573,6 +1574,12 @@ void praat_run () { Melder_assert (Melder_isHorizontalOrVerticalSpace ('\f')); Melder_assert (Melder_isHorizontalOrVerticalSpace ('\v')); + { + double *a = nullptr; + double *b = & a [0]; + Melder_assert (! b); + } + /* According to ISO 30112, a non-breaking space is not a space. We do not agree, as long as spaces are assumed to be word breakers: diff --git a/sys/praat.h b/sys/praat.h index 082a0144..b810d214 100644 --- a/sys/praat.h +++ b/sys/praat.h @@ -2,7 +2,7 @@ #define _praat_h_ /* praat.h * - * Copyright (C) 1992-2019 Paul Boersma + * Copyright (C) 1992-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -181,7 +181,7 @@ typedef struct { /* Readonly */ integer uniqueId; } structPraatObjects, *PraatObjects; typedef struct { // read-only - Graphics graphics; /* The Graphics associated with the Picture window or HyperPage window or Demo window. */ + Graphics graphics; // the Graphics associated with the Picture window int font, lineType; double fontSize; MelderColour colour; @@ -257,8 +257,8 @@ void praat_name2 (char32 *name, ClassInfo klas1, ClassInfo klas2); #ifndef _EditorM_h_ #define FORM(proc,name,helpTitle) \ - extern "C" void proc (UiForm sendingForm, integer narg, Stackel args, conststring32 sendingString, Interpreter interpreter, conststring32 invokingButtonTitle, bool modified, void *buttonClosure); \ - void proc (UiForm _sendingForm_, integer _narg_, Stackel _args_, conststring32 _sendingString_, Interpreter interpreter, conststring32 _invokingButtonTitle_, bool _modified_, void *_buttonClosure_) { \ + extern "C" void proc (UiForm sendingForm, integer narg, Stackel args, conststring32 sendingString, Interpreter interpreter, conststring32 invokingButtonTitle, bool isModified, void *buttonClosure); \ + void proc (UiForm _sendingForm_, integer _narg_, Stackel _args_, conststring32 _sendingString_, Interpreter interpreter, conststring32 _invokingButtonTitle_, bool _isModified_, void *_buttonClosure_) { \ int IOBJECT = 0; \ (void) IOBJECT; \ UiField _radio_ = nullptr; \ @@ -433,7 +433,7 @@ void praat_name2 (char32 *name, ClassInfo klas1, ClassInfo klas2); UiForm_setOption (_dia_.get(), (int *) & enumeratedVariable, (int) enumeratedValue - (int) EnumeratedType::MIN + 1); #define DO \ - UiForm_do (_dia_.get(), _modified_); \ + UiForm_do (_dia_.get(), _isModified_); \ } else if (! _sendingForm_) { \ trace (U"args ", Melder_pointer (_args_)); \ if (_args_) { \ @@ -446,7 +446,7 @@ void praat_name2 (char32 *name, ClassInfo klas1, ClassInfo klas2); { #define DO_ALTERNATIVE(alternative) \ - UiForm_do (_dia_.get(), _modified_); \ + UiForm_do (_dia_.get(), _isModified_); \ } else if (! _sendingForm_) { \ trace (U"alternative args ", Melder_pointer (_args_)); \ try { \ @@ -459,7 +459,7 @@ void praat_name2 (char32 *name, ClassInfo klas1, ClassInfo klas2); autostring32 _parkedError = Melder_dup_f (Melder_getError ()); \ Melder_clearError (); \ try { \ - alternative (nullptr, _narg_, _args_, _sendingString_, interpreter, _invokingButtonTitle_, _modified_, _buttonClosure_); \ + alternative (nullptr, _narg_, _args_, _sendingString_, interpreter, _invokingButtonTitle_, _isModified_, _buttonClosure_); \ } catch (MelderError) { \ Melder_clearError (); \ Melder_appendError (_parkedError.get()); \ @@ -609,6 +609,12 @@ void praat_name2 (char32 *name, ClassInfo klas1, ClassInfo klas2); klas1 me = nullptr; klas2 you = nullptr; klas3 him = nullptr; \ LOOP { if (CLASS == class##klas1) me = (klas1) OBJECT; else if (CLASS == class##klas2) you = (klas2) OBJECT; \ else if (CLASS == class##klas3) him = (klas3) OBJECT; if (me && you && him) break; } + +#define FIND_THREE_WITH_IOBJECT(klas1,klas2,klas3) \ + klas1 me = nullptr; klas2 you = nullptr; klas3 him = nullptr; int _klas1_position = 0;\ + LOOP { if (CLASS == class##klas1) me = (klas1) OBJECT, _klas1_position = IOBJECT; else if (CLASS == class##klas2) you = (klas2) OBJECT; \ + else if (CLASS == class##klas3) him = (klas3) OBJECT; if (me && you && him) break; } \ + IOBJECT = _klas1_position; #define FIND_FOUR(klas1,klas2,klas3,klas4) \ klas1 me = nullptr; klas2 you = nullptr; klas3 him = nullptr; klas4 she = nullptr; \ @@ -616,6 +622,13 @@ void praat_name2 (char32 *name, ClassInfo klas1, ClassInfo klas2); else if (CLASS == class##klas3) him = (klas3) OBJECT; else if (CLASS == class##klas4) she = (klas4) OBJECT; \ if (me && you && him && she) break; } +#define FIND_FOUR_WITH_IOBJECT(klas1,klas2,klas3,klas4) \ + klas1 me = nullptr; klas2 you = nullptr; klas3 him = nullptr; klas4 she = nullptr; int _klas1_position = 0; \ + LOOP { if (CLASS == class##klas1) me = (klas1) OBJECT, _klas1_position = IOBJECT; else if (CLASS == class##klas2) you = (klas2) OBJECT; \ + else if (CLASS == class##klas3) him = (klas3) OBJECT; else if (CLASS == class##klas4) she = (klas4) OBJECT; \ + if (me && you && him && she) break; } \ + IOBJECT = _klas1_position; + #define FIND_LIST(klas) \ OrderedOf list; \ LOOP { iam_LOOP (klas); list. addItem_ref (me); } diff --git a/sys/praatP.h b/sys/praatP.h index d1ee6f3f..694d3879 100644 --- a/sys/praatP.h +++ b/sys/praatP.h @@ -1,6 +1,6 @@ /* praatP.h * - * Copyright (C) 1992-2007,2009-2018 Paul Boersma + * Copyright (C) 1992-2007,2009-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -111,9 +111,6 @@ void praat_picture_prefsChanged (); Picture window will update the font menu. */ GuiMenu praat_picture_resolveMenu (conststring32 menu); -void praat_picture_background (); -void praat_picture_foreground (); - /* The following routines are a bit private (used by praat_script.cpp). */ /* If you must call them, follow them by praat_show (). */ @@ -129,7 +126,7 @@ void praat_foreground (); Editor praat_findEditorFromString (conststring32 string); Editor praat_findEditorById (integer id); -void praat_showLogo (bool autoPopDown); +void praat_showLogo (); /* Communication with praat_menuCommands.cpp: */ void praat_menuCommands_init (); @@ -161,6 +158,7 @@ void praat_reportSystemProperties (); void praat_reportGraphicalProperties (); void praat_reportIntegerProperties (); void praat_reportTextProperties (); +void praat_reportFontProperties (); /* Communication with praat_objectMenus.cpp: */ GuiMenu praat_objects_resolveMenu (conststring32 menu); diff --git a/sys/praat_actions.cpp b/sys/praat_actions.cpp index 7697e54c..3d08f040 100644 --- a/sys/praat_actions.cpp +++ b/sys/praat_actions.cpp @@ -489,7 +489,7 @@ static bool allowExecutionHook (void *closure) { return false; } -static void do_menu (Praat_Command me, bool modified) { +static void do_menu (Praat_Command me, bool isModified) { if (my callback == DO_RunTheScriptFromAnyAddedMenuCommand) { UiHistory_write (U"\nrunScript: "); try { @@ -505,7 +505,7 @@ static void do_menu (Praat_Command me, bool modified) { } Ui_setAllowExecutionHook (allowExecutionHook, (void *) my callback); // BUG: one shouldn't assign a function pointer to a void pointer try { - my callback (nullptr, 0, nullptr, nullptr, nullptr, my title.get(), modified, nullptr); + my callback (nullptr, 0, nullptr, nullptr, nullptr, my title.get(), isModified, nullptr); } catch (MelderError) { Melder_flushError (U"Command \"", my title.get(), U"\" not executed."); } @@ -515,12 +515,13 @@ static void do_menu (Praat_Command me, bool modified) { } static void cb_menu (Praat_Command me, GuiMenuItemEvent event) { - bool modified = event -> shiftKeyPressed || event -> commandKeyPressed || event -> optionKeyPressed || event -> extraControlKeyPressed; - do_menu (me, modified); + bool isModified = event -> shiftKeyPressed || event -> commandKeyPressed || event -> optionKeyPressed; + do_menu (me, isModified); } static void gui_button_cb_menu (Praat_Command me, GuiButtonEvent event) { - do_menu (me, event -> shiftKeyPressed | event -> commandKeyPressed | event -> optionKeyPressed | event -> extraControlKeyPressed); + bool isModified = event -> shiftKeyPressed || event -> commandKeyPressed || event -> optionKeyPressed; + do_menu (me, isModified); } void praat_actions_show () { @@ -728,7 +729,6 @@ void praat_background () { deleteDynamicMenu (); praat_list_background (); Melder_backgrounding = true; - if (! praatP.dontUsePictureWindow) praat_picture_background (); } void praat_foreground () { @@ -737,7 +737,6 @@ void praat_foreground () { Melder_backgrounding = false; praat_list_foreground (); praat_show (); - if (! praatP.dontUsePictureWindow) praat_picture_foreground (); } static bool actionIsToBeIncluded (Praat_Command command, bool deprecated, bool includeSaveAPI, diff --git a/sys/praat_logo.cpp b/sys/praat_logo.cpp index e14c6307..7008860e 100644 --- a/sys/praat_logo.cpp +++ b/sys/praat_logo.cpp @@ -1,6 +1,6 @@ /* praat_logo.cpp * - * Copyright (C) 1996-2012,2013,2014,2015,2016,2017 Paul Boersma, 2008 Stefan de Konink + * Copyright (C) 1996-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -22,7 +22,7 @@ static void logo_defaultDraw (Graphics g) { Graphics_setColour (g, Melder_MAGENTA); - Graphics_fillRectangle (g, 0, 1, 0, 1); + Graphics_fillRectangle (g, 0.0, 1.0, 0.0, 1.0); Graphics_setGrey (g, 0.5); Graphics_fillRectangle (g, 0.05, 0.95, 0.1, 0.9); Graphics_setTextAlignment (g, Graphics_CENTRE, Graphics_HALF); @@ -34,7 +34,7 @@ static void logo_defaultDraw (Graphics g) { Graphics_text (g, 0.5, 0.6, praatP.title.get()); Graphics_setFontStyle (g, 0); Graphics_setFontSize (g, 12); - Graphics_text (g, 0.5, 0.25, U"\\s{Built on the} %%Praat shell%\\s{,© Paul Boersma, 1992-2017"); + Graphics_text (g, 0.5, 0.25, U"\\s{Built on the} %%Praat shell%\\s{,© Paul Boersma, 1992-2020"); } static struct { @@ -46,14 +46,6 @@ static struct { autoGraphics graphics; } theLogo = { 90, 40, logo_defaultDraw }; -#if motif -static void logo_timeOut (XtPointer closure, XtIntervalId *id) { - (void) closure; - (void) id; - GuiThing_hide (theLogo.form); -} -#endif - void praat_setLogo (double width_mm, double height_mm, void (*draw) (Graphics g)) { theLogo.width_mm = width_mm; theLogo.height_mm = height_mm; @@ -61,27 +53,10 @@ void praat_setLogo (double width_mm, double height_mm, void (*draw) (Graphics g) } static void gui_drawingarea_cb_expose (Thing /* me */, GuiDrawingArea_ExposeEvent event) { - if (! theLogo.graphics) - theLogo.graphics = Graphics_create_xmdrawingarea (theLogo.drawingArea); - #if gtk - #if ALLOW_GDK_DRAWING - Graphics_x_setCR (theLogo.graphics.get(), gdk_cairo_create (GDK_DRAWABLE (GTK_WIDGET (event -> widget -> d_widget) -> window))); - #else - Graphics_x_setCR (theLogo.graphics.get(), gdk_cairo_create (gtk_widget_get_window (GTK_WIDGET (event -> widget -> d_widget)))); - #endif - cairo_rectangle ((cairo_t *) Graphics_x_getCR (theLogo.graphics.get()), (double) event->x, (double) event->y, (double) event->width, (double) event->height); - cairo_clip ((cairo_t *) Graphics_x_getCR (theLogo.graphics.get())); - theLogo.draw (theLogo.graphics.get()); - cairo_destroy ((cairo_t *) Graphics_x_getCR (theLogo.graphics.get())); - #elif motif || cocoa - (void) event; - if (! theLogo.graphics) - theLogo.graphics = Graphics_create_xmdrawingarea (theLogo.drawingArea); - theLogo.draw (theLogo.graphics.get()); - #endif + theLogo.draw (theLogo.graphics.get()); } -static void gui_drawingarea_cb_click (Thing /* me */, GuiDrawingArea_ClickEvent /* event */) { +static void gui_drawingarea_cb_mouse (Thing /* me */, GuiDrawingArea_MouseEvent /* event */) { GuiThing_hide (theLogo.form); } @@ -89,40 +64,24 @@ static void gui_cb_goAway (Thing /* boss */) { GuiThing_hide (theLogo.form); } -void praat_showLogo (bool autoPopDown) { - #if gtk - static const gchar *authors [3] = { "Paul Boersma", "David Weenink", nullptr }; - - GuiObject dialog = gtk_about_dialog_new (); - #define xstr(s) str(s) - #define str(s) #s - gtk_about_dialog_set_version (GTK_ABOUT_DIALOG (dialog), xstr (PRAAT_VERSION_STR)); - gtk_about_dialog_set_copyright (GTK_ABOUT_DIALOG (dialog), "Copyright © 1992–" xstr(PRAAT_YEAR) " by Paul Boersma and David Weenink"); - gtk_about_dialog_set_license (GTK_ABOUT_DIALOG (dialog), "GPL"); - gtk_about_dialog_set_website (GTK_ABOUT_DIALOG (dialog), "http://www.praat.org"); - //gtk_about_dialog_set_authors (GTK_ABOUT_DIALOG (dialog), authors); - g_signal_connect (GTK_DIALOG (dialog), "response", G_CALLBACK (gtk_widget_destroy), nullptr); - - gtk_dialog_run (GTK_DIALOG (dialog)); - - #elif motif || cocoa - if (theCurrentPraatApplication -> batch || ! theLogo.draw) return; - if (! theLogo.dia) { - int width = theLogo.width_mm / 25.4 * Gui_getResolution (nullptr); - int height = theLogo.height_mm / 25.4 * Gui_getResolution (nullptr); - theLogo.dia = GuiDialog_create (theCurrentPraatApplication -> topShell, 100, 100, width, height, +void praat_showLogo () { + if (theCurrentPraatApplication -> batch || ! theLogo.draw) + return; + if (! theLogo.dia) { + int width = theLogo.width_mm / 25.4 * Gui_getResolution (nullptr); + int height = theLogo.height_mm / 25.4 * Gui_getResolution (nullptr); + theLogo.dia = GuiDialog_create (theCurrentPraatApplication -> topShell, 100, 100, width, height, U"About", gui_cb_goAway, nullptr, 0); - theLogo.form = theLogo.dia; - theLogo.drawingArea = GuiDrawingArea_createShown (theLogo.form, 0, width, 0, height, - gui_drawingarea_cb_expose, gui_drawingarea_cb_click, nullptr, nullptr, nullptr, 0); - } + theLogo.form = theLogo.dia; + theLogo.drawingArea = GuiDrawingArea_createShown (theLogo.form, 0, width, 0, height, + gui_drawingarea_cb_expose, gui_drawingarea_cb_mouse, nullptr, nullptr, nullptr, 0); + GuiThing_show (theLogo.form); + GuiThing_show (theLogo.dia); + theLogo.graphics = Graphics_create_xmdrawingarea (theLogo.drawingArea); + } else { GuiThing_show (theLogo.form); GuiThing_show (theLogo.dia); - #if motif - if (autoPopDown) - GuiAddTimeOut (2000, logo_timeOut, (XtPointer) nullptr); - #endif - #endif + } } /* End of file praat_logo.cpp */ diff --git a/sys/praat_menuCommands.cpp b/sys/praat_menuCommands.cpp index 1168f74f..bcb6bf4a 100644 --- a/sys/praat_menuCommands.cpp +++ b/sys/praat_menuCommands.cpp @@ -91,12 +91,13 @@ static void do_menu (Praat_Command me, uint32 modified) { } static void gui_button_cb_menu (Praat_Command me, GuiButtonEvent event) { - do_menu (me, event -> shiftKeyPressed | event -> commandKeyPressed | event -> optionKeyPressed | event -> extraControlKeyPressed); + bool isModified = event -> shiftKeyPressed || event -> commandKeyPressed || event -> optionKeyPressed; + do_menu (me, isModified); } static void gui_cb_menu (Praat_Command me, GuiMenuItemEvent event) { - bool modified = event -> shiftKeyPressed || event -> commandKeyPressed || event -> optionKeyPressed || event -> extraControlKeyPressed; - do_menu (me, modified); + bool isModified = event -> shiftKeyPressed || event -> commandKeyPressed || event -> optionKeyPressed; + do_menu (me, isModified); } static GuiMenu windowMenuToWidget (conststring32 window, conststring32 menu) { diff --git a/sys/praat_objectMenus.cpp b/sys/praat_objectMenus.cpp index cf81ee86..bd35f117 100644 --- a/sys/praat_objectMenus.cpp +++ b/sys/praat_objectMenus.cpp @@ -23,7 +23,6 @@ #include "DataEditor.h" #include "site.h" #include "GraphicsP.h" -//#include #undef iam #define iam iam_LOOP @@ -128,7 +127,7 @@ GuiMenu praat_objects_resolveMenu (conststring32 menu) { /********** Callbacks of the Praat menu. **********/ DIRECT (WINDOW_About) { - praat_showLogo (false); + praat_showLogo (); END } DIRECT (WINDOW_praat_newScript) { @@ -288,46 +287,45 @@ DO END } FORM (INFO_reportDifferenceOfTwoProportions, U"Report difference of two proportions", U"Difference of two proportions") { - INTEGER (a, U"left Row 1", U"71") - INTEGER (b, U"right Row 1", U"39") - INTEGER (c, U"left Row 2", U"93") - INTEGER (d, U"right Row 2", U"27") + INTEGER (a_int, U"left Row 1", U"71") + INTEGER (b_int, U"right Row 1", U"39") + INTEGER (c_int, U"left Row 2", U"93") + INTEGER (d_int, U"right Row 2", U"27") OK DO + double a = a_int, b = b_int, c = c_int, d = d_int; double n = a + b + c + d; - double aexp, bexp, cexp, dexp, crossDifference, x2; - if (a < 0 || b < 0 || c < 0 || d < 0) Melder_throw (U"The numbers should not be negative."); - if (a + b <= 0 || c + d <= 0) Melder_throw (U"The row totals should be positive."); - if (a + c <= 0 || b + d <= 0) Melder_throw (U"The column totals should be positive."); + if (a < 0 || b < 0 || c < 0 || d < 0) + Melder_throw (U"The numbers should not be negative."); + if (a + b <= 0 || c + d <= 0) + Melder_throw (U"The row totals should be positive."); + if (a + c <= 0 || b + d <= 0) + Melder_throw (U"The column totals should be positive."); MelderInfo_open (); MelderInfo_writeLine (U"Observed row 1 = ", Melder_iround (a), U" ", Melder_iround (b)); MelderInfo_writeLine (U"Observed row 2 = ", Melder_iround (c), U" ", Melder_iround (d)); - aexp = (a + b) * (a + c) / n; - bexp = (a + b) * (b + d) / n; - cexp = (a + c) * (c + d) / n; - dexp = (b + d) * (c + d) / n; + double aexp = (a + b) * (a + c) / n; + double bexp = (a + b) * (b + d) / n; + double cexp = (a + c) * (c + d) / n; + double dexp = (b + d) * (c + d) / n; MelderInfo_writeLine (U""); MelderInfo_writeLine (U"Expected row 1 = ", aexp, U" ", bexp); MelderInfo_writeLine (U"Expected row 2 = ", cexp, U" ", dexp); /* - * Continuity correction: - * bring the observed numbers closer to the expected numbers by 0.5 (if possible). - */ - if (a < aexp) { a += 0.5; if (a > aexp) a = aexp; } - else if (a > aexp) { a -= 0.5; if (a < aexp) a = aexp; } - if (b < bexp) { b += 0.5; if (b > bexp) b = bexp; } - else if (b > bexp) { b -= 0.5; if (b < bexp) b = bexp; } - if (c < cexp) { c += 0.5; if (c > cexp) c = cexp; } - else if (c > cexp) { c -= 0.5; if (c < cexp) c = cexp; } - if (d < dexp) { d += 0.5; if (d > dexp) d = dexp; } - else if (d > dexp) { d -= 0.5; if (d < dexp) d = dexp; } + Continuity correction: + bring the observed numbers closer to the expected numbers by 0.5 (if possible). + */ + Melder_moveCloserToBy (& a, aexp, 0.5); + Melder_moveCloserToBy (& b, bexp, 0.5); + Melder_moveCloserToBy (& c, cexp, 0.5); + Melder_moveCloserToBy (& d, dexp, 0.5); MelderInfo_writeLine (U""); MelderInfo_writeLine (U"Corrected observed row 1 = ", a, U" ", b); MelderInfo_writeLine (U"Corrected observed row 2 = ", c, U" ", d); n = a + b + c + d; - crossDifference = a * d - b * c; - x2 = n * crossDifference * crossDifference / (a + b) / (c + d) / (a + c) / (b + d); + double crossDifference = a * d - b * c; + double x2 = n * crossDifference * crossDifference / (a + b) / (c + d) / (a + c) / (b + d); MelderInfo_writeLine (U""); MelderInfo_writeLine (U"Chi-square = ", x2); MelderInfo_writeLine (U"Two-tailed p = ", NUMchiSquareQ (x2, 1)); @@ -406,6 +404,10 @@ DIRECT (INFO_reportTextProperties) { praat_reportTextProperties (); END } +DIRECT (INFO_reportFontProperties) { + praat_reportFontProperties (); +END } + /********** Callbacks of the Open menu. **********/ static void readFromFile (MelderFile file) { @@ -543,8 +545,8 @@ END } void praat_show () { /* - * (De)sensitivize the fixed buttons as appropriate for the current selection. - */ + (De)sensitivize the fixed buttons as appropriate for the current selection. + */ praat_sensitivizeFixedButtonCommand (U"Remove", theCurrentPraatObjects -> totalSelection != 0); praat_sensitivizeFixedButtonCommand (U"Rename...", theCurrentPraatObjects -> totalSelection == 1); praat_sensitivizeFixedButtonCommand (U"Copy...", theCurrentPraatObjects -> totalSelection == 1); @@ -573,10 +575,12 @@ static MelderString itemTitle_about; static autoDaata scriptRecognizer (integer nread, const char *header, MelderFile file) { conststring32 name = MelderFile_name (file); - if (nread < 2) return autoDaata (); - if ((header [0] == '#' && header [1] == '!') || str32str (name, U".praat") == name + str32len (name) - 6 - || str32str (name, U".html") == name + str32len (name) - 5) - { + if (nread < 2) + return autoDaata (); + if ((header [0] == '#' && header [1] == '!') + || Melder_stringMatchesCriterion (name, kMelder_string::ENDS_WITH, U".praat", false) + || Melder_stringMatchesCriterion (name, kMelder_string::ENDS_WITH, U".html", false) + ) { return Script_createFromFile (file); } return autoDaata (); @@ -624,8 +628,8 @@ void praat_addMenus (GuiWindow window) { Data_recognizeFileType (scriptRecognizer); /* - * Create the menu titles in the bar. - */ + Create the menu titles in the bar. + */ if (! theCurrentPraatApplication -> batch) { #ifdef macintosh praatMenu = GuiMenu_createInWindow (nullptr, U"\024", 0); @@ -645,15 +649,15 @@ void praat_addMenus (GuiWindow window) { helpMenu = GuiMenu_createInWindow (window, U"Help", 0); } - MelderString_append (& itemTitle_about, U"About ", praatP.title.get(), U"..."); + MelderString_append (& itemTitle_about, U"About ", praatP.title.get()); praat_addMenuCommand (U"Objects", U"Praat", itemTitle_about.string, nullptr, praat_UNHIDABLE, WINDOW_About); #ifdef macintosh #if cocoa /* - * HACK: give the following command weird names, - * because otherwise they may be called from a script. - * (we add three alt-spaces) - */ + HACK: give the following commands weird names, + because otherwise they may be called from a script. + (we add three alt-spaces) + */ praat_addMenuCommand (U"Objects", U"Edit", U"Cut   ", nullptr, praat_UNHIDABLE | 'X' | praat_NO_API, PRAAT_cut); praat_addMenuCommand (U"Objects", U"Edit", U"Copy   ", nullptr, praat_UNHIDABLE | 'C' | praat_NO_API, PRAAT_copy); praat_addMenuCommand (U"Objects", U"Edit", U"Paste   ", nullptr, praat_UNHIDABLE | 'V' | praat_NO_API, PRAAT_paste); @@ -690,9 +694,10 @@ void praat_addMenus (GuiWindow window) { technicalMenu = menuItem ? menuItem -> d_menu : nullptr; praat_addMenuCommand (U"Objects", U"Technical", U"Report memory use", nullptr, 0, INFO_reportMemoryUse); praat_addMenuCommand (U"Objects", U"Technical", U"Report integer properties", nullptr, 0, INFO_reportIntegerProperties); - praat_addMenuCommand (U"Objects", U"Technical", U"Report text properties", nullptr, 0, INFO_reportTextProperties); praat_addMenuCommand (U"Objects", U"Technical", U"Report system properties", nullptr, 0, INFO_reportSystemProperties); praat_addMenuCommand (U"Objects", U"Technical", U"Report graphical properties", nullptr, 0, INFO_reportGraphicalProperties); + praat_addMenuCommand (U"Objects", U"Technical", U"Report text properties", nullptr, 0, INFO_reportTextProperties); + praat_addMenuCommand (U"Objects", U"Technical", U"Report font properties", nullptr, 0, INFO_reportFontProperties); praat_addMenuCommand (U"Objects", U"Technical", U"Debug...", nullptr, 0, PRAAT_debug); praat_addMenuCommand (U"Objects", U"Technical", U"-- api --", nullptr, 0, nullptr); praat_addMenuCommand (U"Objects", U"Technical", U"List readable types of objects", nullptr, 0, INFO_listReadableTypesOfObjects); diff --git a/sys/praat_picture.cpp b/sys/praat_picture.cpp index 327765e2..fad76778 100644 --- a/sys/praat_picture.cpp +++ b/sys/praat_picture.cpp @@ -1,6 +1,6 @@ /* praat_picture.cpp * - * Copyright (C) 1992-2019 Paul Boersma + * Copyright (C) 1992-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -123,7 +123,7 @@ END } autoPraatPicture picture; Graphics_setFontSize (GRAPHICS, praat_size = fontSize); } - Picture_setSelection (praat_picture, x1NDC, x2NDC, y1NDC, y2NDC, False); + Picture_setSelection (praat_picture, x1NDC, x2NDC, y1NDC, y2NDC); updateSizeMenu (); }*/ @@ -206,7 +206,7 @@ DO if (top > bottom) { double temp; temp = top; top = bottom; bottom = temp; } theCurrentPraatPicture -> y1NDC = 12-bottom - ymargin; theCurrentPraatPicture -> y2NDC = 12-top + ymargin; - Picture_setSelection (praat_picture.get(), theCurrentPraatPicture -> x1NDC, theCurrentPraatPicture -> x2NDC, theCurrentPraatPicture -> y1NDC, theCurrentPraatPicture -> y2NDC, false); + Picture_setSelection (praat_picture.get(), theCurrentPraatPicture -> x1NDC, theCurrentPraatPicture -> x2NDC, theCurrentPraatPicture -> y1NDC, theCurrentPraatPicture -> y2NDC); Graphics_updateWs (GRAPHICS); } else if (theCurrentPraatObjects != & theForegroundPraatObjects) { // in manual? if (top > bottom) { double temp; temp = top; top = bottom; bottom = temp; } @@ -261,8 +261,8 @@ DO std::swap (top, bottom); theCurrentPraatPicture -> y1NDC = 12-bottom; theCurrentPraatPicture -> y2NDC = 12-top; - Picture_setSelection (praat_picture.get(), theCurrentPraatPicture -> x1NDC, theCurrentPraatPicture -> x2NDC, theCurrentPraatPicture -> y1NDC, theCurrentPraatPicture -> y2NDC, false); - Graphics_updateWs (GRAPHICS); // BUG: needed on Cocoa, but why? + Picture_setSelection (praat_picture.get(), theCurrentPraatPicture -> x1NDC, theCurrentPraatPicture -> x2NDC, theCurrentPraatPicture -> y1NDC, theCurrentPraatPicture -> y2NDC); + Graphics_updateWs (GRAPHICS); } else if (theCurrentPraatObjects != & theForegroundPraatObjects) { // in manual? if (top > bottom) std::swap (top, bottom); @@ -284,13 +284,13 @@ END } FORM (GRAPHICS_ViewportText, U"Praat picture: Viewport text", U"Viewport text...") { RADIOx (horizontalAlignment, U"Horizontal alignment", 2, 0) - RADIOBUTTON (U"Left") - RADIOBUTTON (U"Centre") - RADIOBUTTON (U"Right") + RADIOBUTTON (U"left") + RADIOBUTTON (U"centre") + RADIOBUTTON (U"right") RADIOx (verticalAlignment, U"Vertical alignment", 2, 0) - RADIOBUTTON (U"Bottom") - RADIOBUTTON (U"Half") - RADIOBUTTON (U"Top") + RADIOBUTTON (U"bottom") + RADIOBUTTON (U"half") + RADIOBUTTON (U"top") REAL (rotation, U"Rotation (degrees)", U"0") TEXTFIELD (text, U"Text:", U"") OK @@ -578,9 +578,8 @@ END } DIRECT (GRAPHICS_Undo) { Graphics_undoGroup (GRAPHICS); - if (theCurrentPraatPicture != & theForegroundPraatPicture) { - Graphics_play (GRAPHICS, GRAPHICS); - } + if (theCurrentPraatPicture != & theForegroundPraatPicture) + Graphics_play (GRAPHICS, GRAPHICS); // TODO: understand this Graphics_updateWs (GRAPHICS); END } @@ -590,18 +589,6 @@ DIRECT (GRAPHICS_Erase_all) { } else { Graphics_clearRecording (GRAPHICS); Graphics_clearWs (GRAPHICS); - #if 1 - autoPraatPicture picture; - MelderColour colour = GRAPHICS -> colour; - Graphics_setColour (GRAPHICS, Melder_WHITE); - double x1, y1, x2, y2; - //Melder_casual (GRAPHICS -> d_x1DC, U" ", GRAPHICS -> d_y1DC, U" ", GRAPHICS -> d_x2DC, U" ", GRAPHICS -> d_y2DC); - Graphics_DCtoWC (GRAPHICS, GRAPHICS -> d_x1DC, GRAPHICS -> d_y1DC, & x1, & y1); - Graphics_DCtoWC (GRAPHICS, GRAPHICS -> d_x2DC, GRAPHICS -> d_y2DC, & x2, & y2); - //Melder_casual (x1, U" ", y1, U" ", x2, U" ", y2); - Graphics_fillRectangle (GRAPHICS, x1, x2, y1, y2); - Graphics_setColour (GRAPHICS, colour); - #endif } END } @@ -613,9 +600,9 @@ FORM (GRAPHICS_Text, U"Praat picture: Text", U"Text...") { U"Horizontal alignment", kGraphics_horizontalAlignment::LEFT) REAL (verticalPosition, U"Vertical position", U"0.0") OPTIONMENUx (verticalAlignment, U"Vertical alignment", 2, 0) - OPTION (U"Bottom") - OPTION (U"Half") - OPTION (U"Top") + OPTION (U"bottom") + OPTION (U"half") + OPTION (U"top") TEXTFIELD (text, U"Text:", U"") OK DO @@ -629,15 +616,13 @@ DO FORM (GRAPHICS_TextSpecial, U"Praat picture: Text special", nullptr) { REAL (horizontalPosition, U"Horizontal position", U"0.0") - OPTIONMENUx (horizontalAlignment, U"Horizontal alignment", 2, 0) - OPTION (U"Left") - OPTION (U"Centre") - OPTION (U"Right") + OPTIONMENU_ENUM (kGraphics_horizontalAlignment, horizontalAlignment, + U"Horizontal alignment", kGraphics_horizontalAlignment::LEFT) REAL (verticalPosition, U"Vertical position", U"0.0") OPTIONMENUx (verticalAlignment, U"Vertical alignment", 2, 0) - OPTION (U"Bottom") - OPTION (U"Half") - OPTION (U"Top") + OPTION (U"bottom") + OPTION (U"half") + OPTION (U"top") OPTIONMENU_ENUM (kGraphics_font, font, U"Font", kGraphics_font::DEFAULT) POSITIVE (fontSize, U"Font size", U"10") SENTENCE (rotation, U"Rotation (degrees or dx;dy)", U"0") @@ -647,7 +632,7 @@ DO kGraphics_font currentFont = Graphics_inqFont (GRAPHICS); const double currentSize = Graphics_inqFontSize (GRAPHICS); GRAPHICS_NONE - Graphics_setTextAlignment (GRAPHICS, (kGraphics_horizontalAlignment) horizontalAlignment, verticalAlignment); + Graphics_setTextAlignment (GRAPHICS, horizontalAlignment, verticalAlignment); Graphics_setInner (GRAPHICS); Graphics_setFont (GRAPHICS, (kGraphics_font) font); Graphics_setFontSize (GRAPHICS, fontSize); @@ -1433,7 +1418,7 @@ DIRECT (HELP_AboutTextStyles) { HELP (U"Text styles") } DIRECT (HELP_PhoneticSymbols) { HELP (U"Phonetic symbols") } DIRECT (GRAPHICS_Picture_settings_report) { MelderInfo_open (); - const conststring32 units = theCurrentPraatPicture == & theForegroundPraatPicture ? U" inches" : U""; + const conststring32 units = ( theCurrentPraatPicture == & theForegroundPraatPicture ? U" inches" : U"" ); MelderInfo_writeLine (U"Outer viewport left: ", theCurrentPraatPicture -> x1NDC, units); MelderInfo_writeLine (U"Outer viewport right: ", theCurrentPraatPicture -> x2NDC, units); MelderInfo_writeLine (U"Outer viewport top: ", @@ -1445,7 +1430,8 @@ DIRECT (GRAPHICS_Picture_settings_report) { theCurrentPraatPicture -> y2NDC : 12 - theCurrentPraatPicture -> y1NDC, units); MelderInfo_writeLine (U"Font size: ", theCurrentPraatPicture -> fontSize, U" points"); - double xmargin = theCurrentPraatPicture -> fontSize * 4.2 / 72.0, ymargin = theCurrentPraatPicture -> fontSize * 2.8 / 72.0; + double xmargin = theCurrentPraatPicture -> fontSize * 4.2 / 72.0; + double ymargin = theCurrentPraatPicture -> fontSize * 2.8 / 72.0; if (theCurrentPraatPicture != & theForegroundPraatPicture) { integer x1DC, x2DC, y1DC, y2DC; Graphics_inqWsViewport (GRAPHICS, & x1DC, & x2DC, & y1DC, & y2DC); @@ -1564,7 +1550,6 @@ void praat_picture_open () { #elif cocoa GuiThing_show (dialog); #endif - Picture_unhighlight (praat_picture.get()); } /* Foregoing drawing routines may have changed some of the output attributes */ /* that can be set by the user. */ @@ -1588,17 +1573,15 @@ void praat_picture_open () { } void praat_picture_close () { - if (theCurrentPraatPicture != & theForegroundPraatPicture) return; - if (! theCurrentPraatApplication -> batch) { - Picture_highlight (praat_picture.get()); - #ifdef macintosh - //dialog -> f_drain (); - #endif - } + if (theCurrentPraatPicture != & theForegroundPraatPicture) + return; + if (! theCurrentPraatApplication -> batch) + Graphics_updateWs (GRAPHICS); } Graphics praat_picture_editor_open (bool eraseFirst) { - if (eraseFirst) Picture_erase (praat_picture.get()); + if (eraseFirst) + Picture_erase (praat_picture.get()); praat_picture_open (); return GRAPHICS; } @@ -1608,7 +1591,8 @@ void praat_picture_editor_close () { } static autoDaata pictureRecognizer (integer nread, const char *header, MelderFile file) { - if (nread < 2) return autoDaata (); + if (nread < 2) + return autoDaata (); if (strnequ (header, "PraatPictureFile", 16)) { Picture_readFromPraatPictureFile (praat_picture.get(), file); return Thing_new (Daata); // a dummy @@ -1851,7 +1835,8 @@ void praat_picture_init () { if (! theCurrentPraatApplication -> batch) { width = height = resolution * 12; scrollWindow = GuiScrolledWindow_createShown (dialog, margin, 0, Machine_getMenuBarHeight () + margin, 0, 1, 1, 0); - drawingArea = GuiDrawingArea_createShown (scrollWindow, width, height, nullptr, nullptr, nullptr, nullptr, nullptr, 0); + drawingArea = GuiDrawingArea_createShown (scrollWindow, width, height, + nullptr, nullptr, nullptr, nullptr, nullptr, 0); GuiThing_show (dialog); } @@ -1875,24 +1860,4 @@ void praat_picture_prefsChanged () { Picture_setMouseSelectsInnerViewport (praat_picture.get(), praat_mouseSelectsInnerViewport); } -void praat_picture_background () { - if (theCurrentPraatPicture != & theForegroundPraatPicture) return; // Demo window and pictures ignore this - if (! theCurrentPraatApplication -> batch) { - //Picture_unhighlight (praat_picture.get()); - #if cocoa - Picture_background (praat_picture.get()); // prevent Cocoa's very slow highlighting until woken up by Picture_foreground() - #endif - } -} - -void praat_picture_foreground () { - if (theCurrentPraatPicture != & theForegroundPraatPicture) return; // Demo window and pictures ignore this - if (! theCurrentPraatApplication -> batch) { - #if cocoa - Picture_foreground (praat_picture.get()); // wake up from the highlighting sleep caused by Picture_background() - #endif - //Picture_highlight (praat_picture.get()); - } -} - /* End of file praat_picture.cpp */ diff --git a/sys/praat_script.cpp b/sys/praat_script.cpp index 0888d0a8..db7efb48 100644 --- a/sys/praat_script.cpp +++ b/sys/praat_script.cpp @@ -546,7 +546,7 @@ void praat_executeCommandFromStandardInput (conststring32 programName) { try { praat_executeCommand (nullptr, command32.get()); } catch (MelderError) { - Melder_flushError (programName, U": command \"", Melder_peek8to32 (command8), U"\" not executed."); + Melder_flushError (programName, U": Command \"", Melder_peek8to32 (command8), U"\" not executed."); } } } diff --git a/sys/praat_statistics.cpp b/sys/praat_statistics.cpp index bbf6ce7c..70465c71 100644 --- a/sys/praat_statistics.cpp +++ b/sys/praat_statistics.cpp @@ -1,6 +1,6 @@ /* praat_statistics.cpp * - * Copyright (C) 1992-2012,2014-2019 Paul Boersma + * Copyright (C) 1992-2012,2014-2020 Paul Boersma * * This code is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -23,6 +23,7 @@ #include #endif #include "praatP.h" +#include "GraphicsP.h" static struct { integer batchSessions, interactiveSessions; @@ -205,6 +206,44 @@ void praat_reportGraphicalProperties () { MelderInfo_close (); } +#if cairo +static void testFont (PangoFontMap *pangoFontMap, PangoContext *pangoContext, conststring32 fontName) { + PangoFontDescription *pangoFontDescription = pango_font_description_from_string (Melder_peek32to8 (fontName)); + PangoFont *pangoFont = pango_font_map_load_font (pangoFontMap, pangoContext, pangoFontDescription); + PangoFontDescription *pangoFontDescription2 = pango_font_describe (pangoFont); + const char *familyName = pango_font_description_get_family (pangoFontDescription2); + MelderInfo_writeLine (U"Asking for font ", fontName, U" gives ", Melder_peek8to32 (familyName), U"."); +} +#endif +void praat_reportFontProperties () { + MelderInfo_open (); + MelderInfo_writeLine (U"Font replacement on this computer:\n"); + #if cairo + PangoFontMap *pangoFontMap = pango_cairo_font_map_get_default (); + PangoContext *pangoContext = pango_font_map_create_context (pangoFontMap); + conststring32 fontNames [] = { U"Times", U"Roman", U"Serif", + U"Helvetica", U"Arial", U"Sans", + U"Courier", U"Courier New", U"Mono", U"Monospace", + U"Palatino", U"Palladio", + U"Doulos", U"Doulos SIL", U"Charis", U"Charis SIL", + U"Symbol", U"Dingbats", + nullptr + }; + for (conststring32 *fontName = & fontNames [0]; !! *fontName; fontName ++) + testFont (pangoFontMap, pangoContext, *fontName); + g_object_unref (pangoContext); + + MelderInfo_writeLine (U"\nAll fonts on this computer:\n"); + PangoFontFamily **families; + int numberOfFamilies; + pango_font_map_list_families (pangoFontMap, & families, & numberOfFamilies); + for (int i = 0; i < numberOfFamilies; i ++) + MelderInfo_writeLine (i, U" ", Melder_peek8to32 (pango_font_family_get_name (families [i]))); + g_free (families); + #endif + MelderInfo_close (); +} + void praat_reportMemoryUse () { MelderInfo_open (); MelderInfo_writeLine (U"Memory use by Praat:\n"); diff --git a/sys/praat_version.h b/sys/praat_version.h index 10b6a930..c7686dc1 100644 --- a/sys/praat_version.h +++ b/sys/praat_version.h @@ -1,5 +1,5 @@ -#define PRAAT_VERSION_STR 6.1.15 -#define PRAAT_VERSION_NUM 6115 +#define PRAAT_VERSION_STR 6.1.29 +#define PRAAT_VERSION_NUM 6129 #define PRAAT_YEAR 2020 -#define PRAAT_MONTH May -#define PRAAT_DAY 20 +#define PRAAT_MONTH October +#define PRAAT_DAY 27 diff --git a/sys/sendpraat.c b/sys/sendpraat.c index 1a9ee9d3..b34a9364 100644 --- a/sys/sendpraat.c +++ b/sys/sendpraat.c @@ -228,6 +228,7 @@ char *sendpraat (void *display, const char *programName, long timeOut, const cha /* * Notify main window. */ +#if ALLOW_GDK_DRAWING GdkEventClient gevent; #if !GLIB_CHECK_VERSION(2,35,0) g_type_init (); @@ -253,6 +254,7 @@ char *sendpraat (void *display, const char *programName, long timeOut, const cha return errorMessage; } if (! displaySupplied) gdk_display_close (display); +#endif } /* * Wait for the running program to notify us of completion, diff --git a/test/LPC/Sound_to_LPC.praat b/test/LPC/Sound_to_LPC.praat new file mode 100644 index 00000000..e31ae048 --- /dev/null +++ b/test/LPC/Sound_to_LPC.praat @@ -0,0 +1,6 @@ +sound = Read from file: "../fon/logicalVersusPhysical.Sound" +lpc = noprogress To LPC (burg): 16, 0.025, 0.005, 50.0 +numberOfFrames = Get number of frames +assert numberOfFrames = 191 ; 'numberOfFrames' +removeObject: sound, lpc + diff --git a/test/fon/Harmonicity.praat b/test/fon/Harmonicity.praat new file mode 100644 index 00000000..136f8174 --- /dev/null +++ b/test/fon/Harmonicity.praat @@ -0,0 +1,6 @@ +my.Sound = Create Sound from formula: "sineWithNoise", 1, 0, 1, 44100, "1/2 * sin(2*pi*377*x) + randomGauss(0,0.1)" +my.Harmonicity = To Harmonicity (cc): 0.01, 75.0, 0.1, 1.0 +mean = Get mean: 0.0, 0.005 +writeInfoLine: mean +removeObject: my.Sound, my.Harmonicity + diff --git a/test/fon/logicalVersusPhysical.Sound b/test/fon/logicalVersusPhysical.Sound new file mode 100644 index 00000000..b0e0a291 Binary files /dev/null and b/test/fon/logicalVersusPhysical.Sound differ diff --git a/test/fon/pitch.praat b/test/fon/pitch.praat index e5216a15..046ff2bd 100644 --- a/test/fon/pitch.praat +++ b/test/fon/pitch.praat @@ -109,7 +109,7 @@ endproc procedure analyse: precision timeStep = 0.09457464735 - timeStep = 0.001 + ;timeStep = 0.001 ;To Pitch... timeStep 75 11025 my.Pitch = noprogress To Pitch ('method$'): timeStep, 75, 15, "no", 0.03, 0.45, 0.03, 0.35, 0.14, 11025 minPitch = Get minimum... 0 0 Hertz None diff --git a/test/fon/texio.praat b/test/fon/texio.praat index b125d180..cde3be71 100644 Binary files a/test/fon/texio.praat and b/test/fon/texio.praat differ diff --git a/test/manually/Demo_recording_problem.praat b/test/manually/Demo_recording_problem.praat index a0678f69..88bbce5c 100644 --- a/test/manually/Demo_recording_problem.praat +++ b/test/manually/Demo_recording_problem.praat @@ -27,10 +27,10 @@ demo Font size: 24 demo Colour: "Black" demo Text: 50, "Centre", 50, "Bottom", "Recording stopped: Now you should see a red and a blue disk" - demo Text: 50, "Centre", 45, "Bottom", "(Click anywhere in the window or hit any key to exit)" + demo Text: 50, "Centre", 45, "Bottom", "(Click anywhere in the window or hit any key to erase and exit)" # Wait and exit demoWaitForInput() demo Erase all - + demoShow() exit diff --git a/test/manually/bold.praat b/test/manually/bold.praat new file mode 100644 index 00000000..b9b87bb0 --- /dev/null +++ b/test/manually/bold.praat @@ -0,0 +1,5 @@ +target = Create Strings as characters: "intention" +source = Create Strings as characters: "execution" +plusObject: target +edt = To EditDistanceTable +Draw: "decimal", 1, 0 diff --git a/test/manually/movies.praat b/test/manually/movies.praat new file mode 100644 index 00000000..725ffbd9 --- /dev/null +++ b/test/manually/movies.praat @@ -0,0 +1,43 @@ +# test/manually/movies.praat +# Paul Boersma 2020-09-19 + +## Matrix movies. + +matrix = Create simple Matrix: "xy", 100, 100, ~ x*y +pauseScript: "watch a line with a slope that rises in time." +Play movie +Remove + +## Articulatory synthesis. + +speaker = Create Speaker: "speaker", "female", "2" +artword = Create Artword: "oko", 1.0 +Set target: 0.0, 0.8, "Lungs" +Set target: 0.3, 0.3, "Lungs" +Set target: 1.0, 0.0, "Lungs" +Set target: 0.0, 0.5, "Interarytenoid" +Set target: 1.0, 0.5, "Interarytenoid" +Set target: 0.5, 0.9, "Styloglossus" + +selectObject: speaker, artword +pauseScript: "Watch a vocal tract saying [oko]." +Play movie + +pauseScript: "Watch the vocal folds move while the sound is computed." +sound = To Sound: 22050, 25, 0,0,0,0,0,0,0,0,0 + +selectObject: speaker, artword, sound +pauseScript: "Watch and hear a vocal tract saying [oko]." +Play movie +Remove + +## OTGrammar. + +grammar = Create place assimilation grammar +distribution = Create place assimilation distribution +selectObject: grammar, distribution +pauseScript: "Watch the constraint rankings evolve." +Learn: 2.0, "symmetric all", 1.0, 1e6, 0.1, 4, 0.1, "yes", 1 +Remove + +## Minimizers. diff --git a/test/manually/test2.praat b/test/manually/test2.praat new file mode 100644 index 00000000..448ca4bf --- /dev/null +++ b/test/manually/test2.praat @@ -0,0 +1,2 @@ +pauseScript: "simply ignored on the command line?" +writeInfoLine: "hoi" \ No newline at end of file diff --git a/test/num/interpolation.praat b/test/num/interpolation.praat new file mode 100644 index 00000000..0d57f4f0 --- /dev/null +++ b/test/num/interpolation.praat @@ -0,0 +1,49 @@ +# +# test/num/interpolation.praat +# Paul Boersma 2020-09-24 +# + +writeInfoLine: "Interpolation, especially cubic..." +Erase all +Times +12 +sound = Create Sound from formula: "fakerandom", 1, 0, 1, 10000, ~ cos (56426631 * x^2) +midTime = 0.5 +timeDepth = 0.00026 +top = -0.4 +@drawValues: "nearest" +@drawValues: "linear" +@drawValues: "cubic" +@drawValues: "sinc70" +@drawValues: "sinc700" +Remove +appendInfoLine: "OK" + +procedure drawValues: interpolation$ + bottom = top + 2.4 + Select outer viewport: 0, 6, top, bottom + Draw: midTime - timeDepth, midTime + timeDepth, -1.1, 1.1, "no", "poles" + Draw inner box + Marks bottom every: 1.0, 0.0001, "yes", "yes", "yes" + Marks left every: 1.0, 0.2, "yes", "yes", "yes" + time = midTime - timeDepth + while time <= midTime + timeDepth + value = Get value at time: 1, time, interpolation$ + Paint circle (mm): "black", time, value, 0.5 + time += 1e-6 + endwhile + peakInterpolation$ = + ... if interpolation$ = "nearest" then "none" + ... else if interpolation$ = "linear" then "parabolic" + ... else interpolation$ fi fi + maximum = Get maximum: midTime - timeDepth / 2, midTime + timeDepth / 2, peakInterpolation$ + timeOfMaximum = Get time of maximum: midTime - timeDepth / 2, midTime + timeDepth / 2, peakInterpolation$ + Paint circle (mm): "red", timeOfMaximum, maximum, 2.0 + if peakInterpolation$ = interpolation$ + interpolatedValue = Get value at time: 1, timeOfMaximum, interpolation$ + appendInfoLine: interpolation$, ": peak at ", timeOfMaximum, + ... " s; peak height ", maximum, "; interpolated value ", interpolatedValue + assert interpolatedValue = maximum + endif + top += 1.8 +endproc diff --git a/test/script/extractNumber.praat b/test/script/extractNumber.praat new file mode 100644 index 00000000..c2a50bf6 --- /dev/null +++ b/test/script/extractNumber.praat @@ -0,0 +1,17 @@ +assert extractNumber ("Number: 234", "Number:") = 234 +assert extractNumber ("Number: 234", "Number: ") = 234 + +assert extractNumber ("Number: 1/2", "Number: ") = 0.5 +assert extractNumber ("Number: 1 / 2", "Number: ") = 1 + +# +# Funny stuff. +# +assert extractNumber ("Number: 1X/2U", "Number: ") = 0.5 +assert extractNumber ("Number: 1X/U", "Number: ") = undefined + +assert extractNumber ("Number: X/U", "Number: ") = undefined + +assert extractNumber ("Number: X/2U", "Number: ") = undefined + +assert extractNumber ("Number: X", "Number: ") = undefined diff --git a/test/script/rounding.praat b/test/script/rounding.praat new file mode 100644 index 00000000..3134bfdb --- /dev/null +++ b/test/script/rounding.praat @@ -0,0 +1,23 @@ +writeInfoLine: "Approximating one third in 64-bit IEEE floating point:" + +oneThird$ = fixed$ (1/3, 60) +# +# This one is closer to 1/3 than 0.333333333333333370340767487505218014121055603027343750000000 is: +# +assert oneThird$ = "0.333333333333333314829616256247390992939472198486328125000000" +... or oneThird$ = "0.333333333333333310000000000000000000000000000000000000000000" ; 'oneThird$' + +a [0] = 0 +d = 0.5 +for i to 65 + a [i] = a [i - 1] + d + d *= -0.5 + string$ [i] = fixed$ (a [i], 60) + appendInfoLine: i, " ", string$ [i] +endfor +appendInfoLine: "1/3 -> ", fixed$ (1/3, 60) +assert string$ [54] = fixed$ (1/3, 60) +assert a [53] <> 1/3 +assert a [54] = 1/3 +assert a [55] <> 1/3 ; this is allowed to vary on platforms +assert a [55] = a [54] or a [55] = a [53] ; the somewhat laxer condition \ No newline at end of file diff --git a/test/sys/colour.praat b/test/sys/colour.praat index 4a6a214e..5d9053da 100644 --- a/test/sys/colour.praat +++ b/test/sys/colour.praat @@ -66,7 +66,8 @@ Paint rectangle: {0.1+0.2}, 50, 100, y-2, y+2 y -= 5 Olive -Text: 50, "right", y, "half", "This falls back to black:" +Text: 50, "right", y, "half", "This is not drawn:" +asserterror Cannot compute a colour Paint rectangle: "{ vxcvxcvbxvbcvb", 50, 100, y-2, y+2 y -= 5 @@ -77,7 +78,7 @@ Paint rectangle: "vxcvxcvbxvbcvb", 50, 100, y-2, y+2 y -= 5 Olive -Text: 50, "right", y, "half", "This falls back to black:" +Text: 50, "right", y, "half", "This is not drawn:" asserterror Cannot compute a colour Paint rectangle: "0.3", 50, 100, y-2, y+2 diff --git a/test/sys/graphics.praat b/test/sys/graphics.praat index 430e45cc..aa232103 100644 Binary files a/test/sys/graphics.praat and b/test/sys/graphics.praat differ diff --git a/test/sys/graphicsText.praat b/test/sys/graphicsText.praat index 7200c11a..8433537c 100644 --- a/test/sys/graphicsText.praat +++ b/test/sys/graphicsText.praat @@ -1,5 +1,5 @@ # graphicsText.praat -# Paul Boersma 2017-09-19 +# Paul Boersma 2020-07-26 Erase all Select outer viewport: 0, 6, 0, 9 @@ -8,12 +8,12 @@ Times 12 Text: 0, "left", 99, "half", "Getting graphical text right is not a trivial task:" Text: 0, "left", 98, "half", "many types of glitches are possible." -Text: 0, "left", 95, "half", "Code might be misaligned as in: $$< > <> <= = >=$, you see?" +Text: 0, "left", 96, "half", "Code might be misaligned as in: $$< > <> <= = >=$, you see?" Courier text$ = "Code might be misaligned as in: $$< > <> <= = >=$, you see?" -Text: 0, "left", 94, "half", text$ +Text: 0, "left", 95, "half", text$ width = Text width (world coordinates): text$ -Text: width, "left", 94, "half", "... and here it continues" +Text: width, "left", 94, "half", "... and here it continues:" Text: 0, "left", 93, "half", "a / b, a/b, a / b, a/b, a / b, a/b, a / b, a /b, a/ b" Times Text: 0, "left", 92, "half", "a / b, a/b, a / b"